module Mig.Core.ServerFun (
ServerFun,
sendResponse,
withBody,
withRawBody,
withQuery,
withQueryFlag,
withOptional,
withCapture,
withHeader,
withOptionalHeader,
withCookie,
withPathInfo,
withFullPathInfo,
handleServerError,
) where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BL
import Data.CaseInsensitive qualified as CI
import Data.Either (fromRight)
import Data.Either.Extra (eitherToMaybe)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text.Encoding qualified as Text
import Mig.Core.Class.MediaType
import Mig.Core.Types
import Network.HTTP.Types.Header (HeaderName)
import Network.HTTP.Types.Status (status500)
import Web.FormUrlEncoded (FromForm (..), urlDecodeForm)
import Web.HttpApiData
type ServerFun m = Request -> m (Maybe Response)
withBody :: forall media a m. (MonadIO m, FromReqBody media a) => (a -> ServerFun m) -> ServerFun m
withBody :: forall {k} (media :: k) a (m :: * -> *).
(MonadIO m, FromReqBody media a) =>
(a -> ServerFun m) -> ServerFun m
withBody a -> ServerFun m
f = forall (m :: * -> *).
MonadIO m =>
(ByteString -> ServerFun m) -> ServerFun m
withRawBody forall a b. (a -> b) -> a -> b
$ \ByteString
val -> \Request
req ->
case forall {k} (ty :: k) b.
FromReqBody ty b =>
ByteString -> Either Text b
fromReqBody @media ByteString
val of
Right a
v -> a -> ServerFun m
f a
v Request
req
Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest @Text forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse request body: " forall a. Semigroup a => a -> a -> a
<> Text
err
withRawBody :: (MonadIO m) => (BL.ByteString -> ServerFun m) -> ServerFun m
withRawBody :: forall (m :: * -> *).
MonadIO m =>
(ByteString -> ServerFun m) -> ServerFun m
withRawBody ByteString -> ServerFun m
act = \Request
req -> do
Either Text ByteString
eBody <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Request
req.readBody
case Either Text ByteString
eBody of
Right ByteString
body -> ByteString -> ServerFun m
act ByteString
body Request
req
Left Text
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Status -> Response -> Response
setRespStatus Status
status500 (forall {k} (media :: k) a. ToRespBody media a => a -> Response
okResponse @Text Text
err)
withQuery :: (Monad m, FromHttpApiData a) => Text -> (a -> ServerFun m) -> ServerFun m
withQuery :: forall (m :: * -> *) a.
(Monad m, FromHttpApiData a) =>
Text -> (a -> ServerFun m) -> ServerFun m
withQuery Text
name a -> ServerFun m
act = forall a (m :: * -> *).
FromHttpApiData a =>
(Request -> Maybe Text) -> (Maybe a -> ServerFun m) -> ServerFun m
withQueryBy (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Request -> Maybe (Maybe Text)
getQuery Text
name) Maybe a -> ServerFun m
processResponse
where
processResponse :: Maybe a -> ServerFun m
processResponse = forall (m :: * -> *) a.
Applicative m =>
Text -> (a -> ServerFun m) -> Maybe a -> ServerFun m
handleMaybeInput Text
errorMessage a -> ServerFun m
act
errorMessage :: Text
errorMessage = Text
"Failed to parse arg: " forall a. Semigroup a => a -> a -> a
<> Text
name
withQueryFlag :: Text -> (Bool -> ServerFun m) -> ServerFun m
withQueryFlag :: forall (m :: * -> *). Text -> (Bool -> ServerFun m) -> ServerFun m
withQueryFlag Text
name Bool -> ServerFun m
act = \Request
req ->
let val :: Bool
val =
case Text -> Request -> Maybe (Maybe Text)
getQuery Text
name Request
req of
Just (Just Text
"") -> Bool
True
Just (Just Text
arg) ->
case forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam @Bool Text
arg of
Right Bool
flag -> Bool
flag
Left Text
_ -> Bool
False
Just Maybe Text
Nothing -> Bool
True
Maybe (Maybe Text)
Nothing -> Bool
False
in Bool -> ServerFun m
act Bool
val Request
req
getQuery :: Text -> Request -> Maybe (Maybe Text)
getQuery :: Text -> Request -> Maybe (Maybe Text)
getQuery Text
name Request
req =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> ByteString
Text.encodeUtf8 Text
name) Request
req.query of
Just Maybe ByteString
mBs ->
case Maybe ByteString
mBs of
Just ByteString
bs -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
bs
Maybe ByteString
Nothing -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
Maybe (Maybe ByteString)
Nothing -> forall a. Maybe a
Nothing
handleMaybeInput :: (Applicative m) => Text -> (a -> ServerFun m) -> (Maybe a -> ServerFun m)
handleMaybeInput :: forall (m :: * -> *) a.
Applicative m =>
Text -> (a -> ServerFun m) -> Maybe a -> ServerFun m
handleMaybeInput Text
message a -> ServerFun m
act = \case
Just a
arg -> \Request
req -> a -> ServerFun m
act a
arg Request
req
Maybe a
Nothing -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest @Text Text
message
withOptional :: (FromHttpApiData a) => Text -> (Maybe a -> ServerFun m) -> ServerFun m
withOptional :: forall a (m :: * -> *).
FromHttpApiData a =>
Text -> (Maybe a -> ServerFun m) -> ServerFun m
withOptional Text
name Maybe a -> ServerFun m
act = forall a (m :: * -> *).
FromHttpApiData a =>
(Request -> Maybe Text) -> (Maybe a -> ServerFun m) -> ServerFun m
withQueryBy (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Request -> Maybe (Maybe Text)
getQuery Text
name) Maybe a -> ServerFun m
act
withQueryBy ::
(FromHttpApiData a) =>
(Request -> Maybe Text) ->
(Maybe a -> ServerFun m) ->
ServerFun m
withQueryBy :: forall a (m :: * -> *).
FromHttpApiData a =>
(Request -> Maybe Text) -> (Maybe a -> ServerFun m) -> ServerFun m
withQueryBy Request -> Maybe Text
getVal Maybe a -> ServerFun m
act = \Request
req ->
let
mArg :: Maybe a
mArg = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> Maybe Text
getVal Request
req
in Maybe a -> ServerFun m
act Maybe a
mArg Request
req
withCapture :: (Monad m, FromHttpApiData a) => Text -> (a -> ServerFun m) -> ServerFun m
withCapture :: forall (m :: * -> *) a.
(Monad m, FromHttpApiData a) =>
Text -> (a -> ServerFun m) -> ServerFun m
withCapture Text
name a -> ServerFun m
act = forall a (m :: * -> *).
FromHttpApiData a =>
(Request -> Maybe Text) -> (Maybe a -> ServerFun m) -> ServerFun m
withQueryBy Request -> Maybe Text
getVal Maybe a -> ServerFun m
processResponse
where
getVal :: Request -> Maybe Text
getVal Request
req = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Request
req.capture
processResponse :: Maybe a -> ServerFun m
processResponse = forall (m :: * -> *) a.
Applicative m =>
Text -> (a -> ServerFun m) -> Maybe a -> ServerFun m
handleMaybeInput Text
errorMessage a -> ServerFun m
act
errorMessage :: Text
errorMessage = Text
"Failed to parse capture: " forall a. Semigroup a => a -> a -> a
<> Text
name
withHeader :: (Monad m, FromHttpApiData a) => HeaderName -> (a -> ServerFun m) -> ServerFun m
HeaderName
name a -> ServerFun m
act = forall a (m :: * -> *).
FromHttpApiData a =>
(Request -> Maybe Text) -> (Maybe a -> ServerFun m) -> ServerFun m
withQueryBy Request -> Maybe Text
getVal Maybe a -> ServerFun m
processResponse
where
getVal :: Request -> Maybe Text
getVal Request
req = forall a b. Either a b -> Maybe b
eitherToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderName
name Request
req.headers
processResponse :: Maybe a -> ServerFun m
processResponse = forall (m :: * -> *) a.
Applicative m =>
Text -> (a -> ServerFun m) -> Maybe a -> ServerFun m
handleMaybeInput Text
errorMessage a -> ServerFun m
act
errorMessage :: Text
errorMessage = Text
"Failed to parse header: " forall a. Semigroup a => a -> a -> a
<> HeaderName -> Text
headerNameToText HeaderName
name
headerNameToText :: CI.CI ByteString -> Text
HeaderName
name = forall b a. b -> Either a b -> b
fromRight Text
"" forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
Text.decodeUtf8' forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
CI.original HeaderName
name
withOptionalHeader :: (FromHttpApiData a) => HeaderName -> (Maybe a -> ServerFun m) -> ServerFun m
HeaderName
name Maybe a -> ServerFun m
act = forall a (m :: * -> *).
FromHttpApiData a =>
(Request -> Maybe Text) -> (Maybe a -> ServerFun m) -> ServerFun m
withQueryBy Request -> Maybe Text
getVal Maybe a -> ServerFun m
act
where
getVal :: Request -> Maybe Text
getVal Request
req = forall a b. Either a b -> Maybe b
eitherToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderName
name Request
req.headers
withCookie :: forall a m. (FromForm a) => (Maybe a -> ServerFun m) -> ServerFun m
withCookie :: forall a (m :: * -> *).
FromForm a =>
(Maybe a -> ServerFun m) -> ServerFun m
withCookie Maybe a -> ServerFun m
act = forall a (m :: * -> *).
FromHttpApiData a =>
HeaderName -> (Maybe a -> ServerFun m) -> ServerFun m
withOptionalHeader @Text HeaderName
"Cookie" (Maybe a -> ServerFun m
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe a
parseCookie =<<))
where
parseCookie :: Text -> Maybe a
parseCookie :: Text -> Maybe a
parseCookie Text
txt = do
Form
form <- forall a b. Either a b -> Maybe b
eitherToMaybe forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text Form
urlDecodeForm forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
txt
forall a b. Either a b -> Maybe b
eitherToMaybe forall a b. (a -> b) -> a -> b
$ forall a. FromForm a => Form -> Either Text a
fromForm Form
form
withPathInfo :: ([Text] -> ServerFun m) -> ServerFun m
withPathInfo :: forall (m :: * -> *). ([Text] -> ServerFun m) -> ServerFun m
withPathInfo [Text] -> ServerFun m
act = \Request
req -> [Text] -> ServerFun m
act Request
req.path Request
req
withFullPathInfo :: (Text -> ServerFun m) -> ServerFun m
withFullPathInfo :: forall (m :: * -> *). (Text -> ServerFun m) -> ServerFun m
withFullPathInfo Text -> ServerFun m
act = \Request
req -> Text -> ServerFun m
act (Request -> Text
toFullPath Request
req) Request
req
sendResponse :: (Functor m) => m Response -> ServerFun m
sendResponse :: forall (m :: * -> *). Functor m => m Response -> ServerFun m
sendResponse m Response
act = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just m Response
act
handleServerError :: (Exception a, MonadCatch m) => (a -> ServerFun m) -> ServerFun m -> ServerFun m
handleServerError :: forall a (m :: * -> *).
(Exception a, MonadCatch m) =>
(a -> ServerFun m) -> ServerFun m -> ServerFun m
handleServerError a -> ServerFun m
handler ServerFun m
act = \Request
req ->
(ServerFun m
act Request
req) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\a
err -> a -> ServerFun m
handler a
err Request
req)