{-# LANGUAGE PartialTypeSignatures #-}

module Web.Minion.Router.Internal where

import Control.Monad ((>=>))
import Control.Monad.IO.Class qualified as IO
import Data.ByteString (ByteString)
import Data.String (IsString (..))
import Data.Text (Text)
import GHC.Exts (IsList (..))
import Network.HTTP.Types qualified as Http
import Network.Wai qualified as Http
import Network.Wai qualified as Wai

import Control.Exception qualified as IOExc
import Control.Monad.Catch qualified as Exc
import Data.ByteString.Lazy qualified as Bytes.Lazy
import Data.Kind (Type)
import Data.Void (Void)
import Web.Minion.Args.Internal (
  Arg,
  FunArgs (apply, type (~>)),
  HList,
  HandleArgs,
  IsLenient,
  IsRequired,
  RHList ((:#!)),
  RHListToHList (revHListToList),
  Reverse (reverseHList),
  RunDelayed (DelayedArgs, runDelayed),
  WithHeader (..),
  WithPiece (..),
  WithPieces (..),
  WithQueryParam (..),
  WithReq (..),
  type (:+),
 )
import Web.Minion.Error (
  ErrorBuilder,
  ErrorBuilders (..),
  NoMatch (..),
  ServerError,
 )
import Web.Minion.Introspect qualified as I
import Web.Minion.Request (IsRequest)
import Web.Minion.Response (CanRespond (..), ToResponse (..))

-- | If you don't care about introspection
type Router = Router' Void

type MiddlewareM m = ApplicationM m -> ApplicationM m

type MakeError = Http.Status -> Bytes.Lazy.ByteString -> ServerError

type ValueCombinator i v ts m = Router' i (ts :+ v) m -> Router' i ts m
type Combinator i ts m = Router' i ts m -> Router' i ts m

data Router' i (ts :: Type) m where
  Piece ::
    -- | .
    Text ->
    Router' i ts m ->
    Router' i ts m
  QueryParam ::
    forall a presence parsing m ts i.
    (I.Introspection i I.QueryParam a, IsRequired presence, IsLenient parsing) =>
    -- | Query param name
    ByteString ->
    -- | Parse query param
    -- Outer Maybe -- is there key
    -- Inner Maybe -- is there value
    (MakeError -> Maybe (Maybe ByteString) -> m (Arg presence parsing a)) ->
    Router' i (ts :+ WithQueryParam presence parsing m a) m ->
    Router' i ts m
  Captures ::
    forall a ts m i.
    (I.Introspection i I.Captures a) =>
    -- | Parse pieces
    (MakeError -> [Text] -> m [a]) ->
    -- | Placeholder
    Text ->
    Router' i (ts :+ WithPieces a) m ->
    Router' i ts m
  Capture ::
    forall a ts m i.
    (I.Introspection i I.Capture a) =>
    -- | Parse piece
    (MakeError -> Text -> m a) ->
    -- | Placeholder
    Text ->
    Router' i (ts :+ WithPiece a) m ->
    Router' i ts m
  Middleware ::
    MiddlewareM m ->
    Router' i ts m ->
    Router' i ts m
  Header ::
    forall a presence parsing m ts i.
    (I.Introspection i I.Header a, IsRequired presence, IsLenient parsing) =>
    Http.HeaderName ->
    -- | Parse header
    (MakeError -> [ByteString] -> m (Arg presence parsing a)) ->
    Router' i (ts :+ WithHeader presence parsing m a) m ->
    Router' i ts m
  Request ::
    forall r m i ts.
    (I.Introspection i I.Request r, IsRequest r) =>
    -- | .
    (ErrorBuilder -> Wai.Request -> m r) ->
    Router' i (ts :+ WithReq m r) m ->
    Router' i ts m
  Alt ::
    -- | Sub routes
    [Router' i ts m] ->
    Router' i ts m
  -- -- | Additional constraints provider with `request` and `response` can be useful for introspection
  Handle ::
    forall o m ts i st.
    ( HandleArgs ts st m
    , ToResponse m o
    , CanRespond o
    , I.Introspection i I.Response o
    ) =>
    -- | Handled HTTP method
    Http.Method ->
    (HList (DelayedArgs st) -> m o) ->
    Router' i ts m
  Description ::
    (I.Introspection i I.Description desc) =>
    -- | .
    desc ->
    Router' i ts m ->
    Router' i ts m
  MapArgs ::
    forall m ts ts' i.
    (RHList ts -> RHList ts') ->
    Router' i ts' m ->
    Router' i ts m
  HideIntrospection ::
    forall i' i ts m.
    Router' i ts m ->
    Router' i' ts m

{-# INLINE route #-}
route ::
  forall m ts i.
  (IO.MonadIO m, Exc.MonadCatch m) =>
  ErrorBuilders ->
  RoutingState ->
  RHList ts ->
  Router' i ts m ->
  ApplicationM m
route :: forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state RHList ts
args (Alt [Router' i ts m]
routes) = \Request
req Response -> IO ResponseReceived
resp -> [m ResponseReceived] -> m ResponseReceived
forall (m :: * -> *) b. (MonadIO m, MonadCatch m) => [m b] -> m b
goThrough ([m ResponseReceived] -> m ResponseReceived)
-> [m ResponseReceived] -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ (Router' i ts m -> m ResponseReceived)
-> [Router' i ts m] -> [m ResponseReceived]
forall a b. (a -> b) -> [a] -> [b]
map (\Router' i ts m
r -> ErrorBuilders
-> RoutingState
-> RHList ts
-> Router' i ts m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state RHList ts
args Router' i ts m
r Request
req Response -> IO ResponseReceived
resp) [Router' i ts m]
routes
route ErrorBuilders
builders RoutingState
state RHList ts
args (Middleware MiddlewareM m
mw Router' i ts m
r) = MiddlewareM m
mw (ErrorBuilders
-> RoutingState
-> RHList ts
-> Router' i ts m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state RHList ts
args Router' i ts m
r)
route ErrorBuilders
builders RoutingState
state RHList ts
args (MapArgs RHList ts -> RHList ts'
f Router' i ts' m
r) = ErrorBuilders
-> RoutingState
-> RHList ts'
-> Router' i ts' m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state (RHList ts -> RHList ts'
f RHList ts
args) Router' i ts' m
r
route ErrorBuilders
builders RoutingState
state RHList ts
args (Description desc
_ Router' i ts m
r) = ErrorBuilders
-> RoutingState
-> RHList ts
-> Router' i ts m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state RHList ts
args Router' i ts m
r
route ErrorBuilders
builders RoutingState
state RHList ts
args (HideIntrospection Router' i ts m
r) = ErrorBuilders
-> RoutingState
-> RHList ts
-> Router' i ts m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state RHList ts
args Router' i ts m
r
route ErrorBuilders
_ RoutingState{[Text]
path :: [Text]
$sel:path:RoutingState :: RoutingState -> [Text]
..} RHList ts
args (Handle @o ByteString
method HList (DelayedArgs st) -> m o
f) = [Text]
-> RHList ts
-> ByteString
-> (HList (DelayedArgs st) -> m o)
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) o ts (st :: [*]).
(MonadIO m, ToResponse m o, CanRespond o, HandleArgs ts st m) =>
[Text]
-> RHList ts
-> ByteString
-> (HList (DelayedArgs st) -> m o)
-> ApplicationM m
routeHandle [Text]
path RHList ts
args ByteString
method HList (DelayedArgs st) -> m o
f
route builders :: ErrorBuilders
builders@ErrorBuilders{ErrorBuilder
headerErrorBuilder :: ErrorBuilder
queryParamsErrorBuilder :: ErrorBuilder
captureErrorBuilder :: ErrorBuilder
bodyErrorBuilder :: ErrorBuilder
$sel:headerErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:queryParamsErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:captureErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:bodyErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
..} RoutingState
state RHList ts
args (Request @f ErrorBuilder -> Request -> m r
get Router' i (ts :+ WithReq m r) m
r) = \Request
req Response -> IO ResponseReceived
resp -> do
  ErrorBuilders
-> RoutingState
-> RHList (ts :+ WithReq m r)
-> Router' i (ts :+ WithReq m r) m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state (m r -> WithReq m r
forall {k} (m :: k -> *) (r :: k). m r -> WithReq m r
WithReq (ErrorBuilder -> Request -> m r
get ErrorBuilder
bodyErrorBuilder Request
req) WithReq m r -> RHList ts -> RHList (ts :+ WithReq m r)
forall t ts1. t -> RHList ts1 -> RHList (ts1 :+ t)
:#! RHList ts
args) Router' i (ts :+ WithReq m r) m
r Request
req Response -> IO ResponseReceived
resp
route builders :: ErrorBuilders
builders@ErrorBuilders{ErrorBuilder
$sel:headerErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:queryParamsErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:captureErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:bodyErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
headerErrorBuilder :: ErrorBuilder
queryParamsErrorBuilder :: ErrorBuilder
captureErrorBuilder :: ErrorBuilder
bodyErrorBuilder :: ErrorBuilder
..} RoutingState
state RHList ts
args (Header @a @presence @parsing HeaderName
headerName MakeError -> [ByteString] -> m (Arg presence parsing a)
get Router' i (ts :+ WithHeader presence parsing m a) m
r) = \Request
req ->
  let header :: [ByteString]
header = Request -> HeaderName -> [ByteString]
lookupHeader Request
req HeaderName
headerName
      withHeader :: RHList (ts :+ WithHeader presence parsing m a)
withHeader = m (Arg presence parsing a) -> WithHeader presence parsing m a
forall presence parsing (m :: * -> *) a.
m (Arg presence parsing a) -> WithHeader presence parsing m a
WithHeader (MakeError -> [ByteString] -> m (Arg presence parsing a)
get (ErrorBuilder
headerErrorBuilder Request
req) [ByteString]
header) WithHeader presence parsing m a
-> RHList ts -> RHList (ts :+ WithHeader presence parsing m a)
forall t ts1. t -> RHList ts1 -> RHList (ts1 :+ t)
:#! RHList ts
args
   in ErrorBuilders
-> RoutingState
-> RHList (ts :+ WithHeader presence parsing m a)
-> Router' i (ts :+ WithHeader presence parsing m a) m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state RHList (ts :+ WithHeader presence parsing m a)
withHeader Router' i (ts :+ WithHeader presence parsing m a) m
r Request
req
route builders :: ErrorBuilders
builders@ErrorBuilders{ErrorBuilder
$sel:headerErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:queryParamsErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:captureErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:bodyErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
headerErrorBuilder :: ErrorBuilder
queryParamsErrorBuilder :: ErrorBuilder
captureErrorBuilder :: ErrorBuilder
bodyErrorBuilder :: ErrorBuilder
..} RoutingState
state RHList ts
args (QueryParam @a @presence @parsing ByteString
queryParamName MakeError -> Maybe (Maybe ByteString) -> m (Arg presence parsing a)
parse Router' i (ts :+ WithQueryParam presence parsing m a) m
r) = \Request
req ->
  let mbQueryParamVal :: Maybe (Maybe ByteString)
mbQueryParamVal = ByteString
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
queryParamName ([(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString))
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> [(ByteString, Maybe ByteString)]
Http.queryString Request
req
      withQueryParam :: RHList (ts :+ WithQueryParam presence parsing m a)
withQueryParam = m (Arg presence parsing a) -> WithQueryParam presence parsing m a
forall presence parsing (m :: * -> *) a.
m (Arg presence parsing a) -> WithQueryParam presence parsing m a
WithQueryParam (MakeError -> Maybe (Maybe ByteString) -> m (Arg presence parsing a)
parse (ErrorBuilder
queryParamsErrorBuilder Request
req) Maybe (Maybe ByteString)
mbQueryParamVal) WithQueryParam presence parsing m a
-> RHList ts -> RHList (ts :+ WithQueryParam presence parsing m a)
forall t ts1. t -> RHList ts1 -> RHList (ts1 :+ t)
:#! RHList ts
args
   in ErrorBuilders
-> RoutingState
-> RHList (ts :+ WithQueryParam presence parsing m a)
-> Router' i (ts :+ WithQueryParam presence parsing m a) m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState
state RHList (ts :+ WithQueryParam presence parsing m a)
withQueryParam Router' i (ts :+ WithQueryParam presence parsing m a) m
r Request
req
route ErrorBuilders
builders RoutingState{[Text]
$sel:path:RoutingState :: RoutingState -> [Text]
path :: [Text]
..} RHList ts
args (Piece Text
txt Router' i ts m
r) = case [Text]
path of
  (Text
t : [Text]
ts) | Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t -> ErrorBuilders
-> RoutingState
-> RHList ts
-> Router' i ts m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState{$sel:path:RoutingState :: [Text]
path = [Text]
ts, ..} RHList ts
args Router' i ts m
r
  [Text]
_ -> \Request
_ Response -> IO ResponseReceived
_ -> NoMatch -> m ResponseReceived
forall e (m :: * -> *) a. (Exception e, MonadIO m) => e -> m a
throwMIO NoMatch
NoMatch
route builders :: ErrorBuilders
builders@ErrorBuilders{ErrorBuilder
$sel:headerErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:queryParamsErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:captureErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:bodyErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
headerErrorBuilder :: ErrorBuilder
queryParamsErrorBuilder :: ErrorBuilder
captureErrorBuilder :: ErrorBuilder
bodyErrorBuilder :: ErrorBuilder
..} RoutingState{[Text]
$sel:path:RoutingState :: RoutingState -> [Text]
path :: [Text]
..} RHList ts
args (Captures MakeError -> [Text] -> m [a]
parse Text
_ Router' i (ts :+ WithPieces a) m
r) = \Request
req Response -> IO ResponseReceived
resp -> do
  [a]
parsed <- MakeError -> [Text] -> m [a]
parse (ErrorBuilder
captureErrorBuilder Request
req) [Text]
path
  ErrorBuilders
-> RoutingState
-> RHList (ts :+ WithPieces a)
-> Router' i (ts :+ WithPieces a) m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState{$sel:path:RoutingState :: [Text]
path = [], ..} ([a] -> WithPieces a
forall a. [a] -> WithPieces a
WithPieces [a]
parsed WithPieces a -> RHList ts -> RHList (ts :+ WithPieces a)
forall t ts1. t -> RHList ts1 -> RHList (ts1 :+ t)
:#! RHList ts
args) Router' i (ts :+ WithPieces a) m
r Request
req Response -> IO ResponseReceived
resp
route builders :: ErrorBuilders
builders@ErrorBuilders{ErrorBuilder
$sel:headerErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:queryParamsErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:captureErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
$sel:bodyErrorBuilder:ErrorBuilders :: ErrorBuilders -> ErrorBuilder
headerErrorBuilder :: ErrorBuilder
queryParamsErrorBuilder :: ErrorBuilder
captureErrorBuilder :: ErrorBuilder
bodyErrorBuilder :: ErrorBuilder
..} RoutingState{[Text]
$sel:path:RoutingState :: RoutingState -> [Text]
path :: [Text]
..} RHList ts
args (Capture MakeError -> Text -> m a
parse Text
_ Router' i (ts :+ WithPiece a) m
r) = \Request
req Response -> IO ResponseReceived
resp -> case [Text]
path of
  (Text
t : [Text]
ts) -> do
    a
v <- MakeError -> Text -> m a
parse (ErrorBuilder
captureErrorBuilder Request
req) Text
t
    ErrorBuilders
-> RoutingState
-> RHList (ts :+ WithPiece a)
-> Router' i (ts :+ WithPiece a) m
-> Request
-> (Response -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) ts i.
(MonadIO m, MonadCatch m) =>
ErrorBuilders
-> RoutingState -> RHList ts -> Router' i ts m -> ApplicationM m
route ErrorBuilders
builders RoutingState{$sel:path:RoutingState :: [Text]
path = [Text]
ts, ..} (a -> WithPiece a
forall a. a -> WithPiece a
WithPiece a
v WithPiece a -> RHList ts -> RHList (ts :+ WithPiece a)
forall t ts1. t -> RHList ts1 -> RHList (ts1 :+ t)
:#! RHList ts
args) Router' i (ts :+ WithPiece a) m
r Request
req Response -> IO ResponseReceived
resp
  [Text]
_ -> NoMatch -> m ResponseReceived
forall e (m :: * -> *) a. (Exception e, MonadIO m) => e -> m a
throwMIO NoMatch
NoMatch

{-# INLINE routeHandle #-}
routeHandle ::
  forall m o ts st.
  (IO.MonadIO m, ToResponse m o, CanRespond o, HandleArgs ts st m) =>
  [Text] ->
  RHList ts ->
  Http.Method ->
  (HList (DelayedArgs st) -> m o) ->
  ApplicationM m
routeHandle :: forall (m :: * -> *) o ts (st :: [*]).
(MonadIO m, ToResponse m o, CanRespond o, HandleArgs ts st m) =>
[Text]
-> RHList ts
-> ByteString
-> (HList (DelayedArgs st) -> m o)
-> ApplicationM m
routeHandle [Text]
path RHList ts
args ByteString
method HList (DelayedArgs st) -> m o
f Request
req Response -> IO ResponseReceived
resp = do
  Request -> [Text] -> ByteString -> m ()
forall (f :: * -> *).
MonadIO f =>
Request -> [Text] -> ByteString -> f ()
checkHandler Request
req [Text]
path ByteString
method
  let acceptHeader :: [ByteString]
acceptHeader = Request -> HeaderName -> [ByteString]
lookupHeader Request
req HeaderName
Http.hAccept
  if forall o. CanRespond o => [ByteString] -> Bool
forall {k} (o :: k). CanRespond o => [ByteString] -> Bool
canRespond @o [ByteString]
acceptHeader
    then do
      HList (DelayedArgs st)
args' <- HList st -> m (HList (DelayedArgs st))
forall (ts :: [*]) (m :: * -> *).
RunDelayed ts m =>
HList ts -> m (HList (DelayedArgs ts))
runDelayed (HList (HListTypes ts) -> HList st
forall (xs :: [*]) (sx :: [*]).
Reverse xs sx =>
HList xs -> HList sx
reverseHList (RHList ts -> HList (HListTypes ts)
forall ts. RHListToHList ts => RHList ts -> HList (HListTypes ts)
revHListToList RHList ts
args))
      HList (DelayedArgs st) -> m o
f HList (DelayedArgs st)
args' m o -> (o -> m ResponseReceived) -> m ResponseReceived
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) r.
ToResponse m r =>
[ByteString] -> r -> m Response
toResponse @m @o [ByteString]
acceptHeader (o -> m Response)
-> (Response -> m ResponseReceived) -> o -> m ResponseReceived
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO ResponseReceived -> m ResponseReceived
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO ResponseReceived -> m ResponseReceived)
-> (Response -> IO ResponseReceived)
-> Response
-> m ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ResponseReceived
resp)
    else IO ResponseReceived -> m ResponseReceived
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO ResponseReceived -> m ResponseReceived)
-> IO ResponseReceived -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
Wai.responseBuilder Status
Http.status406 [] Builder
forall a. Monoid a => a
mempty

{-# INLINE goThrough #-}
goThrough :: (IO.MonadIO m, Exc.MonadCatch m) => [m b] -> m b
goThrough :: forall (m :: * -> *) b. (MonadIO m, MonadCatch m) => [m b] -> m b
goThrough (m b
a : [m b]
as) =
  forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
Exc.try @_ @NoMatch m b
a m (Either NoMatch b) -> (Either NoMatch b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left NoMatch
NoMatch -> [m b] -> m b
forall (m :: * -> *) b. (MonadIO m, MonadCatch m) => [m b] -> m b
goThrough [m b]
as
    Right b
x -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
goThrough [] = NoMatch -> m b
forall e (m :: * -> *) a. (Exception e, MonadIO m) => e -> m a
throwMIO NoMatch
NoMatch

{-# INLINE throwMIO #-}
throwMIO :: (Exc.Exception e, IO.MonadIO m) => e -> m a
throwMIO :: forall e (m :: * -> *) a. (Exception e, MonadIO m) => e -> m a
throwMIO = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO a -> m a) -> (e -> IO a) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall e a. Exception e => e -> IO a
IOExc.throwIO

{-# INLINE checkHandler #-}
checkHandler :: (IO.MonadIO f) => Wai.Request -> [Text] -> Http.Method -> f ()
checkHandler :: forall (f :: * -> *).
MonadIO f =>
Request -> [Text] -> ByteString -> f ()
checkHandler Request
req [Text]
path ByteString
method
  | ByteString
method ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Request -> ByteString
Http.requestMethod Request
req
  , [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
path Bool -> Bool -> Bool
|| [Text]
path [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
Item [Text]
forall a. Monoid a => a
mempty] =
      () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = NoMatch -> f ()
forall e (m :: * -> *) a. (Exception e, MonadIO m) => e -> m a
throwMIO NoMatch
NoMatch

{-# INLINE lookupHeader #-}
lookupHeader :: Wai.Request -> Http.HeaderName -> [ByteString]
lookupHeader :: Request -> HeaderName -> [ByteString]
lookupHeader Request
req HeaderName
hn = ((HeaderName, ByteString) -> ByteString)
-> ResponseHeaders -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (ResponseHeaders -> [ByteString])
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName
hn HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (ResponseHeaders -> [ByteString])
-> ResponseHeaders -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
Http.requestHeaders Request
req

instance IsList (Router' i ts r) where
  type Item (Router' i ts r) = Router' i ts r
  fromList :: [Item (Router' i ts r)] -> Router' i ts r
fromList = [Item (Router' i ts r)] -> Router' i ts r
[Router' i ts r] -> Router' i ts r
forall i ts (m :: * -> *). [Router' i ts m] -> Router' i ts m
Alt
  toList :: Router' i ts r -> [Item (Router' i ts r)]
toList Router' i ts r
a = [Item [Router' i ts r]
Router' i ts r
a]

instance Semigroup (Router' i ts r) where
  Router' i ts r
a <> :: Router' i ts r -> Router' i ts r -> Router' i ts r
<> Router' i ts r
b = [Item (Router' i ts r)
Router' i ts r
a, Item (Router' i ts r)
Router' i ts r
b]

instance Monoid (Router' i ts r) where
  mempty :: Router' i ts r
mempty = []

instance IsString (Combinator i ts m) where
  {-# INLINE fromString #-}
  fromString :: String -> Combinator i ts m
fromString = String -> Combinator i ts m
forall i ts (m :: * -> *). String -> Combinator i ts m
smartPiece

{-# INLINE smartPiece #-}
smartPiece :: String -> Combinator i ts m
smartPiece :: forall i ts (m :: * -> *). String -> Combinator i ts m
smartPiece ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') -> (String
a, String
as)) Router' i ts m
cont =
  if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
as
    then Text -> Router' i ts m -> Router' i ts m
forall i ts (m :: * -> *). Text -> Router' i ts m -> Router' i ts m
Piece (String -> Text
forall a. IsString a => String -> a
fromString String
a) Router' i ts m
cont
    else Text -> Router' i ts m -> Router' i ts m
forall i ts (m :: * -> *). Text -> Router' i ts m -> Router' i ts m
Piece (String -> Text
forall a. IsString a => String -> a
fromString String
a) (String -> Router' i ts m -> Router' i ts m
forall i ts (m :: * -> *). String -> Combinator i ts m
smartPiece (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
as) Router' i ts m
cont)

newtype RoutingState = RoutingState {RoutingState -> [Text]
path :: [Text]}

-- | 'Wai.Application' lifted to `m`
type ApplicationM m =
  Wai.Request ->
  ( Wai.Response ->
    IO Wai.ResponseReceived
  ) ->
  m Wai.ResponseReceived

{-# INLINE makeHandle #-}
makeHandle ::
  forall f o m ts i st.
  ( HandleArgs ts st m
  , ToResponse m (f o)
  , CanRespond (f o)
  , I.Introspection i I.Response (f o)
  ) =>
  Http.Method ->
  (o -> f o) ->
  (DelayedArgs st ~> m o) ->
  Router' i ts m
makeHandle :: forall (f :: * -> *) o (m :: * -> *) ts i (st :: [*]).
(HandleArgs ts st m, ToResponse m (f o), CanRespond (f o),
 Introspection i 'Response (f o)) =>
ByteString
-> (o -> f o) -> (DelayedArgs st ~> m o) -> Router' i ts m
makeHandle ByteString
method o -> f o
packResponse DelayedArgs st ~> m o
f =
  forall o (m :: * -> *) ts i (st :: [*]).
(HandleArgs ts st m, ToResponse m o, CanRespond o,
 Introspection i 'Response o) =>
ByteString -> (HList (DelayedArgs st) -> m o) -> Router' i ts m
Handle @(f o) ByteString
method ((o -> f o) -> m o -> m (f o)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o -> f o
packResponse (m o -> m (f o))
-> (HList (DelayedArgs st) -> m o)
-> HList (DelayedArgs st)
-> m (f o)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DelayedArgs st ~> m o) -> HList (DelayedArgs st) -> m o
forall (ts :: [*]) r. FunArgs ts => (ts ~> r) -> HList ts -> r
forall r. (DelayedArgs st ~> r) -> HList (DelayedArgs st) -> r
apply DelayedArgs st ~> m o
f)