{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- orphan instance for "instance HasRequest Request" :(

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
"N/A" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Request -> Maybe ByteString
lookupRequestId HeaderName
reqIdHeaderName Request
req

----------------------------------------------------------------------------
-- Typed JSON 'Request'

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}

----------------------------------------------------------------------------
-- Instances

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