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