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 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
  -- | Parse a request body. Return a 'Left' value with error messages
  -- in case of failure.
  bodyUnrender :: mt -> Request -> m (Either Text a)

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

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

-- | A backend that stores all files in memory
inMemoryBackend :: BackEnd LBS.ByteString
inMemoryBackend :: BackEnd ByteString
inMemoryBackend = 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 <- 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)