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