{-| Low-level server representarion.
The server is a function from @Request@ to @Response@.

> type ServerFun m = Request -> m (Maybe Response)

To use the mig library with some server library like wai/warp we need
to provide conversion of type @ServerFun@ to the representarion of the given library.
We can convert mig server to @ServerFun@ with function @fromServer@.
The @Maybe@ type in the result encodes missing routes.
-}
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

{-| Low-level representation of the server.
Missing route for a given request returns @Nothing@.
-}
type ServerFun m = Request -> m (Maybe Response)

-- | Reads request body.
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

-- | Reads low-level request body as byte string
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)

-- | Reads required query parameter
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

-- | Reads query flag
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 -- we interpret empty value as True for a flag
          Maybe (Maybe Text)
Nothing -> Bool
False
   in Bool -> ServerFun m
act Bool
val Request
req

{-| The first maybe means that query with that name is missing
the second maybe is weather value is present or empty in the query
-}
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

-- | reads optional query parameter
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

-- | Generic query parameter reader
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 -- TODO: do not ignore parse failure
      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

-- | Reads capture from the path
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

-- | reads request header
withHeader :: (Monad m, FromHttpApiData a) => HeaderName -> (a -> ServerFun m) -> ServerFun m
withHeader :: forall (m :: * -> *) a.
(Monad m, FromHttpApiData a) =>
HeaderName -> (a -> ServerFun m) -> ServerFun m
withHeader 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
headerNameToText :: HeaderName -> Text
headerNameToText 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

-- | Reads optional request header
withOptionalHeader :: (FromHttpApiData a) => HeaderName -> (Maybe a -> ServerFun m) -> ServerFun m
withOptionalHeader :: forall a (m :: * -> *).
FromHttpApiData a =>
HeaderName -> (Maybe a -> ServerFun m) -> ServerFun m
withOptionalHeader 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

-- | Reads full path (without qury parameters)
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

-- | Reads full path (without qury parameters)
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

-- | Runs response getter action and returns it for any input request
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

-- | Handle errors
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)