{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE InstanceSigs #-} {-# OPTIONS -Wno-missing-signatures #-} {-# OPTIONS -Wno-orphans #-} module Hspec.Server.Router where import Control.Monad (unless) import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) import Data.Int (Int) import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) import Data.String (String, IsString(..)) import System.IO (IO, putStrLn) import Text.Show (Show(..), showString, showParen) import qualified Control.Monad.Classes as MC import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Network.Wai.Handler.Warp as Warp import qualified Test.Hspec as Hspec import qualified Test.Hspec.Wai as Wai import Symantic.HTTP import Symantic.HTTP.Server import Hspec.Utils import qualified Debug.Trace as Dbg hspec = testSpecs $ describe "Router" $ do {- Wai.with (return srv) $ do describe "Path" $ do it "call the right route" $ do Wai.get "/a/aa" `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "0" } it "call the right route" $ do Wai.get "/a/AA" `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "3" } -} describe "structure" $ do it "distributes endpoints through static paths" $ do inp_endpoint `shouldRouteAs` exp_endpoint it "distributes nested routes through static paths" $ do inp_static `shouldRouteAs` exp_static it "properly reorders permuted static paths" $ do inp_permute `shouldRouteAs` exp_permute {- it "distributes nested routes through dynamic paths" $ do inp_dynamic `shouldRouteAs` exp_dynamic -} -- * Path tests Server api = "a" "aa" get @String @'[PlainText] "b" "bb" get @Int @'[PlainText] "c" "cc" get @Int @'[PlainText] "a" "AA" get @String @'[PlainText] "b" "bb" get @Int @'[PlainText] srv = server api $ route_a_aa :!: route_b_bb :!: route_c_cc :!: route_a_AA :!: route_b_bb' where route_a_aa = do MC.exec $ putStrLn "/a/aa" return "0" route_b_bb = do MC.exec $ putStrLn "/b/bb" return (-1) route_c_cc = do MC.exec $ putStrLn "/c/cc" return 2 route_a_AA = do MC.exec $ putStrLn "/a/AA" return "3" route_b_bb' = do MC.exec $ putStrLn "/b/bb'" return 4 warp :: IO () warp = Warp.run 8080 srv -- * Utils routerEq :: forall repr a b c d. repr ~ Server => Router repr a b -> Router repr c d -> Bool routerEq x0 y0 = {- let r = go (Dbg.trace ("eq: x: " <> show x0) x0) (Dbg.trace ("eq: y: " <> show y0) y0) in Dbg.trace ("eq: r: " <> show r) r -} go x0 y0 where go :: Router repr a b -> Router repr c d -> Bool go (Router_Seg x) (Router_Seg y) = x == y go (Router_Cat xa xb) (Router_Cat ya yb) = routerEq xa ya && routerEq xb yb go (Router_Alt xl xr) (Router_Alt yl yr) = routerEq xl yl && routerEq xr yr go (Router_Cap xn) (Router_Cap yn) = xn == yn go (Router_Map xs) (Router_Map ys) = let xl = Map.toList xs in let yl = Map.toList ys in (List.length xl == List.length yl &&) $ List.and $ (\((kx, RouterUnion _xb2a x),(ky, RouterUnion _yb2a y)) -> kx==ky && routerEq x y) <$> List.zip xl yl go (Router_Caps xs) (Router_Caps ys) = go xs ys where go :: Captures (Router repr) xs b -> Captures (Router repr) ys d -> Bool go (Captures0 xa xn xr) (Captures0 ya yn yr) = xn == xn && routerEq xr yr go (Captures2 xx xy) (Captures2 yx yy) = go xx yx && go xy yy go Router_Any{} Router_Any{} = True go _x _y = False shouldRouteAs :: Router Server a b -> Router Server c d -> Hspec.Expectation shouldRouteAs inp exp = let inpR = router inp in let expR = router exp in unless (inpR`routerEq`expR) $ Hspec.expectationFailure $ "expected:\n" <> show expR <> "\nbut got:\n" <> show inpR mkBody :: Wai.Body -> Wai.MatchBody mkBody b = Wai.MatchBody $ \_ b' -> if b == b' then Nothing else Just $ TL.unpack $ "expecting: "<>TL.decodeUtf8 b<> " but got: "<>TL.decodeUtf8 b'<>"\n" -- * APIs end = get @String @'[PlainText] inp_endpoint = "a" end "a" end exp_endpoint = "a" (end end) inp_static = "a" "b" end "a" "c" end exp_static = "a" ("b" end "c" end) inp_dynamic = "a" capture @Int "foo" <.> "b" end "a" capture @Bool "bar" <.> "c" end "a" capture @Char "baz" <.> "d" end {- exp_dynamic = "a" captures (Captures2 (Captures2 (Captures0 (Proxy @(Int -> Res)) "foo") (Captures0 (Proxy @(Bool -> Res)) "bar")) (Captures0 (Proxy @(Char -> Res)) "baz")) <.> ("b" end "c" end "d" end) type Res = ResponseArgs (Router Server) String '[PlainText] -} inp_permute = "a" "b" "c" end "b" "a" "c" end "a" "c" "b" end "c" "a" "b" end "b" "c" "a" end "c" "b" "a" end "a" "a" "b" end "a" "a" "c" end exp_permute = "a" ("b" "c" end "c" "b" end "a" "b" end) "b" ("a" "c" end "c" "a" end) "c" ("a" "b" end "b" "a" end) "a" "a" "c" end {- api_PermuteRawEnd = "a" "b" "c" end "b" "a" "c" end "a" "c" "b" end "c" "a" "b" end "b" "c" "a" end "c" "b" "a" end raw api_PermuteRawEndRef = api_PermuteRef api_Raw api_PermuteRawBegin = raw "a" "b" "c" end "b" "a" "c" end "a" "c" "b" end "c" "a" "b" end "b" "c" "a" end "c" "b" "a" end api_PermuteRawBeginRef = raw api_PermuteRef -}