aws-lambda-haskell-runtime-wai 1.0.2 → 2.0.0

raw patch · 3 files changed

+257/−102 lines, 3 filesdep ~aws-lambda-haskell-runtimePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aws-lambda-haskell-runtime

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• aws-lambda-haskell-runtime-wai.cabal +5/−4
• src/Aws/Lambda/Wai.hs +243/−98

@@ -1,5 +1,14 @@ # Changelog for aws-lambda-haskell-runtime-wai +## 2.0.0++* Using version [`4.0.0`](https://github.com/theam/aws-lambda-haskell-runtime/pull/97) of `aws-lambda-haskell-runtime`.+* New handler types that allow you to support ALB or even API Gateway + ALB at once.++## 1.0.3++* Now taking the Wai request path from API Gateway's 'proxy' path parameter. This prevents the resource path from messing up your Wai application routing.+ ## 1.0.2  * Switched to aws-lambda-haskell-runtime 3.0.3

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 56197b54e09e2b69cdedd41eb41de7cbdfbc11cdefef8f57e1141ca11652b166+-- hash: 6ca9eaab6b86b712b823d22c59d7e6bf2ab727e70e373b7ad6be7230c7084187  name:           aws-lambda-haskell-runtime-wai-version:        1.0.2+version:        2.0.0 synopsis:       Run wai applications on AWS Lambda description:    Please see the README on GitHub at <https://github.com/eir-forsakring/aws-lambda-haskell-runtime-wai#readme> category:       AWS@@ -34,9 +34,10 @@       Paths_aws_lambda_haskell_runtime_wai   hs-source-dirs:       src+  ghc-options: -Wall   build-depends:       aeson-    , aws-lambda-haskell-runtime >=3.0.0+    , aws-lambda-haskell-runtime >=4.0.0     , base >=4.7 && <5     , binary     , bytestring@@ -60,7 +61,7 @@   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:       aeson-    , aws-lambda-haskell-runtime >=3.0.0+    , aws-lambda-haskell-runtime >=4.0.0     , aws-lambda-haskell-runtime-wai     , base >=4.7 && <5     , binary

@@ -1,101 +1,257 @@-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} -module Aws.Lambda.Wai (waiHandler, waiHandler', WaiHandler) where+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 qualified Data.Aeson              as Aeson-import qualified Data.Aeson.Types        as Aeson-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.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           GHC.IO.Unsafe           (unsafePerformIO)-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           Text.Read               (readMaybe)+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 WaiHandler context = ApiGatewayRequest Text -> Context context -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text))+type ApiGatewayWaiHandler = ApiGatewayRequest Text -> Context Application -> IO (Either (ApiGatewayResponse Text) (ApiGatewayResponse Text)) -waiHandler :: forall context. IO Wai.Application -> WaiHandler context-waiHandler initApp gatewayRequest context = initApp >>=-  \app -> waiHandler'' app gatewayRequest context+type ALBWaiHandler = ALBRequest Text -> Context Application -> IO (Either (ALBResponse Text) (ALBResponse Text)) -waiHandler' :: forall context. (context -> Wai.Application) -> WaiHandler context-waiHandler' getApp request context = do-  app <- getApp <$> readIORef (customContext context)-  waiHandler'' app request context+newtype ALBIgnoredPathPortion = ALBIgnoredPathPortion {unALBIgnoredPathPortion :: Text} -waiHandler'' :: forall context. Wai.Application -> WaiHandler context-waiHandler'' waiApplication gatewayRequest _ = do-  waiRequest <- mkWaiRequest gatewayRequest+data WaiLambdaProxyType+  = APIGateway+  | ALB (Maybe ALBIgnoredPathPortion) +runWaiAsProxiedHttpLambda ::+  DispatcherOptions ->+  Maybe ALBIgnoredPathPortion ->+  HandlerName ->+  IO Application ->+  IO ()+runWaiAsProxiedHttpLambda options ignoredAlbPath handlerName mkApp =+  runLambdaHaskellRuntime options mkApp id $+    addStandaloneLambdaHandler handlerName $ \(request :: Value) context ->+      case parse parseIsAlb request of+        Success isAlb -> do+          if isAlb+            then case fromJSON @(ALBRequest Text) request of+              Success albRequest ->+                bimap toJSON toJSON <$> albWaiHandler ignoredAlbPath albRequest context+              Error err -> error $ "Could not parse the request as a valid ALB request: " <> err+            else case fromJSON @(ApiGatewayRequest Text) request of+              Success apiGwRequest ->+                bimap toJSON toJSON <$> apiGatewayWaiHandler apiGwRequest context+              Error err -> error $ "Could not parse the request as a valid API Gateway request: " <> err+        Error err ->+          error $+            "Could not parse the request as a valid API Gateway or ALB proxy request: " <> err+  where+    parseIsAlb :: Value -> Parser Bool+    parseIsAlb = withObject "Request" $ \obj -> do+      requestContextMay <- obj .:? "requestContext"+      case requestContextMay of+        Just requestContext -> do+          elb <- requestContext .:? "elb"+          case elb of+            Just (_ :: Value) -> pure True+            Nothing -> pure False+        Nothing -> pure False++runWaiAsLambda ::+  WaiLambdaProxyType ->+  DispatcherOptions ->+  HandlerName ->+  IO Application ->+  IO ()+runWaiAsLambda proxyType options handlerName mkApp = do+  case proxyType of+    APIGateway -> do+      IO.print $ "Starting Lambda using API gateway handler '" <> unHandlerName handlerName <> "'."+      runLambdaHaskellRuntime options mkApp id $ do+        addAPIGatewayHandler handlerName apiGatewayWaiHandler+    (ALB ignoredPath) -> do+      IO.print $ "Starting Lambda using ALB handler '" <> unHandlerName handlerName <> "'."+      runLambdaHaskellRuntime options mkApp id $ do+        addALBHandler handlerName (albWaiHandler ignoredPath)++ignoreALBPathPart :: Text -> Maybe ALBIgnoredPathPortion+ignoreALBPathPart = Just . ALBIgnoredPathPortion++ignoreNothing :: Maybe ALBIgnoredPathPortion+ignoreNothing = Nothing++albWaiHandler :: Maybe ALBIgnoredPathPortion -> ALBWaiHandler+albWaiHandler ignoredPathPortion request context = do+  waiApplication <- readIORef (customContext context)+  waiRequest <- mkWaiRequestFromALB ignoredPathPortion request+   (status, headers, body) <- processRequest waiApplication waiRequest >>= readResponse    if BS.null body-  then return . pure . wrapInResponse (H.statusCode status) headers $ mempty-  else case decodeUtf8' body of-    Right responseBodyText ->-        return . pure . wrapInResponse (H.statusCode status) headers $ responseBodyText-    Left err -> error "Expected a response body that is valid UTF-8."+    then return . pure . mkALBResponse (H.statusCode status) headers $ mempty+    else case decodeUtf8' body of+      Right responseBodyText ->+        return . pure . mkALBResponse (H.statusCode status) headers $ responseBodyText+      Left err -> error $ "Expected a response body that is valid UTF-8: " <> show err -mkWaiRequest :: ApiGatewayRequest Text -> IO Wai.Request-mkWaiRequest ApiGatewayRequest{..} = do-  let ApiGatewayRequestContext{..} = apiGatewayRequestRequestContext-      ApiGatewayRequestContextIdentity{..} = apiGatewayRequestContextIdentity+apiGatewayWaiHandler :: ApiGatewayWaiHandler+apiGatewayWaiHandler request context = do+  waiApplication <- readIORef (customContext context)+  waiRequest <- mkWaiRequestFromApiGw request +  (status, headers, body) <- processRequest waiApplication waiRequest >>= readResponse++  if BS.null body+    then return . pure . mkApiGatewayResponse (H.statusCode status) headers $ mempty+    else case decodeUtf8' body of+      Right responseBodyText ->+        return . pure . mkApiGatewayResponse (H.statusCode status) headers $ responseBodyText+      Left err -> error $ "Expected a response body that is valid UTF-8: " <> show err++mkWaiRequestFromALB :: Maybe ALBIgnoredPathPortion -> ALBRequest Text -> IO Wai.Request+mkWaiRequestFromALB (fmap unALBIgnoredPathPortion -> pathPortionToIgnore) ALBRequest {..} = do+  let sourceIpMay = albRequestHeaders >>= HMap.lookup "x-forwarded-for"++  ip <- parseIp sourceIpMay++  let requestPath =+        case pathPortionToIgnore of+          Just toIgnore ->+            let toIgnoreSafe = "/" <> T.dropWhile (\c -> c == '/' || c == '\\') toIgnore+                throwPathError =+                  error $+                    "Given path piece to ignore '"+                      <> T.unpack toIgnoreSafe+                      <> "' is longer than the received request path "+                      <> T.unpack albRequestPath+                      <> "!"+             in fromMaybe throwPathError $ T.stripPrefix toIgnoreSafe albRequestPath+          Nothing -> albRequestPath++  -- TODO: Duplication+  let pathInfo = H.decodePathSegments (encodeUtf8 requestPath)++  let requestBodyRaw = maybe mempty T.encodeUtf8 albRequestBody+  let requestBodyLength = Wai.KnownLength $ fromIntegral $ BS.length requestBodyRaw++  requestBodyMVar <- newMVar requestBodyRaw++  let requestBody = takeRequestBodyChunk requestBodyMVar+  let headers = fromMaybe HMap.empty albRequestHeaders+  let requestHeaderHost = encodeUtf8 <$> HMap.lookup "host" headers+  let requestHeaderRange = encodeUtf8 <$> HMap.lookup "range" headers+  let requestHeaderReferer = encodeUtf8 <$> HMap.lookup "referer" headers+  let requestHeaderUserAgent = encodeUtf8 <$> HMap.lookup "User-Agent" headers++  let queryParameters = toQueryStringParameters albRequestQueryStringParameters+      rawQueryString = H.renderQuery True queryParameters+      httpVersion = H.http11 -- ALB converts even HTTP/2 requests to 1.1+  let result =+        Wai.Request+          (encodeUtf8 albRequestHttpMethod)+          httpVersion+          (encodeUtf8 requestPath)+          rawQueryString+          (map toHeader $ HMap.toList headers)+          True -- We assume it's always secure as we're passing through API Gateway+          ip+          pathInfo+          queryParameters+          requestBody+          Vault.empty+          requestBodyLength+          requestHeaderHost+          requestHeaderRange+          requestHeaderReferer+          requestHeaderUserAgent++  return result++mkWaiRequestFromApiGw :: ApiGatewayRequest Text -> IO Wai.Request+mkWaiRequestFromApiGw ApiGatewayRequest {..} = do+  let ApiGatewayRequestContext {..} = apiGatewayRequestRequestContext+      ApiGatewayRequestContextIdentity {..} = apiGatewayRequestContextIdentity+   ip <- parseIp apiGatewayRequestContextIdentitySourceIp -  let pathInfo = H.decodePathSegments (encodeUtf8 apiGatewayRequestPath)+  let requestPath =+        -- We prefer the proxied path because apiGatewayRequestPath also+        -- includes the resource which we don't need+        case apiGatewayRequestPathParameters of+          Just pathParametersMap ->+            fromMaybe+              apiGatewayRequestPath+              (HMap.lookup "proxy" pathParametersMap)+          Nothing -> apiGatewayRequestPath +  let pathInfo = H.decodePathSegments (encodeUtf8 requestPath)+   let requestBodyRaw = maybe mempty T.encodeUtf8 apiGatewayRequestBody   let requestBodyLength = Wai.KnownLength $ fromIntegral $ BS.length requestBodyRaw    requestBodyMVar <- newMVar requestBodyRaw    let requestBody = takeRequestBodyChunk requestBodyMVar-  let requestHeaderHost = encodeUtf8 <$> HMap.lookup "host" apiGatewayRequestHeaders-  let requestHeaderRange = encodeUtf8 <$> HMap.lookup "range" apiGatewayRequestHeaders-  let requestHeaderReferer = encodeUtf8 <$> HMap.lookup "referer" apiGatewayRequestHeaders-  let requestHeaderUserAgent = encodeUtf8 <$> HMap.lookup "User-Agent" apiGatewayRequestHeaders+  let headers = fromMaybe HMap.empty apiGatewayRequestHeaders+  let requestHeaderHost = encodeUtf8 <$> HMap.lookup "host" headers+  let requestHeaderRange = encodeUtf8 <$> HMap.lookup "range" headers+  let requestHeaderReferer = encodeUtf8 <$> HMap.lookup "referer" headers+  let requestHeaderUserAgent = encodeUtf8 <$> HMap.lookup "User-Agent" headers    let queryParameters = toQueryStringParameters apiGatewayRequestQueryStringParameters       rawQueryString = H.renderQuery True queryParameters       httpVersion = getHttpVersion apiGatewayRequestContextProtocol -  let result = Wai.Request-                (encodeUtf8 apiGatewayRequestHttpMethod)-                httpVersion-                (encodeUtf8 apiGatewayRequestPath)-                rawQueryString-                (map toHeader $ HMap.toList apiGatewayRequestHeaders)-                True -- We assume it's always secure as we're passing through API Gateway-                ip-                pathInfo-                queryParameters-                requestBody-                Vault.empty-                requestBodyLength-                requestHeaderHost-                requestHeaderRange-                requestHeaderReferer-                requestHeaderUserAgent+  let result =+        Wai.Request+          (encodeUtf8 apiGatewayRequestHttpMethod)+          httpVersion+          (encodeUtf8 requestPath)+          rawQueryString+          (map toHeader $ HMap.toList headers)+          True -- We assume it's always secure as we're passing through API Gateway+          ip+          pathInfo+          queryParameters+          requestBody+          Vault.empty+          requestBodyLength+          requestHeaderHost+          requestHeaderRange+          requestHeaderReferer+          requestHeaderUserAgent    return result @@ -117,7 +273,7 @@ toQueryStringParameters :: Maybe (HMap.HashMap Text Text) -> [H.QueryItem] toQueryStringParameters (Just params) =   let toQueryItem (key, value) = (encodeUtf8 key, Just $ encodeUtf8 value)-  in map toQueryItem $ HMap.toList params+   in map toQueryItem $ HMap.toList params toQueryStringParameters _ = []  parseIp :: Maybe Text -> IO Socket.SockAddr@@ -125,19 +281,19 @@   case sourceIpText of     Just sourceIp ->       case readMaybe (T.unpack sourceIp) of-      Just ip ->-        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-      Nothing -> error "Could not parse source ip."+        Just ip ->+          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+        Nothing -> error "Could not parse source ip."     Nothing -> error "Missing source ip."  processRequest :: Application -> Wai.Request -> IO Wai.Response@@ -150,8 +306,8 @@  readResponse :: Wai.Response -> IO (H.Status, H.ResponseHeaders, ByteString) readResponse (Wai.responseToStream -> (st, hdrs, mkBody)) = do-    body <- mkBody drainBody-    pure (st, hdrs, body)+  body <- mkBody drainBody+  pure (st, hdrs, body)   where     drainBody :: Wai.StreamingBody -> IO ByteString     drainBody body = do@@ -161,16 +317,5 @@         (pure ())       BL.toStrict . Binary.toLazyByteString <$> readIORef ioRef -wrapInResponse-  :: Int-  -> H.ResponseHeaders-  -> res-  -> ApiGatewayResponse res-wrapInResponse code responseHeaders response =-  ApiGatewayResponse code responseHeaders response False- toHeader :: (Text, Text) -> H.Header toHeader (name, val) = (CI.mk . encodeUtf8 $ name, encodeUtf8 val)--tshow :: Show a => a -> Text-tshow = T.pack . show