module WebGear.Middlewares.Body
( JSONRequestBody
, jsonRequestBody
, jsonResponseBody
) where
import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (FromJSON, ToJSON, eitherDecode', encode)
import Data.ByteString.Lazy (ByteString, fromChunks, fromStrict)
import Data.Kind (Type)
import Data.Text (Text, pack)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Types (hContentType)
import WebGear.Trait (Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..),
ResponseMiddleware', badRequest400, getRequestBodyChunk, setResponseHeader)
import WebGear.Util (takeWhileM)
data JSONRequestBody (t :: Type)
instance (FromJSON t, MonadIO m) => Trait (JSONRequestBody t) Request m where
type Attribute (JSONRequestBody t) Request = t
type Absence (JSONRequestBody t) Request = Text
toAttribute :: Request -> m (Result (JSONRequestBody t) Request)
toAttribute r = do
chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk r
pure $ case eitherDecode' (fromChunks chunks) of
Left e -> NotFound (pack e)
Right t -> Found t
jsonRequestBody :: forall t m req a. (FromJSON t, MonadRouter m, MonadIO m)
=> RequestMiddleware' m req (JSONRequestBody t:req) a
jsonRequestBody handler = Kleisli $
probe @(JSONRequestBody t) >=> either (errorResponse . mkError) (runKleisli handler)
where
mkError :: Text -> Response ByteString
mkError e = badRequest400 $ fromStrict $ encodeUtf8 $ "Error parsing request body: " <> e
jsonResponseBody :: (ToJSON t, Monad m) => ResponseMiddleware' m req t ByteString
jsonResponseBody handler = Kleisli $ \req -> do
x <- runKleisli handler req
pure $ setResponseHeader hContentType "application/json" $ encode <$> x