module Trasa.Core
(
Bodiedness(..)
, Content(..)
, Payload(..)
, Router
, Prepared(..)
, Concealed(..)
, Constructed(..)
, conceal
, mapConstructed
, Method
, encodeMethod
, decodeMethod
, QueryString(..)
, encodeQuery
, decodeQuery
, Url(..)
, encodeUrl
, decodeUrl
, TrasaErr(..)
, status
, prepareWith
, dispatchWith
, parseWith
, linkWith
, payloadWith
, requestWith
, routerWith
, Path(..)
, match
, capture
, end
, (./)
, mapPath
, appendPath
, Param(..)
, Query(..)
, Parameter(..)
, Rec(..)
, demoteParameter
, flag
, optional
, list
, qend
, (.&)
, mapQuery
, RequestBody(..)
, body
, bodyless
, encodeRequestBody
, decodeRequestBody
, mapRequestBody
, ResponseBody(..)
, resp
, encodeResponseBody
, decodeResponseBody
, mapResponseBody
, Many(..)
, one
, mapMany
, CaptureEncoding(..)
, CaptureDecoding(..)
, CaptureCodec(..)
, BodyEncoding(..)
, BodyDecoding(..)
, BodyCodec(..)
, captureCodecToCaptureEncoding
, captureCodecToCaptureDecoding
, bodyCodecToBodyEncoding
, bodyCodecToBodyDecoding
, showReadCaptureCodec
, showReadBodyCodec
, ParamBase
, Arguments
, handler
, prettyRouter
) where
import Data.Kind (Type)
import Data.Functor.Identity (Identity(..))
import Control.Applicative (liftA2)
import Data.Maybe (mapMaybe,listToMaybe,isJust)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Data.Foldable (toList)
import Data.Bifunctor (first,bimap)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Types.Status as N
import qualified Network.HTTP.Media.MediaType as N
import qualified Network.HTTP.Media.Accept as N
import qualified Data.HashMap.Strict as HM
import Data.HashMap.Strict (HashMap)
import Data.Vinyl (Rec(..),rmap)
import Data.Vinyl.TypeLevel (type (++))
import Trasa.Method
import Trasa.Url
import Trasa.Error
import Trasa.Codec
newtype Many f a = Many { getMany :: NonEmpty (f a) }
deriving (Functor)
instance Applicative f => Applicative (Many f) where
pure = Many . pure . pure
Many mf <*> Many mx = Many $ liftA2 (<*>) mf mx
one :: f a -> Many f a
one = Many . pure
mapMany :: (forall x. f x -> g x) -> Many f a -> Many g a
mapMany eta (Many m) = Many (fmap eta m)
data Bodiedness = forall a. Body a | Bodyless
data RequestBody :: (Type -> Type) -> Bodiedness -> Type where
RequestBodyPresent :: f a -> RequestBody f ('Body a)
RequestBodyAbsent :: RequestBody f 'Bodyless
body :: rqf req -> RequestBody rqf ('Body req)
body = RequestBodyPresent
bodyless :: RequestBody rqf 'Bodyless
bodyless = RequestBodyAbsent
mapRequestBody :: (forall x. rqf x -> rqf' x) -> RequestBody rqf request -> RequestBody rqf' request
mapRequestBody _ RequestBodyAbsent = RequestBodyAbsent
mapRequestBody f (RequestBodyPresent reqBod) = RequestBodyPresent (f reqBod)
newtype ResponseBody rpf response = ResponseBody { getResponseBody :: rpf response }
resp :: rpf resp -> ResponseBody rpf resp
resp = ResponseBody
mapResponseBody :: (forall x. rpf x -> rpf' x) -> ResponseBody rpf request -> ResponseBody rpf' request
mapResponseBody f (ResponseBody resBod) = ResponseBody (f resBod)
data Path :: (Type -> Type) -> [Type] -> Type where
PathNil :: Path cap '[]
PathConsCapture :: cap a -> Path cap as -> Path cap (a ': as)
PathConsMatch :: T.Text -> Path cap as -> Path cap as
infixr 7 ./
(./) :: (a -> b) -> a -> b
(./) f a = f a
match :: T.Text -> Path cpf caps -> Path cpf caps
match = PathConsMatch
capture :: cpf cap -> Path cpf caps -> Path cpf (cap ': caps)
capture = PathConsCapture
end :: Path cpf '[]
end = PathNil
mapPath :: (forall x. cf x -> cf' x) -> Path cf ps -> Path cf' ps
mapPath _ PathNil = PathNil
mapPath f (PathConsMatch s pnext) = PathConsMatch s (mapPath f pnext)
mapPath f (PathConsCapture c pnext) = PathConsCapture (f c) (mapPath f pnext)
appendPath :: Path f as -> Path f bs -> Path f (as ++ bs)
appendPath PathNil bs = bs
appendPath (PathConsMatch a as) bs = PathConsMatch a (appendPath as bs)
appendPath (PathConsCapture cas as) bs = PathConsCapture cas (appendPath as bs)
data Param
= Flag
| forall a. Optional a
| forall a. List a
data Parameter :: Param -> Type where
ParameterFlag :: Bool -> Parameter Flag
ParameterOptional :: Maybe a -> Parameter (Optional a)
ParameterList :: [a] -> Parameter (List a)
data Query :: (Type -> Type) -> Param -> Type where
QueryFlag :: T.Text -> Query cap Flag
QueryOptional :: T.Text -> cap a -> Query cap (Optional a)
QueryList :: T.Text -> cap a -> Query cap (List a)
flag :: T.Text -> Query cpf Flag
flag = QueryFlag
optional :: T.Text -> cpf query -> Query cpf (Optional query)
optional = QueryOptional
list :: T.Text -> cpf query -> Query cpf (List query)
list = QueryList
qend :: Rec (Query qpf) '[]
qend = RNil
infixr 7 .&
(.&) :: Query qpf q -> Rec (Query qpf) qs -> Rec (Query qpf) (q ': qs)
(.&) = (:&)
mapQuery :: (forall x. f x -> g x) -> Rec (Query f) qs -> Rec (Query g) qs
mapQuery eta = rmap $ \case
QueryFlag key -> QueryFlag key
QueryOptional key query -> QueryOptional key (eta query)
QueryList key query -> QueryList key (eta query)
linkWith :: forall route response.
(forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)
-> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)
-> Prepared route response
-> Url
linkWith toCapEncs toQueries (Prepared route captures querys _) =
encodePieces (toCapEncs route) (toQueries route) captures querys
data Payload = Payload
{ payloadUrl :: !Url
, payloadContent :: !(Maybe Content)
, payloadAccepts :: !(NonEmpty N.MediaType)
}
payloadWith :: forall route response.
(forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)
-> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)
-> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyEncoding) req)
-> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyDecoding) resp)
-> Prepared route response
-> Payload
payloadWith toCapEncs toQueries toReqBody toRespBody p@(Prepared route _ _ reqBody) =
Payload url content accepts
where
url = linkWith toCapEncs toQueries p
content = encodeRequestBody (toReqBody route) reqBody
ResponseBody (Many decodings) = toRespBody route
accepts = bodyDecodingNames =<< decodings
requestWith :: Functor m
=> (forall caps querys req resp. route caps querys req resp -> Method)
-> (forall caps querys req resp. route caps querys req resp -> Path CaptureEncoding caps)
-> (forall caps querys req resp. route caps querys req resp -> Rec (Query CaptureEncoding) querys)
-> (forall caps querys req resp. route caps querys req resp -> RequestBody (Many BodyEncoding) req)
-> (forall caps querys req resp. route caps querys req resp -> ResponseBody (Many BodyDecoding) resp)
-> (Method -> Url -> Maybe Content -> NonEmpty N.MediaType -> m (Either TrasaErr Content))
-> Prepared route response
-> m (Either TrasaErr response)
requestWith toMethod toCapEncs toQueries toReqBody toRespBody run (Prepared route captures querys reqBody) =
let method = toMethod route
url = encodePieces (toCapEncs route) (toQueries route) captures querys
content = encodeRequestBody (toReqBody route) reqBody
respBodyDecs = toRespBody route
ResponseBody (Many decodings) = respBodyDecs
accepts = bodyDecodingNames =<< decodings
in fmap (\c -> c >>= decodeResponseBody respBodyDecs) (run method url content accepts)
encodeRequestBody :: RequestBody (Many BodyEncoding) request -> RequestBody Identity request -> Maybe Content
encodeRequestBody RequestBodyAbsent RequestBodyAbsent = Nothing
encodeRequestBody (RequestBodyPresent (Many encodings)) (RequestBodyPresent (Identity rq)) =
case NE.head encodings of
BodyEncoding names encoding -> Just (Content (NE.head names) (encoding rq))
decodeRequestBody
:: RequestBody (Many BodyDecoding) req
-> Maybe Content
-> Either TrasaErr (RequestBody Identity req)
decodeRequestBody reqDec mcontent = case reqDec of
RequestBodyPresent decs -> case mcontent of
Nothing -> wrongBody
Just (Content media bod) -> go (toList (getMany decs)) media bod
RequestBodyAbsent -> case mcontent of
Nothing -> Right RequestBodyAbsent
Just _ -> wrongBody
where
wrongBody = Left (status N.status415)
go :: [BodyDecoding a] -> N.MediaType -> LBS.ByteString -> Either TrasaErr (RequestBody Identity (Body a))
go [] _ _ = Left (status N.status400)
go (BodyDecoding medias dec:decs) media bod = case any (flip N.matches media) medias of
True -> bimap (TrasaErr N.status415 . LBS.fromStrict . T.encodeUtf8)
(RequestBodyPresent . Identity)
(dec bod)
False -> go decs media bod
encodeResponseBody
:: forall response
. [N.MediaType]
-> ResponseBody (Many BodyEncoding) response
-> response
-> Either TrasaErr Content
encodeResponseBody medias (ResponseBody encs) res = go (toList (getMany encs))
where
go :: [BodyEncoding response] -> Either TrasaErr Content
go [] = Left (status N.status406)
go (BodyEncoding accepts e:es) = case acceptable (toList accepts) medias of
Just typ -> Right (Content typ (e res))
Nothing -> go es
acceptable :: [N.MediaType] -> [N.MediaType] -> Maybe N.MediaType
acceptable [] _ = Nothing
acceptable (a:as) ms = case any (N.matches a) ms of
True -> Just a
False -> acceptable as ms
decodeResponseBody :: ResponseBody (Many BodyDecoding) response -> Content -> Either TrasaErr response
decodeResponseBody (ResponseBody (Many decodings)) (Content name content) = go (toList decodings)
where
go :: [BodyDecoding response] -> Either TrasaErr response
go [] = Left (status N.status415)
go (BodyDecoding names dec:decs) = case any (N.matches name) names of
True -> first (TrasaErr N.status400 . LBS.fromStrict . T.encodeUtf8) (dec content)
False -> go decs
encodePieces
:: Path CaptureEncoding captures
-> Rec (Query CaptureEncoding) querys
-> Rec Identity captures
-> Rec Parameter querys
-> Url
encodePieces pathEncoding queryEncoding path querys =
Url (encodePath pathEncoding path) (QueryString (encodeQueries queryEncoding querys))
where
encodePath
:: forall caps
. Path CaptureEncoding caps
-> Rec Identity caps
-> [T.Text]
encodePath PathNil RNil = []
encodePath (PathConsMatch str ps) xs = str : encodePath ps xs
encodePath (PathConsCapture (CaptureEncoding enc) ps) (Identity x :& xs) = enc x : encodePath ps xs
encodeQueries
:: forall qrys
. Rec (Query CaptureEncoding) qrys
-> Rec Parameter qrys
-> HM.HashMap T.Text QueryParam
encodeQueries RNil RNil = HM.empty
encodeQueries (QueryFlag key :& encs) (ParameterFlag on :& qs) =
if on then HM.insert key QueryParamFlag rest else rest
where rest = encodeQueries encs qs
encodeQueries (QueryOptional key (CaptureEncoding enc) :& encs) (ParameterOptional mval :& qs) =
maybe rest (\val -> HM.insert key (QueryParamSingle (enc val)) rest) mval
where rest = encodeQueries encs qs
encodeQueries (QueryList key (CaptureEncoding enc) :& encs) (ParameterList vals :& qs) =
HM.insert key (QueryParamList (fmap enc vals)) (encodeQueries encs qs)
dispatchWith :: forall route m.
Applicative m
=> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureDecoding) qrys)
-> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyDecoding) req)
-> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyEncoding) resp)
-> (forall caps qrys req resp. route caps qrys req resp -> Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity req -> m resp)
-> Router route
-> Method
-> [N.MediaType]
-> Url
-> Maybe Content
-> m (Either TrasaErr Content)
dispatchWith toQueries toReqBody toRespBody makeResponse router method accepts url mcontent =
case parseWith toQueries toReqBody router method url mcontent of
Left err -> pure (Left err)
Right (Concealed route path querys reqBody) ->
encodeResponseBody accepts (toRespBody route) <$> makeResponse route path querys reqBody
routerWith ::
(forall caps querys req resp. route caps querys req resp -> Method)
-> (forall caps querys req resp. route caps querys req resp -> Path CaptureDecoding caps)
-> [Constructed route]
-> Router route
routerWith toMethod toCapDec enumeratedRoutes = Router $ foldMap
(\(Constructed route) -> singletonIxedRouter route (toMethod route) (toCapDec route))
enumeratedRoutes
parseWith :: forall route.
(forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureDecoding) qrys)
-> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyDecoding) req)
-> Router route
-> Method
-> Url
-> Maybe Content
-> Either TrasaErr (Concealed route)
parseWith toQueries toReqBody router method (Url encodedPath encodedQuery) mcontent = do
Pathed route captures <- maybe (Left (status N.status404)) Right
$ parsePathWith router method encodedPath
querys <- parseQueryWith (toQueries route) encodedQuery
reqBody <- decodeRequestBody (toReqBody route) mcontent
return (Concealed route captures querys reqBody)
parsePathWith :: forall route.
Router route
-> Method
-> [T.Text]
-> Maybe (Pathed route)
parsePathWith (Router r0) method pieces0 =
listToMaybe (go VecNil pieces0 r0)
where
go :: forall n.
Vec n T.Text
-> [T.Text]
-> IxedRouter route n
-> [Pathed route]
go captures ps (IxedRouter matches mcapture responders) = case ps of
[] -> case HM.lookup (encodeMethod method) responders of
Nothing -> []
Just respondersAtMethod ->
mapMaybe (\(IxedResponder route capDecs) ->
fmap (\x -> (Pathed route x)) (decodeCaptureVector capDecs captures)
) respondersAtMethod
p : psNext ->
let res1 = maybe [] id $ fmap (go captures psNext) (HM.lookup p matches)
res2 = maybe [] id $ fmap (go (snocVec p captures) psNext) mcapture
in res1 ++ res2
parseQueryWith :: Rec (Query CaptureDecoding) querys -> QueryString -> Either TrasaErr (Rec Parameter querys)
parseQueryWith decoding (QueryString querys) = go decoding
where
go :: Rec (Query CaptureDecoding) qrys -> Either TrasaErr (Rec Parameter qrys)
go RNil = Right RNil
go (q :& qs) = (:&) <$> param <*> go qs
where
param = case q of
QueryFlag key -> Right (ParameterFlag (HM.member key querys))
QueryOptional key (CaptureDecoding dec) -> case HM.lookup key querys of
Nothing -> Right (ParameterOptional Nothing)
Just query -> case query of
QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when key-value expected")
QueryParamSingle txt -> Right (ParameterOptional (dec txt))
QueryParamList _ -> Left (TrasaErr N.status400 "query param list given when key-value expected")
QueryList key (CaptureDecoding dec) -> case HM.lookup key querys of
Nothing -> Right (ParameterList [])
Just query -> case query of
QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when list expected")
QueryParamSingle txt -> Right (ParameterList (maybe [] (:[]) (dec txt)))
QueryParamList txts -> Right (ParameterList (mapMaybe dec txts))
decodeCaptureVector ::
IxedRec CaptureDecoding n xs
-> Vec n T.Text
-> Maybe (Rec Identity xs)
decodeCaptureVector IxedRecNil VecNil = Just RNil
decodeCaptureVector (IxedRecCons (CaptureDecoding decode) rnext) (VecCons piece vnext) = do
val <- decode piece
vals <- decodeCaptureVector rnext vnext
return (Identity val :& vals)
type family ParamBase (param :: Param) :: Type where
ParamBase Flag = Bool
ParamBase (Optional a) = Maybe a
ParamBase (List a) = [a]
demoteParameter :: Parameter param -> ParamBase param
demoteParameter = \case
ParameterFlag b -> b
ParameterOptional m -> m
ParameterList l -> l
type family Arguments (pieces :: [Type]) (querys :: [Param]) (body :: Bodiedness) (result :: Type) :: Type where
Arguments '[] '[] ('Body b) r = b -> r
Arguments '[] '[] 'Bodyless r = r
Arguments '[] (q ': qs) r b = ParamBase q -> Arguments '[] qs r b
Arguments (c ': cs) qs b r = c -> Arguments cs qs b r
prepareWith ::
(forall caps qry req resp. route caps qry req resp -> Path pf caps)
-> (forall caps qry req resp. route caps qry req resp -> Rec (Query qf) qry)
-> (forall caps qry req resp. route caps qry req resp -> RequestBody rqf req)
-> route captures query request response
-> Arguments captures query request (Prepared route response)
prepareWith toPath toQuery toReqBody route =
prepareExplicit route (toPath route) (toQuery route) (toReqBody route)
prepareExplicit :: forall route captures querys request response rqf pf qf.
route captures querys request response
-> Path pf captures
-> Rec (Query qf) querys
-> RequestBody rqf request
-> Arguments captures querys request (Prepared route response)
prepareExplicit route = go (Prepared route)
where
go :: forall caps qrys z.
(Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity request -> z)
-> Path pf caps
-> Rec (Query qf) qrys
-> RequestBody rqf request
-> Arguments caps qrys request z
go k PathNil RNil RequestBodyAbsent =
k RNil RNil RequestBodyAbsent
go k PathNil RNil (RequestBodyPresent _) =
\reqBod -> k RNil RNil (RequestBodyPresent (Identity reqBod))
go k PathNil (q :& qs) b =
\qt -> go (\caps querys reqBody -> k caps (parameter q qt :& querys) reqBody) PathNil qs b
go k (PathConsMatch _ pnext) qs b =
go k pnext qs b
go k (PathConsCapture _ pnext) qs b =
\c -> go (\caps querys reqBod -> k (Identity c :& caps) querys reqBod) pnext qs b
parameter :: forall param. Query qf param -> ParamBase param -> Parameter param
parameter (QueryFlag _) b = ParameterFlag b
parameter (QueryOptional _ _) m = ParameterOptional m
parameter (QueryList _ _) l = ParameterList l
handler :: forall captures querys request x.
Rec Identity captures
-> Rec Parameter querys
-> RequestBody Identity request
-> Arguments captures querys request x
-> x
handler = go
where
go :: forall caps qrys.
Rec Identity caps
-> Rec Parameter qrys
-> RequestBody Identity request
-> Arguments caps qrys request x
-> x
go RNil RNil RequestBodyAbsent f = f
go RNil RNil (RequestBodyPresent (Identity b)) f = f b
go RNil (q :& qs) b f = go RNil qs b (f (demoteParameter q))
go (Identity c :& cs) qs b f = go cs qs b (f c)
data Constructed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where
Constructed :: route captures querys request response -> Constructed route
mapConstructed ::
(forall caps qrys req resp. sub caps qrys req resp -> route cap qrys req resp)
-> Constructed sub
-> Constructed route
mapConstructed f (Constructed sub) = Constructed (f sub)
data Pathed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where
Pathed :: route captures querys request response -> Rec Identity captures -> Pathed route
data Prepared :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type -> Type where
Prepared ::
route captures querys request response
-> Rec Identity captures
-> Rec Parameter querys
-> RequestBody Identity request
-> Prepared route response
data Concealed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where
Concealed ::
route captures querys request response
-> Rec Identity captures
-> Rec Parameter querys
-> RequestBody Identity request
-> Concealed route
conceal :: Prepared route response -> Concealed route
conceal (Prepared route caps querys req) = Concealed route caps querys req
data Content = Content
{ contentType :: N.MediaType
, contentData :: LBS.ByteString
} deriving (Show,Eq,Ord)
data Nat = S !Nat | Z
newtype Router route = Router (IxedRouter route 'Z)
data IxedRouter :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Nat -> Type where
IxedRouter ::
HashMap T.Text (IxedRouter route n)
-> Maybe (IxedRouter route ('S n))
-> HashMap T.Text [IxedResponder route n]
-> IxedRouter route n
instance Monoid (IxedRouter route n) where
mempty = IxedRouter HM.empty Nothing HM.empty
mappend = unionIxedRouter
data IxedResponder :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Nat -> Type where
IxedResponder ::
route captures query request response
-> IxedRec CaptureDecoding n captures
-> IxedResponder route n
data IxedRec :: (k -> Type) -> Nat -> [k] -> Type where
IxedRecNil :: IxedRec f 'Z '[]
IxedRecCons :: !(f r) -> IxedRec f n rs -> IxedRec f ('S n) (r ': rs)
data Vec :: Nat -> Type -> Type where
VecNil :: Vec 'Z a
VecCons :: !a -> Vec n a -> Vec ('S n) a
data IxedPath :: (Type -> Type) -> Nat -> [Type] -> Type where
IxedPathNil :: IxedPath f 'Z '[]
IxedPathCapture :: f a -> IxedPath f n as -> IxedPath f ('S n) (a ': as)
IxedPathMatch :: T.Text -> IxedPath f n a -> IxedPath f n a
data LenPath :: Nat -> Type where
LenPathNil :: LenPath 'Z
LenPathCapture :: LenPath n -> LenPath ('S n)
LenPathMatch :: T.Text -> LenPath n -> LenPath n
data HideIx :: (Nat -> k -> Type) -> k -> Type where
HideIx :: f n a -> HideIx f a
snocVec :: a -> Vec n a -> Vec ('S n) a
snocVec a VecNil = VecCons a VecNil
snocVec a (VecCons b vnext) =
VecCons b (snocVec a vnext)
pathToIxedPath :: Path f xs -> HideIx (IxedPath f) xs
pathToIxedPath PathNil = HideIx IxedPathNil
pathToIxedPath (PathConsCapture c pnext) =
case pathToIxedPath pnext of
HideIx ixed -> HideIx (IxedPathCapture c ixed)
pathToIxedPath (PathConsMatch s pnext) =
case pathToIxedPath pnext of
HideIx ixed -> HideIx (IxedPathMatch s ixed)
ixedPathToIxedRec :: IxedPath f n xs -> IxedRec f n xs
ixedPathToIxedRec IxedPathNil = IxedRecNil
ixedPathToIxedRec (IxedPathCapture c pnext) =
IxedRecCons c (ixedPathToIxedRec pnext)
ixedPathToIxedRec (IxedPathMatch _ pnext) =
ixedPathToIxedRec pnext
ixedPathToLenPath :: IxedPath f n xs -> LenPath n
ixedPathToLenPath IxedPathNil = LenPathNil
ixedPathToLenPath (IxedPathCapture _ pnext) =
LenPathCapture (ixedPathToLenPath pnext)
ixedPathToLenPath (IxedPathMatch s pnext) =
LenPathMatch s (ixedPathToLenPath pnext)
snocLenPathMatch :: T.Text -> LenPath n -> LenPath n
snocLenPathMatch s x = case x of
LenPathNil -> LenPathMatch s LenPathNil
LenPathMatch t pnext -> LenPathMatch t (snocLenPathMatch s pnext)
LenPathCapture pnext -> LenPathCapture (snocLenPathMatch s pnext)
snocLenPathCapture :: LenPath n -> LenPath ('S n)
snocLenPathCapture x = case x of
LenPathNil -> LenPathCapture LenPathNil
LenPathMatch t pnext -> LenPathMatch t (snocLenPathCapture pnext)
LenPathCapture pnext -> LenPathCapture (snocLenPathCapture pnext)
reverseLenPathMatch :: LenPath n -> LenPath n
reverseLenPathMatch = go
where
go :: forall n. LenPath n -> LenPath n
go LenPathNil = LenPathNil
go (LenPathMatch s pnext) = snocLenPathMatch s (go pnext)
go (LenPathCapture pnext) = snocLenPathCapture (go pnext)
singletonIxedRouter ::
route captures querys request response -> Method -> Path CaptureDecoding captures -> IxedRouter route 'Z
singletonIxedRouter route method capDecs = case pathToIxedPath capDecs of
HideIx ixedCapDecs ->
let ixedCapDecsRec = ixedPathToIxedRec ixedCapDecs
responder = IxedResponder route ixedCapDecsRec
lenPath = reverseLenPathMatch (ixedPathToLenPath ixedCapDecs)
in singletonIxedRouterHelper responder method lenPath
singletonIxedRouterHelper ::
IxedResponder route n -> Method -> LenPath n -> IxedRouter route 'Z
singletonIxedRouterHelper responder method path =
let r = IxedRouter HM.empty Nothing (HM.singleton (encodeMethod method) [responder])
in singletonIxedRouterGo r path
singletonIxedRouterGo ::
IxedRouter route n -> LenPath n -> IxedRouter route 'Z
singletonIxedRouterGo r lp = case lp of
LenPathNil -> r
LenPathCapture lpNext -> singletonIxedRouterGo (IxedRouter HM.empty (Just r) HM.empty) lpNext
LenPathMatch s lpNext -> singletonIxedRouterGo (IxedRouter (HM.singleton s r) Nothing HM.empty) lpNext
unionIxedRouter :: IxedRouter route n -> IxedRouter route n -> IxedRouter route n
unionIxedRouter = go
where
go :: forall route n. IxedRouter route n -> IxedRouter route n -> IxedRouter route n
go (IxedRouter matchesA captureA respsA) (IxedRouter matchesB captureB respsB) =
IxedRouter
(HM.unionWith go matchesA matchesB)
(unionMaybeWith go captureA captureB)
(HM.unionWith (++) respsA respsB)
unionMaybeWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionMaybeWith f x y = case x of
Nothing -> y
Just xval -> case y of
Nothing -> x
Just yval -> Just (f xval yval)
prettyRouter :: Router route -> String
prettyRouter (Router r) = L.unlines (prettyIxedRouter 0 (Nothing,r))
prettyIxedRouter ::
Int
-> (Maybe String, IxedRouter route n)
-> [String]
prettyIxedRouter indent (mnode,IxedRouter matches cap responders) =
let spaces = L.replicate indent ' '
nextIndent = if isJust mnode then indent + 2 else indent
children1 = map (first (Just . ('/' : ) . T.unpack)) (HM.toList matches)
children2 = maybe [] (\x -> [(Just "/:capture",x)]) cap
in concat
[ case mnode of
Nothing -> if length responders > 0
then ["/ " ++ showRespondersList responders]
else []
Just _ -> []
, maybe [] (\x -> [x]) $ flip fmap mnode $ \node -> spaces
++ node
++ (if length responders > 0 then " " ++ showRespondersList responders else "")
, prettyIxedRouter nextIndent =<< children1
, prettyIxedRouter nextIndent =<< children2
]
showRespondersList :: HashMap T.Text [a] -> String
showRespondersList = id
. (\x -> "[" ++ x ++ "]")
. L.intercalate ","
. map (\(method,xs) -> T.unpack method ++ (if L.length xs > 1 then "*" else ""))
. HM.toList