Router.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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.String (String)
import System.IO (IO, putStrLn)
import Text.Show (Show(..))
import qualified Control.Monad.Classes as MC
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Network.Wai.Handler.Warp as Warp
import qualified Test.Hspec as Hspec

import Symantic.HTTP
import Symantic.HTTP.Server
import Hspec.Utils

hspec = testSpecs $ describe "Router" $ 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 "properly reorders permuted static paths in the presence of raw in end" $ do
		inp_PermuteRawEnd `shouldRouteAs` exp_PermuteRawEnd
	it "properly reorders permuted static paths in the presence of raw in beginning" $ do
		inp_PermuteRawBegin `shouldRouteAs` exp_PermuteRawBegin
	it "properly reorders permuted static paths in the presence of raw in middle" $ do
		inp_PermuteRawMiddle `shouldRouteAs` exp_PermuteRawMiddle
	{- NOTE: this is semantically incorrect.
	it "distributes nested routes through dynamic paths" $ do
		inp_Dynamic `shouldRouteAs` exp_Dynamic
	-}
	it "properly handles mixing static paths at different levels" $ do
		inp_Level `shouldRouteAs` exp_Level

-- * 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, x),(ky, y)) -> kx==ky && routerEq x y) <$>
			List.zip xl yl
	go (Router_Caps xs) (Router_Caps ys) = goCaps xs ys
		where
		goCaps :: Captures (Router repr) xs b -> Captures (Router repr) ys d -> Bool
		goCaps (Captures0 _xa xn xr) (Captures0 _ya yn yr) = xn == yn && routerEq xr yr
		goCaps (Captures2 xx xy) (Captures2 yx yy) = goCaps xx yx && goCaps xy yy
		goCaps _ _ = False -- FIXME: may wrongly return False if captures are not in the same order
	go (Router_Union _u x) y = routerEq x y
	go x (Router_Union _u y) = routerEq x y
	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

-- * 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

inp_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
 <!> "a" </> "a" </> "b" </> end
 <!> "a" </> "a" </> "c" </> end
 <!> raw
exp_PermuteRawEnd = exp_Permute <!> raw

inp_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
 <!> "a" </> "a" </> "b" </> end
 <!> "a" </> "a" </> "c" </> end
exp_PermuteRawBegin = raw <!> exp_Permute

inp_PermuteRawMiddle =
     "a" </> "b" </> "c" </> end
 <!> "b" </> "a" </> "c" </> end
 <!> "a" </> "c" </> "b" </> end
 <!> raw
 <!> "c" </> "a" </> "b" </> end
 <!> "b" </> "c" </> "a" </> end
 <!> "c" </> "b" </> "a" </> end
exp_PermuteRawMiddle =
     "a" </> ("b" </> "c" </> end <!>
              "c" </> "b" </> end)
 <!> "b" </> "a" </> "c" </> end
 <!> raw
 <!> "b" </> "c" </> "a" </> end
 <!> "c" </> ("a" </> "b" </> end <!>
              "b" </> "a" </> end)

inp_Level1 =
     "a" </> "b" </> end
 <!> "a" </> end
inp_Level2 =
     "b" </> end
 <!> "a" </> "c" </> end
 <!> end
inp_Level =
 inp_Level1 <!>
 inp_Level2
exp_Level =
     "a" </> ("b" </> end <!> "c" </> end <!> end)
 <!> "b" </> end
 <!> end