{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Network.Wai.Handler.Lambda where

import Control.Concurrent (forkIO)
import Control.DeepSeq (NFData)
import Control.Monad
import Data.Aeson ((.:))
import Data.Bifunctor
import Data.Function (fix)
import Data.List (partition)
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import Network.Wai (Application)
import System.Directory (renameFile)
import System.IO.Unsafe
import UnliftIO
import Text.Read (readMaybe)
import qualified Data.Binary.Builder as Binary
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Internal as Aeson
import qualified Data.Aeson.Parser as Aeson
import qualified Data.Aeson.Parser.Internal as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HMap
import qualified Data.IP as IP
import qualified Data.Text as T
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 qualified Network.Wai as Wai
import qualified Network.Wai.Internal as Wai
import qualified System.IO.Temp as Temp

-- | The representation of the response sent back to API Gateway.
type RawResponse = (H.Status, H.ResponseHeaders, BS.ByteString)

-- | The settings for running an 'Application'.
--
-- See also:
--  * 'runSettings'
--
-- For simplicity use the following setters with 'defaultSettings':
--  * 'setTimeoutSeconds'
--  * 'setHandleTimeout'
--  * 'setHandleException'
--
data Settings = Settings
  { Settings -> Int
timeoutValue :: Int
    -- ^ How many microseconds before we declare a timeout
  , Settings -> ByteString -> IO RawResponse
handleTimeout :: BS.ByteString -> IO RawResponse
    -- ^ How to handle a timeout
  , Settings -> ByteString -> SomeException -> IO RawResponse
handleException :: BS.ByteString -> SomeException -> IO RawResponse
    -- ^ How to handle an exception thrown by the 'Application'
  }

-- | Run an 'Application'.
--
-- Continuously reads requests from @stdin@. Each line should be a a JSON
-- document as described in 'decodeInput'.
--
-- All requests will be timed out after 2 seconds. If any exception
-- is thrown while processing the request this will return an @HTTP 500
-- Internal Server Error@.
--
-- If you need more control use 'handleRequest' directly.
run :: Application -> IO ()
run :: Application -> IO ()
run = Settings -> Application -> IO ()
runSettings Settings
defaultSettings

runSettings :: Settings -> Application -> IO ()
runSettings :: Settings -> Application -> IO ()
runSettings Settings
settings Application
app = forall b c. b -> ((b -> c) -> b -> c) -> c
xif ByteString
BS.empty forall a b. (a -> b) -> a -> b
$ \ByteString -> IO ()
loop ByteString
leftover ->
    -- XXX: we don't use getLine because it errors out on EOF; here we deal
    -- with this explicitly
    Handle -> Int -> IO ByteString
BS.hGetSome Handle
stdin Int
4096 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
bs ->
      if ByteString -> Bool
BS.null ByteString
bs
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- EOF was reached
      else case forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> Maybe (Char, ByteString)
BS8.uncons forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.break (forall a. Eq a => a -> a -> Bool
== Char
'\n') (ByteString
leftover forall a. Semigroup a => a -> a -> a
<> ByteString
bs) of
        (ByteString
_tmpLine, Maybe (Char, ByteString)
Nothing) -> ByteString -> IO ()
loop (ByteString
leftover forall a. Semigroup a => a -> a -> a
<> ByteString
bs)
        (ByteString
line, Just (Char
'\n', ByteString
rest)) -> do
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Settings -> Application -> ByteString -> IO ()
handleRequest Settings
settings Application
app ByteString
line
          ByteString -> IO ()
loop ByteString
rest
        -- This happens if 'break' found a newline character but 'uncons'
        -- returned something different
        (ByteString
_tmpLine, Just{}) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$
          String
"wai-lambda: The impossible happened: was expecting newline"

setTimeoutSeconds :: Int -> Settings -> Settings
setTimeoutSeconds :: Int -> Settings -> Settings
setTimeoutSeconds Int
tout Settings
settings = Settings
settings
    { timeoutValue :: Int
timeoutValue = Int
tout forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000 }

setHandleException
  :: (BS.ByteString -> SomeException -> IO RawResponse)
  -> Settings
  -> Settings
setHandleException :: (ByteString -> SomeException -> IO RawResponse)
-> Settings -> Settings
setHandleException ByteString -> SomeException -> IO RawResponse
handler Settings
settings = Settings
settings
    { handleException :: ByteString -> SomeException -> IO RawResponse
handleException = ByteString -> SomeException -> IO RawResponse
handler}

setHandleTimeout
  :: (BS.ByteString -> IO RawResponse)
  -> Settings
  -> Settings
setHandleTimeout :: (ByteString -> IO RawResponse) -> Settings -> Settings
setHandleTimeout ByteString -> IO RawResponse
handler Settings
settings = Settings
settings
    { handleTimeout :: ByteString -> IO RawResponse
handleTimeout = ByteString -> IO RawResponse
handler}

defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = Settings
    { timeoutValue :: Int
timeoutValue = Int
defaultTimeoutValue
    , handleTimeout :: ByteString -> IO RawResponse
handleTimeout = ByteString -> IO RawResponse
defaultHandleTimeout
    , handleException :: ByteString -> SomeException -> IO RawResponse
handleException = ByteString -> SomeException -> IO RawResponse
defaultHandleException
    }

defaultHandleException :: BS.ByteString -> SomeException -> IO RawResponse
defaultHandleException :: ByteString -> SomeException -> IO RawResponse
defaultHandleException ByteString
bs SomeException
e = do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
      String
"Could not process request: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
bs forall a. Semigroup a => a -> a -> a
<>
      String
" error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
e
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
H.status500, [], ByteString
"Internal Server Error")

-- | Default request timeout. 2 seconds.
defaultTimeoutValue :: Int
defaultTimeoutValue :: Int
defaultTimeoutValue = Int
2 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000

defaultHandleTimeout :: BS.ByteString -> IO RawResponse
defaultHandleTimeout :: ByteString -> IO RawResponse
defaultHandleTimeout ByteString
bs = do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Timeout processing request: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
bs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
H.status504, [], ByteString
"Timeout")

-------------------------------------------------------------------------------
-- Request handling
-------------------------------------------------------------------------------

-- | Parse and handle the request.
--
-- * Returns 504 if no response is available after the specified timeout.
-- * Returns 500 if an exception occurs while processing the request.
-- * Throws an exception if the input cannot be parsed.
handleRequest
  :: Settings
  -> Application
  -> BS.ByteString -- ^ The request (see 'decodeInput')
  -> IO ()
handleRequest :: Settings -> Application -> ByteString -> IO ()
handleRequest Settings
settings Application
app ByteString
bs = case ByteString -> Either (JSONPath, String) (String, IO Request)
decodeInput ByteString
bs of
    Left (JSONPath, String)
err -> do
      -- The request couldn't be parsed. There isn't much we can do since we
      -- don't even know where to put the response.
      let msg :: String
msg = [String] -> String
unlines
            [ String
"Cannot decode request " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (JSONPath, String)
err
            , String
"Request was: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
bs
            ]
      String -> IO ()
putStrLn String
msg
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
msg
    Right (String
fp, IO Request
mkReq) -> do
      Request
req <- IO Request
mkReq
      Maybe (Either SomeException Response)
mresp <- forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Settings -> Int
timeoutValue Settings
settings) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ Application -> Request -> IO Response
processRequest Application
app Request
req
      Object
resp <- case Maybe (Either SomeException Response)
mresp of
        Just (Right Response
r) -> do
          (Status
st, ResponseHeaders
hdrs, ByteString
body) <- Response -> IO RawResponse
readResponse Response
r
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Object
toJSONResponse Status
st ResponseHeaders
hdrs ByteString
body
        Just (Left SomeException
e) ->
          forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Status -> ResponseHeaders -> ByteString -> Object
toJSONResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> ByteString -> SomeException -> IO RawResponse
handleException Settings
settings ByteString
bs SomeException
e
        Maybe (Either SomeException Response)
Nothing ->
          forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Status -> ResponseHeaders -> ByteString -> Object
toJSONResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> ByteString -> IO RawResponse
handleTimeout Settings
settings ByteString
bs

      String -> ByteString -> IO ()
writeFileAtomic String
fp forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Aeson.encode forall a b. (a -> b) -> a -> b
$ Object -> Value
Aeson.Object Object
resp

-- | Run the 'Request' through the 'Application'.
--
-- This function is completely dependent on the 'Application. Any exception
-- thrown by the 'Application' will be rethrown here. No timeout is
-- implemented: if the 'Application' never provides a 'Response' then
-- 'processRequest' won't return.
processRequest :: Application -> Wai.Request -> IO Wai.Response
processRequest :: Application -> Request -> IO Response
processRequest Application
app Request
req = do
    MVar Response
mvar <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
    ResponseReceived
Wai.ResponseReceived <- Application
app Request
req forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
      forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar Response
mvar Response
resp
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
Wai.ResponseReceived
    forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar Response
mvar

-------------------------------------------------------------------------------
-- WAI <-> API Gateway
-------------------------------------------------------------------------------

-- | Decode a 'ByteString' into (1) a Wai 'Request' and (2) a filepath where
-- the response should be written.
-- The argument is JSON document with two fields:
--  * @request@: the API Gateway request (see 'parseRequest')
--  * @reqsponseFile@: Where to write the API Gateway response (see
--      'toJSONResponse')
decodeInput :: BS.ByteString -> Either (Aeson.JSONPath, String) (FilePath, IO Wai.Request)
decodeInput :: ByteString -> Either (JSONPath, String) (String, IO Request)
decodeInput = forall a.
Parser Value
-> (Value -> IResult a)
-> ByteString
-> Either (JSONPath, String) a
Aeson.eitherDecodeStrictWith Parser Value
Aeson.jsonEOF forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Parser b) -> a -> IResult b
Aeson.iparse forall a b. (a -> b) -> a -> b
$
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"input" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"responseFile" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        (Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Parser (IO Request)
parseRequest)

data ApiGatewayRequestV2 = ApiGatewayRequestV2
  { ApiGatewayRequestV2 -> Maybe Text
body :: !(Maybe T.Text)
  , ApiGatewayRequestV2 -> HashMap Text Text
headers :: !(HMap.HashMap T.Text T.Text)
  , ApiGatewayRequestV2 -> Maybe Text
rawQueryString :: !(Maybe T.Text)
  , ApiGatewayRequestV2 -> RequestContext
requestContext :: !RequestContext
  , ApiGatewayRequestV2 -> Maybe [Text]
cookies :: !(Maybe [T.Text])
  , ApiGatewayRequestV2 -> Bool
isBase64Encoded :: !Bool
  }
  deriving (Int -> ApiGatewayRequestV2 -> ShowS
[ApiGatewayRequestV2] -> ShowS
ApiGatewayRequestV2 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiGatewayRequestV2] -> ShowS
$cshowList :: [ApiGatewayRequestV2] -> ShowS
show :: ApiGatewayRequestV2 -> String
$cshow :: ApiGatewayRequestV2 -> String
showsPrec :: Int -> ApiGatewayRequestV2 -> ShowS
$cshowsPrec :: Int -> ApiGatewayRequestV2 -> ShowS
Show, forall x. Rep ApiGatewayRequestV2 x -> ApiGatewayRequestV2
forall x. ApiGatewayRequestV2 -> Rep ApiGatewayRequestV2 x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApiGatewayRequestV2 x -> ApiGatewayRequestV2
$cfrom :: forall x. ApiGatewayRequestV2 -> Rep ApiGatewayRequestV2 x
Generic, [ApiGatewayRequestV2] -> Encoding
[ApiGatewayRequestV2] -> Value
ApiGatewayRequestV2 -> Encoding
ApiGatewayRequestV2 -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ApiGatewayRequestV2] -> Encoding
$ctoEncodingList :: [ApiGatewayRequestV2] -> Encoding
toJSONList :: [ApiGatewayRequestV2] -> Value
$ctoJSONList :: [ApiGatewayRequestV2] -> Value
toEncoding :: ApiGatewayRequestV2 -> Encoding
$ctoEncoding :: ApiGatewayRequestV2 -> Encoding
toJSON :: ApiGatewayRequestV2 -> Value
$ctoJSON :: ApiGatewayRequestV2 -> Value
Aeson.ToJSON, Value -> Parser [ApiGatewayRequestV2]
Value -> Parser ApiGatewayRequestV2
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ApiGatewayRequestV2]
$cparseJSONList :: Value -> Parser [ApiGatewayRequestV2]
parseJSON :: Value -> Parser ApiGatewayRequestV2
$cparseJSON :: Value -> Parser ApiGatewayRequestV2
Aeson.FromJSON, ApiGatewayRequestV2 -> ()
forall a. (a -> ()) -> NFData a
rnf :: ApiGatewayRequestV2 -> ()
$crnf :: ApiGatewayRequestV2 -> ()
NFData)

data RequestContext = RequestContext
  { RequestContext -> Text
accountId :: !T.Text
  , RequestContext -> Text
apiId :: !T.Text
  , RequestContext -> Text
domainName :: !T.Text
  , RequestContext -> Http
http :: Http
  , RequestContext -> Text
requestId :: !T.Text
  }
  deriving (Int -> RequestContext -> ShowS
[RequestContext] -> ShowS
RequestContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestContext] -> ShowS
$cshowList :: [RequestContext] -> ShowS
show :: RequestContext -> String
$cshow :: RequestContext -> String
showsPrec :: Int -> RequestContext -> ShowS
$cshowsPrec :: Int -> RequestContext -> ShowS
Show, forall x. Rep RequestContext x -> RequestContext
forall x. RequestContext -> Rep RequestContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RequestContext x -> RequestContext
$cfrom :: forall x. RequestContext -> Rep RequestContext x
Generic, [RequestContext] -> Encoding
[RequestContext] -> Value
RequestContext -> Encoding
RequestContext -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RequestContext] -> Encoding
$ctoEncodingList :: [RequestContext] -> Encoding
toJSONList :: [RequestContext] -> Value
$ctoJSONList :: [RequestContext] -> Value
toEncoding :: RequestContext -> Encoding
$ctoEncoding :: RequestContext -> Encoding
toJSON :: RequestContext -> Value
$ctoJSON :: RequestContext -> Value
Aeson.ToJSON, Value -> Parser [RequestContext]
Value -> Parser RequestContext
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RequestContext]
$cparseJSONList :: Value -> Parser [RequestContext]
parseJSON :: Value -> Parser RequestContext
$cparseJSON :: Value -> Parser RequestContext
Aeson.FromJSON, RequestContext -> ()
forall a. (a -> ()) -> NFData a
rnf :: RequestContext -> ()
$crnf :: RequestContext -> ()
NFData)

data Http = Http
  { Http -> Text
method :: !T.Text
  , Http -> Text
path :: !T.Text
  , Http -> Text
protocol :: !T.Text
  , Http -> Text
sourceIp :: !T.Text
  }
  deriving (Int -> Http -> ShowS
[Http] -> ShowS
Http -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Http] -> ShowS
$cshowList :: [Http] -> ShowS
show :: Http -> String
$cshow :: Http -> String
showsPrec :: Int -> Http -> ShowS
$cshowsPrec :: Int -> Http -> ShowS
Show, forall x. Rep Http x -> Http
forall x. Http -> Rep Http x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Http x -> Http
$cfrom :: forall x. Http -> Rep Http x
Generic, [Http] -> Encoding
[Http] -> Value
Http -> Encoding
Http -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Http] -> Encoding
$ctoEncodingList :: [Http] -> Encoding
toJSONList :: [Http] -> Value
$ctoJSONList :: [Http] -> Value
toEncoding :: Http -> Encoding
$ctoEncoding :: Http -> Encoding
toJSON :: Http -> Value
$ctoJSON :: Http -> Value
Aeson.ToJSON, Value -> Parser [Http]
Value -> Parser Http
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Http]
$cparseJSONList :: Value -> Parser [Http]
parseJSON :: Value -> Parser Http
$cparseJSON :: Value -> Parser Http
Aeson.FromJSON, Http -> ()
forall a. (a -> ()) -> NFData a
rnf :: Http -> ()
$crnf :: Http -> ()
NFData)

-- | Parser for a 'Wai.Request'.
--
-- The input is an AWS API Gateway request event:
-- https://docs.aws.amazon.com/lambda/latest/dg/eventsources.html#eventsources-api-gateway-request
parseRequest :: Aeson.Object -> Aeson.Parser (IO Wai.Request)
parseRequest :: Object -> Parser (IO Request)
parseRequest Object
obj = do
  ApiGatewayRequestV2
    { Maybe Text
body :: Maybe Text
body :: ApiGatewayRequestV2 -> Maybe Text
body
    , HashMap Text Text
headers :: HashMap Text Text
headers :: ApiGatewayRequestV2 -> HashMap Text Text
headers
    , Maybe Text
rawQueryString :: Maybe Text
rawQueryString :: ApiGatewayRequestV2 -> Maybe Text
rawQueryString
    , Maybe [Text]
cookies :: Maybe [Text]
cookies :: ApiGatewayRequestV2 -> Maybe [Text]
cookies
    , requestContext :: ApiGatewayRequestV2 -> RequestContext
requestContext = RequestContext
      { http :: RequestContext -> Http
http = Http
        { Text
method :: Text
method :: Http -> Text
method
        , Text
protocol :: Text
protocol :: Http -> Text
protocol
        , Text
path :: Text
path :: Http -> Text
path
        , Text
sourceIp :: Text
sourceIp :: Http -> Text
sourceIp
        }
      }
    } <- forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON (Object -> Value
Aeson.Object Object
obj)

  -- We don't get data about the version, just assume
  HttpVersion
httpVersion <- case forall s. FoldCase s => s -> CI s
CI.mk Text
protocol of
    CI Text
"http/0.9" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HttpVersion
H.http09
    CI Text
"http/1.0" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HttpVersion
H.http10
    CI Text
"http/1.1" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HttpVersion
H.http11
    CI Text
"http/2.0" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HttpVersion
H.http20
    CI Text
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown http protocol " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
protocol

  --  "headers": {
  --    "Accept": "text/html,application/xhtml+xml,...",
  --    ...
  --    "X-Forwarded-Proto": "https"
  --  },
  let
    cookieHeaders :: ResponseHeaders
cookieHeaders = (\Text
c -> (CI ByteString
H.hCookie, Text -> ByteString
T.encodeUtf8 Text
c)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
cookies
    otherHeaders :: ResponseHeaders
otherHeaders = (\(Text
k,Text
v) -> (forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
T.encodeUtf8 Text
k),Text -> ByteString
T.encodeUtf8 Text
v)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap Text Text
headers
    requestHeaders :: ResponseHeaders
requestHeaders = ResponseHeaders
otherHeaders forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
cookieHeaders

  Bool
isSecure <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"X-Forwarded-Proto" ResponseHeaders
requestHeaders of
    Just ByteString
"https" -> Bool
True
    Maybe ByteString
_ -> Bool
False

  let rawPathInfo :: ByteString
rawPathInfo = Text -> ByteString
T.encodeUtf8 Text
path
  [Text]
pathInfo <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> [Text]
H.decodePathSegments ByteString
rawPathInfo

  SockAddr
remoteHost <- case forall a. Read a => String -> Maybe a
readMaybe @IP.IP (Text -> String
T.unpack Text
sourceIp) of
    Just (IP.IPv4 IPv4
ip) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PortNumber -> FlowInfo -> SockAddr
Socket.SockAddrInet PortNumber
0 (IPv4 -> FlowInfo
IP.toHostAddress IPv4
ip)
    Just (IP.IPv6 IPv6
ip) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PortNumber -> FlowInfo -> HostAddress6 -> FlowInfo -> SockAddr
Socket.SockAddrInet6 PortNumber
0 FlowInfo
0 (IPv6 -> HostAddress6
IP.toHostAddress6 IPv6
ip) FlowInfo
0
    Maybe IP
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not parse ip address: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
sourceIp

  let
    rawQueryStringBytes :: ByteString
rawQueryStringBytes = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Text -> ByteString
T.encodeUtf8 Maybe Text
rawQueryString
    queryString :: Query
queryString = ByteString -> Query
H.parseQuery (ByteString
rawQueryStringBytes)

  -- XXX: default to empty body as Lambda doesn't always set one (e.g. GET
  -- requests)
  let requestBodyRaw :: ByteString
requestBodyRaw = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Text -> ByteString
T.encodeUtf8 Maybe Text
body
  RequestBodyLength
requestBodyLength <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Word64 -> RequestBodyLength
Wai.KnownLength forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
requestBodyRaw

  Vault
vault <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Key a -> a -> Vault -> Vault
Vault.insert Key Object
originalRequestKey Object
obj Vault
Vault.empty

  Maybe ByteString
requestHeaderHost <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"host" ResponseHeaders
requestHeaders
  Maybe ByteString
requestHeaderRange <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"range" ResponseHeaders
requestHeaders
  Maybe ByteString
requestHeaderReferer <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"referer" ResponseHeaders
requestHeaders
  Maybe ByteString
requestHeaderUserAgent <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"User-Agent" ResponseHeaders
requestHeaders

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    MVar ByteString
requestBodyMVar <- forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ByteString
requestBodyRaw
    let requestBody :: IO ByteString
requestBody = do
          forall (m :: * -> *) a. MonadIO m => MVar a -> m (Maybe a)
tryTakeMVar MVar ByteString
requestBodyMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just ByteString
bs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
            Maybe ByteString
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BS.empty

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Wai.Request
        { requestMethod :: ByteString
requestMethod = Text -> ByteString
T.encodeUtf8 Text
method
        , HttpVersion
httpVersion :: HttpVersion
httpVersion :: HttpVersion
httpVersion
        , ByteString
rawPathInfo :: ByteString
rawPathInfo :: ByteString
rawPathInfo
        , rawQueryString :: ByteString
rawQueryString = ByteString
rawQueryStringBytes
        , Query
queryString :: Query
queryString :: Query
queryString
        , RequestBodyLength
requestBodyLength :: RequestBodyLength
requestBodyLength :: RequestBodyLength
requestBodyLength
        , Maybe ByteString
requestHeaderHost :: Maybe ByteString
requestHeaderHost :: Maybe ByteString
requestHeaderHost
        , Maybe ByteString
requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent
        , Maybe ByteString
requestHeaderRange :: Maybe ByteString
requestHeaderRange :: Maybe ByteString
requestHeaderRange
        , Maybe ByteString
requestHeaderReferer :: Maybe ByteString
requestHeaderReferer :: Maybe ByteString
requestHeaderReferer
        , ResponseHeaders
requestHeaders :: ResponseHeaders
requestHeaders :: ResponseHeaders
requestHeaders
        , Bool
isSecure :: Bool
isSecure :: Bool
isSecure
        , SockAddr
remoteHost :: SockAddr
remoteHost :: SockAddr
remoteHost
        , [Text]
pathInfo :: [Text]
pathInfo :: [Text]
pathInfo
        , IO ByteString
requestBody :: IO ByteString
requestBody :: IO ByteString
requestBody
        , Vault
vault :: Vault
vault :: Vault
vault
        }

originalRequestKey :: Vault.Key Aeson.Object
originalRequestKey :: Key Object
originalRequestKey = forall a. IO a -> a
unsafePerformIO forall a. IO (Key a)
Vault.newKey
{-# NOINLINE originalRequestKey #-}

-- | Read the status, headers and body of a 'Wai.Response'.
readResponse :: Wai.Response -> IO RawResponse
readResponse :: Response -> IO RawResponse
readResponse (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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
st, ResponseHeaders
hdrs, ByteString
body)
  where
    drainBody :: Wai.StreamingBody -> IO BS.ByteString
    drainBody :: StreamingBody -> IO ByteString
drainBody StreamingBody
body = do
      IORef Builder
ioref <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Builder
Binary.empty
      StreamingBody
body
        (\Builder
b -> forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef Builder
ioref (\Builder
b' -> (Builder
b forall a. Semigroup a => a -> a -> a
<> Builder
b', ())))
        (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Binary.toLazyByteString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Builder
ioref

-- | Make an API Gateway response from status, headers and body.
-- https://docs.aws.amazon.com/lambda/latest/dg/eventsources.html#eventsources-api-gateway-response
toJSONResponse :: H.Status -> H.ResponseHeaders -> BS.ByteString -> Aeson.Object
toJSONResponse :: Status -> ResponseHeaders -> ByteString -> Object
toJSONResponse Status
st ResponseHeaders
hdrs ByteString
body =
  let
    (ResponseHeaders
setCookieHeaders, ResponseHeaders
otherHeaders) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(CI ByteString
k,ByteString
_) -> CI ByteString
k forall a. Eq a => a -> a -> Bool
== CI ByteString
"set-cookie") ResponseHeaders
hdrs
    Aeson.Object Object
obj =
      [Pair] -> Value
Aeson.object
        [ (Key
"statusCode", Scientific -> Value
Aeson.Number (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Status -> Int
H.statusCode Status
st)))
        , (Key
"headers", forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMap.fromList forall a b. (a -> b) -> a -> b
$
            (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ByteString -> Text
T.decodeUtf8 ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s. CI s -> s
CI.original) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponseHeaders
otherHeaders)
        , (Key
"cookies", forall a. ToJSON a => a -> Value
Aeson.toJSON (ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponseHeaders
setCookieHeaders))
        , (Key
"body", Text -> Value
Aeson.String (ByteString -> Text
T.decodeUtf8 ByteString
body))
        ]
  in Object
obj

-------------------------------------------------------------------------------
-- Auxiliary
-------------------------------------------------------------------------------

-- | Atomically write the 'ByteString' to the file.
--
-- Uses @rename(2)@.
writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
writeFileAtomic :: String -> ByteString -> IO ()
writeFileAtomic String
fp ByteString
bs =
    forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
Temp.withSystemTempFile String
"temp-response" forall a b. (a -> b) -> a -> b
$ \String
tmpFp Handle
h -> do
      forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
      String -> ByteString -> IO ()
BS.writeFile String
tmpFp ByteString
bs
      String -> String -> IO ()
renameFile String
tmpFp String
fp

-- | @flip fix@
xif :: b -> ((b -> c) -> b -> c) -> c
xif :: forall b c. b -> ((b -> c) -> b -> c) -> c
xif = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> a) -> a
fix

{-# INLINE uncurry3 #-}
uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
uncurry3 :: forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f ~(a
a,b
b,c
c) = a -> b -> c -> d
f a
a b
b c
c