module Mig.Internal.Types
(
Server (..)
, Req (..)
, Resp (..)
, RespBody (..)
, QueryMap
, ToText (..)
, Error (..)
, toConst
, toMethod
, toWithBody
, toWithCapture
, toWithPath
, toWithHeader
, toWithFormData
, toWithPathInfo
, FormBody (..)
, text
, json
, html
, raw
, ok
, badRequest
, setContent
, ServerConfig (..)
, Kilobytes
, toApplication
, 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
data Resp = Resp
{ Resp -> Status
status :: Status
, :: ResponseHeaders
, Resp -> RespBody
body :: RespBody
}
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
data RespBody
= TextResp Text
| HtmlResp Html
| JsonResp Json.Value
| FileResp FilePath
| StreamResp
| RawResp BL.ByteString
data Req = Req
{ Req -> [Text]
path :: [Text]
, Req -> QueryMap
query :: QueryMap
, :: RequestHeaders
, Req -> ByteString
method :: Method
, Req -> IO (Either (Error Text) ByteString)
readBody :: IO (Either (Error Text) BL.ByteString)
, 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)]
}
data Error a = Error
{ forall a. Error a -> Status
status :: Status
, forall a. Error a -> a
body :: a
}
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
type QueryMap = Map ByteString ByteString
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
}
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)
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)
type Kilobytes = Int
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
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)
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 #-}
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 :: (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 :: 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 :: (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 :: 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
ok :: ResponseHeaders -> RespBody -> Resp
ok :: ResponseHeaders -> RespBody -> Resp
ok ResponseHeaders
headers RespBody
body = Status -> ResponseHeaders -> RespBody -> Resp
Resp Status
ok200 ResponseHeaders
headers RespBody
body
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)
data ServerConfig = ServerConfig
{ ServerConfig -> Maybe Kilobytes
maxBodySize :: Maybe Kilobytes
}
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)
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
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!")