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

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE InstanceSigs #-}
   4 module Hspec.Server.Router where
   5
   6 import Control.Monad (when)
   7 import Data.Eq (Eq(..))
   8 import Data.Int (Int)
   9 import Data.Maybe (Maybe(..))
  10 import Data.Ord (Ord(..))
  11 import Data.String (String, IsString(..))
  12 import Prelude ((+))
  13 import System.IO (IO, putStrLn)
  14 import Test.Hspec.Wai (liftIO)
  15 import Text.Show (Show(..), showString, showParen)
  16 import qualified Data.ByteString as BS
  17 import qualified Data.Text.Lazy as TL
  18 import qualified Data.Text.Lazy.Encoding as TL
  19 import qualified Data.ByteString.Base64 as BS64
  20 import qualified Network.HTTP.Types as HTTP
  21 import qualified Network.Wai.Handler.Warp as Warp
  22 import qualified Test.Hspec.Wai as Wai
  23 import qualified Data.Map.Strict as Map
  24 import qualified Control.Monad.Classes as MC
  25
  26 import Control.Arrow (first)
  27 import Data.Function (const)
  28 import Data.Bool
  29 import qualified Data.Map.Merge.Strict as Map
  30 import qualified Data.List as List
  31
  32 import Symantic.HTTP
  33 import Symantic.HTTP.Server
  34 import Hspec.Utils
  35
  36
  37 api2 =
  38      "a" </> "b" </> "b" </> end
  39  <!> "a" </> "b" </> "c" </> end
  40 api3 =
  41      "a" </> "b" </> end
  42  <!> "a" </> "c" </> end
  43
  44 api =
  45  "a" </> "aa" </> get @String @'[PlainText]
  46  <!>
  47  "b" </> "bb" </> get @Int @'[PlainText]
  48  <!>
  49  "c" </> "cc" </> get @Int @'[PlainText]
  50  <!>
  51  "a" </> "AA" </> get @String @'[PlainText]
  52  <!>
  53  "b" </> "bb" </> get @Int @'[PlainText]
  54
  55
  56 end = get @String @'[PlainText]
  57 api_permute0 =
  58      "a" </> "b" </> "c" </> end
  59 api_permute1 =
  60      "a" </> "b" </> "c" </> end
  61  <!> "b" </> "a" </> "c" </> end
  62 api_permute2 =
  63      "a" </> "b" </> "c" </> end
  64  <!> "b" </> "a" </> "c" </> end
  65  <!> "a" </> "c" </> "b" </> end
  66 api_permute3 =
  67      "a" </> "b" </> "c" </> end
  68  <!> "b" </> "a" </> "c" </> end
  69  <!> "a" </> "c" </> "b" </> end
  70  <!> "c" </> "a" </> "b" </> end
  71 api_permute =
  72      "a" </> "b" </> "c" </> end
  73  <!> "b" </> "a" </> "c" </> end
  74  <!> "a" </> "c" </> "b" </> end
  75  <!> "c" </> "a" </> "b" </> end
  76  <!> "b" </> "c" </> "a" </> end
  77  <!> "c" </> "b" </> "a" </> end
  78  <!> "a" </> "a" </> "b" </> end
  79
  80 api_permute_ref =
  81      "a" </> ("b" </> "c" </> end
  82           <!> "c" </> "b" </> end
  83           <!> "a" </> "b" </> end)
  84  <!> "b" </> ("a" </> "c" </> end
  85           <!> "c" </> "a" </> end)
  86  <!> "c" </> ("a" </> "b" </> end
  87           <!> "b" </> "a" </> end)
  88
  89 srv = server api $
  90         route_a_aa :!:
  91         route_b_bb :!:
  92         route_c_cc :!:
  93         route_a_AA :!:
  94         route_b_bb'
  95         where
  96         route_a_aa = do
  97                 MC.exec $ putStrLn "/a/aa"
  98                 return "0"
  99         route_b_bb = do
 100                 MC.exec $ putStrLn "/b/bb"
 101                 return (-1)
 102         route_c_cc = do
 103                 MC.exec $ putStrLn "/c/cc"
 104                 return 2
 105         route_a_AA = do
 106                 MC.exec $ putStrLn "/a/AA"
 107                 return "3"
 108         route_b_bb' = do
 109                 MC.exec $ putStrLn "/b/bb'"
 110                 return 4
 111
 112 warp :: IO ()
 113 warp = Warp.run 8080 srv
 114
 115 instance Show (Router Server a b) where
 116         showsPrec p = \case
 117          Router_Any{} ->
 118                 showString "X"
 119          Router_Map ms ->
 120                 showParen (p>=10) $
 121                 showString "map " .
 122                 showsPrec p (Map.toList ms)
 123          Router_Seg s ->
 124                 showsPrec 10 s
 125          Router_Cat x y ->
 126                 showParen (p>=4) $
 127                 showsPrec 10 x .
 128                 showString " <.> " .
 129                 showsPrec 10 y
 130          Router_Alt x y ->
 131                 showParen (p>=3) $
 132                 showsPrec 10 x .
 133                 showString " <!> " .
 134                 showsPrec 10 y
 135          Router_AltL x ->
 136                 showParen (p>=4) $
 137                 showString "L " .
 138                 showsPrec 10 x
 139          Router_AltR x ->
 140                 showParen (p>=4) $
 141                 showString "R " .
 142                 showsPrec 10 x
 143
 144 r = show (router @Server api)
 145
 146 hspec = testSpecs $ describe "Router" $ Wai.with (return srv) $ do
 147         describe "Path" $ do
 148                 it "call the right route" $ do
 149                         Wai.get "/a/aa"
 150                          `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "0" }
 151                 it "call the right route" $ do
 152                         Wai.get "/a/AA"
 153                          `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "3" }
 154
 155 mkBody b = Wai.MatchBody $ \_ b' ->
 156         if b == b'
 157         then Nothing
 158         else Just $ TL.unpack $
 159          "expecting: "<>TL.decodeUtf8 b<>
 160          " but got: "<>TL.decodeUtf8 b'<>"\n"
 161
 162