diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -31,7 +31,7 @@ This doesn't require any particular Lambda environment. By following the instructions in the [build](#build) section the resulting `zip` file uploaded -to AWS Lambda is typically be smaller than 1MB. For basic webapps the request +to AWS Lambda is typically smaller than 1MB. For basic webapps the request handling duration (as reported by AWS) is between 1 and 5 milliseconds. * [**Install**](#install) with either Cabal, stack or Nix. diff --git a/src/Network/Wai/Handler/Lambda.hs b/src/Network/Wai/Handler/Lambda.hs --- a/src/Network/Wai/Handler/Lambda.hs +++ b/src/Network/Wai/Handler/Lambda.hs @@ -1,15 +1,24 @@ +{-# 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.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 @@ -36,12 +45,26 @@ 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 { timeoutValue :: Int + -- ^ How many microseconds before we declare a timeout , handleTimeout :: BS.ByteString -> IO RawResponse + -- ^ How to handle a timeout , handleException :: BS.ByteString -> SomeException -> IO RawResponse + -- ^ How to handle an exception thrown by the 'Application' } -- | Run an 'Application'. @@ -184,115 +207,126 @@ obj .: "responseFile" <*> (obj .: "request" >>= parseRequest) +data ApiGatewayRequestV2 = ApiGatewayRequestV2 + { body :: !(Maybe T.Text) + , headers :: !(HMap.HashMap T.Text T.Text) + , rawQueryString :: !(Maybe T.Text) + , requestContext :: !RequestContext + , cookies :: !(Maybe [T.Text]) + , isBase64Encoded :: !Bool + } + deriving (Show, Generic, Aeson.ToJSON, Aeson.FromJSON, NFData) + +data RequestContext = RequestContext + { accountId :: !T.Text + , apiId :: !T.Text + , domainName :: !T.Text + , http :: Http + , requestId :: !T.Text + } + deriving (Show, Generic, Aeson.ToJSON, Aeson.FromJSON, NFData) + +data Http = Http + { method :: !T.Text + , path :: !T.Text + , protocol :: !T.Text + , sourceIp :: !T.Text + } + deriving (Show, Generic, Aeson.ToJSON, Aeson.FromJSON, 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.Value -> Aeson.Parser (IO Wai.Request) -parseRequest = Aeson.withObject "request" $ \obj -> do - - -- "httpMethod": "GET" - requestMethod <- obj .: "httpMethod" >>= - Aeson.withText "requestMethod" (pure . T.encodeUtf8) - - -- We don't get data about the version, just assume - httpVersion <- pure H.http11 - - -- "queryStringParameters": { - -- "name": "me" - -- }, - -- XXX: default to empty object for the query params as Lambda doesn't set - -- 'queryStringParameters' if there are no query parameters - queryParams <- obj .:? "queryStringParameters" .!= Aeson.Object HMap.empty >>= - Aeson.withObject "queryParams" ( - fmap - (fmap (first T.encodeUtf8) . HMap.toList ) . - traverse (Aeson.withText "queryParam" (pure . T.encodeUtf8)) - ) - - rawQueryString <- pure $ H.renderSimpleQuery True queryParams - - -- "path": "/test/hello", - path <- obj .: "path" >>= - Aeson.withText "path" (pure . T.encodeUtf8) +parseRequest :: Aeson.Object -> Aeson.Parser (IO Wai.Request) +parseRequest obj = do + ApiGatewayRequestV2 + { body + , headers + , rawQueryString + , cookies + , requestContext = RequestContext + { http = Http + { method + , protocol + , path + , sourceIp + } + } + } <- Aeson.parseJSON (Aeson.Object obj) - rawPathInfo <- pure $ path <> rawQueryString + -- We don't get data about the version, just assume + httpVersion <- case CI.mk protocol of + "http/0.9" -> pure H.http09 + "http/1.0" -> pure H.http10 + "http/1.1" -> pure H.http11 + "http/2.0" -> pure H.http20 + _ -> fail $ "Unknown http protocol " <> T.unpack protocol - -- "headers": { - -- "Accept": "text/html,application/xhtml+xml,...", - -- ... - -- "X-Forwarded-Proto": "https" - -- }, - requestHeaders <- obj .: "headers" >>= - Aeson.withObject "headers" ( - fmap - (fmap (first (CI.mk . T.encodeUtf8)) . HMap.toList) . - traverse (Aeson.withText "header" (pure . T.encodeUtf8)) - ) + -- "headers": { + -- "Accept": "text/html,application/xhtml+xml,...", + -- ... + -- "X-Forwarded-Proto": "https" + -- }, + let + cookieHeaders = (\c -> (H.hCookie, T.encodeUtf8 c)) <$> fromMaybe [] cookies + otherHeaders = (\(k,v) -> (CI.mk (T.encodeUtf8 k),T.encodeUtf8 v)) <$> HMap.toList headers + requestHeaders = otherHeaders <> cookieHeaders - isSecure <- pure $ case lookup "X-Forwarded-Proto" requestHeaders of - Just "https" -> True - _ -> False + isSecure <- pure $ case lookup "X-Forwarded-Proto" requestHeaders of + Just "https" -> True + _ -> False + let rawPathInfo = T.encodeUtf8 path + pathInfo <- pure $ H.decodePathSegments rawPathInfo - -- "requestContext": { - -- ... - -- "identity": { - -- ... - -- "sourceIp": "192.168.100.1", - -- }, - -- ... - -- }, - remoteHost <- obj .: "requestContext" >>= - Aeson.withObject "requestContext" (\obj' -> - obj' .: "identity" >>= - Aeson.withObject "identity" (\idt -> do - sourceIp <- case HMap.lookup "sourceIp" idt of - Nothing -> fail "no sourceIp" - Just (Aeson.String x) -> pure $ T.unpack x - Just _ -> fail "bad type for sourceIp" - ip <- case readMaybe sourceIp of - Just ip -> pure ip - Nothing -> fail "cannot parse sourceIp" + remoteHost <- case readMaybe @IP.IP (T.unpack sourceIp) of + Just (IP.IPv4 ip) -> pure $ Socket.SockAddrInet 0 (IP.toHostAddress ip) + Just (IP.IPv6 ip) -> pure $ Socket.SockAddrInet6 0 0 (IP.toHostAddress6 ip) 0 + _ -> fail $ "Could not parse ip address: " <> T.unpack sourceIp - pure $ case ip of - IP.IPv4 ip4 -> - Socket.SockAddrInet - 0 -- default port - (IP.toHostAddress ip4) - IP.IPv6 ip6 -> - Socket.SockAddrInet6 - 0 -- default port - 0 -- flow info - (IP.toHostAddress6 ip6) - 0 -- scope id - ) - ) + let + rawQueryStringBytes = maybe "" T.encodeUtf8 rawQueryString + queryString = H.parseQuery (rawQueryStringBytes) - pathInfo <- pure $ H.decodePathSegments path - queryString <- pure $ H.parseQuery rawQueryString + -- XXX: default to empty body as Lambda doesn't always set one (e.g. GET + -- requests) + let requestBodyRaw = maybe "" T.encodeUtf8 body + requestBodyLength <- pure $ + Wai.KnownLength $ fromIntegral $ BS.length requestBodyRaw - -- XXX: default to empty body as Lambda doesn't always set one (e.g. GET - -- requests) - requestBodyRaw <- obj .:? "body" .!= Aeson.String "" >>= - Aeson.withText "body" (pure . T.encodeUtf8) - requestBodyLength <- pure $ - Wai.KnownLength $ fromIntegral $ BS.length requestBodyRaw + vault <- pure $ Vault.insert originalRequestKey obj Vault.empty - vault <- pure $ Vault.insert originalRequestKey obj Vault.empty + requestHeaderHost <- pure $ lookup "host" requestHeaders + requestHeaderRange <- pure $ lookup "range" requestHeaders + requestHeaderReferer <- pure $ lookup "referer" requestHeaders + requestHeaderUserAgent <- pure $ lookup "User-Agent" requestHeaders - requestHeaderHost <- pure $ lookup "host" requestHeaders - requestHeaderRange <- pure $ lookup "range" requestHeaders - requestHeaderReferer <- pure $ lookup "referer" requestHeaders - requestHeaderUserAgent <- pure $ lookup "User-Agent" requestHeaders + pure $ do + requestBodyMVar <- newMVar requestBodyRaw + let requestBody = do + tryTakeMVar requestBodyMVar >>= \case + Just bs -> pure bs + Nothing -> pure BS.empty - pure $ do - requestBodyMVar <- newMVar requestBodyRaw - let requestBody = do - tryTakeMVar requestBodyMVar >>= \case - Just bs -> pure bs - Nothing -> pure BS.empty - pure $ Wai.Request {..} + pure $ Wai.Request + { requestMethod = T.encodeUtf8 method + , httpVersion + , rawPathInfo + , rawQueryString = rawQueryStringBytes + , queryString + , requestBodyLength + , requestHeaderHost + , requestHeaderUserAgent + , requestHeaderRange + , requestHeaderReferer + , requestHeaders + , isSecure + , remoteHost + , pathInfo + , requestBody + , vault + } originalRequestKey :: Vault.Key Aeson.Object originalRequestKey = unsafePerformIO Vault.newKey @@ -315,12 +349,18 @@ -- | 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 st hdrs body = HMap.fromList - [ ("statusCode", Aeson.Number (fromIntegral (H.statusCode st))) - , ("headers", Aeson.toJSON $ HMap.fromList $ - (bimap T.decodeUtf8 T.decodeUtf8 . first CI.original) <$> hdrs) - , ("body", Aeson.String (T.decodeUtf8 body)) - ] +toJSONResponse st hdrs body = + let + (setCookieHeaders, otherHeaders) = partition (\(k,_) -> k == "set-cookie") hdrs + Aeson.Object obj = + Aeson.object + [ ("statusCode", Aeson.Number (fromIntegral (H.statusCode st))) + , ("headers", Aeson.toJSON $ HMap.fromList $ + (bimap T.decodeUtf8 T.decodeUtf8 . first CI.original) <$> otherHeaders) + , ("cookies", Aeson.toJSON (T.decodeUtf8 . snd <$> setCookieHeaders)) + , ("body", Aeson.String (T.decodeUtf8 body)) + ] + in obj ------------------------------------------------------------------------------- -- Auxiliary diff --git a/wai-lambda.cabal b/wai-lambda.cabal --- a/wai-lambda.cabal +++ b/wai-lambda.cabal @@ -1,13 +1,11 @@ -cabal-version: >= 1.10 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.29.7. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack --- --- hash: bdba09ec63c6108d8b0ae25f59ab61765a732917d3c89f71307185aad1462185 name: wai-lambda -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Haskell Webapps on AWS Lambda description: . ![wai-lambda](https://github.com/deckgo/wai-lambda/raw/master/assets/wai-lambda-small.png) @@ -46,6 +44,7 @@ , binary , bytestring , case-insensitive + , deepseq , directory , http-types , iproute @@ -69,6 +68,7 @@ , binary , bytestring , case-insensitive + , deepseq , directory , http-types , iproute