{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Aws.Lambda.Wai
  ( runWaiAsLambda,
    runWaiAsProxiedHttpLambda,
    WaiLambdaProxyType (..),
    apiGatewayWaiHandler,
    ApiGatewayWaiHandler,
    albWaiHandler,
    ALBWaiHandler,
    ignoreALBPathPart,
    ignoreNothing,
  )
where

import Aws.Lambda
import Control.Concurrent.MVar
import Data.Aeson
import Data.Aeson.Types
import Data.Bifunctor (Bifunctor (bimap))
import qualified Data.Binary.Builder as Binary
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HMap
import Data.IORef
import qualified Data.IP as IP
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import qualified Data.Text.Encoding as T
import qualified Data.Vault.Lazy as Vault
import qualified Network.HTTP.Types as H
import qualified Network.Socket as Socket
import Network.Wai (Application)
import qualified Network.Wai as Wai
import qualified Network.Wai.Internal as Wai
import qualified System.IO as IO
import Text.Read (readMaybe)

type ApiGatewayWaiHandler = ApiGatewayRequest Text -> Context Application -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))

type ALBWaiHandler = ALBRequest Text -> Context Application -> IO (Either (ALBResponse Text) (ALBResponse Text))

newtype ALBIgnoredPathPortion = ALBIgnoredPathPortion {ALBIgnoredPathPortion -> Text
unALBIgnoredPathPortion :: Text}

data WaiLambdaProxyType
  = APIGateway
  | ALB (Maybe ALBIgnoredPathPortion)

runWaiAsProxiedHttpLambda ::
  DispatcherOptions ->
  Maybe ALBIgnoredPathPortion ->
  HandlerName ->
  IO Application ->
  IO ()
runWaiAsProxiedHttpLambda :: DispatcherOptions
-> Maybe ALBIgnoredPathPortion
-> HandlerName
-> IO Application
-> IO ()
runWaiAsProxiedHttpLambda DispatcherOptions
options Maybe ALBIgnoredPathPortion
ignoredAlbPath HandlerName
handlerName IO Application
mkApp =
  DispatcherOptions
-> IO Application
-> (forall a. IO a -> IO a)
-> HandlersM
     'StandaloneHandlerType IO Application Value Value Value ()
-> IO ()
forall (handlerType :: HandlerType) (m :: * -> *) context request
       response error.
RuntimeContext handlerType m context request response error =>
DispatcherOptions
-> IO context
-> (forall a. m a -> IO a)
-> HandlersM handlerType m context request response error ()
-> IO ()
runLambdaHaskellRuntime DispatcherOptions
options IO Application
mkApp forall a. a -> a
forall a. IO a -> IO a
id (HandlersM
   'StandaloneHandlerType IO Application Value Value Value ()
 -> IO ())
-> HandlersM
     'StandaloneHandlerType IO Application Value Value Value ()
-> IO ()
forall a b. (a -> b) -> a -> b
$
    HandlerName
-> StandaloneCallback IO Application Value Value Value
-> HandlersM
     'StandaloneHandlerType IO Application Value Value Value ()
forall (m :: * -> *) context request response error.
HandlerName
-> StandaloneCallback m context request response error
-> HandlersM
     'StandaloneHandlerType m context request response error ()
addStandaloneLambdaHandler HandlerName
handlerName (StandaloneCallback IO Application Value Value Value
 -> HandlersM
      'StandaloneHandlerType IO Application Value Value Value ())
-> StandaloneCallback IO Application Value Value Value
-> HandlersM
     'StandaloneHandlerType IO Application Value Value Value ()
forall a b. (a -> b) -> a -> b
$ \(Value
request :: Value) Context Application
context ->
      case (Value -> Parser Bool) -> Value -> Result Bool
forall a b. (a -> Parser b) -> a -> Result b
parse Value -> Parser Bool
parseIsAlb Value
request of
        Success Bool
isAlb -> do
          if Bool
isAlb
            then case Value -> Result (ALBRequest Text)
forall a. FromJSON a => Value -> Result a
fromJSON @(ALBRequest Text) Value
request of
              Success ALBRequest Text
albRequest ->
                (ALBResponse Text -> Value)
-> (ALBResponse Text -> Value)
-> Either (ALBResponse Text) (ALBResponse Text)
-> Either Value Value
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ALBResponse Text -> Value
forall a. ToJSON a => a -> Value
toJSON ALBResponse Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Either (ALBResponse Text) (ALBResponse Text)
 -> Either Value Value)
-> IO (Either (ALBResponse Text) (ALBResponse Text))
-> IO (Either Value Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ALBIgnoredPathPortion -> ALBWaiHandler
albWaiHandler Maybe ALBIgnoredPathPortion
ignoredAlbPath ALBRequest Text
albRequest Context Application
context
              Error String
err -> String -> IO (Either Value Value)
forall a. HasCallStack => String -> a
error (String -> IO (Either Value Value))
-> String -> IO (Either Value Value)
forall a b. (a -> b) -> a -> b
$ String
"Could not parse the request as a valid ALB request: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
            else case Value -> Result (ApiGatewayRequest Text)
forall a. FromJSON a => Value -> Result a
fromJSON @(ApiGatewayRequest Text) Value
request of
              Success ApiGatewayRequest Text
apiGwRequest ->
                (ApiGatewayResponse Text -> Value)
-> (ApiGatewayResponse Text -> Value)
-> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
-> Either Value Value
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ApiGatewayResponse Text -> Value
forall a. ToJSON a => a -> Value
toJSON ApiGatewayResponse Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
 -> Either Value Value)
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
-> IO (Either Value Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApiGatewayWaiHandler
apiGatewayWaiHandler ApiGatewayRequest Text
apiGwRequest Context Application
context
              Error String
err -> String -> IO (Either Value Value)
forall a. HasCallStack => String -> a
error (String -> IO (Either Value Value))
-> String -> IO (Either Value Value)
forall a b. (a -> b) -> a -> b
$ String
"Could not parse the request as a valid API Gateway request: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
        Error String
err ->
          String -> IO (Either Value Value)
forall a. HasCallStack => String -> a
error (String -> IO (Either Value Value))
-> String -> IO (Either Value Value)
forall a b. (a -> b) -> a -> b
$
            String
"Could not parse the request as a valid API Gateway or ALB proxy request: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
  where
    parseIsAlb :: Value -> Parser Bool
    parseIsAlb :: Value -> Parser Bool
parseIsAlb = String -> (Object -> Parser Bool) -> Value -> Parser Bool
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Request" ((Object -> Parser Bool) -> Value -> Parser Bool)
-> (Object -> Parser Bool) -> Value -> Parser Bool
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      Maybe Object
requestContextMay <- Object
obj Object -> Text -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"requestContext"
      case Maybe Object
requestContextMay of
        Just Object
requestContext -> do
          Maybe Value
elb <- Object
requestContext Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"elb"
          case Maybe Value
elb of
            Just (Value
_ :: Value) -> Bool -> Parser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            Maybe Value
Nothing -> Bool -> Parser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Maybe Object
Nothing -> Bool -> Parser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

runWaiAsLambda ::
  WaiLambdaProxyType ->
  DispatcherOptions ->
  HandlerName ->
  IO Application ->
  IO ()
runWaiAsLambda :: WaiLambdaProxyType
-> DispatcherOptions -> HandlerName -> IO Application -> IO ()
runWaiAsLambda WaiLambdaProxyType
proxyType DispatcherOptions
options HandlerName
handlerName IO Application
mkApp = do
  case WaiLambdaProxyType
proxyType of
    WaiLambdaProxyType
APIGateway -> do
      Text -> IO ()
forall a. Show a => a -> IO ()
IO.print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Starting Lambda using API gateway handler '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HandlerName -> Text
unHandlerName HandlerName
handlerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'."
      DispatcherOptions
-> IO Application
-> (forall a. IO a -> IO a)
-> HandlersM
     'APIGatewayHandlerType IO Application Text Text Text ()
-> IO ()
forall (handlerType :: HandlerType) (m :: * -> *) context request
       response error.
RuntimeContext handlerType m context request response error =>
DispatcherOptions
-> IO context
-> (forall a. m a -> IO a)
-> HandlersM handlerType m context request response error ()
-> IO ()
runLambdaHaskellRuntime DispatcherOptions
options IO Application
mkApp forall a. a -> a
forall a. IO a -> IO a
id (HandlersM 'APIGatewayHandlerType IO Application Text Text Text ()
 -> IO ())
-> HandlersM
     'APIGatewayHandlerType IO Application Text Text Text ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
        HandlerName
-> ApiGatewayWaiHandler
-> HandlersM
     'APIGatewayHandlerType IO Application Text Text Text ()
forall (m :: * -> *) context request response error.
HandlerName
-> APIGatewayCallback m context request response error
-> HandlersM
     'APIGatewayHandlerType m context request response error ()
addAPIGatewayHandler HandlerName
handlerName ApiGatewayWaiHandler
apiGatewayWaiHandler
    (ALB Maybe ALBIgnoredPathPortion
ignoredPath) -> do
      Text -> IO ()
forall a. Show a => a -> IO ()
IO.print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Starting Lambda using ALB handler '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HandlerName -> Text
unHandlerName HandlerName
handlerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'."
      DispatcherOptions
-> IO Application
-> (forall a. IO a -> IO a)
-> HandlersM 'ALBHandlerType IO Application Text Text Text ()
-> IO ()
forall (handlerType :: HandlerType) (m :: * -> *) context request
       response error.
RuntimeContext handlerType m context request response error =>
DispatcherOptions
-> IO context
-> (forall a. m a -> IO a)
-> HandlersM handlerType m context request response error ()
-> IO ()
runLambdaHaskellRuntime DispatcherOptions
options IO Application
mkApp forall a. a -> a
forall a. IO a -> IO a
id (HandlersM 'ALBHandlerType IO Application Text Text Text ()
 -> IO ())
-> HandlersM 'ALBHandlerType IO Application Text Text Text ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ do
        HandlerName
-> ALBWaiHandler
-> HandlersM 'ALBHandlerType IO Application Text Text Text ()
forall (m :: * -> *) context request response error.
HandlerName
-> ALBCallback m context request response error
-> HandlersM 'ALBHandlerType m context request response error ()
addALBHandler HandlerName
handlerName (Maybe ALBIgnoredPathPortion -> ALBWaiHandler
albWaiHandler Maybe ALBIgnoredPathPortion
ignoredPath)

ignoreALBPathPart :: Text -> Maybe ALBIgnoredPathPortion
ignoreALBPathPart :: Text -> Maybe ALBIgnoredPathPortion
ignoreALBPathPart = ALBIgnoredPathPortion -> Maybe ALBIgnoredPathPortion
forall a. a -> Maybe a
Just (ALBIgnoredPathPortion -> Maybe ALBIgnoredPathPortion)
-> (Text -> ALBIgnoredPathPortion)
-> Text
-> Maybe ALBIgnoredPathPortion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ALBIgnoredPathPortion
ALBIgnoredPathPortion

ignoreNothing :: Maybe ALBIgnoredPathPortion
ignoreNothing :: Maybe ALBIgnoredPathPortion
ignoreNothing = Maybe ALBIgnoredPathPortion
forall a. Maybe a
Nothing

albWaiHandler :: Maybe ALBIgnoredPathPortion -> ALBWaiHandler
albWaiHandler :: Maybe ALBIgnoredPathPortion -> ALBWaiHandler
albWaiHandler Maybe ALBIgnoredPathPortion
ignoredPathPortion ALBRequest Text
request Context Application
context = do
  Application
waiApplication <- IORef Application -> IO Application
forall a. IORef a -> IO a
readIORef (Context Application -> IORef Application
forall context. Context context -> IORef context
customContext Context Application
context)
  Request
waiRequest <- Maybe ALBIgnoredPathPortion -> ALBRequest Text -> IO Request
mkWaiRequestFromALB Maybe ALBIgnoredPathPortion
ignoredPathPortion ALBRequest Text
request

  (Status
status, ResponseHeaders
headers, ByteString
body) <- Application -> Request -> IO Response
processRequest Application
waiApplication Request
waiRequest IO Response
-> (Response -> IO (Status, ResponseHeaders, ByteString))
-> IO (Status, ResponseHeaders, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO (Status, ResponseHeaders, ByteString)
readResponse

  if ByteString -> Bool
BS.null ByteString
body
    then Either (ALBResponse Text) (ALBResponse Text)
-> IO (Either (ALBResponse Text) (ALBResponse Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ALBResponse Text) (ALBResponse Text)
 -> IO (Either (ALBResponse Text) (ALBResponse Text)))
-> (Text -> Either (ALBResponse Text) (ALBResponse Text))
-> Text
-> IO (Either (ALBResponse Text) (ALBResponse Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALBResponse Text -> Either (ALBResponse Text) (ALBResponse Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ALBResponse Text -> Either (ALBResponse Text) (ALBResponse Text))
-> (Text -> ALBResponse Text)
-> Text
-> Either (ALBResponse Text) (ALBResponse Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ResponseHeaders -> Text -> ALBResponse Text
forall payload.
Int -> ResponseHeaders -> payload -> ALBResponse payload
mkALBResponse (Status -> Int
H.statusCode Status
status) ResponseHeaders
headers (Text -> IO (Either (ALBResponse Text) (ALBResponse Text)))
-> Text -> IO (Either (ALBResponse Text) (ALBResponse Text))
forall a b. (a -> b) -> a -> b
$ Text
forall a. Monoid a => a
mempty
    else case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
body of
      Right Text
responseBodyText ->
        Either (ALBResponse Text) (ALBResponse Text)
-> IO (Either (ALBResponse Text) (ALBResponse Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ALBResponse Text) (ALBResponse Text)
 -> IO (Either (ALBResponse Text) (ALBResponse Text)))
-> (Text -> Either (ALBResponse Text) (ALBResponse Text))
-> Text
-> IO (Either (ALBResponse Text) (ALBResponse Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALBResponse Text -> Either (ALBResponse Text) (ALBResponse Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ALBResponse Text -> Either (ALBResponse Text) (ALBResponse Text))
-> (Text -> ALBResponse Text)
-> Text
-> Either (ALBResponse Text) (ALBResponse Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ResponseHeaders -> Text -> ALBResponse Text
forall payload.
Int -> ResponseHeaders -> payload -> ALBResponse payload
mkALBResponse (Status -> Int
H.statusCode Status
status) ResponseHeaders
headers (Text -> IO (Either (ALBResponse Text) (ALBResponse Text)))
-> Text -> IO (Either (ALBResponse Text) (ALBResponse Text))
forall a b. (a -> b) -> a -> b
$ Text
responseBodyText
      Left UnicodeException
err -> String -> IO (Either (ALBResponse Text) (ALBResponse Text))
forall a. HasCallStack => String -> a
error (String -> IO (Either (ALBResponse Text) (ALBResponse Text)))
-> String -> IO (Either (ALBResponse Text) (ALBResponse Text))
forall a b. (a -> b) -> a -> b
$ String
"Expected a response body that is valid UTF-8: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err

apiGatewayWaiHandler :: ApiGatewayWaiHandler
apiGatewayWaiHandler :: ApiGatewayWaiHandler
apiGatewayWaiHandler ApiGatewayRequest Text
request Context Application
context = do
  Application
waiApplication <- IORef Application -> IO Application
forall a. IORef a -> IO a
readIORef (Context Application -> IORef Application
forall context. Context context -> IORef context
customContext Context Application
context)
  Request
waiRequest <- ApiGatewayRequest Text -> IO Request
mkWaiRequestFromApiGw ApiGatewayRequest Text
request

  (Status
status, ResponseHeaders
headers, ByteString
body) <- Application -> Request -> IO Response
processRequest Application
waiApplication Request
waiRequest IO Response
-> (Response -> IO (Status, ResponseHeaders, ByteString))
-> IO (Status, ResponseHeaders, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO (Status, ResponseHeaders, ByteString)
readResponse

  if ByteString -> Bool
BS.null ByteString
body
    then Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
 -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)))
-> (Text
    -> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
-> Text
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiGatewayResponse Text
-> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApiGatewayResponse Text
 -> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
-> (Text -> ApiGatewayResponse Text)
-> Text
-> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ResponseHeaders -> Text -> ApiGatewayResponse Text
forall payload.
Int -> ResponseHeaders -> payload -> ApiGatewayResponse payload
mkApiGatewayResponse (Status -> Int
H.statusCode Status
status) ResponseHeaders
headers (Text
 -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)))
-> Text
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall a b. (a -> b) -> a -> b
$ Text
forall a. Monoid a => a
mempty
    else case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
body of
      Right Text
responseBodyText ->
        Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
 -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)))
-> (Text
    -> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
-> Text
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiGatewayResponse Text
-> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApiGatewayResponse Text
 -> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
-> (Text -> ApiGatewayResponse Text)
-> Text
-> Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ResponseHeaders -> Text -> ApiGatewayResponse Text
forall payload.
Int -> ResponseHeaders -> payload -> ApiGatewayResponse payload
mkApiGatewayResponse (Status -> Int
H.statusCode Status
status) ResponseHeaders
headers (Text
 -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)))
-> Text
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall a b. (a -> b) -> a -> b
$ Text
responseBodyText
      Left UnicodeException
err -> String
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall a. HasCallStack => String -> a
error (String
 -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)))
-> String
-> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))
forall a b. (a -> b) -> a -> b
$ String
"Expected a response body that is valid UTF-8: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err

mkWaiRequestFromALB :: Maybe ALBIgnoredPathPortion -> ALBRequest Text -> IO Wai.Request
mkWaiRequestFromALB :: Maybe ALBIgnoredPathPortion -> ALBRequest Text -> IO Request
mkWaiRequestFromALB ((ALBIgnoredPathPortion -> Text)
-> Maybe ALBIgnoredPathPortion -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ALBIgnoredPathPortion -> Text
unALBIgnoredPathPortion -> Maybe Text
pathPortionToIgnore) ALBRequest {Bool
Maybe Text
Maybe (HashMap Text Text)
Text
ALBRequestContext
$sel:albRequestPath:ALBRequest :: forall body. ALBRequest body -> Text
$sel:albRequestHttpMethod:ALBRequest :: forall body. ALBRequest body -> Text
$sel:albRequestHeaders:ALBRequest :: forall body. ALBRequest body -> Maybe (HashMap Text Text)
$sel:albRequestQueryStringParameters:ALBRequest :: forall body. ALBRequest body -> Maybe (HashMap Text Text)
$sel:albRequestIsBase64Encoded:ALBRequest :: forall body. ALBRequest body -> Bool
$sel:albRequestRequestContext:ALBRequest :: forall body. ALBRequest body -> ALBRequestContext
$sel:albRequestBody:ALBRequest :: forall body. ALBRequest body -> Maybe body
albRequestBody :: Maybe Text
albRequestRequestContext :: ALBRequestContext
albRequestIsBase64Encoded :: Bool
albRequestQueryStringParameters :: Maybe (HashMap Text Text)
albRequestHeaders :: Maybe (HashMap Text Text)
albRequestHttpMethod :: Text
albRequestPath :: Text
..} = do
  let sourceIpMay :: Maybe Text
sourceIpMay = Maybe (HashMap Text Text)
albRequestHeaders Maybe (HashMap Text Text)
-> (HashMap Text Text -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"x-forwarded-for"

  SockAddr
ip <- Maybe Text -> IO SockAddr
parseIp Maybe Text
sourceIpMay

  let requestPath :: Text
requestPath =
        case Maybe Text
pathPortionToIgnore of
          Just Text
toIgnore ->
            let toIgnoreSafe :: Text
toIgnoreSafe = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') Text
toIgnore
                throwPathError :: a
throwPathError =
                  String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
                    String
"Given path piece to ignore '"
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
toIgnoreSafe
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' is longer than the received request path "
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
albRequestPath
                      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"!"
             in Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
forall a. a
throwPathError (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
toIgnoreSafe Text
albRequestPath
          Maybe Text
Nothing -> Text
albRequestPath

  -- TODO: Duplication
  let pathInfo :: [Text]
pathInfo = ByteString -> [Text]
H.decodePathSegments (Text -> ByteString
encodeUtf8 Text
requestPath)

  let requestBodyRaw :: ByteString
requestBodyRaw = ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty Text -> ByteString
T.encodeUtf8 Maybe Text
albRequestBody
  let requestBodyLength :: RequestBodyLength
requestBodyLength = Word64 -> RequestBodyLength
Wai.KnownLength (Word64 -> RequestBodyLength) -> Word64 -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
requestBodyRaw

  MVar ByteString
requestBodyMVar <- ByteString -> IO (MVar ByteString)
forall a. a -> IO (MVar a)
newMVar ByteString
requestBodyRaw

  let requestBody :: IO ByteString
requestBody = MVar ByteString -> IO ByteString
takeRequestBodyChunk MVar ByteString
requestBodyMVar
  let headers :: HashMap Text Text
headers = HashMap Text Text -> Maybe (HashMap Text Text) -> HashMap Text Text
forall a. a -> Maybe a -> a
fromMaybe HashMap Text Text
forall k v. HashMap k v
HMap.empty Maybe (HashMap Text Text)
albRequestHeaders
  let requestHeaderHost :: Maybe ByteString
requestHeaderHost = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"host" HashMap Text Text
headers
  let requestHeaderRange :: Maybe ByteString
requestHeaderRange = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"range" HashMap Text Text
headers
  let requestHeaderReferer :: Maybe ByteString
requestHeaderReferer = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"referer" HashMap Text Text
headers
  let requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"User-Agent" HashMap Text Text
headers

  let queryParameters :: [QueryItem]
queryParameters = Maybe (HashMap Text Text) -> [QueryItem]
toQueryStringParameters Maybe (HashMap Text Text)
albRequestQueryStringParameters
      rawQueryString :: ByteString
rawQueryString = Bool -> [QueryItem] -> ByteString
H.renderQuery Bool
True [QueryItem]
queryParameters
      httpVersion :: HttpVersion
httpVersion = HttpVersion
H.http11 -- ALB converts even HTTP/2 requests to 1.1
  let result :: Request
result =
        ByteString
-> HttpVersion
-> ByteString
-> ByteString
-> ResponseHeaders
-> Bool
-> SockAddr
-> [Text]
-> [QueryItem]
-> IO ByteString
-> Vault
-> RequestBodyLength
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Request
Wai.Request
          (Text -> ByteString
encodeUtf8 Text
albRequestHttpMethod)
          HttpVersion
httpVersion
          (Text -> ByteString
encodeUtf8 Text
requestPath)
          ByteString
rawQueryString
          (((Text, Text) -> Header) -> [(Text, Text)] -> ResponseHeaders
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Header
toHeader ([(Text, Text)] -> ResponseHeaders)
-> [(Text, Text)] -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap Text Text
headers)
          Bool
True -- We assume it's always secure as we're passing through API Gateway
          SockAddr
ip
          [Text]
pathInfo
          [QueryItem]
queryParameters
          IO ByteString
requestBody
          Vault
Vault.empty
          RequestBodyLength
requestBodyLength
          Maybe ByteString
requestHeaderHost
          Maybe ByteString
requestHeaderRange
          Maybe ByteString
requestHeaderReferer
          Maybe ByteString
requestHeaderUserAgent

  Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
result

mkWaiRequestFromApiGw :: ApiGatewayRequest Text -> IO Wai.Request
mkWaiRequestFromApiGw :: ApiGatewayRequest Text -> IO Request
mkWaiRequestFromApiGw ApiGatewayRequest {Bool
Maybe Text
Maybe (HashMap Text Text)
Text
ApiGatewayRequestContext
$sel:apiGatewayRequestResource:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Text
$sel:apiGatewayRequestPath:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Text
$sel:apiGatewayRequestHttpMethod:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Text
$sel:apiGatewayRequestHeaders:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Maybe (HashMap Text Text)
$sel:apiGatewayRequestQueryStringParameters:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Maybe (HashMap Text Text)
$sel:apiGatewayRequestPathParameters:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Maybe (HashMap Text Text)
$sel:apiGatewayRequestStageVariables:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Maybe (HashMap Text Text)
$sel:apiGatewayRequestIsBase64Encoded:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Bool
$sel:apiGatewayRequestRequestContext:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> ApiGatewayRequestContext
$sel:apiGatewayRequestBody:ApiGatewayRequest :: forall body. ApiGatewayRequest body -> Maybe body
apiGatewayRequestBody :: Maybe Text
apiGatewayRequestRequestContext :: ApiGatewayRequestContext
apiGatewayRequestIsBase64Encoded :: Bool
apiGatewayRequestStageVariables :: Maybe (HashMap Text Text)
apiGatewayRequestPathParameters :: Maybe (HashMap Text Text)
apiGatewayRequestQueryStringParameters :: Maybe (HashMap Text Text)
apiGatewayRequestHeaders :: Maybe (HashMap Text Text)
apiGatewayRequestHttpMethod :: Text
apiGatewayRequestPath :: Text
apiGatewayRequestResource :: Text
..} = do
  let ApiGatewayRequestContext {Maybe Value
Text
ApiGatewayRequestContextIdentity
$sel:apiGatewayRequestContextResourceId:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextResourcePath:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextHttpMethod:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextExtendedRequestId:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextRequestTime:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextPath:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextAccountId:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextProtocol:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextStage:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextDomainPrefix:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextRequestId:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextDomainName:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextApiId:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Text
$sel:apiGatewayRequestContextIdentity:ApiGatewayRequestContext :: ApiGatewayRequestContext -> ApiGatewayRequestContextIdentity
$sel:apiGatewayRequestContextAuthorizer:ApiGatewayRequestContext :: ApiGatewayRequestContext -> Maybe Value
apiGatewayRequestContextAuthorizer :: Maybe Value
apiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity
apiGatewayRequestContextApiId :: Text
apiGatewayRequestContextDomainName :: Text
apiGatewayRequestContextRequestId :: Text
apiGatewayRequestContextDomainPrefix :: Text
apiGatewayRequestContextStage :: Text
apiGatewayRequestContextProtocol :: Text
apiGatewayRequestContextAccountId :: Text
apiGatewayRequestContextPath :: Text
apiGatewayRequestContextRequestTime :: Text
apiGatewayRequestContextExtendedRequestId :: Text
apiGatewayRequestContextHttpMethod :: Text
apiGatewayRequestContextResourcePath :: Text
apiGatewayRequestContextResourceId :: Text
..} = ApiGatewayRequestContext
apiGatewayRequestRequestContext
      ApiGatewayRequestContextIdentity {Maybe Text
Maybe Value
$sel:apiGatewayRequestContextIdentityCognitoIdentityPoolId:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityAccountId:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityCognitoIdentityId:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityCaller:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentitySourceIp:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityPrincipalOrgId:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityAccesskey:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityCognitoAuthenticationType:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityCognitoAuthenticationProvider:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Value
$sel:apiGatewayRequestContextIdentityUserArn:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityUserAgent:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
$sel:apiGatewayRequestContextIdentityUser:ApiGatewayRequestContextIdentity :: ApiGatewayRequestContextIdentity -> Maybe Text
apiGatewayRequestContextIdentityUser :: Maybe Text
apiGatewayRequestContextIdentityUserAgent :: Maybe Text
apiGatewayRequestContextIdentityUserArn :: Maybe Text
apiGatewayRequestContextIdentityCognitoAuthenticationProvider :: Maybe Value
apiGatewayRequestContextIdentityCognitoAuthenticationType :: Maybe Text
apiGatewayRequestContextIdentityAccesskey :: Maybe Text
apiGatewayRequestContextIdentityPrincipalOrgId :: Maybe Text
apiGatewayRequestContextIdentitySourceIp :: Maybe Text
apiGatewayRequestContextIdentityCaller :: Maybe Text
apiGatewayRequestContextIdentityCognitoIdentityId :: Maybe Text
apiGatewayRequestContextIdentityAccountId :: Maybe Text
apiGatewayRequestContextIdentityCognitoIdentityPoolId :: Maybe Text
..} = ApiGatewayRequestContextIdentity
apiGatewayRequestContextIdentity

  SockAddr
ip <- Maybe Text -> IO SockAddr
parseIp Maybe Text
apiGatewayRequestContextIdentitySourceIp

  let requestPath :: Text
requestPath =
        -- We prefer the proxied path because apiGatewayRequestPath also
        -- includes the resource which we don't need
        case Maybe (HashMap Text Text)
apiGatewayRequestPathParameters of
          Just HashMap Text Text
pathParametersMap ->
            Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe
              Text
apiGatewayRequestPath
              (Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"proxy" HashMap Text Text
pathParametersMap)
          Maybe (HashMap Text Text)
Nothing -> Text
apiGatewayRequestPath

  let pathInfo :: [Text]
pathInfo = ByteString -> [Text]
H.decodePathSegments (Text -> ByteString
encodeUtf8 Text
requestPath)

  let requestBodyRaw :: ByteString
requestBodyRaw = ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty Text -> ByteString
T.encodeUtf8 Maybe Text
apiGatewayRequestBody
  let requestBodyLength :: RequestBodyLength
requestBodyLength = Word64 -> RequestBodyLength
Wai.KnownLength (Word64 -> RequestBodyLength) -> Word64 -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
requestBodyRaw

  MVar ByteString
requestBodyMVar <- ByteString -> IO (MVar ByteString)
forall a. a -> IO (MVar a)
newMVar ByteString
requestBodyRaw

  let requestBody :: IO ByteString
requestBody = MVar ByteString -> IO ByteString
takeRequestBodyChunk MVar ByteString
requestBodyMVar
  let headers :: HashMap Text Text
headers = HashMap Text Text -> Maybe (HashMap Text Text) -> HashMap Text Text
forall a. a -> Maybe a -> a
fromMaybe HashMap Text Text
forall k v. HashMap k v
HMap.empty Maybe (HashMap Text Text)
apiGatewayRequestHeaders
  let requestHeaderHost :: Maybe ByteString
requestHeaderHost = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"host" HashMap Text Text
headers
  let requestHeaderRange :: Maybe ByteString
requestHeaderRange = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"range" HashMap Text Text
headers
  let requestHeaderReferer :: Maybe ByteString
requestHeaderReferer = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"referer" HashMap Text Text
headers
  let requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
"User-Agent" HashMap Text Text
headers

  let queryParameters :: [QueryItem]
queryParameters = Maybe (HashMap Text Text) -> [QueryItem]
toQueryStringParameters Maybe (HashMap Text Text)
apiGatewayRequestQueryStringParameters
      rawQueryString :: ByteString
rawQueryString = Bool -> [QueryItem] -> ByteString
H.renderQuery Bool
True [QueryItem]
queryParameters
      httpVersion :: HttpVersion
httpVersion = Text -> HttpVersion
getHttpVersion Text
apiGatewayRequestContextProtocol

  let result :: Request
result =
        ByteString
-> HttpVersion
-> ByteString
-> ByteString
-> ResponseHeaders
-> Bool
-> SockAddr
-> [Text]
-> [QueryItem]
-> IO ByteString
-> Vault
-> RequestBodyLength
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Request
Wai.Request
          (Text -> ByteString
encodeUtf8 Text
apiGatewayRequestHttpMethod)
          HttpVersion
httpVersion
          (Text -> ByteString
encodeUtf8 Text
requestPath)
          ByteString
rawQueryString
          (((Text, Text) -> Header) -> [(Text, Text)] -> ResponseHeaders
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Header
toHeader ([(Text, Text)] -> ResponseHeaders)
-> [(Text, Text)] -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap Text Text
headers)
          Bool
True -- We assume it's always secure as we're passing through API Gateway
          SockAddr
ip
          [Text]
pathInfo
          [QueryItem]
queryParameters
          IO ByteString
requestBody
          Vault
Vault.empty
          RequestBodyLength
requestBodyLength
          Maybe ByteString
requestHeaderHost
          Maybe ByteString
requestHeaderRange
          Maybe ByteString
requestHeaderReferer
          Maybe ByteString
requestHeaderUserAgent

  Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
result

getHttpVersion :: Text -> H.HttpVersion
getHttpVersion :: Text -> HttpVersion
getHttpVersion Text
protocol
  | Text
"0.9" Text -> Text -> Bool
`T.isSuffixOf` Text
protocol = HttpVersion
H.http09
  | Text
"1.0" Text -> Text -> Bool
`T.isSuffixOf` Text
protocol = HttpVersion
H.http10
  | Text
"1.1" Text -> Text -> Bool
`T.isSuffixOf` Text
protocol = HttpVersion
H.http11
  | Text
"2.0" Text -> Text -> Bool
`T.isSuffixOf` Text
protocol = HttpVersion
H.http20
  | Bool
otherwise = HttpVersion
H.http11

takeRequestBodyChunk :: MVar ByteString -> IO ByteString
takeRequestBodyChunk :: MVar ByteString -> IO ByteString
takeRequestBodyChunk MVar ByteString
requestBodyMVar = do
  Maybe ByteString
result <- MVar ByteString -> IO (Maybe ByteString)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ByteString
requestBodyMVar
  case Maybe ByteString
result of
    Just ByteString
bs -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
    Maybe ByteString
Nothing -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BS.empty

toQueryStringParameters :: Maybe (HMap.HashMap Text Text) -> [H.QueryItem]
toQueryStringParameters :: Maybe (HashMap Text Text) -> [QueryItem]
toQueryStringParameters (Just HashMap Text Text
params) =
  let toQueryItem :: (Text, Text) -> QueryItem
toQueryItem (Text
key, Text
value) = (Text -> ByteString
encodeUtf8 Text
key, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
value)
   in ((Text, Text) -> QueryItem) -> [(Text, Text)] -> [QueryItem]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> QueryItem
toQueryItem ([(Text, Text)] -> [QueryItem]) -> [(Text, Text)] -> [QueryItem]
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap Text Text
params
toQueryStringParameters Maybe (HashMap Text Text)
_ = []

parseIp :: Maybe Text -> IO Socket.SockAddr
parseIp :: Maybe Text -> IO SockAddr
parseIp Maybe Text
sourceIpText =
  case Maybe Text
sourceIpText of
    Just Text
sourceIp ->
      case String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
sourceIp) of
        Just IP
ip ->
          SockAddr -> IO SockAddr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> IO SockAddr) -> SockAddr -> IO SockAddr
forall a b. (a -> b) -> a -> b
$ case IP
ip of
            IP.IPv4 IPv4
ip4 ->
              PortNumber -> HostAddress -> SockAddr
Socket.SockAddrInet
                PortNumber
0 -- default port
                (IPv4 -> HostAddress
IP.toHostAddress IPv4
ip4)
            IP.IPv6 IPv6
ip6 ->
              PortNumber
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
Socket.SockAddrInet6
                PortNumber
0 -- default port
                HostAddress
0 -- flow info
                (IPv6 -> HostAddress6
IP.toHostAddress6 IPv6
ip6)
                HostAddress
0 -- scope id
        Maybe IP
Nothing -> String -> IO SockAddr
forall a. HasCallStack => String -> a
error String
"Could not parse source ip."
    Maybe Text
Nothing -> String -> IO SockAddr
forall a. HasCallStack => String -> a
error String
"Missing source ip."

processRequest :: Application -> Wai.Request -> IO Wai.Response
processRequest :: Application -> Request -> IO Response
processRequest Application
app Request
req = do
  MVar Response
mvar <- IO (MVar Response)
forall a. IO (MVar a)
newEmptyMVar
  ResponseReceived
Wai.ResponseReceived <- Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
    MVar Response -> Response -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Response
mvar Response
resp
    ResponseReceived -> IO ResponseReceived
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
Wai.ResponseReceived
  MVar Response -> IO Response
forall a. MVar a -> IO a
takeMVar MVar Response
mvar

readResponse :: Wai.Response -> IO (H.Status, H.ResponseHeaders, ByteString)
readResponse :: Response -> IO (Status, ResponseHeaders, ByteString)
readResponse (Response
-> (Status, ResponseHeaders,
    (StreamingBody -> IO ByteString) -> IO ByteString)
forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
Wai.responseToStream -> (Status
st, ResponseHeaders
hdrs, (StreamingBody -> IO ByteString) -> IO ByteString
mkBody)) = do
  ByteString
body <- (StreamingBody -> IO ByteString) -> IO ByteString
mkBody StreamingBody -> IO ByteString
drainBody
  (Status, ResponseHeaders, ByteString)
-> IO (Status, ResponseHeaders, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
st, ResponseHeaders
hdrs, ByteString
body)
  where
    drainBody :: Wai.StreamingBody -> IO ByteString
    drainBody :: StreamingBody -> IO ByteString
drainBody StreamingBody
body = do
      IORef Builder
ioRef <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
Binary.empty
      StreamingBody
body
        (\Builder
b -> IORef Builder -> (Builder -> (Builder, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Builder
ioRef (\Builder
b' -> (Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b', ())))
        (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Binary.toLazyByteString (Builder -> ByteString) -> IO Builder -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
ioRef

toHeader :: (Text, Text) -> H.Header
toHeader :: (Text, Text) -> Header
toHeader (Text
name, Text
val) = (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (Text -> ByteString) -> Text -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> CI ByteString) -> Text -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Text
name, Text -> ByteString
encodeUtf8 Text
val)