{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

-- |
--
-- Module      : Network.Wai.Handler.Hal
-- Copyright   : (C) 2021, 2024 Bellroy Pty Ltd
-- License     : BSD-3-Clause
-- Maintainer  : Bellroy Tech Team <haskell@bellroy.com>
-- Stability   : experimental
--
-- Lifts an 'Wai.Application' so that it can be run using
-- 'AWS.Lambda.Runtime.mRuntime' or
-- 'AWS.Lambda.Runtime.mRuntimeWithContext'. The glue code will look
-- something like this:
--
-- @
-- import AWS.Lambda.Runtime ('AWS.Lambda.Runtime.mRuntime')
-- import Network.Wai (Application)
-- import qualified Network.Wai.Handler.Hal as WaiHandler
--
-- app :: Application
-- app = undefined -- From Servant or wherever else
--
-- main :: IO ()
-- main = 'AWS.Lambda.Runtime.mRuntime' $ WaiHandler.'run' app
-- @
module Network.Wai.Handler.Hal
  ( run,
    runWithOptions,
    runWithContext,
    Options (..),
    defaultOptions,
    toWaiRequest,
    fromWaiResponse,
  )
where

import AWS.Lambda.Context (LambdaContext)
import qualified AWS.Lambda.Events.ApiGateway.ProxyRequest as HalRequest
  ( RequestContext (identity),
  )
import qualified AWS.Lambda.Events.ApiGateway.ProxyRequest as HalRequest hiding
  ( RequestContext (..),
  )
import qualified AWS.Lambda.Events.ApiGateway.ProxyResponse as HalResponse
import Control.Exception (IOException, tryJust)
import Control.Monad.IO.Class (MonadIO (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Builder.Extra as Builder
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import qualified Data.IORef as IORef
import Data.List (foldl', sort)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Vault.Lazy (Key, Vault)
import qualified Data.Vault.Lazy as Vault
import Network.HTTP.Media (MediaType, matches, parseAccept, renderHeader)
import Network.HTTP.Types.Header
  ( HeaderName,
    ResponseHeaders,
    hContentType,
    hHost,
    hRange,
    hReferer,
    hUserAgent,
  )
import Network.HTTP.Types.URI
  ( Query,
    QueryItem,
    encodePath,
    queryTextToQuery,
    renderQuery,
  )
import Network.HTTP.Types.Version (HttpVersion (..))
import Network.Socket (PortNumber)
import qualified Network.Socket as NS
import qualified Network.Wai as Wai
import qualified Network.Wai.Internal as Wai
import System.IO
  ( IOMode (..),
    SeekMode (..),
    hPutStrLn,
    hSeek,
    stderr,
    withFile,
  )

-- | Convert a WAI 'Wai.Application' into a function that can
-- be run by hal's 'AWS.Lambda.Runtime.mRuntime'. This is the simplest
-- form, and probably all that you'll need. See 'runWithContext' if
-- you have more complex needs.
run ::
  (MonadIO m) =>
  Wai.Application ->
  HalRequest.ProxyRequest HalRequest.NoAuthorizer ->
  m HalResponse.ProxyResponse
run :: forall (m :: * -> *).
MonadIO m =>
Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
run = Options
-> Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
forall (m :: * -> *).
MonadIO m =>
Options
-> Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
runWithOptions Options
defaultOptions

-- | Options that can be used to customize the behaviour of 'runWithContext'.
-- 'defaultOptions' provides sensible defaults.
data Options = Options
  { -- | Vault of values to share between the application and any
    -- middleware. You can pass in @Data.Vault.Lazy.'Vault.empty'@, or
    -- 'mempty' if you don't want to depend on @vault@ directly.
    Options -> Vault
vault :: Vault,
    -- | API Gateway doesn't tell us the port it's listening on, so you
    -- have to tell it yourself. This is almost always going to be 443
    -- (HTTPS).
    Options -> PortNumber
portNumber :: PortNumber,
    -- | To return binary data, API Gateway requires you to configure
    -- the @binaryMediaTypes@ setting on your API, and then
    -- base64-encode your binary responses.
    --
    -- If the @Content-Type@ header in the @wai@ 'Wai.Response'
    -- matches any of the media types in this field, @wai-handler-hal@
    -- will base64-encode its response to the API Gateway.
    --
    -- If you set @binaryMediaTypes@ in your API, you should override
    -- the default (empty) list to match.
    --
    -- /See:/ [Content type conversion in API Gateway](https://docs.aws.amazon.com/apigateway/latest/developerguide/api-gateway-payload-encodings-workflow.html)
    -- in the [Amazon API Gateway Developer Guide](https://docs.aws.amazon.com/apigateway/latest/developerguide/).
    Options -> [MediaType]
binaryMediaTypes :: [MediaType]
  }

-- | Default options for running 'Wai.Application's on Lambda.
defaultOptions :: Options
defaultOptions :: Options
defaultOptions =
  Options
    { vault :: Vault
vault = Vault
Vault.empty,
      portNumber :: PortNumber
portNumber = PortNumber
443,
      binaryMediaTypes :: [MediaType]
binaryMediaTypes = []
    }

-- | A variant of 'run' with configurable 'Options'. Useful if you
-- just want to override the 'binaryMediaTypes' setting but don't need
-- the rest of 'runWithContext''s features.
--
-- @since 0.4.0.0
runWithOptions ::
  (MonadIO m) =>
  -- | Configuration options. 'defaultOptions' provides sensible defaults.
  Options ->
  Wai.Application ->
  HalRequest.ProxyRequest HalRequest.NoAuthorizer ->
  m HalResponse.ProxyResponse
runWithOptions :: forall (m :: * -> *).
MonadIO m =>
Options
-> Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
runWithOptions Options
opts Application
app ProxyRequest NoAuthorizer
req = IO ProxyResponse -> m ProxyResponse
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProxyResponse -> m ProxyResponse)
-> IO ProxyResponse -> m ProxyResponse
forall a b. (a -> b) -> a -> b
$ do
    Request
waiReq <- Options -> ProxyRequest NoAuthorizer -> IO Request
forall a. Options -> ProxyRequest a -> IO Request
toWaiRequest Options
opts ProxyRequest NoAuthorizer
req
    IORef (Maybe Response)
responseRef <- Maybe Response -> IO (IORef (Maybe Response))
forall a. a -> IO (IORef a)
IORef.newIORef Maybe Response
forall a. Maybe a
Nothing
    ResponseReceived
Wai.ResponseReceived <- Application
app Request
waiReq ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
waiResp ->
      ResponseReceived
Wai.ResponseReceived ResponseReceived -> IO () -> IO ResponseReceived
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IORef (Maybe Response) -> Maybe Response -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (Maybe Response)
responseRef (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
waiResp)
    Just Response
waiResp <- IORef (Maybe Response) -> IO (Maybe Response)
forall a. IORef a -> IO a
IORef.readIORef IORef (Maybe Response)
responseRef
    Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts Response
waiResp

-- | Convert a WAI 'Wai.Application' into a function that can
-- be run by hal's 'AWS.Lambda.Runtime.mRuntimeWithContext'. This
-- function exposes all the configurable knobs.
runWithContext ::
  (MonadIO m) =>
  -- | Configuration options. 'defaultOptions' provides sensible defaults.
  Options ->
  -- | We pass two 'Vault' keys to the callback that provides the
  -- 'Wai.Application'. This allows the application to look into the
  -- 'Vault' part of each request and read @hal@ data structures, if
  -- necessary:
  --
  -- * The @'Key' 'LambdaContext'@ provides
  --   information about the Lambda invocation, function, and
  --   execution environment; and
  --
  -- * The @'Key' ('HalRequest.ProxyRequest'
  -- 'HalRequest.NoAuthorizer')@ provides the unmodified API Gateway
  -- representation of the HTTP request.
  ( Key LambdaContext ->
    Key (HalRequest.ProxyRequest HalRequest.NoAuthorizer) ->
    Wai.Application
  ) ->
  LambdaContext ->
  -- | We force 'HalRequest.NoAuthorizer' because it's a type alias
  -- for 'Data.Aeson.Value' (i.e., should always parse), and it avoids
  -- an "ambiguous type variable" error at the use site.
  HalRequest.ProxyRequest HalRequest.NoAuthorizer ->
  m HalResponse.ProxyResponse
runWithContext :: forall (m :: * -> *).
MonadIO m =>
Options
-> (Key LambdaContext
    -> Key (ProxyRequest NoAuthorizer) -> Application)
-> LambdaContext
-> ProxyRequest NoAuthorizer
-> m ProxyResponse
runWithContext Options
opts Key LambdaContext -> Key (ProxyRequest NoAuthorizer) -> Application
app LambdaContext
ctx ProxyRequest NoAuthorizer
req = IO ProxyResponse -> m ProxyResponse
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProxyResponse -> m ProxyResponse)
-> IO ProxyResponse -> m ProxyResponse
forall a b. (a -> b) -> a -> b
$ do
  Key LambdaContext
contextKey <- IO (Key LambdaContext)
forall a. IO (Key a)
Vault.newKey
  Key (ProxyRequest NoAuthorizer)
requestKey <- IO (Key (ProxyRequest NoAuthorizer))
forall a. IO (Key a)
Vault.newKey
  let vault' :: Vault
vault' =
        Options -> Vault
vault Options
opts
          Vault -> (Vault -> Vault) -> Vault
forall a b. a -> (a -> b) -> b
& Key LambdaContext -> LambdaContext -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key LambdaContext
contextKey LambdaContext
ctx
          Vault -> (Vault -> Vault) -> Vault
forall a b. a -> (a -> b) -> b
& Key (ProxyRequest NoAuthorizer)
-> ProxyRequest NoAuthorizer -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (ProxyRequest NoAuthorizer)
requestKey ProxyRequest NoAuthorizer
req
      opts' :: Options
opts' = Options
opts {vault = vault'}
  Request
waiReq <- Options -> ProxyRequest NoAuthorizer -> IO Request
forall a. Options -> ProxyRequest a -> IO Request
toWaiRequest Options
opts' ProxyRequest NoAuthorizer
req
  IORef (Maybe Response)
responseRef <- Maybe Response -> IO (IORef (Maybe Response))
forall a. a -> IO (IORef a)
IORef.newIORef Maybe Response
forall a. Maybe a
Nothing
  ResponseReceived
Wai.ResponseReceived <- Key LambdaContext -> Key (ProxyRequest NoAuthorizer) -> Application
app Key LambdaContext
contextKey Key (ProxyRequest NoAuthorizer)
requestKey Request
waiReq ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
waiResp ->
    ResponseReceived
Wai.ResponseReceived ResponseReceived -> IO () -> IO ResponseReceived
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IORef (Maybe Response) -> Maybe Response -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (Maybe Response)
responseRef (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
waiResp)
  Just Response
waiResp <- IORef (Maybe Response) -> IO (Maybe Response)
forall a. IORef a -> IO a
IORef.readIORef IORef (Maybe Response)
responseRef
  Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts' Response
waiResp

-- | Convert the request sent to a Lambda serving an API Gateway proxy
-- integration into a WAI request.
--
-- __Note:__ We aren't told the HTTP version the client is using, so
-- we assume HTTP 1.1.
toWaiRequest ::
  Options ->
  HalRequest.ProxyRequest a ->
  IO Wai.Request
toWaiRequest :: forall a. Options -> ProxyRequest a -> IO Request
toWaiRequest Options
opts ProxyRequest a
req = do
  let port :: PortNumber
port = Options -> PortNumber
portNumber Options
opts
      pathSegments :: [Text]
pathSegments = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> Text
forall a. ProxyRequest a -> Text
HalRequest.path ProxyRequest a
req
      query :: Query
query = Query -> Query
forall a. Ord a => [a] -> [a]
sort (Query -> Query)
-> (HashMap Text [Text] -> Query) -> HashMap Text [Text] -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text [Text] -> Query
constructQuery (HashMap Text [Text] -> Query) -> HashMap Text [Text] -> Query
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> HashMap Text [Text]
forall a. ProxyRequest a -> HashMap Text [Text]
HalRequest.multiValueQueryStringParameters ProxyRequest a
req
      hints :: AddrInfo
hints =
        AddrInfo
NS.defaultHints
          { NS.addrFlags = [NS.AI_NUMERICHOST],
            NS.addrFamily = NS.AF_INET,
            NS.addrSocketType = NS.Stream
          }
      sourceIp :: String
sourceIp =
        Text -> String
T.unpack
          (Text -> String)
-> (RequestContext a -> Text) -> RequestContext a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity -> Text
HalRequest.sourceIp
          (Identity -> Text)
-> (RequestContext a -> Identity) -> RequestContext a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestContext a -> Identity
forall a. RequestContext a -> Identity
HalRequest.identity
          (RequestContext a -> String) -> RequestContext a -> String
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> RequestContext a
forall a. ProxyRequest a -> RequestContext a
HalRequest.requestContext ProxyRequest a
req
  -- Test invokes from the API Gateway console pass a "sourceIp" field
  -- of "test-invoke-source-ip". If the getAddrInfo call fails, just
  -- assume localhost.
  SockAddr
sourceHost <-
    (IOException -> Maybe IOException)
-> IO [AddrInfo] -> IO (Either IOException [AddrInfo])
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust
      (forall a. a -> Maybe a
Just @IOException)
      (Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
NS.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
sourceIp) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port))
      IO (Either IOException [AddrInfo])
-> (Either IOException [AddrInfo] -> IO SockAddr) -> IO SockAddr
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (AddrInfo
s : [AddrInfo]
_) -> SockAddr -> IO SockAddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> IO SockAddr) -> SockAddr -> IO SockAddr
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
NS.addrAddress AddrInfo
s
        Either IOException [AddrInfo]
_ -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            [String] -> String
forall a. Monoid a => [a] -> a
mconcat
              [ String
"Cannot convert sourceIp ",
                String -> String
forall a. Show a => a -> String
show String
sourceIp,
                String
" to address; assuming 127.0.0.1"
              ]
          SockAddr -> IO SockAddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> IO SockAddr)
-> (HostAddress -> SockAddr) -> HostAddress -> IO SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> HostAddress -> SockAddr
NS.SockAddrInet PortNumber
port (HostAddress -> IO SockAddr) -> HostAddress -> IO SockAddr
forall a b. (a -> b) -> a -> b
$ (Word8, Word8, Word8, Word8) -> HostAddress
NS.tupleToHostAddress (Word8
127, Word8
0, Word8
0, Word8
1)
  IO ByteString
body <- ByteString -> IO (IO ByteString)
returnChunks (ByteString -> IO (IO ByteString))
-> ByteString -> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> ByteString
forall a. ProxyRequest a -> ByteString
HalRequest.body ProxyRequest a
req
  let waiReq :: Request
waiReq =
        Wai.Request
          { requestMethod :: ByteString
Wai.requestMethod = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> Text
forall a. ProxyRequest a -> Text
HalRequest.httpMethod ProxyRequest a
req,
            httpVersion :: HttpVersion
Wai.httpVersion = Int -> Int -> HttpVersion
HttpVersion Int
1 Int
1,
            rawPathInfo :: ByteString
Wai.rawPathInfo =
              ByteString -> ByteString
BL.toStrict
                (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString
                (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Query -> Builder
encodePath [Text]
pathSegments [],
            rawQueryString :: ByteString
Wai.rawQueryString = case Query
query of
              [] -> ByteString
""
              Query
_ -> Bool -> Query -> ByteString
renderQuery Bool
True Query
query,
            requestHeaders :: [Header]
Wai.requestHeaders =
              [Header] -> [Header]
forall a. Ord a => [a] -> [a]
sort
                ([Header] -> [Header])
-> (HashMap (CI Text) [Text] -> [Header])
-> HashMap (CI Text) [Text]
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI Text, [Text]) -> [Header]) -> [(CI Text, [Text])] -> [Header]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                  ( \(CI Text
hName, [Text]
hValues) ->
                      ((Text -> ByteString) -> CI Text -> HeaderName
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map Text -> ByteString
T.encodeUtf8 CI Text
hName,) (ByteString -> Header) -> (Text -> ByteString) -> Text -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> Header) -> [Text] -> [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
hValues
                  )
                ([(CI Text, [Text])] -> [Header])
-> (HashMap (CI Text) [Text] -> [(CI Text, [Text])])
-> HashMap (CI Text) [Text]
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap (CI Text) [Text] -> [(CI Text, [Text])]
forall k v. HashMap k v -> [(k, v)]
H.toList
                (HashMap (CI Text) [Text] -> [Header])
-> HashMap (CI Text) [Text] -> [Header]
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> HashMap (CI Text) [Text]
forall a. ProxyRequest a -> HashMap (CI Text) [Text]
HalRequest.multiValueHeaders ProxyRequest a
req,
            isSecure :: Bool
Wai.isSecure = Bool
True,
            remoteHost :: SockAddr
Wai.remoteHost = SockAddr
sourceHost,
            pathInfo :: [Text]
Wai.pathInfo = [Text]
pathSegments,
            queryString :: Query
Wai.queryString = Query
query,
            requestBody :: IO ByteString
Wai.requestBody = IO ByteString
body,
            vault :: Vault
Wai.vault = Options -> Vault
vault Options
opts,
            requestBodyLength :: RequestBodyLength
Wai.requestBodyLength =
              Word64 -> RequestBodyLength
Wai.KnownLength (Word64 -> RequestBodyLength)
-> (ByteString -> Word64) -> ByteString -> RequestBodyLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> (ByteString -> Int64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> RequestBodyLength)
-> ByteString -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> ByteString
forall a. ProxyRequest a -> ByteString
HalRequest.body ProxyRequest a
req,
            requestHeaderHost :: Maybe ByteString
Wai.requestHeaderHost = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hHost ProxyRequest a
req,
            requestHeaderRange :: Maybe ByteString
Wai.requestHeaderRange = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hRange ProxyRequest a
req,
            requestHeaderReferer :: Maybe ByteString
Wai.requestHeaderReferer = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hReferer ProxyRequest a
req,
            requestHeaderUserAgent :: Maybe ByteString
Wai.requestHeaderUserAgent = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hUserAgent ProxyRequest a
req
          }
  Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
waiReq

-- | Unpack a lazy 'BL.ByteString' into its chunks, and return an IO
-- action which returns each chunk in sequence, and returns 'B.empty'
-- forever after the bytestring is exhausted.
returnChunks :: BL.ByteString -> IO (IO B.ByteString)
returnChunks :: ByteString -> IO (IO ByteString)
returnChunks ByteString
bs = do
  IORef [ByteString]
chunkRef <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
IORef.newIORef ([ByteString] -> IO (IORef [ByteString]))
-> [ByteString] -> IO (IORef [ByteString])
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks ByteString
bs
  IO ByteString -> IO (IO ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ByteString -> IO (IO ByteString))
-> (([ByteString] -> ([ByteString], ByteString)) -> IO ByteString)
-> ([ByteString] -> ([ByteString], ByteString))
-> IO (IO ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef [ByteString]
chunkRef (([ByteString] -> ([ByteString], ByteString))
 -> IO (IO ByteString))
-> ([ByteString] -> ([ByteString], ByteString))
-> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$
    \case
      [] -> ([ByteString], ByteString)
forall a. Monoid a => a
mempty
      (ByteString
ch : [ByteString]
chs) -> ([ByteString]
chs, ByteString
ch)

constructQuery :: HashMap Text [Text] -> Query
constructQuery :: HashMap Text [Text] -> Query
constructQuery = ((Text, [Text]) -> Query) -> [(Text, [Text])] -> Query
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text, [Text]) -> Query
expandParamList ([(Text, [Text])] -> Query)
-> (HashMap Text [Text] -> [(Text, [Text])])
-> HashMap Text [Text]
-> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text [Text] -> [(Text, [Text])]
forall k v. HashMap k v -> [(k, v)]
H.toList
  where
    expandParamList :: (Text, [Text]) -> [QueryItem]
    expandParamList :: (Text, [Text]) -> Query
expandParamList (Text
param, [Text]
values) =
      QueryText -> Query
queryTextToQuery (QueryText -> Query) -> QueryText -> Query
forall a b. (a -> b) -> a -> b
$ case [Text]
values of
        [] -> [(Text
param, Maybe Text
forall a. Maybe a
Nothing)]
        [Text]
_ -> (Text
param,) (Maybe Text -> (Text, Maybe Text))
-> (Text -> Maybe Text) -> Text -> (Text, Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> (Text, Maybe Text)) -> [Text] -> QueryText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
values

getHeader :: HeaderName -> HalRequest.ProxyRequest a -> Maybe ByteString
getHeader :: forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
h =
  (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
T.encodeUtf8 (Maybe Text -> Maybe ByteString)
-> (ProxyRequest a -> Maybe Text)
-> ProxyRequest a
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> HashMap (CI Text) Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup ((ByteString -> Text) -> HeaderName -> CI Text
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map ByteString -> Text
T.decodeUtf8 HeaderName
h) (HashMap (CI Text) Text -> Maybe Text)
-> (ProxyRequest a -> HashMap (CI Text) Text)
-> ProxyRequest a
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyRequest a -> HashMap (CI Text) Text
forall a. ProxyRequest a -> HashMap (CI Text) Text
HalRequest.headers

-- | Convert a WAI 'Wai.Response' into a hal
-- 'HalResponse.ProxyResponse'.
fromWaiResponse :: Options -> Wai.Response -> IO HalResponse.ProxyResponse
fromWaiResponse :: Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts (Wai.ResponseFile Status
status [Header]
headers String
path Maybe FilePart
mFilePart) = do
  ByteString
fileData <- String -> Maybe FilePart -> IO ByteString
readFilePart String
path Maybe FilePart
mFilePart
  ProxyResponse -> IO ProxyResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ProxyResponse -> IO ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> IO ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Header] -> ProxyResponse -> ProxyResponse
addHeaders [Header]
headers
    (ProxyResponse -> ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ProxyBody -> ProxyResponse
HalResponse.response Status
status
    (ProxyBody -> ProxyResponse)
-> (ByteString -> ProxyBody) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> MediaType -> ByteString -> ProxyBody
createProxyBody Options
opts ([Header] -> MediaType
getContentType [Header]
headers)
    (ByteString -> IO ProxyResponse) -> ByteString -> IO ProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString
fileData
fromWaiResponse Options
opts (Wai.ResponseBuilder Status
status [Header]
headers Builder
builder) =
  ProxyResponse -> IO ProxyResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ProxyResponse -> IO ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> IO ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Header] -> ProxyResponse -> ProxyResponse
addHeaders [Header]
headers
    (ProxyResponse -> ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ProxyBody -> ProxyResponse
HalResponse.response Status
status
    (ProxyBody -> ProxyResponse)
-> (ByteString -> ProxyBody) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> MediaType -> ByteString -> ProxyBody
createProxyBody Options
opts ([Header] -> MediaType
getContentType [Header]
headers)
    (ByteString -> ProxyBody)
-> (ByteString -> ByteString) -> ByteString -> ProxyBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict
    (ByteString -> IO ProxyResponse) -> ByteString -> IO ProxyResponse
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString Builder
builder
fromWaiResponse Options
opts (Wai.ResponseStream Status
status [Header]
headers StreamingBody
stream) = do
  IORef Builder
builderRef <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
IORef.newIORef Builder
forall a. Monoid a => a
mempty
  let addChunk :: Builder -> IO ()
addChunk Builder
chunk = IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef Builder
builderRef (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunk)
      flush :: IO ()
flush = IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef Builder
builderRef (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
Builder.flush)
  StreamingBody
stream Builder -> IO ()
addChunk IO ()
flush
  Builder
builder <- IORef Builder -> IO Builder
forall a. IORef a -> IO a
IORef.readIORef IORef Builder
builderRef
  Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts (Status -> [Header] -> Builder -> Response
Wai.ResponseBuilder Status
status [Header]
headers Builder
builder)
fromWaiResponse Options
opts (Wai.ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
_ Response
resp) = Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts Response
resp

readFilePart :: FilePath -> Maybe Wai.FilePart -> IO ByteString
readFilePart :: String -> Maybe FilePart -> IO ByteString
readFilePart String
path Maybe FilePart
mPart = String -> IOMode -> (Handle -> IO ByteString) -> IO ByteString
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode ((Handle -> IO ByteString) -> IO ByteString)
-> (Handle -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
  case Maybe FilePart
mPart of
    Maybe FilePart
Nothing -> Handle -> IO ByteString
B.hGetContents Handle
h
    Just (Wai.FilePart Integer
offset Integer
count Integer
_) -> do
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
offset
      Handle -> Int -> IO ByteString
B.hGet Handle
h (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
count

createProxyBody :: Options -> MediaType -> ByteString -> HalResponse.ProxyBody
createProxyBody :: Options -> MediaType -> ByteString -> ProxyBody
createProxyBody Options
opts MediaType
contentType ByteString
body =
  HalResponse.ProxyBody
    { $sel:contentType:ProxyBody :: Text
HalResponse.contentType = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
contentType,
      $sel:serialized:ProxyBody :: Text
HalResponse.serialized =
        if Bool
isBase64Encoded
          then ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
body
          else ByteString -> Text
T.decodeUtf8 ByteString
body,
      Bool
isBase64Encoded :: Bool
$sel:isBase64Encoded:ProxyBody :: Bool
HalResponse.isBase64Encoded
    }
  where
    isBase64Encoded :: Bool
isBase64Encoded = (MediaType -> Bool) -> [MediaType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (MediaType
contentType MediaType -> MediaType -> Bool
forall a. Accept a => a -> a -> Bool
`matches`) ([MediaType] -> Bool) -> [MediaType] -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> [MediaType]
binaryMediaTypes Options
opts

addHeaders ::
  ResponseHeaders -> HalResponse.ProxyResponse -> HalResponse.ProxyResponse
addHeaders :: [Header] -> ProxyResponse -> ProxyResponse
addHeaders [Header]
headers ProxyResponse
response = (ProxyResponse -> Header -> ProxyResponse)
-> ProxyResponse -> [Header] -> ProxyResponse
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ProxyResponse -> Header -> ProxyResponse
addHeader ProxyResponse
response [Header]
headers
  where
    addHeader :: ProxyResponse -> Header -> ProxyResponse
addHeader ProxyResponse
r (HeaderName
hName, ByteString
hValue) =
      Text -> Text -> ProxyResponse -> ProxyResponse
HalResponse.addHeader
        (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
hName)
        (ByteString -> Text
T.decodeUtf8 ByteString
hValue)
        ProxyResponse
r

-- | Try to find the content-type of a response, given the response
-- headers. If we can't, return @"application/octet-stream"@.
getContentType :: ResponseHeaders -> MediaType
getContentType :: [Header] -> MediaType
getContentType [Header]
headers =
  MediaType -> Maybe MediaType -> MediaType
forall a. a -> Maybe a -> a
fromMaybe MediaType
"application/octet-stream" (Maybe MediaType -> MediaType) -> Maybe MediaType -> MediaType
forall a b. (a -> b) -> a -> b
$
    HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType [Header]
headers Maybe ByteString
-> (ByteString -> Maybe MediaType) -> Maybe MediaType
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe MediaType
forall a. Accept a => ByteString -> Maybe a
parseAccept