module Web.Minion.Request.Body where

import Control.Monad ((>=>))
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Class qualified as IO
import Data.ByteString qualified as Bytes
import Data.ByteString.Lazy qualified as Bytes.Lazy
import Data.List.NonEmpty qualified as Nel
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Data.Text.Lazy.Encoding qualified as Text.Encode.Lazy
import GHC.Base (Type)
import Network.HTTP.Media qualified as Http
import Network.HTTP.Types qualified as Http
import Network.Wai qualified as Wai
import Web.FormUrlEncoded (FromForm)
import Web.FormUrlEncoded qualified as Http
import Web.Minion.Args (WithReq)
import Web.Minion.Introspect qualified as I
import Web.Minion.Media
import Web.Minion.Media.FormUrlEncoded
import Web.Minion.Media.PlainText (PlainText)

import Web.Minion.Request
import Web.Minion.Router

newtype ReqBody (cts :: [Type]) a = ReqBody a

instance IsRequest (ReqBody cts a) where
  type RequestValue (ReqBody cts a) = a
  getRequestValue :: ReqBody cts a -> RequestValue (ReqBody cts a)
getRequestValue (ReqBody a
a) = a
RequestValue (ReqBody cts a)
a

class DecodeBody cts a where
  decodeBody ::
    (MonadIO m, MonadThrow m) =>
    MakeError ->
    -- | Content-Type header value
    Bytes.ByteString ->
    -- | Request body
    IO Bytes.Lazy.ByteString ->
    m (ReqBody cts a)

instance DecodeBody '[] a where
  decodeBody :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
MakeError -> ByteString -> IO ByteString -> m (ReqBody '[] a)
decodeBody MakeError
makeError ByteString
_ IO ByteString
_ = ServerError -> m (ReqBody '[] a)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ServerError -> m (ReqBody '[] a))
-> ServerError -> m (ReqBody '[] a)
forall a b. (a -> b) -> a -> b
$ MakeError
makeError Status
Http.status415 ByteString
"Unsupported Content-Type"

instance (ContentType ct, Decode ct a, DecodeBody cts a) => DecodeBody (ct ': cts) a where
  decodeBody :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
MakeError
-> ByteString -> IO ByteString -> m (ReqBody (ct : cts) a)
decodeBody MakeError
makeError ByteString
contentType IO ByteString
body
    | Just MediaType
_ <- [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
Http.matchAccept (NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
Nel.toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ forall a. ContentType a => NonEmpty MediaType
forall {k} (a :: k). ContentType a => NonEmpty MediaType
media @ct) ByteString
contentType =
        IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
body
          m ByteString
-> (ByteString -> m (ReqBody (ct : cts) a))
-> m (ReqBody (ct : cts) a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> m (ReqBody (ct : cts) a))
-> (a -> m (ReqBody (ct : cts) a))
-> Either Text a
-> m (ReqBody (ct : cts) a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (m (ReqBody (ct : cts) a) -> Text -> m (ReqBody (ct : cts) a)
forall a b. a -> b -> a
const (m (ReqBody (ct : cts) a) -> Text -> m (ReqBody (ct : cts) a))
-> m (ReqBody (ct : cts) a) -> Text -> m (ReqBody (ct : cts) a)
forall a b. (a -> b) -> a -> b
$ ServerError -> m (ReqBody (ct : cts) a)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ServerError -> m (ReqBody (ct : cts) a))
-> ServerError -> m (ReqBody (ct : cts) a)
forall a b. (a -> b) -> a -> b
$ MakeError
makeError Status
Http.status400 ByteString
"Failed to parse body")
            (ReqBody (ct : cts) a -> m (ReqBody (ct : cts) a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReqBody (ct : cts) a -> m (ReqBody (ct : cts) a))
-> (a -> ReqBody (ct : cts) a) -> a -> m (ReqBody (ct : cts) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReqBody (ct : cts) a
forall (cts :: [*]) a. a -> ReqBody cts a
ReqBody)
            (Either Text a -> m (ReqBody (ct : cts) a))
-> (ByteString -> Either Text a)
-> ByteString
-> m (ReqBody (ct : cts) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (ct :: k) a. Decode ct a => ByteString -> Either Text a
forall ct a. Decode ct a => ByteString -> Either Text a
decode @ct @a
    | Bool
otherwise = do
        ReqBody a
a :: ReqBody cts a <- MakeError -> ByteString -> IO ByteString -> m (ReqBody cts a)
forall (cts :: [*]) a (m :: * -> *).
(DecodeBody cts a, MonadIO m, MonadThrow m) =>
MakeError -> ByteString -> IO ByteString -> m (ReqBody cts a)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
MakeError -> ByteString -> IO ByteString -> m (ReqBody cts a)
decodeBody MakeError
makeError ByteString
contentType IO ByteString
body
        ReqBody (ct : cts) a -> m (ReqBody (ct : cts) a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReqBody (ct : cts) a -> m (ReqBody (ct : cts) a))
-> ReqBody (ct : cts) a -> m (ReqBody (ct : cts) a)
forall a b. (a -> b) -> a -> b
$ a -> ReqBody (ct : cts) a
forall (cts :: [*]) a. a -> ReqBody cts a
ReqBody a
a

class Decode ct a where
  decode :: Bytes.Lazy.ByteString -> Either Text.Text a

instance Decode PlainText Text.Text where
  decode :: ByteString -> Either Text Text
decode = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text)
-> (ByteString -> Text) -> ByteString -> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.Lazy.toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.Encode.Lazy.decodeUtf8

instance Decode PlainText Text.Lazy.Text where
  decode :: ByteString -> Either Text Text
decode = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text)
-> (ByteString -> Text) -> ByteString -> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.Encode.Lazy.decodeUtf8

instance Decode PlainText String where
  decode :: ByteString -> Either Text String
decode = (Text -> String) -> Either Text Text -> Either Text String
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text.Lazy.unpack (Either Text Text -> Either Text String)
-> (ByteString -> Either Text Text)
-> ByteString
-> Either Text String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (ct :: k) a. Decode ct a => ByteString -> Either Text a
forall ct a. Decode ct a => ByteString -> Either Text a
decode @PlainText

instance (FromForm a) => Decode FormUrlEncoded a where
  decode :: ByteString -> Either Text a
decode = ByteString -> Either Text Form
Http.urlDecodeForm (ByteString -> Either Text Form)
-> (Form -> Either Text a) -> ByteString -> Either Text a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Form -> Either Text a
forall a. FromForm a => Form -> Either Text a
Http.fromForm

{- | Extracts request body with specified Content-Type

@
... '/>' 'reqBody' \@'[PlainText] \@MyRequest
@
-}
reqBody ::
  forall cts r m i ts.
  (I.Introspection i I.Request (ReqBody cts r)) =>
  (IO.MonadIO m, MonadThrow m) =>
  (DecodeBody cts r) =>
  -- | .
  ValueCombinator i (WithReq m (ReqBody cts r)) ts m
reqBody :: forall (cts :: [*]) r (m :: * -> *) i ts.
(Introspection i 'Request (ReqBody cts r), MonadIO m, MonadThrow m,
 DecodeBody cts r) =>
ValueCombinator i (WithReq m (ReqBody cts r)) ts m
reqBody = (ErrorBuilder -> Request -> m (ReqBody cts r))
-> Router' i (ts :+ WithReq m (ReqBody cts r)) m -> Router' i ts m
forall r (m :: * -> *) i ts.
(Introspection i 'Request r, IsRequest r) =>
(ErrorBuilder -> Request -> m r)
-> Router' i (ts :+ WithReq m r) m -> Router' i ts m
Request \ErrorBuilder
makeError Request
req -> case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
Http.hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
req of
  Maybe ByteString
Nothing -> ServerError -> m (ReqBody cts r)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ServerError -> m (ReqBody cts r))
-> ServerError -> m (ReqBody cts r)
forall a b. (a -> b) -> a -> b
$ ErrorBuilder
makeError Request
req Status
Http.status415 ByteString
"Unsupported Content-Type"
  Just ByteString
ct -> forall (cts :: [*]) a (m :: * -> *).
(DecodeBody cts a, MonadIO m, MonadThrow m) =>
MakeError -> ByteString -> IO ByteString -> m (ReqBody cts a)
decodeBody @cts @r (ErrorBuilder
makeError Request
req) ByteString
ct (Request -> IO ByteString
Wai.lazyRequestBody Request
req)