module WebGear.Server.MIMETypes (
BodyUnrender (..),
BodyRender (..),
inMemoryBackend,
tempFileBackend,
) where
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Resource (MonadResource, getInternalState, liftResourceT)
import qualified Data.Aeson as Aeson
import Data.Bifunctor (Bifunctor (first))
import qualified Data.Binary.Builder as B
import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), runParser')
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text, pack)
import Data.Text.Conversions (FromText (..), ToText (..))
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Encoding as LText
import qualified Network.HTTP.Media as HTTP
import Network.Wai.Parse (BackEnd, lbsBackEnd, parseRequestBodyEx, tempFileBackEnd)
import Web.FormUrlEncoded (
FromForm (..),
ToForm (..),
urlDecodeForm,
urlEncodeFormStable,
)
import WebGear.Core.MIMETypes (
FormData (..),
FormDataResult (..),
FormURLEncoded (..),
HTML,
JSON,
MIMEType (..),
OctetStream,
PlainText,
)
import WebGear.Core.Request (Request (..), getRequestBody)
import WebGear.Core.Response (Response, ResponseBody (..))
class (MIMEType mt) => BodyUnrender m mt a where
bodyUnrender :: mt -> Request -> m (Either Text a)
class (MIMEType mt) => BodyRender m mt a where
bodyRender :: mt -> Response -> a -> m (HTTP.MediaType, ResponseBody)
instance (MonadIO m, FromForm a) => BodyUnrender m FormURLEncoded a where
bodyUnrender :: FormURLEncoded -> Request -> m (Either Text a)
bodyUnrender :: FormURLEncoded -> Request -> m (Either Text a)
bodyUnrender FormURLEncoded
FormURLEncoded Request
request = do
ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text Form
urlDecodeForm ByteString
body forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FromForm a => Form -> Either Text a
fromForm
instance (Monad m, ToForm a) => BodyRender m FormURLEncoded a where
bodyRender :: FormURLEncoded -> Response -> a -> m (HTTP.MediaType, ResponseBody)
bodyRender :: FormURLEncoded -> Response -> a -> m (MediaType, ResponseBody)
bodyRender FormURLEncoded
FormURLEncoded Response
_response a
a = do
let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.fromLazyByteString forall a b. (a -> b) -> a -> b
$ Form -> ByteString
urlEncodeFormStable forall a b. (a -> b) -> a -> b
$ forall a. ToForm a => a -> Form
toForm a
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall mt. MIMEType mt => mt -> MediaType
mimeType FormURLEncoded
FormURLEncoded, ResponseBody
body)
instance (MonadIO m, FromByteString a) => BodyUnrender m HTML a where
bodyUnrender :: HTML -> Request -> m (Either Text a)
bodyUnrender :: HTML -> Request -> m (Either Text a)
bodyUnrender HTML
_ Request
request = do
ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
runParser' forall a. FromByteString a => Parser a
parser ByteString
body
instance (Monad m, ToByteString a) => BodyRender m HTML a where
bodyRender :: HTML -> Response -> a -> m (HTTP.MediaType, ResponseBody)
bodyRender :: HTML -> Response -> a -> m (MediaType, ResponseBody)
bodyRender HTML
html Response
_response a
a = do
let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder forall a b. (a -> b) -> a -> b
$ forall a. ToByteString a => a -> Builder
builder a
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall mt. MIMEType mt => mt -> MediaType
mimeType HTML
html, ResponseBody
body)
instance (MonadIO m, Aeson.FromJSON a) => BodyUnrender m JSON a where
bodyUnrender :: JSON -> Request -> m (Either Text a)
bodyUnrender :: JSON -> Request -> m (Either Text a)
bodyUnrender JSON
_ Request
request = do
ByteString
s <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
s
instance (Monad m, Aeson.ToJSON a) => BodyRender m JSON a where
bodyRender :: JSON -> Response -> a -> m (HTTP.MediaType, ResponseBody)
bodyRender :: JSON -> Response -> a -> m (MediaType, ResponseBody)
bodyRender JSON
json Response
_response a
a = do
let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder forall a b. (a -> b) -> a -> b
$ forall tag. Encoding' tag -> Builder
Aeson.fromEncoding forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
Aeson.toEncoding a
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall mt. MIMEType mt => mt -> MediaType
mimeType JSON
json, ResponseBody
body)
inMemoryBackend :: BackEnd LBS.ByteString
inMemoryBackend :: BackEnd ByteString
inMemoryBackend = forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd
tempFileBackend :: (MonadResource m) => m (BackEnd FilePath)
tempFileBackend :: forall (m :: * -> *). MonadResource m => m (BackEnd String)
tempFileBackend = do
InternalState
st <- forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT forall (m :: * -> *). Monad m => ResourceT m InternalState
getInternalState
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ignored1 ignored2.
InternalState -> ignored1 -> ignored2 -> IO ByteString -> IO String
tempFileBackEnd InternalState
st
instance (MonadIO m) => BodyUnrender m (FormData a) (FormDataResult a) where
bodyUnrender :: FormData a -> Request -> m (Either Text (FormDataResult a))
bodyUnrender :: FormData a -> Request -> m (Either Text (FormDataResult a))
bodyUnrender FormData{ParseRequestBodyOptions
parseOptions :: forall a. FormData a -> ParseRequestBodyOptions
parseOptions :: ParseRequestBodyOptions
parseOptions, BackEnd a
backendOptions :: forall a. FormData a -> BackEnd a
backendOptions :: BackEnd a
backendOptions} Request
request = do
([Param]
formDataParams, [File a]
formDataFiles) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
parseRequestBodyEx ParseRequestBodyOptions
parseOptions BackEnd a
backendOptions forall a b. (a -> b) -> a -> b
$ Request -> Request
toWaiRequest Request
request
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right FormDataResult{[Param]
formDataParams :: [Param]
formDataParams :: [Param]
formDataParams, [File a]
formDataFiles :: [File a]
formDataFiles :: [File a]
formDataFiles}
instance (MonadIO m, FromByteString a) => BodyUnrender m OctetStream a where
bodyUnrender :: OctetStream -> Request -> m (Either Text a)
bodyUnrender :: OctetStream -> Request -> m (Either Text a)
bodyUnrender OctetStream
_ Request
request = do
ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
runParser' forall a. FromByteString a => Parser a
parser ByteString
body
instance (Monad m, ToByteString a) => BodyRender m OctetStream a where
bodyRender :: OctetStream -> Response -> a -> m (HTTP.MediaType, ResponseBody)
bodyRender :: OctetStream -> Response -> a -> m (MediaType, ResponseBody)
bodyRender OctetStream
os Response
_response a
a = do
let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder forall a b. (a -> b) -> a -> b
$ forall a. ToByteString a => a -> Builder
builder a
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall mt. MIMEType mt => mt -> MediaType
mimeType OctetStream
os, ResponseBody
body)
instance (MonadIO m, FromText a) => BodyUnrender m PlainText a where
bodyUnrender :: PlainText -> Request -> m (Either Text a)
bodyUnrender :: PlainText -> Request -> m (Either Text a)
bodyUnrender PlainText
_ Request
request = do
ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case ByteString -> Either UnicodeException Text
LText.decodeUtf8' ByteString
body of
Left UnicodeException
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnicodeException
e
Right Text
t -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. FromText a => Text -> a
fromText forall a b. (a -> b) -> a -> b
$ Text -> Text
LText.toStrict Text
t
instance (Monad m, ToText a) => BodyRender m PlainText a where
bodyRender :: PlainText -> Response -> a -> m (HTTP.MediaType, ResponseBody)
bodyRender :: PlainText -> Response -> a -> m (MediaType, ResponseBody)
bodyRender PlainText
txt Response
_response a
a = do
let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder forall a b. (a -> b) -> a -> b
$ Text -> Builder
Text.encodeUtf8Builder forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText a
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall mt. MIMEType mt => mt -> MediaType
mimeType PlainText
txt, ResponseBody
body)