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 "distributes nested routes through dynamic paths" $ do
  51                         inp_dynamic `shouldRouteAs` exp_dynamic
  52                 it "properly reorders permuted static paths" $ do
  53                         inp_permute `shouldRouteAs` exp_permute
  54
  55 -- * Path tests Server
  56
  57 api =
  58  "a" </> "aa" </> get @String @'[PlainText]
  59  <!>
  60  "b" </> "bb" </> get @Int @'[PlainText]
  61  <!>
  62  "c" </> "cc" </> get @Int @'[PlainText]
  63  <!>
  64  "a" </> "AA" </> get @String @'[PlainText]
  65  <!>
  66  "b" </> "bb" </> get @Int @'[PlainText]
  67
  68 srv = server api $
  69         route_a_aa :!:
  70         route_b_bb :!:
  71         route_c_cc :!:
  72         route_a_AA :!:
  73         route_b_bb'
  74         where
  75         route_a_aa = do
  76                 MC.exec $ putStrLn "/a/aa"
  77                 return "0"
  78         route_b_bb = do
  79                 MC.exec $ putStrLn "/b/bb"
  80                 return (-1)
  81         route_c_cc = do
  82                 MC.exec $ putStrLn "/c/cc"
  83                 return 2
  84         route_a_AA = do
  85                 MC.exec $ putStrLn "/a/AA"
  86                 return "3"
  87         route_b_bb' = do
  88                 MC.exec $ putStrLn "/b/bb'"
  89                 return 4
  90
  91 warp :: IO ()
  92 warp = Warp.run 8080 srv
  93
  94 -- * Utils
  95
  96 routerEq :: repr ~ Server => Router repr a b -> Router repr c d -> Bool
  97 routerEq x0 y0 =
  98         {-
  99         let r = go
 100                  (Dbg.trace ("eq: x: " <> show x0) x0)
 101                  (Dbg.trace ("eq: y: " <> show y0) y0) in
 102         Dbg.trace ("eq: r: " <> show r) r
 103         -}
 104         go x0 y0
 105         where
 106         go :: repr ~ Server => Router repr a b -> Router repr c d -> Bool
 107         go (Router_Map xs) (Router_Map ys) =
 108                 List.and $ (\((kx,x),(ky,y)) -> kx==ky && routerEq x y) <$>
 109                 List.zip (Map.toList xs) (Map.toList ys)
 110         go (Router_Seg x) (Router_Seg y) = x == y
 111         go (Router_Cat xa xb) (Router_Cat ya yb) = routerEq xa ya && routerEq xb yb
 112         go (Router_Alt xl xr) (Router_Alt yl yr) = routerEq xl yl && routerEq xr yr
 113         go (Router_AltL x) y = routerEq x y
 114         go (Router_AltR x) y = routerEq x y
 115         go x (Router_AltL y) = routerEq x y
 116         go x (Router_AltR y) = routerEq x y
 117         go (Router_Cap xn) (Router_Cap yn) = xn == yn
 118         go (Router_Caps xs) (Router_Caps ys) = go xs ys
 119                 where
 120                 go :: Captures xs -> Captures ys -> Bool
 121                 go (Captures0 xa xn) (Captures0 ya yn) = xn == xn
 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 exp_dynamic =
 156  "a" </> captures (Captures2 (Captures2 (Captures0 (Proxy @(Int -> Res)) "foo")
 157                                         (Captures0 (Proxy @(Bool -> Res)) "bar"))
 158                              (Captures0 (Proxy @(Char -> Res)) "baz"))
 159      <.> ("b" </> end <!> "c" </> end <!> "d" </> end)
 160 type Res = ResponseArgs (Router Server) String '[PlainText]
 161
 162 inp_permute =
 163      "a" </> "b" </> "c" </> end
 164  <!> "b" </> "a" </> "c" </> end
 165  <!> "a" </> "c" </> "b" </> end
 166  <!> "c" </> "a" </> "b" </> end
 167  <!> "b" </> "c" </> "a" </> end
 168  <!> "c" </> "b" </> "a" </> end
 169  <!> "a" </> "a" </> "b" </> end
 170  <!> "a" </> "a" </> "c" </> end
 171 exp_permute =
 172      "a" </> ("b" </> "c" </> end
 173           <!> "c" </> "b" </> end
 174           <!> "a" </> "b" </> end)
 175  <!> "b" </> ("a" </> "c" </> end
 176           <!> "c" </> "a" </> end)
 177  <!> "c" </> ("a" </> "b" </> end
 178           <!> "b" </> "a" </> end)
 179  <!> "a" </> "a" </> "c" </> end
 180
 181 {-
 182 map [
 183  ("a",L (L map [("a","b" <.> R X),("b","c" <.> L (L X)),("c","b" <.> L (R X))])
 184       <!> "a" <.> "c" <.> X)
 185 ,("b",L (L (R map [("a","c" <.> L X),("c","a" <.> R X)])))
 186 ,("c",map [("a","b" <.> L (R (L X))),("b","a" <.> L (R (R X)))])
 187 ]
 188 -}
 189 {-
 190 api_PermuteRawEnd =
 191        "a" </> "b" </> "c" </> end
 192   <!> "b" </> "a" </> "c" </> end
 193   <!> "a" </> "c" </> "b" </> end
 194   <!> "c" </> "a" </> "b" </> end
 195   <!> "b" </> "c" </> "a" </> end
 196   <!> "c" </> "b" </> "a" </> end
 197   <!> raw
 198 api_PermuteRawEndRef = api_PermuteRef <!> api_Raw
 199 api_PermuteRawBegin =
 200        raw
 201   <!> "a" </> "b" </> "c" </> end
 202   <!> "b" </> "a" </> "c" </> end
 203   <!> "a" </> "c" </> "b" </> end
 204   <!> "c" </> "a" </> "b" </> end
 205   <!> "b" </> "c" </> "a" </> end
 206   <!> "c" </> "b" </> "a" </> end
 207 api_PermuteRawBeginRef = raw <!> api_PermuteRef
 208 -}
 209