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

-- |
--
-- Module      : Network.Wai.Handler.Hal
-- Copyright   : (C) 2021 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,
    runWithContext,
    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.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')
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.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 (..), hSeek, 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 :: Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
run Application
app ProxyRequest NoAuthorizer
req = IO ProxyResponse -> m ProxyResponse
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 <- Vault -> PortNumber -> ProxyRequest NoAuthorizer -> IO Request
forall a. Vault -> PortNumber -> ProxyRequest a -> IO Request
toWaiRequest Vault
Vault.empty PortNumber
443 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 (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
  Response -> IO ProxyResponse
fromWaiResponse 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 =>
  -- | 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.
  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).
  PortNumber ->
  -- | 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 :: Vault
-> PortNumber
-> (Key LambdaContext
    -> Key (ProxyRequest NoAuthorizer) -> Application)
-> LambdaContext
-> ProxyRequest NoAuthorizer
-> m ProxyResponse
runWithContext Vault
vault PortNumber
port Key LambdaContext -> Key (ProxyRequest NoAuthorizer) -> Application
app LambdaContext
ctx ProxyRequest NoAuthorizer
req = IO ProxyResponse -> m ProxyResponse
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' =
        Vault
vault
          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
  Request
waiReq <- Vault -> PortNumber -> ProxyRequest NoAuthorizer -> IO Request
forall a. Vault -> PortNumber -> ProxyRequest a -> IO Request
toWaiRequest Vault
vault' PortNumber
port 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 (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
  Response -> IO ProxyResponse
fromWaiResponse 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 ::
  Vault ->
  PortNumber ->
  HalRequest.ProxyRequest a ->
  IO Wai.Request
toWaiRequest :: Vault -> PortNumber -> ProxyRequest a -> IO Request
toWaiRequest Vault
vault PortNumber
port ProxyRequest a
req = do
  let pathSegments :: [Text]
pathSegments = 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 = 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
          { addrFlags :: [AddrInfoFlag]
NS.addrFlags = [AddrInfoFlag
NS.AI_NUMERICHOST],
            addrFamily :: Family
NS.addrFamily = Family
NS.AF_INET,
            addrSocketType :: SocketType
NS.addrSocketType = SocketType
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
  Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> Text
forall a. ProxyRequest a -> Text
HalRequest.path ProxyRequest a
req
  [Text] -> IO ()
forall a. Show a => a -> IO ()
print [Text]
pathSegments
  AddrInfo
sourceAddr : [AddrInfo]
_ <- 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 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 =
        Request :: ByteString
-> HttpVersion
-> ByteString
-> ByteString
-> RequestHeaders
-> Bool
-> SockAddr
-> [Text]
-> Query
-> IO ByteString
-> Vault
-> RequestBodyLength
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Request
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 Query
query,
            rawQueryString :: ByteString
Wai.rawQueryString = case Query
query of
              [] -> ByteString
""
              Query
_ -> Bool -> Query -> ByteString
renderQuery Bool
True Query
query,
            requestHeaders :: RequestHeaders
Wai.requestHeaders =
              ((CI Text, [Text]) -> RequestHeaders)
-> [(CI Text, [Text])] -> RequestHeaders
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                ( \(CI Text
hName, [Text]
hValues) ->
                    ((Text -> ByteString) -> CI Text -> CI ByteString
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map Text -> ByteString
T.encodeUtf8 CI Text
hName,) (ByteString -> (CI ByteString, ByteString))
-> (Text -> ByteString) -> Text -> (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> (CI ByteString, ByteString)) -> [Text] -> RequestHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
hValues
                )
                ([(CI Text, [Text])] -> RequestHeaders)
-> (HashMap (CI Text) [Text] -> [(CI Text, [Text])])
-> HashMap (CI Text) [Text]
-> RequestHeaders
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] -> RequestHeaders)
-> HashMap (CI Text) [Text] -> RequestHeaders
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 = AddrInfo -> SockAddr
NS.addrAddress AddrInfo
sourceAddr,
            pathInfo :: [Text]
Wai.pathInfo = [Text]
pathSegments,
            queryString :: Query
Wai.queryString = Query
query,
            requestBody :: IO ByteString
Wai.requestBody = IO ByteString
body,
            vault :: Vault
Wai.vault = Vault
vault,
            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 = CI ByteString -> ProxyRequest a -> Maybe ByteString
forall a. CI ByteString -> ProxyRequest a -> Maybe ByteString
getHeader CI ByteString
hHost ProxyRequest a
req,
            requestHeaderRange :: Maybe ByteString
Wai.requestHeaderRange = CI ByteString -> ProxyRequest a -> Maybe ByteString
forall a. CI ByteString -> ProxyRequest a -> Maybe ByteString
getHeader CI ByteString
hRange ProxyRequest a
req,
            requestHeaderReferer :: Maybe ByteString
Wai.requestHeaderReferer = CI ByteString -> ProxyRequest a -> Maybe ByteString
forall a. CI ByteString -> ProxyRequest a -> Maybe ByteString
getHeader CI ByteString
hReferer ProxyRequest a
req,
            requestHeaderUserAgent :: Maybe ByteString
Wai.requestHeaderUserAgent = CI ByteString -> ProxyRequest a -> Maybe ByteString
forall a. CI ByteString -> ProxyRequest a -> Maybe ByteString
getHeader CI ByteString
hUserAgent ProxyRequest a
req
          }
  Request -> IO ()
forall a. Show a => a -> IO ()
print Request
waiReq
  Request -> IO Request
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 (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 (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 :: CI ByteString -> ProxyRequest a -> Maybe ByteString
getHeader CI ByteString
h =
  (Text -> ByteString) -> Maybe Text -> Maybe ByteString
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) -> CI ByteString -> CI Text
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map ByteString -> Text
T.decodeUtf8 CI ByteString
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 :: Wai.Response -> IO HalResponse.ProxyResponse
fromWaiResponse :: Response -> IO ProxyResponse
fromWaiResponse (Wai.ResponseFile Status
status RequestHeaders
headers String
path Maybe FilePart
mFilePart) = do
  ByteString
fileData <- String -> Maybe FilePart -> IO ByteString
readFilePart String
path Maybe FilePart
mFilePart
  ProxyResponse -> IO ProxyResponse
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
. RequestHeaders -> ProxyResponse -> ProxyResponse
addHeaders RequestHeaders
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
. Text -> ByteString -> ProxyBody
createProxyBody (RequestHeaders -> Text
getContentType RequestHeaders
headers)
    (ByteString -> IO ProxyResponse) -> ByteString -> IO ProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString
fileData
fromWaiResponse (Wai.ResponseBuilder Status
status RequestHeaders
headers Builder
builder) =
  ProxyResponse -> IO ProxyResponse
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
. RequestHeaders -> ProxyResponse -> ProxyResponse
addHeaders RequestHeaders
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
. Text -> ByteString -> ProxyBody
createProxyBody (RequestHeaders -> Text
getContentType RequestHeaders
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 (Wai.ResponseStream Status
status RequestHeaders
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
  Response -> IO ProxyResponse
fromWaiResponse (Status -> RequestHeaders -> Builder -> Response
Wai.ResponseBuilder Status
status RequestHeaders
headers Builder
builder)
fromWaiResponse (Wai.ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
_ Response
resp) = Response -> IO ProxyResponse
fromWaiResponse 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 :: Text -> ByteString -> HalResponse.ProxyBody
createProxyBody :: Text -> ByteString -> ProxyBody
createProxyBody Text
contentType ByteString
body
  | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
contentType) [Text
"text/plain", Text
"application/json"] =
    Text -> Text -> Bool -> ProxyBody
HalResponse.ProxyBody Text
contentType (ByteString -> Text
T.decodeUtf8 ByteString
body) Bool
False
  | Bool
otherwise =
    Text -> Text -> Bool -> ProxyBody
HalResponse.ProxyBody Text
contentType (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
body) Bool
True

addHeaders ::
  ResponseHeaders -> HalResponse.ProxyResponse -> HalResponse.ProxyResponse
addHeaders :: RequestHeaders -> ProxyResponse -> ProxyResponse
addHeaders RequestHeaders
headers ProxyResponse
response = (ProxyResponse -> (CI ByteString, ByteString) -> ProxyResponse)
-> ProxyResponse -> RequestHeaders -> ProxyResponse
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ProxyResponse -> (CI ByteString, ByteString) -> ProxyResponse
addHeader ProxyResponse
response RequestHeaders
headers
  where
    addHeader :: ProxyResponse -> (CI ByteString, ByteString) -> ProxyResponse
addHeader ProxyResponse
r (CI ByteString
hName, ByteString
hValue) =
      Text -> Text -> ProxyResponse -> ProxyResponse
HalResponse.addHeader
        (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
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 -> Text
getContentType :: RequestHeaders -> Text
getContentType =
  Text -> (ByteString -> Text) -> Maybe ByteString -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"application/octet-stream" ByteString -> Text
T.decodeUtf8 (Maybe ByteString -> Text)
-> (RequestHeaders -> Maybe ByteString) -> RequestHeaders -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hContentType