{-# OPTIONS_GHC -Wno-orphans #-}
module Network.Wai.Utilities.Request where
import Control.Error
import Data.Aeson
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as Lazy
import Data.Id
import Data.Text.Lazy qualified as Text
import Imports
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Predicate.Request
import Pipes
import Pipes.Prelude qualified as P
readBody :: (MonadIO m, HasRequest r) => r -> m LByteString
readBody :: forall (m :: * -> *) r.
(MonadIO m, HasRequest r) =>
r -> m LByteString
readBody r
r = IO LByteString -> m LByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LByteString -> m LByteString)
-> IO LByteString -> m LByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> LByteString
Lazy.fromChunks ([ByteString] -> LByteString) -> IO [ByteString] -> IO LByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Producer ByteString IO () -> IO [ByteString]
forall (m :: * -> *) a. Monad m => Producer a m () -> m [a]
P.toListM Producer ByteString IO ()
chunks
where
chunks :: Producer ByteString IO ()
chunks = do
ByteString
b <- IO ByteString -> Proxy X () () ByteString IO ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> Proxy X () () ByteString m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ByteString -> Proxy X () () ByteString IO ByteString)
-> IO ByteString -> Proxy X () () ByteString IO ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBodyChunk (r -> Request
forall a. HasRequest a => a -> Request
getRequest r
r)
Bool -> Producer ByteString IO () -> Producer ByteString IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
b) (Producer ByteString IO () -> Producer ByteString IO ())
-> Producer ByteString IO () -> Producer ByteString IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString -> Producer ByteString IO ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
yield ByteString
b
Producer ByteString IO ()
chunks
parseBody ::
(MonadIO m, FromJSON a) =>
JsonRequest a ->
ExceptT LText m a
parseBody :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
JsonRequest a -> ExceptT LText m a
parseBody JsonRequest a
r = JsonRequest a -> ExceptT LText m LByteString
forall (m :: * -> *) r.
(MonadIO m, HasRequest r) =>
r -> m LByteString
readBody JsonRequest a
r ExceptT LText m LByteString
-> (LByteString -> ExceptT LText m a) -> ExceptT LText m a
forall a b.
ExceptT LText m a -> (a -> ExceptT LText m b) -> ExceptT LText m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either LText a -> ExceptT LText m a
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither (Either LText a -> ExceptT LText m a)
-> (LByteString -> Either LText a)
-> LByteString
-> ExceptT LText m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> LText) -> Either String a -> Either LText a
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL String -> LText
Text.pack (Either String a -> Either LText a)
-> (LByteString -> Either String a)
-> LByteString
-> Either LText a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LByteString -> Either String a
forall a. FromJSON a => LByteString -> Either String a
eitherDecode'
lookupRequestId :: HeaderName -> Request -> Maybe ByteString
lookupRequestId :: HeaderName -> Request -> Maybe ByteString
lookupRequestId HeaderName
reqIdHeaderName =
HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
reqIdHeaderName ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
requestHeaders
getRequestId :: HeaderName -> Request -> RequestId
getRequestId :: HeaderName -> Request -> RequestId
getRequestId HeaderName
reqIdHeaderName Request
req =
ByteString -> RequestId
RequestId (ByteString -> RequestId) -> ByteString -> RequestId
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall s. IsString s => s
defRequestId (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Request -> Maybe ByteString
lookupRequestId HeaderName
reqIdHeaderName Request
req
newtype JsonRequest body = JsonRequest {forall {k} (body :: k). JsonRequest body -> Request
fromJsonRequest :: Request}
newtype OptionalJsonRequest body = OptionalJsonRequest {forall {k} (body :: k). OptionalJsonRequest body -> Request
fromOptionalJsonRequest :: Request}
instance HasRequest (JsonRequest a) where
getRequest :: JsonRequest a -> Request
getRequest = JsonRequest a -> Request
forall {k} (body :: k). JsonRequest body -> Request
fromJsonRequest
instance HasRequest (OptionalJsonRequest a) where
getRequest :: OptionalJsonRequest a -> Request
getRequest = OptionalJsonRequest a -> Request
forall {k} (body :: k). OptionalJsonRequest body -> Request
fromOptionalJsonRequest
instance HasRequest Request where
getRequest :: Request -> Request
getRequest = Request -> Request
forall a. a -> a
id