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