{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeApplications      #-}

module Web.Eved.Server
    where

import           Control.Applicative  ((<|>))
import           Control.Exception    (Exception, SomeException (..), catch,
                                       handle, throwIO, try)
import           Control.Monad
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List.NonEmpty   as NE
import           Data.Maybe           (catMaybes, fromMaybe)
import           Data.Text            (Text)
import           Data.Text.Encoding   (encodeUtf8)
import           Network.HTTP.Media   (renderHeader)
import           Network.HTTP.Types   (Header, Status, badRequest400, hAccept,
                                       hContentType, internalServerError500,
                                       methodNotAllowed405, notAcceptable406,
                                       notFound404, queryToQueryText,
                                       renderStdMethod, unsupportedMediaType415)

import qualified Web.Eved.ContentType as CT
import           Web.Eved.Internal
import qualified Web.Eved.QueryParam  as QP
import qualified Web.Eved.UrlElement  as UE


import           Network.Wai          (Application, Response, lazyRequestBody,
                                       pathInfo, queryString, requestHeaders,
                                       requestMethod, responseLBS)

data RequestData a
  = BodyRequestData (LBS.ByteString -> Either Text a)
  | PureRequestData a
  deriving a -> RequestData b -> RequestData a
(a -> b) -> RequestData a -> RequestData b
(forall a b. (a -> b) -> RequestData a -> RequestData b)
-> (forall a b. a -> RequestData b -> RequestData a)
-> Functor RequestData
forall a b. a -> RequestData b -> RequestData a
forall a b. (a -> b) -> RequestData a -> RequestData b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RequestData b -> RequestData a
$c<$ :: forall a b. a -> RequestData b -> RequestData a
fmap :: (a -> b) -> RequestData a -> RequestData b
$cfmap :: forall a b. (a -> b) -> RequestData a -> RequestData b
Functor

newtype EvedServerT m a = EvedServerT
    { EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT :: (forall a. m a -> IO a) -> [Text] -> RequestData a -> Application }


server :: (forall a. m a -> IO a) -> a -> EvedServerT m a -> Application
server :: (forall a. m a -> IO a) -> a -> EvedServerT m a -> Application
server forall a. m a -> IO a
nt a
handlers EvedServerT m a
api Request
req Response -> IO ResponseReceived
resp =
    EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m a
api forall a. m a -> IO a
nt (Request -> [Text]
pathInfo Request
req) (a -> RequestData a
forall a. a -> RequestData a
PureRequestData a
handlers) Request
req Response -> IO ResponseReceived
resp
        IO ResponseReceived
-> (RoutingError -> IO ResponseReceived) -> IO ResponseReceived
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\case
            RoutingError
PathError -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
notFound404 [] ByteString
"Not Found"
            CaptureError Text
err -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
badRequest400 [] (ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
err)
            QueryParamParseError Text
err -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
badRequest400 [] (ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
err)
            RoutingError
NoContentMatchError -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
unsupportedMediaType415 [] ByteString
"Unsupported Media Type"
            RoutingError
NoAcceptMatchError -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
notAcceptable406 [] ByteString
"Not Acceptable"
            RoutingError
NoMethodMatchError -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
methodNotAllowed405 [] ByteString
"Method Not Allowed")
        IO ResponseReceived
-> (ServerError -> IO ResponseReceived) -> IO ResponseReceived
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> (ServerError -> Response) -> ServerError -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerError -> Response
serverErrorToResponse)
        IO ResponseReceived
-> (UserApplicationError SomeException -> IO ResponseReceived)
-> IO ResponseReceived
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(UserApplicationError SomeException
err) -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> Response
serverErrorToResponse (ServerError -> Response) -> ServerError -> Response
forall a b. (a -> b) -> a -> b
$ SomeException -> ServerError
defaultErrorHandler SomeException
err)

data RoutingError
    = PathError
    | CaptureError Text
    | QueryParamParseError Text
    | NoContentMatchError
    | NoAcceptMatchError
    | NoMethodMatchError
    deriving (Int -> RoutingError -> ShowS
[RoutingError] -> ShowS
RoutingError -> String
(Int -> RoutingError -> ShowS)
-> (RoutingError -> String)
-> ([RoutingError] -> ShowS)
-> Show RoutingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoutingError] -> ShowS
$cshowList :: [RoutingError] -> ShowS
show :: RoutingError -> String
$cshow :: RoutingError -> String
showsPrec :: Int -> RoutingError -> ShowS
$cshowsPrec :: Int -> RoutingError -> ShowS
Show, RoutingError -> RoutingError -> Bool
(RoutingError -> RoutingError -> Bool)
-> (RoutingError -> RoutingError -> Bool) -> Eq RoutingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RoutingError -> RoutingError -> Bool
$c/= :: RoutingError -> RoutingError -> Bool
== :: RoutingError -> RoutingError -> Bool
$c== :: RoutingError -> RoutingError -> Bool
Eq, Eq RoutingError
Eq RoutingError
-> (RoutingError -> RoutingError -> Ordering)
-> (RoutingError -> RoutingError -> Bool)
-> (RoutingError -> RoutingError -> Bool)
-> (RoutingError -> RoutingError -> Bool)
-> (RoutingError -> RoutingError -> Bool)
-> (RoutingError -> RoutingError -> RoutingError)
-> (RoutingError -> RoutingError -> RoutingError)
-> Ord RoutingError
RoutingError -> RoutingError -> Bool
RoutingError -> RoutingError -> Ordering
RoutingError -> RoutingError -> RoutingError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RoutingError -> RoutingError -> RoutingError
$cmin :: RoutingError -> RoutingError -> RoutingError
max :: RoutingError -> RoutingError -> RoutingError
$cmax :: RoutingError -> RoutingError -> RoutingError
>= :: RoutingError -> RoutingError -> Bool
$c>= :: RoutingError -> RoutingError -> Bool
> :: RoutingError -> RoutingError -> Bool
$c> :: RoutingError -> RoutingError -> Bool
<= :: RoutingError -> RoutingError -> Bool
$c<= :: RoutingError -> RoutingError -> Bool
< :: RoutingError -> RoutingError -> Bool
$c< :: RoutingError -> RoutingError -> Bool
compare :: RoutingError -> RoutingError -> Ordering
$ccompare :: RoutingError -> RoutingError -> Ordering
$cp1Ord :: Eq RoutingError
Ord)

newtype UserApplicationError a = UserApplicationError a
    deriving Int -> UserApplicationError a -> ShowS
[UserApplicationError a] -> ShowS
UserApplicationError a -> String
(Int -> UserApplicationError a -> ShowS)
-> (UserApplicationError a -> String)
-> ([UserApplicationError a] -> ShowS)
-> Show (UserApplicationError a)
forall a. Show a => Int -> UserApplicationError a -> ShowS
forall a. Show a => [UserApplicationError a] -> ShowS
forall a. Show a => UserApplicationError a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserApplicationError a] -> ShowS
$cshowList :: forall a. Show a => [UserApplicationError a] -> ShowS
show :: UserApplicationError a -> String
$cshow :: forall a. Show a => UserApplicationError a -> String
showsPrec :: Int -> UserApplicationError a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> UserApplicationError a -> ShowS
Show

instance Exception RoutingError
instance Exception a => Exception (UserApplicationError a)

instance Eved (EvedServerT m) m where
    EvedServerT m a
a .<|> :: EvedServerT m a -> EvedServerT m b -> EvedServerT m (a :<|> b)
.<|> EvedServerT m b
b = ((forall a. m a -> IO a)
 -> [Text] -> RequestData (a :<|> b) -> Application)
-> EvedServerT m (a :<|> b)
forall (m :: * -> *) a.
((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
EvedServerT (((forall a. m a -> IO a)
  -> [Text] -> RequestData (a :<|> b) -> Application)
 -> EvedServerT m (a :<|> b))
-> ((forall a. m a -> IO a)
    -> [Text] -> RequestData (a :<|> b) -> Application)
-> EvedServerT m (a :<|> b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
nt [Text]
path RequestData (a :<|> b)
requestData Request
req Response -> IO ResponseReceived
resp -> do
        let applicationA :: Application
applicationA = EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m a
a forall a. m a -> IO a
nt [Text]
path (((a :<|> b) -> a) -> RequestData (a :<|> b) -> RequestData a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
l :<|> b
_) -> a
l) RequestData (a :<|> b)
requestData)
            applicationB :: Application
applicationB = EvedServerT m b
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData b
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m b
b forall a. m a -> IO a
nt [Text]
path (((a :<|> b) -> b) -> RequestData (a :<|> b) -> RequestData b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
_ :<|> b
r) -> b
r) RequestData (a :<|> b)
requestData)
        Either RoutingError ResponseReceived
eApplicationAResult <- forall a.
Exception RoutingError =>
IO a -> IO (Either RoutingError a)
forall e a. Exception e => IO a -> IO (Either e a)
try @RoutingError (IO ResponseReceived -> IO (Either RoutingError ResponseReceived))
-> IO ResponseReceived -> IO (Either RoutingError ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Application
applicationA Request
req Response -> IO ResponseReceived
resp
        case Either RoutingError ResponseReceived
eApplicationAResult of
          Right ResponseReceived
a -> ResponseReceived -> IO ResponseReceived
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
a
          Left RoutingError
errA -> do
            Either RoutingError ResponseReceived
eApplicationBResult <- forall a.
Exception RoutingError =>
IO a -> IO (Either RoutingError a)
forall e a. Exception e => IO a -> IO (Either e a)
try @RoutingError (IO ResponseReceived -> IO (Either RoutingError ResponseReceived))
-> IO ResponseReceived -> IO (Either RoutingError ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Application
applicationB Request
req Response -> IO ResponseReceived
resp
            case Either RoutingError ResponseReceived
eApplicationBResult of
              Right ResponseReceived
b   -> ResponseReceived -> IO ResponseReceived
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
b
              Left RoutingError
errB -> if RoutingError
errA RoutingError -> RoutingError -> Bool
forall a. Ord a => a -> a -> Bool
> RoutingError
errB then RoutingError -> IO ResponseReceived
forall e a. Exception e => e -> IO a
throwIO RoutingError
errA else RoutingError -> IO ResponseReceived
forall e a. Exception e => e -> IO a
throwIO RoutingError
errB

    lit :: Text -> EvedServerT m a -> EvedServerT m a
lit Text
s EvedServerT m a
next = ((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
forall (m :: * -> *) a.
((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
EvedServerT (((forall a. m a -> IO a)
  -> [Text] -> RequestData a -> Application)
 -> EvedServerT m a)
-> ((forall a. m a -> IO a)
    -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
nt [Text]
path RequestData a
action ->
        case [Text]
path of
            Text
x:[Text]
rest | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s -> EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m a
next forall a. m a -> IO a
nt [Text]
rest RequestData a
action
            [Text]
_               -> \Request
_ Response -> IO ResponseReceived
_ -> RoutingError -> IO ResponseReceived
forall e a. Exception e => e -> IO a
throwIO RoutingError
PathError

    capture :: Text -> UrlElement a -> EvedServerT m b -> EvedServerT m (a -> b)
capture Text
_s UrlElement a
el EvedServerT m b
next = ((forall a. m a -> IO a)
 -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall (m :: * -> *) a.
((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
EvedServerT (((forall a. m a -> IO a)
  -> [Text] -> RequestData (a -> b) -> Application)
 -> EvedServerT m (a -> b))
-> ((forall a. m a -> IO a)
    -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
nt [Text]
path RequestData (a -> b)
action ->
        case [Text]
path of
          Text
x:[Text]
rest ->
              case UrlElement a -> Text -> Either Text a
forall a. UrlElement a -> Text -> Either Text a
UE.fromUrlPiece UrlElement a
el Text
x of
                Right a
arg ->
                    EvedServerT m b
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData b
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m b
next forall a. m a -> IO a
nt [Text]
rest (RequestData b -> Application) -> RequestData b -> Application
forall a b. (a -> b) -> a -> b
$ ((a -> b) -> b) -> RequestData (a -> b) -> RequestData b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
arg) RequestData (a -> b)
action
                Left Text
err -> \Request
_ Response -> IO ResponseReceived
_ -> RoutingError -> IO ResponseReceived
forall e a. Exception e => e -> IO a
throwIO (RoutingError -> IO ResponseReceived)
-> RoutingError -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Text -> RoutingError
CaptureError Text
err
          [Text]
_ -> \Request
_ Response -> IO ResponseReceived
_ -> RoutingError -> IO ResponseReceived
forall e a. Exception e => e -> IO a
throwIO RoutingError
PathError

    reqBody :: NonEmpty (ContentType a)
-> EvedServerT m b -> EvedServerT m (a -> b)
reqBody NonEmpty (ContentType a)
ctypes EvedServerT m b
next = ((forall a. m a -> IO a)
 -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall (m :: * -> *) a.
((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
EvedServerT (((forall a. m a -> IO a)
  -> [Text] -> RequestData (a -> b) -> Application)
 -> EvedServerT m (a -> b))
-> ((forall a. m a -> IO a)
    -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
nt [Text]
path RequestData (a -> b)
action Request
req -> do
        let mContentTypeBS :: Maybe ByteString
mContentTypeBS = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req
        case Maybe ByteString
mContentTypeBS of
              Just ByteString
contentTypeBS ->
                case NonEmpty (ContentType a)
-> ByteString -> Maybe (ByteString -> Either Text a)
forall a.
NonEmpty (ContentType a)
-> ByteString -> Maybe (ByteString -> Either Text a)
CT.chooseContentCType NonEmpty (ContentType a)
ctypes ByteString
contentTypeBS of
                      Just ByteString -> Either Text a
bodyParser ->
                          EvedServerT m b
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData b
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m b
next forall a. m a -> IO a
nt [Text]
path ((ByteString -> Either Text a)
-> RequestData (a -> b) -> RequestData b
forall a a.
(ByteString -> Either Text a)
-> RequestData (a -> a) -> RequestData a
addBodyParser ByteString -> Either Text a
bodyParser RequestData (a -> b)
action) Request
req
                      Maybe (ByteString -> Either Text a)
Nothing ->
                            \Response -> IO ResponseReceived
_ -> RoutingError -> IO ResponseReceived
forall e a. Exception e => e -> IO a
throwIO RoutingError
NoContentMatchError
              Maybe ByteString
Nothing ->
                  EvedServerT m b
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData b
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m b
next forall a. m a -> IO a
nt [Text]
path ((ByteString -> Either Text a)
-> RequestData (a -> b) -> RequestData b
forall a a.
(ByteString -> Either Text a)
-> RequestData (a -> a) -> RequestData a
addBodyParser (ContentType a -> ByteString -> Either Text a
forall a. ContentType a -> ByteString -> Either Text a
CT.fromContentType (NonEmpty (ContentType a) -> ContentType a
forall a. NonEmpty a -> a
NE.head NonEmpty (ContentType a)
ctypes)) RequestData (a -> b)
action) Request
req

       where
            addBodyParser :: (ByteString -> Either Text a)
-> RequestData (a -> a) -> RequestData a
addBodyParser ByteString -> Either Text a
bodyParser RequestData (a -> a)
action =
                case RequestData (a -> a)
action of
                  BodyRequestData ByteString -> Either Text (a -> a)
fn -> (ByteString -> Either Text a) -> RequestData a
forall a. (ByteString -> Either Text a) -> RequestData a
BodyRequestData ((ByteString -> Either Text a) -> RequestData a)
-> (ByteString -> Either Text a) -> RequestData a
forall a b. (a -> b) -> a -> b
$ \ByteString
bodyText -> ByteString -> Either Text (a -> a)
fn ByteString
bodyText Either Text (a -> a) -> Either Text a -> Either Text a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Either Text a
bodyParser ByteString
bodyText
                  PureRequestData a -> a
v -> (ByteString -> Either Text a) -> RequestData a
forall a. (ByteString -> Either Text a) -> RequestData a
BodyRequestData ((ByteString -> Either Text a) -> RequestData a)
-> (ByteString -> Either Text a) -> RequestData a
forall a b. (a -> b) -> a -> b
$ \ByteString
bodyText -> a -> a
v (a -> a) -> Either Text a -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either Text a
bodyParser ByteString
bodyText

    queryParam :: Text -> QueryParam a -> EvedServerT m b -> EvedServerT m (a -> b)
queryParam Text
s QueryParam a
qp EvedServerT m b
next = ((forall a. m a -> IO a)
 -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall (m :: * -> *) a.
((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
EvedServerT (((forall a. m a -> IO a)
  -> [Text] -> RequestData (a -> b) -> Application)
 -> EvedServerT m (a -> b))
-> ((forall a. m a -> IO a)
    -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
nt [Text]
path RequestData (a -> b)
action Request
req ->
       let queryText :: QueryText
queryText = Query -> QueryText
queryToQueryText (Request -> Query
queryString Request
req)
           params :: [Text]
params = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"true" (Maybe Text -> Text)
-> ((Text, Maybe Text) -> Maybe Text) -> (Text, Maybe Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd ((Text, Maybe Text) -> Text) -> QueryText -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Maybe Text) -> Bool) -> QueryText -> QueryText
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
k, Maybe Text
_) -> Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s) QueryText
queryText
       in case QueryParam a -> [Text] -> Either Text a
forall a. QueryParam a -> [Text] -> Either Text a
QP.fromQueryParam QueryParam a
qp [Text]
params of
            Right a
a  -> EvedServerT m b
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData b
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
unEvedServerT EvedServerT m b
next forall a. m a -> IO a
nt [Text]
path (((a -> b) -> b) -> RequestData (a -> b) -> RequestData b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$a
a) RequestData (a -> b)
action) Request
req
            Left Text
err -> \Response -> IO ResponseReceived
_ -> RoutingError -> IO ResponseReceived
forall e a. Exception e => e -> IO a
throwIO (RoutingError -> IO ResponseReceived)
-> RoutingError -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Text -> RoutingError
QueryParamParseError Text
err

    verb :: StdMethod
-> Status -> NonEmpty (ContentType a) -> EvedServerT m (m a)
verb StdMethod
method Status
status NonEmpty (ContentType a)
ctypes = ((forall a. m a -> IO a)
 -> [Text] -> RequestData (m a) -> Application)
-> EvedServerT m (m a)
forall (m :: * -> *) a.
((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
EvedServerT (((forall a. m a -> IO a)
  -> [Text] -> RequestData (m a) -> Application)
 -> EvedServerT m (m a))
-> ((forall a. m a -> IO a)
    -> [Text] -> RequestData (m a) -> Application)
-> EvedServerT m (m a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
nt [Text]
path RequestData (m a)
action Request
req Response -> IO ResponseReceived
resp -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
path) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            RoutingError -> IO ()
forall e a. Exception e => e -> IO a
throwIO RoutingError
PathError

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StdMethod -> ByteString
renderStdMethod StdMethod
method ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Request -> ByteString
requestMethod Request
req) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            RoutingError -> IO ()
forall e a. Exception e => e -> IO a
throwIO RoutingError
NoMethodMatchError

        (MediaType
ctype, a -> ByteString
renderContent) <-
                case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req of
                      Just ByteString
acceptBS ->
                        case NonEmpty (ContentType a)
-> ByteString -> Maybe (MediaType, a -> ByteString)
forall a.
NonEmpty (ContentType a)
-> ByteString -> Maybe (MediaType, a -> ByteString)
CT.chooseAcceptCType NonEmpty (ContentType a)
ctypes ByteString
acceptBS of
                          Just (MediaType
ctype, a -> ByteString
renderContent) -> (MediaType, a -> ByteString) -> IO (MediaType, a -> ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MediaType
ctype, a -> ByteString
renderContent)
                          Maybe (MediaType, a -> ByteString)
Nothing -> RoutingError -> IO (MediaType, a -> ByteString)
forall e a. Exception e => e -> IO a
throwIO RoutingError
NoAcceptMatchError
                      Maybe ByteString
Nothing ->
                          let ctype :: ContentType a
ctype = NonEmpty (ContentType a) -> ContentType a
forall a. NonEmpty a -> a
NE.head NonEmpty (ContentType a)
ctypes
                          in (MediaType, a -> ByteString) -> IO (MediaType, a -> ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty MediaType -> MediaType
forall a. NonEmpty a -> a
NE.head (NonEmpty MediaType -> MediaType)
-> NonEmpty MediaType -> MediaType
forall a b. (a -> b) -> a -> b
$ ContentType a -> NonEmpty MediaType
forall a. ContentType a -> NonEmpty MediaType
CT.mediaTypes ContentType a
ctype, ContentType a -> a -> ByteString
forall a. ContentType a -> a -> ByteString
CT.toContentType ContentType a
ctype)

        a
responseData <-
            case RequestData (m a)
action of
                BodyRequestData ByteString -> Either Text (m a)
fn -> do
                    ByteString
reqBody <- Request -> IO ByteString
lazyRequestBody Request
req
                    case ByteString -> Either Text (m a)
fn ByteString
reqBody of
                        Right m a
res ->
                            m a -> IO a
forall a. m a -> IO a
nt m a
res IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException e
e) -> UserApplicationError e -> IO a
forall e a. Exception e => e -> IO a
throwIO (UserApplicationError e -> IO a) -> UserApplicationError e -> IO a
forall a b. (a -> b) -> a -> b
$ e -> UserApplicationError e
forall a. a -> UserApplicationError a
UserApplicationError e
e)
                        Left Text
err ->
                            ServerError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ServerError -> IO a) -> ServerError -> IO a
forall a b. (a -> b) -> a -> b
$ ServerError :: Status -> ByteString -> ResponseHeaders -> ServerError
ServerError
                              { errorStatus :: Status
errorStatus = Status
badRequest400
                              , errorBody :: ByteString
errorBody = ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
err
                              , errorHeaders :: ResponseHeaders
errorHeaders = []
                              }
                PureRequestData m a
a ->
                    m a -> IO a
forall a. m a -> IO a
nt m a
a IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException e
e) -> UserApplicationError e -> IO a
forall e a. Exception e => e -> IO a
throwIO (UserApplicationError e -> IO a) -> UserApplicationError e -> IO a
forall a b. (a -> b) -> a -> b
$ e -> UserApplicationError e
forall a. a -> UserApplicationError a
UserApplicationError e
e)

        Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status [(HeaderName
hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
ctype)] (a -> ByteString
renderContent a
responseData)

serverErrorToResponse :: ServerError -> Response
serverErrorToResponse :: ServerError -> Response
serverErrorToResponse ServerError
err =
    Status -> ResponseHeaders -> ByteString -> Response
responseLBS (ServerError -> Status
errorStatus ServerError
err) (ServerError -> ResponseHeaders
errorHeaders ServerError
err) (ServerError -> ByteString
errorBody ServerError
err)

data ServerError = ServerError
    { ServerError -> Status
errorStatus  :: Status
    , ServerError -> ByteString
errorBody    :: LBS.ByteString
    , ServerError -> ResponseHeaders
errorHeaders :: [Header]
    } deriving Int -> ServerError -> ShowS
[ServerError] -> ShowS
ServerError -> String
(Int -> ServerError -> ShowS)
-> (ServerError -> String)
-> ([ServerError] -> ShowS)
-> Show ServerError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerError] -> ShowS
$cshowList :: [ServerError] -> ShowS
show :: ServerError -> String
$cshow :: ServerError -> String
showsPrec :: Int -> ServerError -> ShowS
$cshowsPrec :: Int -> ServerError -> ShowS
Show
instance Exception ServerError

defaultErrorHandler :: SomeException -> ServerError
defaultErrorHandler :: SomeException -> ServerError
defaultErrorHandler SomeException
_ =
    ServerError :: Status -> ByteString -> ResponseHeaders -> ServerError
ServerError
        { errorStatus :: Status
errorStatus = Status
internalServerError500
        , errorBody :: ByteString
errorBody = ByteString
"Internal Server Error"
        , errorHeaders :: ResponseHeaders
errorHeaders = []
        }