symantic-http-test/Hspec/Server/Router.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE InstanceSigs #-}
   4 {-# OPTIONS -Wno-missing-signatures #-}
   5 {-# OPTIONS -Wno-orphans #-}
   6 module Hspec.Server.Router where
   7
   8 import Control.Monad (unless)
   9 import Data.Bool
  10 import Data.Char (Char)
  11 import Data.Eq (Eq(..))
  12 import Data.Int (Int)
  13 import Data.Maybe (Maybe(..))
  14 import Data.Ord (Ord(..))
  15 import Data.Proxy (Proxy(..))
  16 import Data.String (String, IsString(..))
  17 import System.IO (IO, putStrLn)
  18 import Text.Show (Show(..), showString, showParen)
  19 import qualified Control.Monad.Classes as MC
  20 import qualified Data.List as List
  21 import qualified Data.Map.Strict as Map
  22 import qualified Data.Text.Lazy as TL
  23 import qualified Data.Text.Lazy.Encoding as TL
  24 import qualified Network.Wai.Handler.Warp as Warp
  25 import qualified Test.Hspec as Hspec
  26 import qualified Test.Hspec.Wai as Wai
  27
  28 import Symantic.HTTP
  29 import Symantic.HTTP.Server
  30 import Hspec.Utils
  31
  32 import qualified Debug.Trace as Dbg
  33
  34 hspec = testSpecs $ describe "Router" $ do
  35         {-
  36         Wai.with (return srv) $ do
  37                 describe "Path" $ do
  38                         it "call the right route" $ do
  39                                 Wai.get "/a/aa"
  40                                  `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "0" }
  41                         it "call the right route" $ do
  42                                 Wai.get "/a/AA"
  43                                  `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "3" }
  44         -}
  45         describe "structure" $ do
  46                 it "distributes endpoints through static paths" $ do
  47                         inp_endpoint `shouldRouteAs` exp_endpoint
  48                 it "distributes nested routes through static paths" $ do
  49                         inp_static `shouldRouteAs` exp_static
  50                 it "properly reorders permuted static paths" $ do
  51                         inp_permute `shouldRouteAs` exp_permute
  52                 {-
  53                 it "distributes nested routes through dynamic paths" $ do
  54                         inp_dynamic `shouldRouteAs` exp_dynamic
  55                 -}
  56
  57 -- * Path tests Server
  58
  59 api = "a" </> "aa" </> get @String @'[PlainText]
  60   <!> "b" </> "bb" </> get @Int @'[PlainText]
  61   <!> "c" </> "cc" </> get @Int @'[PlainText]
  62   <!> "a" </> "AA" </> get @String @'[PlainText]
  63   <!> "b" </> "bb" </> get @Int @'[PlainText]
  64
  65 srv = server api $
  66         route_a_aa :!:
  67         route_b_bb :!:
  68         route_c_cc :!:
  69         route_a_AA :!:
  70         route_b_bb'
  71         where
  72         route_a_aa = do
  73                 MC.exec $ putStrLn "/a/aa"
  74                 return "0"
  75         route_b_bb = do
  76                 MC.exec $ putStrLn "/b/bb"
  77                 return (-1)
  78         route_c_cc = do
  79                 MC.exec $ putStrLn "/c/cc"
  80                 return 2
  81         route_a_AA = do
  82                 MC.exec $ putStrLn "/a/AA"
  83                 return "3"
  84         route_b_bb' = do
  85                 MC.exec $ putStrLn "/b/bb'"
  86                 return 4
  87
  88 warp :: IO ()
  89 warp = Warp.run 8080 srv
  90
  91 -- * Utils
  92
  93 routerEq ::
  94  forall repr a b c d. repr ~ Server =>
  95  Router repr a b -> Router repr c d -> Bool
  96 routerEq x0 y0 =
  97         {-
  98         let r = go
  99                  (Dbg.trace ("eq: x: " <> show x0) x0)
 100                  (Dbg.trace ("eq: y: " <> show y0) y0) in
 101         Dbg.trace ("eq: r: " <> show r) r
 102         -}
 103         go x0 y0
 104         where
 105         go :: Router repr a b -> Router repr c d -> Bool
 106         go (Router_Seg x) (Router_Seg y) = x == y
 107         go (Router_Cat xa xb) (Router_Cat ya yb) = routerEq xa ya && routerEq xb yb
 108         go (Router_Alt xl xr) (Router_Alt yl yr) = routerEq xl yl && routerEq xr yr
 109         go (Router_Cap xn) (Router_Cap yn) = xn == yn
 110         go (Router_Map xs) (Router_Map ys) =
 111                 let xl = Map.toList xs in
 112                 let yl = Map.toList ys in
 113                 (List.length xl == List.length yl &&) $
 114                 List.and $
 115                  (\((kx, RouterUnion _xb2a x),(ky, RouterUnion _yb2a y)) ->
 116                         kx==ky && routerEq x y) <$>
 117                 List.zip xl yl
 118         go (Router_Caps xs) (Router_Caps ys) = go xs ys
 119                 where
 120                 go :: Captures (Router repr) xs b -> Captures (Router repr) ys d -> Bool
 121                 go (Captures0 xa xn xr) (Captures0 ya yn yr) = xn == xn && routerEq xr yr
 122                 go (Captures2 xx xy) (Captures2 yx yy) = go xx yx && go xy yy
 123         go Router_Any{} Router_Any{} = True
 124         go _x _y = False
 125
 126 shouldRouteAs :: Router Server a b -> Router Server c d -> Hspec.Expectation
 127 shouldRouteAs inp exp =
 128         let inpR = router inp in
 129         let expR = router exp in
 130         unless (inpR`routerEq`expR) $
 131                 Hspec.expectationFailure $ "expected:\n" <> show expR <> "\nbut got:\n" <> show inpR
 132
 133 mkBody :: Wai.Body -> Wai.MatchBody
 134 mkBody b = Wai.MatchBody $ \_ b' ->
 135         if b == b'
 136         then Nothing
 137         else Just $ TL.unpack $
 138          "expecting: "<>TL.decodeUtf8 b<>
 139          " but got: "<>TL.decodeUtf8 b'<>"\n"
 140
 141 -- * APIs
 142
 143 end = get @String @'[PlainText]
 144
 145 inp_endpoint = "a" </> end <!> "a" </> end
 146 exp_endpoint = "a" </> (end <!> end)
 147
 148 inp_static = "a" </> "b" </> end <!> "a" </> "c" </> end
 149 exp_static = "a" </> ("b" </> end <!> "c" </> end)
 150
 151 inp_dynamic =
 152      "a" </> capture @Int  "foo" <.> "b" </> end
 153  <!> "a" </> capture @Bool "bar" <.> "c" </> end
 154  <!> "a" </> capture @Char "baz" <.> "d" </> end
 155 {-
 156 exp_dynamic =
 157  "a" </> captures (Captures2 (Captures2 (Captures0 (Proxy @(Int -> Res)) "foo")
 158                                         (Captures0 (Proxy @(Bool -> Res)) "bar"))
 159                              (Captures0 (Proxy @(Char -> Res)) "baz"))
 160      <.> ("b" </> end <!> "c" </> end <!> "d" </> end)
 161 type Res = ResponseArgs (Router Server) String '[PlainText]
 162 -}
 163
 164 inp_permute =
 165      "a" </> "b" </> "c" </> end
 166  <!> "b" </> "a" </> "c" </> end
 167  <!> "a" </> "c" </> "b" </> end
 168  <!> "c" </> "a" </> "b" </> end
 169  <!> "b" </> "c" </> "a" </> end
 170  <!> "c" </> "b" </> "a" </> end
 171  <!> "a" </> "a" </> "b" </> end
 172  <!> "a" </> "a" </> "c" </> end
 173 exp_permute =
 174      "a" </> ("b" </> "c" </> end
 175           <!> "c" </> "b" </> end
 176           <!> "a" </> "b" </> end)
 177  <!> "b" </> ("a" </> "c" </> end
 178           <!> "c" </> "a" </> end)
 179  <!> "c" </> ("a" </> "b" </> end
 180           <!> "b" </> "a" </> end)
 181  <!> "a" </> "a" </> "c" </> end
 182
 183
 184 {-
 185 api_PermuteRawEnd =
 186        "a" </> "b" </> "c" </> end
 187   <!> "b" </> "a" </> "c" </> end
 188   <!> "a" </> "c" </> "b" </> end
 189   <!> "c" </> "a" </> "b" </> end
 190   <!> "b" </> "c" </> "a" </> end
 191   <!> "c" </> "b" </> "a" </> end
 192   <!> raw
 193 api_PermuteRawEndRef = api_PermuteRef <!> api_Raw
 194 api_PermuteRawBegin =
 195        raw
 196   <!> "a" </> "b" </> "c" </> end
 197   <!> "b" </> "a" </> "c" </> end
 198   <!> "a" </> "c" </> "b" </> end
 199   <!> "c" </> "a" </> "b" </> end
 200   <!> "b" </> "c" </> "a" </> end
 201   <!> "c" </> "b" </> "a" </> end
 202 api_PermuteRawBeginRef = raw <!> api_PermuteRef
 203 -}