-- | Parsing and rendering of MIME types
module WebGear.Server.MIMETypes (
  -- * Parsing and rendering MIME types
  BodyUnrender (..),
  BodyRender (..),

  -- * FormData utils
  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 qualified Data.ByteString as BS
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 (..))

{- | Instances of this class are used to parse the body of a request
as specified by a MIME type.
-}
class (MIMEType mt) => BodyUnrender m mt a where
  -- | Parse a request body. Return a 'Left' value with error messages
  -- in case of failure.
  bodyUnrender :: mt -> Request -> m (Either Text a)

{- | Instances of this class serializes a value to a response body as
specified by a MIME type.
-}
class (MIMEType mt) => BodyRender m mt a where
  -- | Render a value in the format specified by the media type.
  --
  -- Returns the response body and the media type to be used in the
  -- "Content-Type" header. This could be a variant of the original
  -- media type with additional parameters.
  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 <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
    Either Text a -> m (Either Text a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> m (Either Text a))
-> Either Text a -> m (Either Text a)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text Form
urlDecodeForm ByteString
body Either Text Form -> (Form -> Either Text a) -> Either Text a
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Form -> Either Text a
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 (Builder -> ResponseBody) -> Builder -> ResponseBody
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.fromLazyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Form -> ByteString
urlEncodeFormStable (Form -> ByteString) -> Form -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> Form
forall a. ToForm a => a -> Form
toForm a
a
    (MediaType, ResponseBody) -> m (MediaType, ResponseBody)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormURLEncoded -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType FormURLEncoded
FormURLEncoded, ResponseBody
body)

--------------------------------------------------------------------------------

instance (MonadIO m) => BodyUnrender m HTML BS.ByteString where
  bodyUnrender :: HTML -> Request -> m (Either Text BS.ByteString)
  bodyUnrender :: HTML -> Request -> m (Either Text ByteString)
bodyUnrender HTML
_ Request
request = do
    ByteString
body <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
    Either Text ByteString -> m (Either Text ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text ByteString -> m (Either Text ByteString))
-> Either Text ByteString -> m (Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right (ByteString -> Either Text ByteString)
-> ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
body

instance (Monad m) => BodyRender m HTML BS.ByteString where
  bodyRender :: HTML -> Response -> BS.ByteString -> m (HTTP.MediaType, ResponseBody)
  bodyRender :: HTML -> Response -> ByteString -> m (MediaType, ResponseBody)
bodyRender HTML
html Response
_response ByteString
a = do
    let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder (Builder -> ResponseBody) -> Builder -> ResponseBody
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.fromByteString ByteString
a
    (MediaType, ResponseBody) -> m (MediaType, ResponseBody)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HTML -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType HTML
html, ResponseBody
body)

instance (MonadIO m) => BodyUnrender m HTML LBS.ByteString where
  bodyUnrender :: HTML -> Request -> m (Either Text LBS.ByteString)
  bodyUnrender :: HTML -> Request -> m (Either Text ByteString)
bodyUnrender HTML
_ Request
request = do
    ByteString
body <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
    Either Text ByteString -> m (Either Text ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text ByteString -> m (Either Text ByteString))
-> Either Text ByteString -> m (Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
body

instance (Monad m) => BodyRender m HTML LBS.ByteString where
  bodyRender :: HTML -> Response -> LBS.ByteString -> m (HTTP.MediaType, ResponseBody)
  bodyRender :: HTML -> Response -> ByteString -> m (MediaType, ResponseBody)
bodyRender HTML
html Response
_response ByteString
a = do
    let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder (Builder -> ResponseBody) -> Builder -> ResponseBody
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.fromLazyByteString ByteString
a
    (MediaType, ResponseBody) -> m (MediaType, ResponseBody)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HTML -> MediaType
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 <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
    Either Text a -> m (Either Text a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> m (Either Text a))
-> Either Text a -> m (Either Text a)
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> Either String a -> Either Text a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
pack (Either String a -> Either Text a)
-> Either String a -> Either Text a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
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 (Builder -> ResponseBody) -> Builder -> ResponseBody
forall a b. (a -> b) -> a -> b
$ Encoding' Value -> Builder
forall tag. Encoding' tag -> Builder
Aeson.fromEncoding (Encoding' Value -> Builder) -> Encoding' Value -> Builder
forall a b. (a -> b) -> a -> b
$ a -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
Aeson.toEncoding a
a
    (MediaType, ResponseBody) -> m (MediaType, ResponseBody)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSON -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType JSON
json, ResponseBody
body)

--------------------------------------------------------------------------------

-- | A backend that stores all files in memory
inMemoryBackend :: BackEnd LBS.ByteString
inMemoryBackend :: BackEnd ByteString
inMemoryBackend = BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd

-- | A backend that stores files in a temp directory.
tempFileBackend :: (MonadResource m) => m (BackEnd FilePath)
tempFileBackend :: forall (m :: * -> *). MonadResource m => m (BackEnd String)
tempFileBackend = do
  InternalState
st <- ResourceT IO InternalState -> m InternalState
forall a. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT ResourceT IO InternalState
forall (m :: * -> *). Monad m => ResourceT m InternalState
getInternalState
  BackEnd String -> m (BackEnd String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BackEnd String -> m (BackEnd String))
-> BackEnd String -> m (BackEnd String)
forall a b. (a -> b) -> a -> b
$ InternalState -> BackEnd String
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 :: ParseRequestBodyOptions
parseOptions :: forall a. FormData a -> ParseRequestBodyOptions
parseOptions, BackEnd a
backendOptions :: BackEnd a
backendOptions :: forall a. FormData a -> BackEnd a
backendOptions} Request
request = do
    ([Param]
formDataParams, [File a]
formDataFiles) <-
      IO ([Param], [File a]) -> m ([Param], [File a])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Param], [File a]) -> m ([Param], [File a]))
-> IO ([Param], [File a]) -> m ([Param], [File a])
forall a b. (a -> b) -> a -> b
$ ParseRequestBodyOptions
-> BackEnd a -> Request -> IO ([Param], [File a])
forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
parseRequestBodyEx ParseRequestBodyOptions
parseOptions BackEnd a
backendOptions (Request -> IO ([Param], [File a]))
-> Request -> IO ([Param], [File a])
forall a b. (a -> b) -> a -> b
$ Request -> Request
toWaiRequest Request
request
    Either Text (FormDataResult a)
-> m (Either Text (FormDataResult a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (FormDataResult a)
 -> m (Either Text (FormDataResult a)))
-> Either Text (FormDataResult a)
-> m (Either Text (FormDataResult a))
forall a b. (a -> b) -> a -> b
$ FormDataResult a -> Either Text (FormDataResult a)
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) => BodyUnrender m OctetStream BS.ByteString where
  bodyUnrender :: OctetStream -> Request -> m (Either Text BS.ByteString)
  bodyUnrender :: OctetStream -> Request -> m (Either Text ByteString)
bodyUnrender OctetStream
_ Request
request = do
    ByteString
body <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
    Either Text ByteString -> m (Either Text ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text ByteString -> m (Either Text ByteString))
-> Either Text ByteString -> m (Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right (ByteString -> Either Text ByteString)
-> ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
body

instance (Monad m) => BodyRender m OctetStream BS.ByteString where
  bodyRender :: OctetStream -> Response -> BS.ByteString -> m (HTTP.MediaType, ResponseBody)
  bodyRender :: OctetStream
-> Response -> ByteString -> m (MediaType, ResponseBody)
bodyRender OctetStream
os Response
_response ByteString
a = do
    let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder (Builder -> ResponseBody) -> Builder -> ResponseBody
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.fromByteString ByteString
a
    (MediaType, ResponseBody) -> m (MediaType, ResponseBody)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OctetStream -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType OctetStream
os, ResponseBody
body)

instance (MonadIO m) => BodyUnrender m OctetStream LBS.ByteString where
  bodyUnrender :: OctetStream -> Request -> m (Either Text LBS.ByteString)
  bodyUnrender :: OctetStream -> Request -> m (Either Text ByteString)
bodyUnrender OctetStream
_ Request
request = do
    ByteString
body <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
    Either Text ByteString -> m (Either Text ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text ByteString -> m (Either Text ByteString))
-> Either Text ByteString -> m (Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
body

instance (Monad m) => BodyRender m OctetStream LBS.ByteString where
  bodyRender :: OctetStream -> Response -> LBS.ByteString -> m (HTTP.MediaType, ResponseBody)
  bodyRender :: OctetStream
-> Response -> ByteString -> m (MediaType, ResponseBody)
bodyRender OctetStream
os Response
_response ByteString
a = do
    let body :: ResponseBody
body = Builder -> ResponseBody
ResponseBodyBuilder (Builder -> ResponseBody) -> Builder -> ResponseBody
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.fromLazyByteString ByteString
a
    (MediaType, ResponseBody) -> m (MediaType, ResponseBody)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OctetStream -> MediaType
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 <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBody Request
request
    Either Text a -> m (Either Text a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> m (Either Text a))
-> Either Text a -> m (Either Text a)
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either UnicodeException Text
LText.decodeUtf8' ByteString
body of
      Left UnicodeException
e -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e
      Right Text
t -> a -> Either Text a
forall a b. b -> Either a b
Right (a -> Either Text a) -> a -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> a
forall a. FromText a => Text -> a
fromText (Text -> a) -> Text -> a
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 (Builder -> ResponseBody) -> Builder -> ResponseBody
forall a b. (a -> b) -> a -> b
$ Text -> Builder
Text.encodeUtf8Builder (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. ToText a => a -> Text
toText a
a
    (MediaType, ResponseBody) -> m (MediaType, ResponseBody)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlainText -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType PlainText
txt, ResponseBody
body)