-- | Internal types and functions
module Mig.Internal.Types
  ( -- * types
    Server (..)
  , Req (..)
  , Resp (..)
  , RespBody (..)
  , QueryMap
  , ToText (..)
  , Error (..)
  -- * constructors
  , toConst
  , toMethod
  , toWithBody
  , toWithCapture
  , toWithPath
  , toWithHeader
  , toWithFormData
  , toWithPathInfo
  , FormBody (..)
  -- * responses
  , text
  , json
  , html
  , raw
  , ok
  , badRequest
  , setContent
  -- * WAI
  , ServerConfig (..)
  , Kilobytes
  , toApplication
  -- * utils
  , setRespStatus
  , handleError
  , toResponse
  , fromRequest
  , pathHead
  ) where

import Data.Bifunctor
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as TL
import Data.Aeson (ToJSON)
import Data.Aeson qualified as Json
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Text.Blaze.Html (Html)
import Text.Blaze.Html (ToMarkup)
import Text.Blaze.Html qualified as Html
import Network.HTTP.Types.Method (Method)
import Network.HTTP.Types.Header (ResponseHeaders, RequestHeaders, HeaderName)
import Network.HTTP.Types.Status (Status, ok200, status500, status413)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text.Encoding qualified as Text
import Data.List qualified as List
import Network.Wai
import Text.Blaze.Renderer.Utf8 qualified as Html
import Data.Maybe
import Data.Sequence (Seq (..), (|>))
import Data.Sequence qualified as Seq
import Data.Foldable
import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Typeable
import Network.Wai.Parse qualified as Parse

-- | Http response
data Resp = Resp
  { Resp -> Status
status :: Status
    -- ^ status
  , Resp -> ResponseHeaders
headers :: ResponseHeaders
    -- ^ headers
  , Resp -> RespBody
body :: RespBody
    -- ^ response body
  }

instance IsString Resp where
  fromString :: String -> Resp
fromString = forall a. ToText a => a -> Resp
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

-- | Http response body
data RespBody
  = TextResp Text
  | HtmlResp Html
  | JsonResp Json.Value
  | FileResp FilePath
  | StreamResp
  | RawResp BL.ByteString

-- | Http request
data Req = Req
  { Req -> [Text]
path :: [Text]
    -- ^ URI path
  , Req -> QueryMap
query :: QueryMap
    -- ^ query parameters
  , Req -> ResponseHeaders
headers :: RequestHeaders
    -- ^ request headers
  , Req -> ByteString
method :: Method
    -- ^ request method
  , Req -> IO (Either (Error Text) ByteString)
readBody :: IO (Either (Error Text) BL.ByteString)
    -- ^ lazy body reader. Error can happen if size is too big (configured on running the server)
  , Req -> IO (Either (Error Text) FormBody)
readFormBody :: IO (Either (Error Text) FormBody)
  }

data FormBody = FormBody
  { FormBody -> [(ByteString, ByteString)]
params :: [(ByteString, ByteString)]
  , FormBody -> [(ByteString, FileInfo ByteString)]
files :: [(ByteString, Parse.FileInfo BL.ByteString)]
  }

-- Errors

-- | Errors
data Error a = Error
  { forall a. Error a -> Status
status :: Status
    -- error status
  , forall a. Error a -> a
body :: a
    -- message or error details
  }
  deriving (Kilobytes -> Error a -> ShowS
forall a. Show a => Kilobytes -> Error a -> ShowS
forall a. Show a => [Error a] -> ShowS
forall a. Show a => Error a -> String
forall a.
(Kilobytes -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error a] -> ShowS
$cshowList :: forall a. Show a => [Error a] -> ShowS
show :: Error a -> String
$cshow :: forall a. Show a => Error a -> String
showsPrec :: Kilobytes -> Error a -> ShowS
$cshowsPrec :: forall a. Show a => Kilobytes -> Error a -> ShowS
Show)

instance (Typeable a, Show a) => Exception (Error a) where

-- | Map of query parameters for fast-access
type QueryMap = Map ByteString ByteString

-- | Bad request response
badRequest :: Text -> Resp
badRequest :: Text -> Resp
badRequest Text
message =
  Resp
    { $sel:status:Resp :: Status
status = Status
status500
    , $sel:headers:Resp :: ResponseHeaders
headers = ByteString -> ResponseHeaders
setContent ByteString
"text/plain"
    , $sel:body:Resp :: RespBody
body = Text -> RespBody
TextResp Text
message
    }

-- | Server type. It is a function fron request to response.
-- Some servers does not return valid value. We use it to find right path.
--
-- Example:
--
-- > server :: Server IO
-- > server =
-- >   "api" /. "v1" /.
-- >      mconcat
-- >        [ "foo" /. (\(Query @"name" arg) -> Get  @Json (handleFoo arg)
-- >        , "bar" /. Post @Json handleBar
-- >        ]
-- >
-- > handleFoo :: Int -> IO Text
-- > handleBar :: IO Text
--
-- Note that server is monoid and it can be constructed with Monoid functions and
-- path constructor @(/.)@. To pass inputs for handler we can use special newtype wrappers:
--
-- * @Query@ - for required query parameters
-- * @Optional@ - for optional query parameters
-- * @Capture@ - for parsing elements of URI
-- * @Body@ - fot JSON-body input
-- * @RawBody@ - for raw ByteString input
-- * @Header@ - for headers
--
-- To distinguish by HTTP-method we use corresponding constructors: Get, Post, Put, etc.
-- Let's discuss the structure of the constructor. Let's take Get for example:
--
-- > newtype Get ty m a = Get (m a)
--
--  Let's look at the arguments of he type
--
-- * @ty@ - type of the response. it can be: Text, Html, Json, ByteString
-- * @m@ - underlying server monad
-- * @a@ - result type. It should be convertible to the type of the response.
--
-- also result can be wrapped to special data types to modify Http-response.
-- we have wrappers:
--
-- * @SetStatus@ - to set status
-- * @AddHeaders@ - to append headers
-- * @Either (Error err)@ - to response with errors
newtype Server m = Server { forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer :: Req -> m (Maybe Resp) }

toConst :: Functor m => m Resp -> Server m
toConst :: forall (m :: * -> *). Functor m => m Resp -> Server m
toConst m Resp
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Resp
act

toMethod :: Monad m => Method -> m Resp -> Server m
toMethod :: forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
method m Resp
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
ByteString -> m Resp -> Req -> m (Maybe Resp)
checkMethod ByteString
method m Resp
act

checkMethod :: Monad m => Method -> m Resp -> Req -> m (Maybe Resp)
checkMethod :: forall (m :: * -> *).
Monad m =>
ByteString -> m Resp -> Req -> m (Maybe Resp)
checkMethod ByteString
method m Resp
act Req
req
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Req
req.path Bool -> Bool -> Bool
&& Req
req.method forall a. Eq a => a -> a -> Bool
== ByteString
method = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Resp
act
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

toWithBody :: MonadIO m => (BL.ByteString -> Server m) -> Server m
toWithBody :: forall (m :: * -> *).
MonadIO m =>
(ByteString -> Server m) -> Server m
toWithBody ByteString -> Server m
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req -> do
  Either (Error Text) ByteString
eBody <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Req
req.readBody
  case Either (Error Text) ByteString
eBody of
    Right ByteString
body -> forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer (ByteString -> Server m
act ByteString
body) Req
req
    Left Error 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 -> Resp -> Resp
setRespStatus Error Text
err.status (forall a. ToText a => a -> Resp
text Error Text
err.body)

-- TODO: make it size limited by HTTP-body size
toWithFormData :: MonadIO m => (FormBody -> Server m) -> Server m
toWithFormData :: forall (m :: * -> *).
MonadIO m =>
(FormBody -> Server m) -> Server m
toWithFormData FormBody -> Server m
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req -> do
  Either (Error Text) FormBody
eFormBody <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Req
req.readFormBody
  case Either (Error Text) FormBody
eFormBody of
    Right FormBody
formBody -> forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer (FormBody -> Server m
act FormBody
formBody) Req
req
    Left Error 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 -> Resp -> Resp
setRespStatus Error Text
err.status (forall a. ToText a => a -> Resp
text Error Text
err.body)


-- | Size of the input body
type Kilobytes = Int

-- | Read request body in chunks
readRequestBody :: IO B.ByteString -> Maybe Kilobytes -> IO (Either (Error Text) [B.ByteString])
readRequestBody :: IO ByteString
-> Maybe Kilobytes -> IO (Either (Error Text) [ByteString])
readRequestBody IO ByteString
readChunk Maybe Kilobytes
maxSize = Kilobytes
-> Seq ByteString -> IO (Either (Error Text) [ByteString])
loop Kilobytes
0 forall a. Seq a
Seq.empty
  where
    loop :: Kilobytes -> Seq B.ByteString -> IO (Either (Error Text) [B.ByteString])
    loop :: Kilobytes
-> Seq ByteString -> IO (Either (Error Text) [ByteString])
loop !Kilobytes
currentSize !Seq ByteString
result
      | Kilobytes -> Bool
isBigger Kilobytes
currentSize = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Either (Error Text) a
outOfSize
      | Bool
otherwise = do
          ByteString
chunk <- IO ByteString
readChunk
          if ByteString -> Bool
B.null ByteString
chunk
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq ByteString
result)
            else Kilobytes
-> Seq ByteString -> IO (Either (Error Text) [ByteString])
loop (Kilobytes
currentSize forall a. Num a => a -> a -> a
+ ByteString -> Kilobytes
B.length ByteString
chunk) (Seq ByteString
result forall a. Seq a -> a -> Seq a
|> ByteString
chunk)

    outOfSize :: Either (Error Text) a
    outOfSize :: forall a. Either (Error Text) a
outOfSize = forall a b. a -> Either a b
Left (forall a. Status -> a -> Error a
Error Status
status413 (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ String
"Request is too big Jim!"))

    isBigger :: Kilobytes -> Bool
isBigger = case Maybe Kilobytes
maxSize of
      Just Kilobytes
size -> \Kilobytes
current -> Kilobytes
current forall a. Ord a => a -> a -> Bool
> Kilobytes
size
      Maybe Kilobytes
Nothing -> forall a b. a -> b -> a
const Bool
False

toWithPath :: Monad m => Text -> Server m -> Server m
toWithPath :: forall (m :: * -> *). Monad m => Text -> Server m -> Server m
toWithPath Text
route Server m
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req ->
  case Text -> [Text] -> Maybe [Text]
hasPath Text
route Req
req.path of
    Just [Text]
restPath -> forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer Server m
act (Req
req { $sel:path:Req :: [Text]
path = [Text]
restPath })
    Maybe [Text]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

type Path = [Text]

hasPath :: Text -> Path -> Maybe Path
hasPath :: Text -> [Text] -> Maybe [Text]
hasPath Text
route (Text
path:[Text]
restPath)
  | Text
route forall a. Eq a => a -> a -> Bool
== Text
path = forall a. a -> Maybe a
Just [Text]
restPath
  | Bool
otherwise = forall a. Maybe a
Nothing
hasPath Text
_ [Text]
_ = forall a. Maybe a
Nothing

toWithCapture :: Monad m => (Text -> Server m) -> Server m
toWithCapture :: forall (m :: * -> *). Monad m => (Text -> Server m) -> Server m
toWithCapture Text -> Server m
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req ->
  case Req -> Maybe (Text, Req)
pathHead Req
req of
    Just (Text
arg, Req
nextReq) -> forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer (Text -> Server m
act Text
arg) Req
nextReq
    Maybe (Text, Req)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

pathHead :: Req -> Maybe (Text, Req)
pathHead :: Req -> Maybe (Text, Req)
pathHead Req
req =
  case Req
req.path of
    Text
hd : [Text]
tl -> forall a. a -> Maybe a
Just (Text
hd, Req
req { $sel:path:Req :: [Text]
path = [Text]
tl })
    [Text]
_ -> forall a. Maybe a
Nothing

toWithHeader :: HeaderName -> (Maybe ByteString -> Server m) -> Server m
toWithHeader :: forall (m :: * -> *).
HeaderName -> (Maybe ByteString -> Server m) -> Server m
toWithHeader HeaderName
name Maybe ByteString -> Server m
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req ->
  forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer (Maybe ByteString -> Server m
act (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== HeaderName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Req
req.headers)) Req
req

toWithPathInfo :: ([Text] -> Server m) -> Server m
toWithPathInfo :: forall (m :: * -> *). ([Text] -> Server m) -> Server m
toWithPathInfo [Text] -> Server m
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req ->
  forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer ([Text] -> Server m
act Req
req.path) Req
req

instance Monad m => Semigroup (Server m) where
  <> :: Server m -> Server m -> Server m
(<>) (Server Req -> m (Maybe Resp)
serverA) (Server Req -> m (Maybe Resp)
serverB) = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req -> do
    Maybe Resp
mRespA <- Req -> m (Maybe Resp)
serverA Req
req
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Req -> m (Maybe Resp)
serverB Req
req) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Maybe Resp
mRespA

instance Monad m => Monoid (Server m) where
  mempty :: Server m
mempty = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server (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. Maybe a
Nothing)

-- | Values convertible to lazy text
class ToText a where
  toText :: a -> Text

instance ToText TL.Text where
  toText :: Text -> Text
toText = Text -> Text
TL.toStrict

instance ToText Text where
  toText :: Text -> Text
toText = forall a. a -> a
id

instance ToText Int where
  toText :: Kilobytes -> Text
toText = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance ToText Float where
  toText :: Float -> Text
toText = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance ToText String where
  toText :: String -> Text
toText = forall a. IsString a => String -> a
fromString

{-# INLINE setContent #-}
-- | Headers to set content type
setContent :: ByteString -> ResponseHeaders
setContent :: ByteString -> ResponseHeaders
setContent ByteString
contentType =
  [(HeaderName
"Content-Type", ByteString
contentType forall a. Semigroup a => a -> a -> a
<>ByteString
"; charset=utf-8")]

setRespStatus :: Status -> Resp -> Resp
setRespStatus :: Status -> Resp -> Resp
setRespStatus Status
status (Resp Status
_ ResponseHeaders
headers RespBody
body) = Status -> ResponseHeaders -> RespBody -> Resp
Resp Status
status ResponseHeaders
headers RespBody
body

-- | Json response constructor
json :: (ToJSON resp) => resp -> Resp
json :: forall resp. ToJSON resp => resp -> Resp
json = (ResponseHeaders -> RespBody -> Resp
ok (ByteString -> ResponseHeaders
setContent ByteString
"text/json") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> RespBody
JsonResp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
Json.toJSON)

-- | Text response constructor
text :: ToText a => a -> Resp
text :: forall a. ToText a => a -> Resp
text = ResponseHeaders -> RespBody -> Resp
ok (ByteString -> ResponseHeaders
setContent ByteString
"text/plain") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RespBody
TextResp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToText a => a -> Text
toText

-- | Html response constructor
html :: (ToMarkup a) => a -> Resp
html :: forall a. ToMarkup a => a -> Resp
html = ResponseHeaders -> RespBody -> Resp
ok (ByteString -> ResponseHeaders
setContent ByteString
"text/html") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> RespBody
HtmlResp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMarkup a => a -> Html
Html.toHtml

-- | Raw bytestring response constructor
raw :: BL.ByteString -> Resp
raw :: ByteString -> Resp
raw = ResponseHeaders -> RespBody -> Resp
ok (ByteString -> ResponseHeaders
setContent ByteString
"text/plain") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RespBody
RawResp

-- | Respond with ok 200-status
ok :: ResponseHeaders -> RespBody -> Resp
ok :: ResponseHeaders -> RespBody -> Resp
ok ResponseHeaders
headers RespBody
body = Status -> ResponseHeaders -> RespBody -> Resp
Resp Status
ok200 ResponseHeaders
headers RespBody
body

-- | Handle errors
handleError ::(Exception a, MonadCatch m) => (a -> Server m) -> Server m -> Server m
handleError :: forall a (m :: * -> *).
(Exception a, MonadCatch m) =>
(a -> Server m) -> Server m -> Server m
handleError a -> Server m
handler (Server Req -> m (Maybe Resp)
act) = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req ->
  (Req -> m (Maybe Resp)
act Req
req) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\a
err -> forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer (a -> Server m
handler a
err) Req
req)

-------------------------------------------------------------------------------------
-- render to WAI

-- | Server config
data ServerConfig = ServerConfig
  { ServerConfig -> Maybe Kilobytes
maxBodySize :: Maybe Kilobytes
  }

-- | Convert server to WAI-application
toApplication :: ServerConfig -> Server IO -> Application
toApplication :: ServerConfig -> Server IO -> Application
toApplication ServerConfig
config Server IO
server Request
req Response -> IO ResponseReceived
processResponse = do
  Maybe Resp
mResp <- forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer (forall a (m :: * -> *).
(Exception a, MonadCatch m) =>
(a -> Server m) -> Server m -> Server m
handleError SomeException -> Server IO
onErr Server IO
server) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Kilobytes -> Request -> IO Req
fromRequest ServerConfig
config.maxBodySize Request
req
  Response -> IO ResponseReceived
processResponse forall a b. (a -> b) -> a -> b
$ Resp -> Response
toResponse forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Resp
noResult Maybe Resp
mResp
  where
    noResult :: Resp
noResult = Text -> Resp
badRequest Text
"Server produces nothing"

    onErr :: SomeException -> Server IO
    onErr :: SomeException -> Server IO
onErr SomeException
err = forall (m :: * -> *). Functor m => m Resp -> Server m
toConst forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Resp
badRequest forall a b. (a -> b) -> a -> b
$ Text
"Error: Exception has happened: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText (forall a. Show a => a -> String
show SomeException
err)

-- | Convert response to low-level WAI-response
toResponse :: Resp -> Response
toResponse :: Resp -> Response
toResponse Resp
resp =
  case Resp
resp.body of
    TextResp Text
textResp -> ByteString -> Response
lbs forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict (Text -> ByteString
Text.encodeUtf8 Text
textResp)
    HtmlResp Html
htmlResp -> ByteString -> Response
lbs (Html -> ByteString
Html.renderMarkup Html
htmlResp)
    JsonResp Value
jsonResp -> ByteString -> Response
lbs (forall a. ToJSON a => a -> ByteString
Json.encode Value
jsonResp)
    FileResp String
file -> Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
responseFile Resp
resp.status Resp
resp.headers String
file forall a. Maybe a
Nothing
    RawResp ByteString
str -> ByteString -> Response
lbs ByteString
str
    RespBody
StreamResp -> forall a. HasCallStack => a
undefined
  where
    lbs :: ByteString -> Response
lbs = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Resp
resp.status Resp
resp.headers

-- | Read request from low-level WAI-request
-- First argument limits the size of input body. The body is read in chunks.
fromRequest :: Maybe Kilobytes -> Request -> IO Req
fromRequest :: Maybe Kilobytes -> Request -> IO Req
fromRequest Maybe Kilobytes
maxSize Request
req =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Req
    { $sel:path:Req :: [Text]
path = Request -> [Text]
pathInfo Request
req
    , $sel:query:Req :: QueryMap
query = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(ByteString
key, Maybe ByteString
mVal) -> (ByteString
key, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
mVal) (Request -> Query
queryString Request
req)
    , $sel:headers:Req :: ResponseHeaders
headers = Request -> ResponseHeaders
requestHeaders Request
req
    , $sel:method:Req :: ByteString
method = Request -> ByteString
requestMethod Request
req
    , $sel:readBody:Req :: IO (Either (Error Text) ByteString)
readBody = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
BL.fromChunks) forall a b. (a -> b) -> a -> b
$ IO ByteString
-> Maybe Kilobytes -> IO (Either (Error Text) [ByteString])
readRequestBody (Request -> IO ByteString
getRequestBodyChunk Request
req) Maybe Kilobytes
maxSize
    , $sel:readFormBody:Req :: IO (Either (Error Text) FormBody)
readFormBody = Request -> IO (Either (Error Text) FormBody)
getReadFormBody Request
req
    }

getReadFormBody :: Request -> IO (Either (Error Text) FormBody)
getReadFormBody :: Request -> IO (Either (Error Text) FormBody)
getReadFormBody Request
req = do
  case Request -> Maybe RequestBodyType
Parse.getRequestBodyType Request
req of
    Maybe RequestBodyType
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ([(ByteString, ByteString)]
-> [(ByteString, FileInfo ByteString)] -> FormBody
FormBody [] [])
    Just RequestBodyType
reqBodyType -> do
      Either
  SomeException
  ([(ByteString, ByteString)], [(ByteString, FileInfo ByteString)])
eResult <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @IO @SomeException (forall y.
BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
Parse.sinkRequestBody forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
Parse.lbsBackEnd RequestBodyType
reqBodyType (Request -> IO ByteString
getRequestBodyChunk Request
req))
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. a -> b -> a
const Error Text
toError) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [(ByteString, ByteString)]
-> [(ByteString, FileInfo ByteString)] -> FormBody
FormBody) Either
  SomeException
  ([(ByteString, ByteString)], [(ByteString, FileInfo ByteString)])
eResult
  where
    toError :: Error Text
toError = forall a. Status -> a -> Error a
Error Status
status413 (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ String
"Request is too big!")