-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Traits related to HTTP body.
module WebGear.Trait.Body
  ( JSONRequestBody
  ) where

import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson (FromJSON, eitherDecode')
import Data.ByteString.Lazy (fromChunks)
import Data.Kind (Type)
import Data.Text (Text, pack)

import WebGear.Trait (CheckResult (..), Trait (..))
import WebGear.Types (Request, getRequestBodyChunk)
import WebGear.Util (takeWhileM)


-- | A 'Trait' for converting a JSON request body into a value.
data JSONRequestBody (t :: Type)

instance (FromJSON t, MonadIO m) => Trait (JSONRequestBody t) Request m where
  type Val (JSONRequestBody t) Request = t
  type Fail (JSONRequestBody t) Request = Text

  check :: Request -> m (CheckResult (JSONRequestBody t) Request)
  check :: Request -> m (CheckResult (JSONRequestBody t) Request)
check r :: Request
r = do
    [ByteString]
chunks <- (ByteString -> Bool) -> [m ByteString] -> m [ByteString]
forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
forall a. Monoid a => a
mempty) ([m ByteString] -> m [ByteString])
-> [m ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ m ByteString -> [m ByteString]
forall a. a -> [a]
repeat (m ByteString -> [m ByteString]) -> m ByteString -> [m ByteString]
forall a b. (a -> b) -> a -> b
$ IO ByteString -> m ByteString
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
getRequestBodyChunk Request
r
    pure $ case ByteString -> Either String t
forall a. FromJSON a => ByteString -> Either String a
eitherDecode' ([ByteString] -> ByteString
fromChunks [ByteString]
chunks) of
             Left e :: String
e  -> Fail (JSONRequestBody t) Request
-> CheckResult (JSONRequestBody t) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail (String -> Text
pack String
e)
             Right t :: t
t -> Request
-> Val (JSONRequestBody t) Request
-> CheckResult (JSONRequestBody t) Request
forall k (t :: k) a. a -> Val t a -> CheckResult t a
CheckSuccess Request
r t
Val (JSONRequestBody t) Request
t