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

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   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.String (String)
  14 import System.IO (IO, putStrLn)
  15 import Text.Show (Show(..))
  16 import qualified Control.Monad.Classes as MC
  17 import qualified Data.List as List
  18 import qualified Data.Map.Strict as Map
  19 import qualified Network.Wai.Handler.Warp as Warp
  20 import qualified Test.Hspec as Hspec
  21
  22 import Symantic.HTTP
  23 import Symantic.HTTP.Server
  24 import Hspec.Utils
  25
  26 hspec = testSpecs $ describe "Router" $ do
  27         it "distributes endpoints through static paths" $ do
  28                 inp_Endpoint `shouldRouteAs` exp_Endpoint
  29         it "distributes nested routes through static paths" $ do
  30                 inp_Static `shouldRouteAs` exp_Static
  31         it "properly reorders permuted static paths" $ do
  32                 inp_Permute `shouldRouteAs` exp_Permute
  33         it "properly reorders permuted static paths in the presence of raw in end" $ do
  34                 inp_PermuteRawEnd `shouldRouteAs` exp_PermuteRawEnd
  35         it "properly reorders permuted static paths in the presence of raw in beginning" $ do
  36                 inp_PermuteRawBegin `shouldRouteAs` exp_PermuteRawBegin
  37         it "properly reorders permuted static paths in the presence of raw in middle" $ do
  38                 inp_PermuteRawMiddle `shouldRouteAs` exp_PermuteRawMiddle
  39         {- NOTE: this is semantically incorrect.
  40         it "distributes nested routes through dynamic paths" $ do
  41                 inp_Dynamic `shouldRouteAs` exp_Dynamic
  42         -}
  43         it "properly handles mixing static paths at different levels" $ do
  44                 inp_Level `shouldRouteAs` exp_Level
  45
  46 -- * Utils
  47
  48 routerEq ::
  49  forall repr a b c d. repr ~ Server =>
  50  Router repr a b -> Router repr c d -> Bool
  51 routerEq x0 y0 =
  52         {-
  53         let r = go
  54                  (Dbg.trace ("eq: x: " <> show x0) x0)
  55                  (Dbg.trace ("eq: y: " <> show y0) y0) in
  56         Dbg.trace ("eq: r: " <> show r) r
  57         -}
  58         go x0 y0
  59         where
  60         go :: Router repr a b -> Router repr c d -> Bool
  61         go (Router_Seg x) (Router_Seg y) = x == y
  62         go (Router_Cat xa xb) (Router_Cat ya yb) = routerEq xa ya && routerEq xb yb
  63         go (Router_Alt xl xr) (Router_Alt yl yr) = routerEq xl yl && routerEq xr yr
  64         go (Router_Cap xn) (Router_Cap yn) = xn == yn
  65         go (Router_Map xs) (Router_Map ys) =
  66                 let xl = Map.toList xs in
  67                 let yl = Map.toList ys in
  68                 (List.length xl == List.length yl &&) $
  69                 List.and $
  70                         (\((kx, x),(ky, y)) -> kx==ky && routerEq x y) <$>
  71                         List.zip xl yl
  72         go (Router_Caps xs) (Router_Caps ys) = goCaps xs ys
  73                 where
  74                 goCaps :: Captures (Router repr) xs b -> Captures (Router repr) ys d -> Bool
  75                 goCaps (Captures0 _xa xn xr) (Captures0 _ya yn yr) = xn == yn && routerEq xr yr
  76                 goCaps (Captures2 xx xy) (Captures2 yx yy) = goCaps xx yx && goCaps xy yy
  77                 goCaps _ _ = False -- FIXME: may wrongly return False if captures are not in the same order
  78         go (Router_Union _u x) y = routerEq x y
  79         go x (Router_Union _u y) = routerEq x y
  80         go Router_Any{} Router_Any{} = True
  81         go _x _y = False
  82
  83 shouldRouteAs :: Router Server a b -> Router Server c d -> Hspec.Expectation
  84 shouldRouteAs inp exp =
  85         let inpR = router inp in
  86         let expR = router exp in
  87         unless (inpR`routerEq`expR) $
  88                 Hspec.expectationFailure $ "expected:\n" <> show expR <> "\nbut got:\n" <> show inpR
  89
  90 -- * APIs
  91
  92 end = get @String @'[PlainText]
  93
  94 inp_Endpoint = "a" </> end <!> "a" </> end
  95 exp_Endpoint = "a" </> (end <!> end)
  96
  97 inp_Static = "a" </> "b" </> end <!> "a" </> "c" </> end
  98 exp_Static = "a" </> ("b" </> end <!> "c" </> end)
  99
 100 {-
 101 inp_Dynamic =
 102      "a" </> capture @Int  "foo" <.> "b" </> end
 103  <!> "a" </> capture @Bool "bar" <.> "c" </> end
 104  <!> "a" </> capture @Char "baz" <.> "d" </> end
 105 exp_Dynamic =
 106  "a" </> captures (Captures2 (Captures2 (Captures0 (Proxy @(Int -> Res)) "foo")
 107                                         (Captures0 (Proxy @(Bool -> Res)) "bar"))
 108                              (Captures0 (Proxy @(Char -> Res)) "baz"))
 109      <.> ("b" </> end <!> "c" </> end <!> "d" </> end)
 110 type Res = ResponseArgs (Router Server) String '[PlainText]
 111 -}
 112
 113 inp_Permute =
 114      "a" </> "b" </> "c" </> end
 115  <!> "b" </> "a" </> "c" </> end
 116  <!> "a" </> "c" </> "b" </> end
 117  <!> "c" </> "a" </> "b" </> end
 118  <!> "b" </> "c" </> "a" </> end
 119  <!> "c" </> "b" </> "a" </> end
 120  <!> "a" </> "a" </> "b" </> end
 121  <!> "a" </> "a" </> "c" </> end
 122 exp_Permute =
 123      "a" </> ("b" </> "c" </> end
 124           <!> "c" </> "b" </> end
 125           <!> "a" </> "b" </> end)
 126  <!> "b" </> ("a" </> "c" </> end
 127           <!> "c" </> "a" </> end)
 128  <!> "c" </> ("a" </> "b" </> end
 129           <!> "b" </> "a" </> end)
 130  <!> "a" </> "a" </> "c" </> end
 131
 132 inp_PermuteRawEnd =
 133      "a" </> "b" </> "c" </> end
 134  <!> "b" </> "a" </> "c" </> end
 135  <!> "a" </> "c" </> "b" </> end
 136  <!> "c" </> "a" </> "b" </> end
 137  <!> "b" </> "c" </> "a" </> end
 138  <!> "c" </> "b" </> "a" </> end
 139  <!> "a" </> "a" </> "b" </> end
 140  <!> "a" </> "a" </> "c" </> end
 141  <!> raw
 142 exp_PermuteRawEnd = exp_Permute <!> raw
 143
 144 inp_PermuteRawBegin =
 145      raw
 146  <!> "a" </> "b" </> "c" </> end
 147  <!> "b" </> "a" </> "c" </> end
 148  <!> "a" </> "c" </> "b" </> end
 149  <!> "c" </> "a" </> "b" </> end
 150  <!> "b" </> "c" </> "a" </> end
 151  <!> "c" </> "b" </> "a" </> end
 152  <!> "a" </> "a" </> "b" </> end
 153  <!> "a" </> "a" </> "c" </> end
 154 exp_PermuteRawBegin = raw <!> exp_Permute
 155
 156 inp_PermuteRawMiddle =
 157      "a" </> "b" </> "c" </> end
 158  <!> "b" </> "a" </> "c" </> end
 159  <!> "a" </> "c" </> "b" </> end
 160  <!> raw
 161  <!> "c" </> "a" </> "b" </> end
 162  <!> "b" </> "c" </> "a" </> end
 163  <!> "c" </> "b" </> "a" </> end
 164 exp_PermuteRawMiddle =
 165      "a" </> ("b" </> "c" </> end <!>
 166               "c" </> "b" </> end)
 167  <!> "b" </> "a" </> "c" </> end
 168  <!> raw
 169  <!> "b" </> "c" </> "a" </> end
 170  <!> "c" </> ("a" </> "b" </> end <!>
 171               "b" </> "a" </> end)
 172
 173 inp_Level1 =
 174      "a" </> "b" </> end
 175  <!> "a" </> end
 176 inp_Level2 =
 177      "b" </> end
 178  <!> "a" </> "c" </> end
 179  <!> end
 180 inp_Level =
 181  inp_Level1 <!>
 182  inp_Level2
 183 exp_Level =
 184      "a" </> ("b" </> end <!> "c" </> end <!> end)
 185  <!> "b" </> end
 186  <!> end