{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TupleSections         #-}
{-# 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            as List
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 Data.CaseInsensitive as CI
import qualified Web.Eved.ContentType as CT
import qualified Web.Eved.Header      as H
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 }

simpleServer :: a -> EvedServerT IO a -> Application
simpleServer :: a -> EvedServerT IO a -> Application
simpleServer =
    (forall a. IO a -> IO a) -> a -> EvedServerT IO a -> Application
forall (m :: * -> *) a.
(forall a. m a -> IO a) -> a -> EvedServerT m a -> Application
server forall a. a -> a
forall a. IO a -> IO a
id

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 = (SomeException -> ServerError)
-> (forall a. m a -> IO a) -> a -> EvedServerT m a -> Application
forall (m :: * -> *) a.
(SomeException -> ServerError)
-> (forall a. m a -> IO a) -> a -> EvedServerT m a -> Application
hoistServerWithErrorHandler SomeException -> ServerError
defaultErrorHandler

hoistServerWithErrorHandler
        :: (SomeException -> ServerError)
        -> (forall a. m a -> IO a)
        -> a
        -> EvedServerT m a
        -> Application
hoistServerWithErrorHandler :: (SomeException -> ServerError)
-> (forall a. m a -> IO a) -> a -> EvedServerT m a -> Application
hoistServerWithErrorHandler SomeException -> ServerError
errorHandler 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 ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"") (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 ServerError -> IO ResponseReceived)
-> IO ResponseReceived
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(UserApplicationError ServerError
err) -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> Response
serverErrorToResponse ServerError
err)
        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
errorHandler SomeException
err)

data RoutingError
    = PathError
    | CaptureError Text
    | HeaderParseError 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)
-> ResponseHeaders
-> ByteString
-> Maybe (ByteString -> Either Text a)
forall a.
NonEmpty (ContentType a)
-> ResponseHeaders
-> ByteString
-> Maybe (ByteString -> Either Text a)
CT.chooseContentCType NonEmpty (ContentType a)
ctypes ResponseHeaders
forall a. Monoid a => a
mempty 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 -> (ResponseHeaders, ByteString) -> Either Text a
forall a.
ContentType a -> (ResponseHeaders, ByteString) -> Either Text a
CT.fromContentType (NonEmpty (ContentType a) -> ContentType a
forall a. NonEmpty a -> a
NE.head NonEmpty (ContentType a)
ctypes) ((ResponseHeaders, ByteString) -> Either Text a)
-> (ByteString -> (ResponseHeaders, ByteString))
-> ByteString
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseHeaders
forall a. Monoid a => a
mempty,)) 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 ((a -> a) -> Either Text a -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
v (Either Text a -> Either Text a)
-> (ByteString -> Either Text a) -> ByteString -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text a
bodyParser)

    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

    header :: Text -> Header a -> EvedServerT m b -> EvedServerT m (a -> b)
header Text
headerName Header a
h 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 ciHeaderName :: HeaderName
ciHeaderName = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
encodeUtf8 Text
headerName)
           mHeader :: Maybe ByteString
mHeader = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
ciHeaderName (Request -> ResponseHeaders
requestHeaders Request
req)
       in case Header a -> Maybe ByteString -> Either Text a
forall a. Header a -> Maybe ByteString -> Either Text a
H.fromHeaderValue Header a
h Maybe ByteString
mHeader 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
HeaderParseError 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 -> (ResponseHeaders, 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 -> (ResponseHeaders, ByteString))
forall a.
NonEmpty (ContentType a)
-> ByteString
-> Maybe (MediaType, a -> (ResponseHeaders, ByteString))
CT.chooseAcceptCType NonEmpty (ContentType a)
ctypes ByteString
acceptBS of
                          Just (MediaType
ctype, a -> (ResponseHeaders, ByteString)
renderContent) -> (MediaType, a -> (ResponseHeaders, ByteString))
-> IO (MediaType, a -> (ResponseHeaders, ByteString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MediaType
ctype, a -> (ResponseHeaders, ByteString)
renderContent)
                          Maybe (MediaType, a -> (ResponseHeaders, ByteString))
Nothing -> RoutingError -> IO (MediaType, a -> (ResponseHeaders, 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 -> (ResponseHeaders, ByteString))
-> IO (MediaType, a -> (ResponseHeaders, 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 -> (ResponseHeaders, ByteString)
forall a. ContentType a -> a -> (ResponseHeaders, ByteString)
CT.toContentType ContentType a
ctype)

        (ResponseHeaders
rHeaders, ByteString
rBody) <-
                    a -> (ResponseHeaders, ByteString)
renderContent (a -> (ResponseHeaders, ByteString))
-> IO a -> IO (ResponseHeaders, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        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
                                    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)(HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:ResponseHeaders
rHeaders) ByteString
rBody

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 = []
        }