aws-lambda-haskell-runtime 3.0.5 → 4.0.0

raw patch · 25 files changed

+1095/−854 lines, 25 filesdep +exceptionsdep +hashabledep +mtldep ~base

Dependencies added: exceptions, hashable, mtl

Dependency ranges changed: base

Files

aws-lambda-haskell-runtime.cabal +54/−25
src/Aws/Lambda.hs +8/−5
src/Aws/Lambda/Configuration.hs +0/−21
src/Aws/Lambda/Meta/Common.hs +0/−41
src/Aws/Lambda/Meta/Discover.hs +0/−67
src/Aws/Lambda/Meta/Dispatch.hs +0/−110
src/Aws/Lambda/Meta/Main.hs +0/−25
src/Aws/Lambda/Meta/Run.hs +0/−17
src/Aws/Lambda/Runtime.hs +59/−56
src/Aws/Lambda/Runtime/ALB/Types.hs +171/−0
src/Aws/Lambda/Runtime/API/Endpoints.hs +50/−44
src/Aws/Lambda/Runtime/API/Version.hs +6/−3
src/Aws/Lambda/Runtime/APIGateway/Types.hs +218/−0
src/Aws/Lambda/Runtime/ApiGatewayInfo.hs +0/−191
src/Aws/Lambda/Runtime/ApiInfo.hs +34/−35
src/Aws/Lambda/Runtime/Common.hs +54/−71
src/Aws/Lambda/Runtime/Configuration.hs +16/−0
src/Aws/Lambda/Runtime/Context.hs +55/−52
src/Aws/Lambda/Runtime/Environment.hs +30/−29
src/Aws/Lambda/Runtime/Error.hs +28/−24
src/Aws/Lambda/Runtime/Publish.hs +39/−30
src/Aws/Lambda/Runtime/StandaloneLambda/Types.hs +33/−0
src/Aws/Lambda/Setup.hs +211/−0
src/Aws/Lambda/Utilities.hs +24/−3
test/Spec.hs +5/−5

aws-lambda-haskell-runtime.cabal view

@@ -1,11 +1,7 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.34.2.------ see: https://github.com/sol/hpack+cabal-version: 3.0  name:           aws-lambda-haskell-runtime-version:        3.0.5+version:        4.0.0 synopsis:       Haskell runtime for AWS Lambda description:    Please see the README on GitHub at <https://github.com/theam/aws-lambda-haskell-runtime#readme> category:       AWS@@ -13,7 +9,7 @@ bug-reports:    https://github.com/theam/aws-lambda-haskell-runtime/issues author:         Nikita Tchayka maintainer:     hackers@theagilemonkeys.com-copyright:      2018 The Agile Monkeys SL+copyright:      2021 The Agile Monkeys SL license:        Apache-2.0 license-file:   LICENSE build-type:     Simple@@ -24,57 +20,90 @@   type: git   location: https://github.com/theam/aws-lambda-haskell-runtime +common common-options+  build-depends:+    base ^>= 4.7++  default-extensions:+    TemplateHaskell+    OverloadedStrings+    RecordWildCards+    ScopedTypeVariables+    DeriveGeneric+    TypeApplications+    FlexibleContexts+    DeriveAnyClass+    QuasiQuotes++  ghc-options:+    -Wall+    -- -Werror+    -optP-Wno-nonportable-include-path+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -Wcompat+    -Widentities+    -Wredundant-constraints+    -Wmissing-export-lists+    -Wpartial-fields+    -fhide-source-paths+    -freverse-errors++  default-language: Haskell2010++ library+  import: common-options   exposed-modules:       Aws.Lambda-      Aws.Lambda.Runtime-      Aws.Lambda.Runtime.Common   other-modules:-      Aws.Lambda.Configuration-      Aws.Lambda.Meta.Common-      Aws.Lambda.Meta.Discover-      Aws.Lambda.Meta.Dispatch-      Aws.Lambda.Meta.Main-      Aws.Lambda.Meta.Run+      Aws.Lambda.Runtime+      Aws.Lambda.Runtime.ALB.Types       Aws.Lambda.Runtime.API.Endpoints       Aws.Lambda.Runtime.API.Version-      Aws.Lambda.Runtime.ApiGatewayInfo+      Aws.Lambda.Runtime.APIGateway.Types       Aws.Lambda.Runtime.ApiInfo+      Aws.Lambda.Runtime.Common+      Aws.Lambda.Runtime.Configuration       Aws.Lambda.Runtime.Context       Aws.Lambda.Runtime.Environment       Aws.Lambda.Runtime.Error       Aws.Lambda.Runtime.Publish+      Aws.Lambda.Runtime.StandaloneLambda.Types+      Aws.Lambda.Setup       Aws.Lambda.Utilities       Paths_aws_lambda_haskell_runtime+  autogen-modules:+      Paths_aws_lambda_haskell_runtime   hs-source-dirs:       src-  default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables DeriveGeneric TypeApplications FlexibleContexts DeriveAnyClass QuasiQuotes-  ghc-options: -Wall -fno-warn-orphans -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -Wmissing-export-lists -Wpartial-fields -fhide-source-paths -freverse-errors   build-depends:       aeson-    , base >=4.7 && <5     , bytestring     , case-insensitive+    , exceptions+    , hashable     , http-client     , http-types+    , mtl     , path >0.7     , path-io     , safe-exceptions-checked     , template-haskell     , text     , unordered-containers-  default-language: Haskell2010  test-suite aws-lambda-haskell-runtime-test+  import: common-options   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:       Paths_aws_lambda_haskell_runtime   hs-source-dirs:       test-  default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables DeriveGeneric TypeApplications FlexibleContexts DeriveAnyClass QuasiQuotes-  ghc-options: -Wall -fno-warn-orphans -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -Wmissing-export-lists -Wpartial-fields -fhide-source-paths -freverse-errors -threaded -rtsopts -with-rtsopts=-N+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N   build-depends:-      base >=4.7 && <5-    , hspec-  default-language: Haskell2010+     hspec

src/Aws/Lambda.hs view

@@ -1,9 +1,12 @@ module Aws.Lambda-  ( module Reexported-  ) where+  ( module Reexported,+  )+where -import Aws.Lambda.Configuration as Reexported import Aws.Lambda.Runtime as Reexported-import Aws.Lambda.Runtime.Context as Reexported-import Aws.Lambda.Runtime.ApiGatewayInfo as Reexported+import Aws.Lambda.Runtime.ALB.Types as Reexported+import Aws.Lambda.Runtime.APIGateway.Types as Reexported import Aws.Lambda.Runtime.Common as Reexported+import Aws.Lambda.Runtime.Configuration as Reexported+import Aws.Lambda.Runtime.Context as Reexported+import Aws.Lambda.Setup as Reexported

− src/Aws/Lambda/Configuration.hs

@@ -1,21 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-}-module Aws.Lambda.Configuration-  ( Main.LambdaOptions(..)-  , generateLambdaDispatcher-  , Dispatch.decodeObj-  )-where--import qualified Language.Haskell.TH as Meta--import qualified Aws.Lambda.Meta.Dispatch as Dispatch-import qualified Aws.Lambda.Meta.Main as Main-import qualified Aws.Lambda.Meta.Run as Run--{-| Generates a @main@ function that acts as a dispatcher--}-generateLambdaDispatcher :: Main.DispatcherStrategy -> Main.DispatcherOptions -> Meta.DecsQ-generateLambdaDispatcher strategy options = do-  main <- Main.generate-  run <- Run.generate options strategy-  return (main <> [run])

− src/Aws/Lambda/Meta/Common.hs

@@ -1,41 +0,0 @@-{-| Helper functions to make code generation easier -}-module Aws.Lambda.Meta.Common-  ( declarationName-  , expressionName-  , getFieldsFrom-  , constructorName-  ) where--import Data.Text (Text)-import qualified Data.Text as Text-import Language.Haskell.TH---- | Helper for defining names in declarations--- think of @myValue@ in @myValue = 2@-declarationName :: Text -> Q Pat-declarationName = pure . VarP . mkName . Text.unpack---- | Helper for defining names in expressions--- think of @myFunction@ in @quux = myFunction 3@-expressionName :: Text -> Q Exp-expressionName = pure . VarE . mkName . Text.unpack---- | Helper for defining names for constructors--- think of @Foo@ in @quux = Foo 3@-constructorName :: Text -> Q Exp-constructorName = pure . ConE . mkName . Text.unpack---- | Helper for extracting fields of a specified record--- it expects the constructor name as the first parameter,--- and the list of fields to bring into scope as second--- think of @Person@, and @personAge@, @personName@ in--- @myFunction Person { personAge, personName } = ...@-getFieldsFrom :: Text -> [Text] -> Q Pat-getFieldsFrom name fields = do-  extractedFields <- traverse extractField fields-  pure $ RecP (mkName $ Text.unpack name) extractedFields- where-  -- | Helper for extracting fields of records-  -- think of @personAge@ in @myFunction Person { personAge = personAge } = ...@-  extractField :: Text -> Q FieldPat-  extractField n = pure (mkName $ Text.unpack n, VarP $ mkName $ Text.unpack n)

− src/Aws/Lambda/Meta/Discover.hs

@@ -1,67 +0,0 @@-{-| Discovery of AWS Lambda handlers-A handler is basically a function that has a type definition that-starts with "handler " and two colons.- -}-module Aws.Lambda.Meta.Discover-  ( handlers-  ) where--import qualified Control.Monad as Monad-import Data.Function ((&))-import qualified Data.Maybe as Maybe-import Data.Text (Text)-import qualified Data.Text as Text--import Path-import qualified Path.IO as PathIO---- | Paths to ignore during compilation-ignoredPaths :: [Text]-ignoredPaths =-  [ "node_modules"-  , ".stack-work"-  , ".serverless"-  ]--{-| Returns a list of handler paths that look like--@src/Foo/Bar/Quux.handler@--It is the path to the source file, but changing the-extension for ".handler"--}-handlers :: IO [Text]-handlers = do-  (_, files) <- PathIO.listDirRecurRel [reldir|.|]-  handlerFiles <- modulesWithHandler files-  pure (handlerNames handlerFiles)--modulesWithHandler :: [Path Rel File] -> IO [Path Rel File]-modulesWithHandler files =-  filter isHaskellModule files-  & Monad.filterM containsHandler- where-  isHaskellModule file =-    fileExtension file == Just ".hs"-    && isNotIgnoredPath file--  isNotIgnoredPath file =-    filter (\ignoredPath -> ignoredPath `Text.isInfixOf` (Text.pack $ toFilePath file)) ignoredPaths-    & null--handlerNames :: [Path Rel File] -> [Text]-handlerNames modules =-  fmap changeExtensionToHandler modules-  & fmap (Text.pack . toFilePath)- where-  changeExtensionToHandler file =-    replaceExtension ".handler" file-    & Maybe.fromJust  -- The path will be always parsable, as we just replace the extension--containsHandler :: Path Rel File -> IO Bool-containsHandler file = do-  fileContents <- readFile $ toFilePath file-  lines fileContents-    & filter (Text.isPrefixOf "handler :: " . Text.pack)-    & (not . null)-    & pure

− src/Aws/Lambda/Meta/Dispatch.hs

@@ -1,110 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--{-| Dispatcher generation -}-module Aws.Lambda.Meta.Dispatch-  ( generate-  , decodeObj-  , Runtime.LambdaResult(..)-  ) where--import qualified Data.Char as Char-import Data.Function ((&))-import Data.Text (Text)-import qualified Data.Text as Text--import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as LazyByteString-import qualified Language.Haskell.TH as Meta--import Aws.Lambda.Meta.Common-import qualified Aws.Lambda.Meta.Main as Main-import qualified Aws.Lambda.Runtime.ApiGatewayInfo as ApiGatewayInfo-import Aws.Lambda.Runtime.Common (toStandaloneLambdaResponse)-import qualified Aws.Lambda.Runtime.Common as Runtime-import qualified Aws.Lambda.Runtime.Error as Error-import qualified Control.Exception as Unchecked-import Data.Typeable (Proxy (..), Typeable, typeRep)--{-| Helper function that the dispatcher will use to-decode the JSON that comes as an AWS Lambda event into the-appropriate type expected by the handler.--}-decodeObj :: forall a. (FromJSON a, Typeable a) => LazyByteString.ByteString -> Either Error.Parsing a-decodeObj x =-  let objName = show (typeRep (Proxy :: Proxy a)) in-  case (eitherDecode x) of-    Left e  -> Left $ Error.Parsing e (LazyByteString.unpack x) objName-    Right v -> return v--{-| Generates the dispatcher out of a list of-handler names in the form @src/Foo/Bar.handler@--This dispatcher has a case for each of the handlers that calls-the appropriate qualified function. In the case of the example above,-the dispatcher will call @Foo.Bar.handler@.--}-generate :: Main.DispatcherOptions -> Main.DispatcherStrategy -> [Text] -> Meta.ExpQ-generate options strategy handlerNames = do-  caseExp <- expressionName "functionHandler"-  case strategy of-    Main.StandaloneLambda -> do-      matches <- traverse standaloneLambdaHandlerCase handlerNames-      unmatched <- standaloneLambdaUnmatchedCase-      pure $ Meta.CaseE caseExp (matches <> [unmatched])-    Main.UseWithAPIGateway -> do-      matches <- traverse (apiGatewayHandlerCase options) handlerNames-      unmatched <- apiGatewayUnmatchedCase-      pure $ Meta.CaseE caseExp (matches <> [unmatched])--standaloneLambdaHandlerCase :: Text -> Meta.MatchQ-standaloneLambdaHandlerCase lambdaHandler = do-  let pat = Meta.LitP (Meta.StringL $ Text.unpack lambdaHandler)-  body <- [e|do-    case decodeObj $(expressionName "eventObject") of-      Right eventObject -> (do-          result <- $(expressionName (qualifiedHandlerName lambdaHandler)) eventObject contextObject-          either (pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse) (pure . Right . Runtime.StandaloneLambdaResult . toStandaloneLambdaResponse) result)-          `Unchecked.catch` \(handlerError :: Unchecked.SomeException) -> pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse . show $ handlerError-      Left err -> pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse $ err|]-  pure $ Meta.Match pat (Meta.NormalB body) []--standaloneLambdaUnmatchedCase :: Meta.MatchQ-standaloneLambdaUnmatchedCase = do-  let pattern = Meta.WildP-  body <- [e|-    pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse $ ("Handler " <> $(expressionName "functionHandler") <> " does not exist on project" :: String)-    |]-  pure $ Meta.Match pattern (Meta.NormalB body) []--apiGatewayHandlerCase :: Main.DispatcherOptions -> Text -> Meta.MatchQ-apiGatewayHandlerCase options lambdaHandler = do-  let pat = Meta.LitP (Meta.StringL $ Text.unpack lambdaHandler)-  body <- [e|do-    let returnErr statusCode = pure . Left . Runtime.ApiGatewayLambdaError . ApiGatewayInfo.mkApiGatewayResponse statusCode-    case decodeObj $(expressionName "eventObject") of-      Right eventObject -> do-        resultE <- Unchecked.try $ $(expressionName (qualifiedHandlerName lambdaHandler)) eventObject contextObject-        case resultE of-          Right result ->-            either (pure . Left . Runtime.ApiGatewayLambdaError . fmap toApiGatewayResponseBody) (pure . Right . Runtime.ApiGatewayResult . fmap toApiGatewayResponseBody) result-          Left (handlerError :: Unchecked.SomeException) ->-            if (Runtime.propagateImpureExceptions . Runtime.apiGatewayDispatcherOptions $ options)-            then returnErr 500 . toApiGatewayResponseBody . show $ handlerError-            else returnErr 500 . toApiGatewayResponseBody . Text.pack $ "Something went wrong."-      Left err -> returnErr 400 . toApiGatewayResponseBody . show $ err|]-  pure $ Meta.Match pat (Meta.NormalB body) []--apiGatewayUnmatchedCase :: Meta.MatchQ-apiGatewayUnmatchedCase = do-  let pattern = Meta.WildP-  body <- [e|-    pure . Left . Runtime.ApiGatewayLambdaError . ApiGatewayInfo.mkApiGatewayResponse 500 . toApiGatewayResponseBody $ ("Handler " <> $(expressionName "functionHandler") <> " does not exist on project")-    |]-  pure $ Meta.Match pattern (Meta.NormalB body) []--qualifiedHandlerName :: Text -> Text-qualifiedHandlerName lambdaHandler =-    lambdaHandler-    & Text.splitOn "/"-    & filter (Char.isUpper . Text.head)-    & Text.intercalate "."

− src/Aws/Lambda/Meta/Main.hs

@@ -1,25 +0,0 @@-{-| main function generation for interoperation with the layer -}-module Aws.Lambda.Meta.Main-  ( Runtime.LambdaOptions(..)-  , Runtime.DispatcherStrategy(..)-  , Runtime.DispatcherOptions(..)-  , Runtime.ApiGatewayDispatcherOptions(..)-  , Runtime.defaultDispatcherOptions-  , generate-  ) where--import qualified Language.Haskell.TH as Meta--import Aws.Lambda.Meta.Common-import qualified Aws.Lambda.Runtime.Common as Runtime---- | Generate the main function with the dispatcher-generate :: Meta.DecsQ-generate = [d|-  $(declarationName "main") = $(directCallBody)-  |]- where-  directCallBody =-    [e|-    runLambda initializeContext run-    |]

− src/Aws/Lambda/Meta/Run.hs

@@ -1,17 +0,0 @@-module Aws.Lambda.Meta.Run-  ( generate-  ) where--import qualified Language.Haskell.TH as Meta--import Aws.Lambda.Meta.Common-import qualified Aws.Lambda.Meta.Discover as Discover-import qualified Aws.Lambda.Meta.Dispatch as Dispatch-import qualified Aws.Lambda.Meta.Main as Main--generate :: Main.DispatcherOptions -> Main.DispatcherStrategy -> Meta.DecQ-generate options strategy = do-  handlers <- Meta.runIO Discover.handlers-  clause' <- getFieldsFrom "LambdaOptions" ["functionHandler", "contextObject", "eventObject", "executionUuid"]-  body <- Dispatch.generate options strategy handlers-  pure $ Meta.FunD (Meta.mkName "run") [Meta.Clause [clause'] (Meta.NormalB body) []]

src/Aws/Lambda/Runtime.hs view

@@ -1,26 +1,15 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}  module Aws.Lambda.Runtime-  ( runLambda-  , Runtime.LambdaResult(..)-  , Runtime.DispatcherStrategy(..)-  , Runtime.DispatcherOptions(..)-  , Runtime.ApiGatewayDispatcherOptions(..)-  , Runtime.defaultDispatcherOptions-  , Error.Parsing(..)-  ) where--import Control.Exception.Safe.Checked-import qualified Control.Exception.Safe.Checked as Checked-import Control.Monad (forever)-import System.IO (hFlush, stdout, stderr)-import qualified Network.HTTP.Client as Http--import Data.Aeson-import Data.IORef+  ( runLambda,+    Runtime.LambdaResult (..),+    Runtime.ApiGatewayDispatcherOptions (..),+    Error.Parsing (..),+  )+where  import qualified Aws.Lambda.Runtime.ApiInfo as ApiInfo import qualified Aws.Lambda.Runtime.Common as Runtime@@ -29,65 +18,77 @@ import qualified Aws.Lambda.Runtime.Error as Error import qualified Aws.Lambda.Runtime.Publish as Publish import qualified Control.Exception as Unchecked+import Control.Exception.Safe.Checked (Throws, catch, throw)+import qualified Control.Exception.Safe.Checked as Checked+import Control.Monad (forever)+import Data.Aeson (ToJSON (toJSON))+import Data.IORef (newIORef)+import Data.Text (Text, unpack)+import qualified Network.HTTP.Client as Http+import System.IO (hFlush, stderr, stdout)  -- | Runs the user @haskell_lambda@ executable and posts back the -- results. This is called from the layer's @main@ function.-runLambda :: forall context. IO context -> Runtime.RunCallback context -> IO ()+runLambda :: forall context handlerType. IO context -> Runtime.RunCallback handlerType context -> IO () runLambda initializeCustomContext callback = do   manager <- Http.newManager httpManagerSettings   customContext <- initializeCustomContext   customContextRef <- newIORef customContext-  context   <- Context.initialize @context customContextRef `catch` errorParsing `catch` variableNotSet+  context <- Context.initialize @context customContextRef `catch` errorParsing `catch` variableNotSet   forever $ do     lambdaApi <- Environment.apiEndpoint `catch` variableNotSet-    event     <- ApiInfo.fetchEvent manager lambdaApi `catch` errorParsing+    event <- ApiInfo.fetchEvent manager lambdaApi `catch` errorParsing      -- Purposefully shadowing to prevent using the initial "empty" context     context <- Context.setEventData context event -    (((invokeAndRun callback manager lambdaApi event context-      `Checked.catch` \err -> Publish.parsingError err lambdaApi context manager)-      `Checked.catch` \err -> Publish.invocationError err lambdaApi context manager)-      `Checked.catch` \(err :: Error.EnvironmentVariableNotSet) -> Publish.runtimeInitError err lambdaApi context manager)+    ( ( ( invokeAndRun callback manager lambdaApi event context+            `Checked.catch` \err -> Publish.parsingError err lambdaApi context manager+        )+          `Checked.catch` \err -> Publish.invocationError err lambdaApi context manager+      )+        `Checked.catch` \(err :: Error.EnvironmentVariableNotSet) -> Publish.runtimeInitError err lambdaApi context manager+      )       `Unchecked.catch` \err -> Publish.invocationError err lambdaApi context manager  httpManagerSettings :: Http.ManagerSettings httpManagerSettings =   -- We set the timeout to none, as AWS Lambda freezes the containers.   Http.defaultManagerSettings-  { Http.managerResponseTimeout = Http.responseTimeoutNone-  }+    { Http.managerResponseTimeout = Http.responseTimeoutNone+    } -invokeAndRun-  :: Throws Error.Invocation-  => Throws Error.EnvironmentVariableNotSet-  => Runtime.RunCallback context-  -> Http.Manager-  -> String-  -> ApiInfo.Event-  -> Context.Context context-  -> IO ()+invokeAndRun ::+  Throws Error.Invocation =>+  Throws Error.EnvironmentVariableNotSet =>+  Runtime.RunCallback handlerType context ->+  Http.Manager ->+  Text ->+  ApiInfo.Event ->+  Context.Context context ->+  IO () invokeAndRun callback manager lambdaApi event context = do   result <- invokeWithCallback callback event context    Publish.result result lambdaApi context manager     `catch` \err -> Publish.invocationError err lambdaApi context manager -invokeWithCallback-  :: Throws Error.Invocation-  => Throws Error.EnvironmentVariableNotSet-  => Runtime.RunCallback context-  -> ApiInfo.Event-  -> Context.Context context-  -> IO Runtime.LambdaResult+invokeWithCallback ::+  Throws Error.Invocation =>+  Throws Error.EnvironmentVariableNotSet =>+  Runtime.RunCallback handlerType context ->+  ApiInfo.Event ->+  Context.Context context ->+  IO (Runtime.LambdaResult handlerType) invokeWithCallback callback event context = do-  handlerName <- Environment.handlerName-  let lambdaOptions = Runtime.LambdaOptions-                      { eventObject = ApiInfo.event event-                      , functionHandler = handlerName-                      , executionUuid = ""  -- DirectCall doesnt use UUID-                      , contextObject = context-                      }+  handlerName <- Runtime.HandlerName <$> Environment.handlerName+  let lambdaOptions =+        Runtime.LambdaOptions+          { eventObject = ApiInfo.event event,+            functionHandler = handlerName,+            executionUuid = "", -- DirectCall doesnt use UUID+            contextObject = context+          }   result <- callback lambdaOptions   -- Flush output to insure output goes into CloudWatch logs   flushOutput@@ -95,18 +96,20 @@     Left lambdaError -> case lambdaError of       Runtime.StandaloneLambdaError err ->         throw $ Error.Invocation $ toJSON err-      Runtime.ApiGatewayLambdaError err ->+      Runtime.APIGatewayLambdaError err ->         throw $ Error.Invocation $ toJSON err+      Runtime.ALBLambdaError err ->+        throw $ Error.Invocation $ toJSON err     Right value ->       pure value  variableNotSet :: Error.EnvironmentVariableNotSet -> IO a variableNotSet (Error.EnvironmentVariableNotSet env) =-  error ("Error initializing, variable not set: " <> env)+  error ("Error initializing, variable not set: " <> unpack env)  errorParsing :: Error.Parsing -> IO a-errorParsing Error.Parsing{..} =-  error ("Failed parsing " <> errorMessage <> ", got" <> actualValue)+errorParsing Error.Parsing {..} =+  error ("Failed parsing " <> unpack errorMessage <> ", got" <> unpack actualValue)  -- | Flush standard output ('stdout') and standard error output ('stderr') handlers flushOutput :: IO ()

+ src/Aws/Lambda/Runtime/ALB/Types.hs view

@@ -0,0 +1,171 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Aws.Lambda.Runtime.ALB.Types+  ( ALBRequest (..),+    ALBRequestContext (..),+    ALBResponse (..),+    ALBResponseBody (..),+    ToALBResponseBody (..),+    mkALBResponse,+  )+where++import Aws.Lambda.Utilities (toJSONText, tshow)+import Data.Aeson+  ( FromJSON (parseJSON),+    KeyValue ((.=)),+    Object,+    ToJSON (toJSON),+    Value (Null, Object, String),+    eitherDecodeStrict,+    object,+    (.:),+  )+import Data.Aeson.Types (Parser)+import qualified Data.Aeson.Types as T+import qualified Data.CaseInsensitive as CI+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.Generics (Generic)+import Network.HTTP.Types (Header, ResponseHeaders)++data ALBRequest body = ALBRequest+  { albRequestPath :: !Text,+    albRequestHttpMethod :: !Text,+    albRequestHeaders :: !(Maybe (HashMap Text Text)),+    -- TODO: They won't be url decoded in ALB+    albRequestQueryStringParameters :: !(Maybe (HashMap Text Text)),+    albRequestIsBase64Encoded :: !Bool,+    albRequestRequestContext :: !ALBRequestContext,+    albRequestBody :: !(Maybe body)+  }+  deriving (Show)++-- We special case String and Text in order+-- to avoid unneeded encoding which will wrap them in quotes and break parsing+instance {-# OVERLAPPING #-} FromJSON (ALBRequest Text) where+  parseJSON = parseALBRequest (.:)++instance {-# OVERLAPPING #-} FromJSON (ALBRequest String) where+  parseJSON = parseALBRequest (.:)++instance FromJSON body => FromJSON (ALBRequest body) where+  parseJSON = parseALBRequest parseObjectFromStringField++-- We need this because API Gateway is going to send us the payload as a JSON string+parseObjectFromStringField :: FromJSON a => Object -> Text -> Parser (Maybe a)+parseObjectFromStringField obj fieldName = do+  fieldContents <- obj .: fieldName+  case fieldContents of+    String stringContents ->+      case eitherDecodeStrict (T.encodeUtf8 stringContents) of+        Right success -> pure success+        Left err -> fail err+    Null -> pure Nothing+    other -> T.typeMismatch "String or Null" other++parseALBRequest :: (Object -> Text -> Parser (Maybe body)) -> Value -> Parser (ALBRequest body)+parseALBRequest bodyParser (Object v) =+  ALBRequest+    <$> v .: "path"+    <*> v .: "httpMethod"+    <*> v .: "headers"+    <*> v .: "queryStringParameters"+    <*> v .: "isBase64Encoded"+    <*> v .: "requestContext"+    <*> v `bodyParser` "body"+parseALBRequest _ _ = fail "Expected ALBRequest to be an object."++newtype ALBRequestContext = ALBRequestContext+  {albRequestContextElb :: ALBELB}+  deriving (Show)++instance FromJSON ALBRequestContext where+  parseJSON (Object v) =+    ALBRequestContext+      <$> v .: "elb"+  parseJSON _ = fail "Expected ALBRequestContext to be an object."++newtype ALBELB = ALBELB+  {albElbTargetGroupArn :: Text}+  deriving (Show)++instance FromJSON ALBELB where+  parseJSON (Object v) =+    ALBELB+      <$> v .: "targetGroupArn"+  parseJSON _ = fail "Expected ALBELB to be an object."++newtype ALBResponseBody+  = ALBResponseBody Text+  deriving newtype (ToJSON, FromJSON)++class ToALBResponseBody a where+  toALBResponseBody :: a -> ALBResponseBody++-- We special case Text and String to avoid unneeded encoding which will wrap them in quotes+instance {-# OVERLAPPING #-} ToALBResponseBody Text where+  toALBResponseBody = ALBResponseBody++instance {-# OVERLAPPING #-} ToALBResponseBody String where+  toALBResponseBody = ALBResponseBody . T.pack++instance ToJSON a => ToALBResponseBody a where+  toALBResponseBody = ALBResponseBody . toJSONText++data ALBResponse body = ALBResponse+  { albResponseStatusCode :: !Int,+    albResponseStatusDescription :: !Text,+    albResponseHeaders :: !ResponseHeaders,+    albResponseMultiValueHeaders :: !ResponseHeaders,+    albResponseBody :: !body,+    albResponseIsBase64Encoded :: !Bool+  }+  deriving (Generic, Show)++instance Functor ALBResponse where+  fmap f v = v {albResponseBody = f (albResponseBody v)}++instance ToJSON body => ToJSON (ALBResponse body) where+  toJSON = albResponseToJSON toJSON++albResponseToJSON :: (body -> Value) -> ALBResponse body -> Value+albResponseToJSON bodyTransformer ALBResponse {..} =+  object+    [ "statusCode" .= albResponseStatusCode,+      "body" .= bodyTransformer albResponseBody,+      "headers" .= object (map headerToPair albResponseHeaders),+      "multiValueHeaders" .= object (map headerToPair albResponseHeaders),+      "isBase64Encoded" .= albResponseIsBase64Encoded+    ]++mkALBResponse :: Int -> ResponseHeaders -> payload -> ALBResponse payload+mkALBResponse code headers payload =+  ALBResponse code (codeDescription code) headers headers payload False+  where+    codeDescription 200 = "200 OK"+    codeDescription 201 = "201 Created"+    codeDescription 202 = "202 Accepted"+    codeDescription 203 = "203 Non-Authoritative Information"+    codeDescription 204 = "204 No Content"+    codeDescription 400 = "400 Bad Request"+    codeDescription 401 = "401 Unauthorized"+    codeDescription 402 = "402 Payment Required"+    codeDescription 403 = "403 Forbidden"+    codeDescription 404 = "404 Not Found"+    codeDescription 405 = "405 Method Not Allowed"+    codeDescription 406 = "406 Not Acceptable"+    codeDescription 500 = "500 Internal Server Error"+    codeDescription other = tshow other++headerToPair :: Header -> T.Pair+headerToPair (cibyte, bstr) = k .= v+  where+    k = (T.decodeUtf8 . CI.original) cibyte+    v = T.decodeUtf8 bstr

src/Aws/Lambda/Runtime/API/Endpoints.hs view

@@ -1,61 +1,67 @@ module Aws.Lambda.Runtime.API.Endpoints-  ( response-  , invocationError-  , runtimeInitError-  , nextInvocation-  , Endpoint(..)-  ) where+  ( response,+    invocationError,+    runtimeInitError,+    nextInvocation,+    Endpoint (..),+  )+where  import qualified Aws.Lambda.Runtime.API.Version as Version+import Data.Text (Text) -newtype Endpoint =-  Endpoint String+newtype Endpoint+  = Endpoint Text   deriving (Show)  -- | Endpoint that provides the ID of the next invocation-nextInvocation :: String -> Endpoint+nextInvocation :: Text -> Endpoint nextInvocation lambdaApi =-  Endpoint $ concat-    [ "http://"-    , lambdaApi-    , "/"-    , Version.value-    , "/runtime/invocation/next"-    ]+  Endpoint $+    mconcat+      [ "http://",+        lambdaApi,+        "/",+        Version.value,+        "/runtime/invocation/next"+      ]  -- | Where the response of the Lambda gets published-response :: String -> String -> Endpoint+response :: Text -> Text -> Endpoint response lambdaApi requestId =-  Endpoint $ concat-    [ "http://"-    , lambdaApi-    , "/"-    , Version.value-    , "/runtime/invocation/"-    , requestId-    , "/response"-    ]+  Endpoint $+    mconcat+      [ "http://",+        lambdaApi,+        "/",+        Version.value,+        "/runtime/invocation/",+        requestId,+        "/response"+      ]  -- | Invocation (runtime) errors should be published here-invocationError :: String -> String -> Endpoint+invocationError :: Text -> Text -> Endpoint invocationError lambdaApi requestId =-  Endpoint $ concat-    [ "http://"-    , lambdaApi-    , "/"-    , Version.value-    , "/runtime/invocation/"-    , requestId-    , "/error"-    ]+  Endpoint $+    mconcat+      [ "http://",+        lambdaApi,+        "/",+        Version.value,+        "/runtime/invocation/",+        requestId,+        "/error"+      ]  -- | Runtime initialization errors should go here-runtimeInitError :: String -> Endpoint+runtimeInitError :: Text -> Endpoint runtimeInitError lambdaApi =-  Endpoint $ concat-    [ "http://"-    , lambdaApi-    , "/"-    , Version.value-    , "/runtime/init/error"-    ]+  Endpoint $+    mconcat+      [ "http://",+        lambdaApi,+        "/",+        Version.value,+        "/runtime/init/error"+      ]

src/Aws/Lambda/Runtime/API/Version.hs view

@@ -1,7 +1,10 @@ module Aws.Lambda.Runtime.API.Version-  ( value-  ) where+  ( value,+  )+where +import Data.Text (Text)+ -- | Version of the AWS Lambda runtime REST API-value :: String+value :: Text value = "2018-06-01"

+ src/Aws/Lambda/Runtime/APIGateway/Types.hs view

@@ -0,0 +1,218 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Aws.Lambda.Runtime.APIGateway.Types+  ( ApiGatewayRequest (..),+    ApiGatewayRequestContext (..),+    ApiGatewayRequestContextIdentity (..),+    ApiGatewayResponse (..),+    ApiGatewayResponseBody (..),+    ToApiGatewayResponseBody (..),+    ApiGatewayDispatcherOptions (..),+    mkApiGatewayResponse,+  )+where++import Aws.Lambda.Utilities (toJSONText)+import Data.Aeson+  ( FromJSON (parseJSON),+    KeyValue ((.=)),+    Object,+    ToJSON (toJSON),+    Value (Null, Object, String),+    eitherDecodeStrict,+    object,+    (.:),+  )+import Data.Aeson.Types (Parser)+import qualified Data.Aeson.Types as T+import qualified Data.CaseInsensitive as CI+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.Generics (Generic)+import Network.HTTP.Types (Header, ResponseHeaders)++-- | API Gateway specific dispatcher options+newtype ApiGatewayDispatcherOptions = ApiGatewayDispatcherOptions+  { -- | Should impure exceptions be propagated through the API Gateway interface+    propagateImpureExceptions :: Bool+  }++data ApiGatewayRequest body = ApiGatewayRequest+  { apiGatewayRequestResource :: !Text,+    apiGatewayRequestPath :: !Text,+    apiGatewayRequestHttpMethod :: !Text,+    apiGatewayRequestHeaders :: !(Maybe (HashMap Text Text)),+    apiGatewayRequestQueryStringParameters :: !(Maybe (HashMap Text Text)),+    apiGatewayRequestPathParameters :: !(Maybe (HashMap Text Text)),+    apiGatewayRequestStageVariables :: !(Maybe (HashMap Text Text)),+    apiGatewayRequestIsBase64Encoded :: !Bool,+    apiGatewayRequestRequestContext :: !ApiGatewayRequestContext,+    apiGatewayRequestBody :: !(Maybe body)+  }+  deriving (Show)++-- We special case String and Text in order+-- to avoid unneeded encoding which will wrap them in quotes and break parsing+instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest Text) where+  parseJSON = parseApiGatewayRequest (.:)++instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest String) where+  parseJSON = parseApiGatewayRequest (.:)++instance FromJSON body => FromJSON (ApiGatewayRequest body) where+  parseJSON = parseApiGatewayRequest parseObjectFromStringField++-- We need this because API Gateway is going to send us the payload as a JSON string+parseObjectFromStringField :: FromJSON a => Object -> Text -> Parser (Maybe a)+parseObjectFromStringField obj fieldName = do+  fieldContents <- obj .: fieldName+  case fieldContents of+    String stringContents ->+      case eitherDecodeStrict (T.encodeUtf8 stringContents) of+        Right success -> pure success+        Left err -> fail err+    Null -> pure Nothing+    other -> T.typeMismatch "String or Null" other++parseApiGatewayRequest :: (Object -> Text -> Parser (Maybe body)) -> Value -> Parser (ApiGatewayRequest body)+parseApiGatewayRequest bodyParser (Object v) =+  ApiGatewayRequest+    <$> v .: "resource"+    <*> v .: "path"+    <*> v .: "httpMethod"+    <*> v .: "headers"+    <*> v .: "queryStringParameters"+    <*> v .: "pathParameters"+    <*> v .: "stageVariables"+    <*> v .: "isBase64Encoded"+    <*> v .: "requestContext"+    <*> v `bodyParser` "body"+parseApiGatewayRequest _ _ = fail "Expected ApiGatewayRequest to be an object."++data ApiGatewayRequestContext = ApiGatewayRequestContext+  { apiGatewayRequestContextResourceId :: !Text,+    apiGatewayRequestContextResourcePath :: !Text,+    apiGatewayRequestContextHttpMethod :: !Text,+    apiGatewayRequestContextExtendedRequestId :: !Text,+    apiGatewayRequestContextRequestTime :: !Text,+    apiGatewayRequestContextPath :: !Text,+    apiGatewayRequestContextAccountId :: !Text,+    apiGatewayRequestContextProtocol :: !Text,+    apiGatewayRequestContextStage :: !Text,+    apiGatewayRequestContextDomainPrefix :: !Text,+    apiGatewayRequestContextRequestId :: !Text,+    apiGatewayRequestContextDomainName :: !Text,+    apiGatewayRequestContextApiId :: !Text,+    apiGatewayRequestContextIdentity :: !ApiGatewayRequestContextIdentity,+    apiGatewayRequestContextAuthorizer :: !Value+  }+  deriving (Show)++instance FromJSON ApiGatewayRequestContext where+  parseJSON (Object v) =+    ApiGatewayRequestContext+      <$> v .: "resourceId"+      <*> v .: "path"+      <*> v .: "httpMethod"+      <*> v .: "extendedRequestId"+      <*> v .: "requestTime"+      <*> v .: "path"+      <*> v .: "accountId"+      <*> v .: "protocol"+      <*> v .: "stage"+      <*> v .: "domainPrefix"+      <*> v .: "requestId"+      <*> v .: "domainName"+      <*> v .: "apiId"+      <*> v .: "identity"+      <*> v .: "authorizer"+  parseJSON _ = fail "Expected ApiGatewayRequestContext to be an object."++data ApiGatewayRequestContextIdentity = ApiGatewayRequestContextIdentity+  { apiGatewayRequestContextIdentityCognitoIdentityPoolId :: !(Maybe Text),+    apiGatewayRequestContextIdentityAccountId :: !(Maybe Text),+    apiGatewayRequestContextIdentityCognitoIdentityId :: !(Maybe Text),+    apiGatewayRequestContextIdentityCaller :: !(Maybe Text),+    apiGatewayRequestContextIdentitySourceIp :: !(Maybe Text),+    apiGatewayRequestContextIdentityPrincipalOrgId :: !(Maybe Text),+    apiGatewayRequestContextIdentityAccesskey :: !(Maybe Text),+    apiGatewayRequestContextIdentityCognitoAuthenticationType :: !(Maybe Text),+    apiGatewayRequestContextIdentityCognitoAuthenticationProvider :: !(Maybe Value),+    apiGatewayRequestContextIdentityUserArn :: !(Maybe Text),+    apiGatewayRequestContextIdentityUserAgent :: !(Maybe Text),+    apiGatewayRequestContextIdentityUser :: !(Maybe Text)+  }+  deriving (Show)++instance FromJSON ApiGatewayRequestContextIdentity where+  parseJSON (Object v) =+    ApiGatewayRequestContextIdentity+      <$> v .: "cognitoIdentityPoolId"+      <*> v .: "accountId"+      <*> v .: "cognitoIdentityId"+      <*> v .: "caller"+      <*> v .: "sourceIp"+      <*> v .: "principalOrgId"+      <*> v .: "accessKey"+      <*> v .: "cognitoAuthenticationType"+      <*> v .: "cognitoAuthenticationProvider"+      <*> v .: "userArn"+      <*> v .: "userAgent"+      <*> v .: "user"+  parseJSON _ = fail "Expected ApiGatewayRequestContextIdentity to be an object."++newtype ApiGatewayResponseBody+  = ApiGatewayResponseBody Text+  deriving newtype (ToJSON, FromJSON)++class ToApiGatewayResponseBody a where+  toApiGatewayResponseBody :: a -> ApiGatewayResponseBody++-- We special case Text and String to avoid unneeded encoding which will wrap them in quotes+instance {-# OVERLAPPING #-} ToApiGatewayResponseBody Text where+  toApiGatewayResponseBody = ApiGatewayResponseBody++instance {-# OVERLAPPING #-} ToApiGatewayResponseBody String where+  toApiGatewayResponseBody = ApiGatewayResponseBody . T.pack++instance ToJSON a => ToApiGatewayResponseBody a where+  toApiGatewayResponseBody = ApiGatewayResponseBody . toJSONText++data ApiGatewayResponse body = ApiGatewayResponse+  { apiGatewayResponseStatusCode :: !Int,+    apiGatewayResponseHeaders :: !ResponseHeaders,+    apiGatewayResponseBody :: !body,+    apiGatewayResponseIsBase64Encoded :: !Bool+  }+  deriving (Generic, Show)++instance Functor ApiGatewayResponse where+  fmap f v = v {apiGatewayResponseBody = f (apiGatewayResponseBody v)}++instance ToJSON body => ToJSON (ApiGatewayResponse body) where+  toJSON = apiGatewayResponseToJSON toJSON++apiGatewayResponseToJSON :: (body -> Value) -> ApiGatewayResponse body -> Value+apiGatewayResponseToJSON bodyTransformer ApiGatewayResponse {..} =+  object+    [ "statusCode" .= apiGatewayResponseStatusCode,+      "body" .= bodyTransformer apiGatewayResponseBody,+      "headers" .= object (map headerToPair apiGatewayResponseHeaders),+      "isBase64Encoded" .= apiGatewayResponseIsBase64Encoded+    ]++mkApiGatewayResponse :: Int -> ResponseHeaders -> payload -> ApiGatewayResponse payload+mkApiGatewayResponse code headers payload =+  ApiGatewayResponse code headers payload False++headerToPair :: Header -> T.Pair+headerToPair (cibyte, bstr) = k .= v+  where+    k = (T.decodeUtf8 . CI.original) cibyte+    v = T.decodeUtf8 bstr

− src/Aws/Lambda/Runtime/ApiGatewayInfo.hs

@@ -1,191 +0,0 @@-{-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE DerivingStrategies         #-}-{-# LANGUAGE DuplicateRecordFields      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralisedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances       #-}--module Aws.Lambda.Runtime.ApiGatewayInfo-  ( ApiGatewayRequest(..)-  , ApiGatewayRequestContext(..)-  , ApiGatewayRequestContextIdentity(..)-  , ApiGatewayResponse(..)-  , ApiGatewayResponseBody(..)-  , ToApiGatewayResponseBody(..)-  , mkApiGatewayResponse ) where--import Aws.Lambda.Utilities-import Data.Aeson-import Data.Aeson.Types (Parser)-import qualified Data.Aeson.Types as T-import qualified Data.CaseInsensitive as CI-import Data.HashMap.Strict (HashMap)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import GHC.Generics (Generic)-import Network.HTTP.Types--data ApiGatewayRequest body = ApiGatewayRequest-  { apiGatewayRequestResource              :: !Text-  , apiGatewayRequestPath                  :: !Text-  , apiGatewayRequestHttpMethod            :: !Text-  , apiGatewayRequestHeaders               :: !(Maybe (HashMap Text Text))-  , apiGatewayRequestQueryStringParameters :: !(Maybe (HashMap Text Text))-  , apiGatewayRequestPathParameters        :: !(Maybe (HashMap Text Text))-  , apiGatewayRequestStageVariables        :: !(Maybe (HashMap Text Text))-  , apiGatewayRequestIsBase64Encoded       :: !Bool-  , apiGatewayRequestRequestContext        :: !ApiGatewayRequestContext-  , apiGatewayRequestBody                  :: !(Maybe body)-  } deriving (Show)---- We special case String and Text in order--- to avoid unneeded encoding which will wrap them in quotes and break parsing-instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest Text) where-  parseJSON = parseApiGatewayRequest (.:)--instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest String) where-  parseJSON = parseApiGatewayRequest (.:)--instance FromJSON body => FromJSON (ApiGatewayRequest body) where-  parseJSON = parseApiGatewayRequest parseObjectFromStringField---- We need this because API Gateway is going to send us the payload as a JSON string-parseObjectFromStringField :: FromJSON a => Object -> Text -> Parser (Maybe a)-parseObjectFromStringField obj fieldName = do-  fieldContents <- obj .: fieldName-  case fieldContents of-    String stringContents ->-      case eitherDecodeStrict (T.encodeUtf8 stringContents) of-        Right success -> pure success-        Left err      -> fail err-    Null -> pure Nothing-    other -> T.typeMismatch "String or Null" other--parseApiGatewayRequest :: (Object -> Text -> Parser (Maybe body)) -> Value -> Parser (ApiGatewayRequest body)-parseApiGatewayRequest bodyParser (Object v) = ApiGatewayRequest <$>-  v .: "resource" <*>-  v .: "path" <*>-  v .: "httpMethod" <*>-  v .: "headers" <*>-  v .: "queryStringParameters" <*>-  v .: "pathParameters" <*>-  v .: "stageVariables" <*>-  v .: "isBase64Encoded" <*>-  v .: "requestContext" <*>-  v `bodyParser` "body"-parseApiGatewayRequest _ _ = fail "Expected ApiGatewayRequest to be an object."--data ApiGatewayRequestContext = ApiGatewayRequestContext-  { apiGatewayRequestContextResourceId        :: !Text-  , apiGatewayRequestContextResourcePath      :: !Text-  , apiGatewayRequestContextHttpMethod        :: !Text-  , apiGatewayRequestContextExtendedRequestId :: !Text-  , apiGatewayRequestContextRequestTime       :: !Text-  , apiGatewayRequestContextPath              :: !Text-  , apiGatewayRequestContextAccountId         :: !Text-  , apiGatewayRequestContextProtocol          :: !Text-  , apiGatewayRequestContextStage             :: !Text-  , apiGatewayRequestContextDomainPrefix      :: !Text-  , apiGatewayRequestContextRequestId         :: !Text-  , apiGatewayRequestContextDomainName        :: !Text-  , apiGatewayRequestContextApiId             :: !Text-  , apiGatewayRequestContextIdentity          :: !ApiGatewayRequestContextIdentity-  } deriving (Show)--instance FromJSON ApiGatewayRequestContext where-  parseJSON (Object v) = ApiGatewayRequestContext <$>-    v .: "resourceId" <*>-    v .: "path" <*>-    v .: "httpMethod" <*>-    v .: "extendedRequestId" <*>-    v .: "requestTime" <*>-    v .: "path" <*>-    v .: "accountId" <*>-    v .: "protocol" <*>-    v .: "stage" <*>-    v .: "domainPrefix" <*>-    v .: "requestId" <*>-    v .: "domainName" <*>-    v .: "apiId" <*>-    v .: "identity"-  parseJSON _ = fail "Expected ApiGatewayRequestContext to be an object."--data ApiGatewayRequestContextIdentity = ApiGatewayRequestContextIdentity-  { apiGatewayRequestContextIdentityCognitoIdentityPoolId         :: !(Maybe Text)-  , apiGatewayRequestContextIdentityAccountId                     :: !(Maybe Text)-  , apiGatewayRequestContextIdentityCognitoIdentityId             :: !(Maybe Text)-  , apiGatewayRequestContextIdentityCaller                        :: !(Maybe Text)-  , apiGatewayRequestContextIdentitySourceIp                      :: !(Maybe Text)-  , apiGatewayRequestContextIdentityPrincipalOrgId                :: !(Maybe Text)-  , apiGatewayRequestContextIdentityAccesskey                     :: !(Maybe Text)-  , apiGatewayRequestContextIdentityCognitoAuthenticationType     :: !(Maybe Text)-  , apiGatewayRequestContextIdentityCognitoAuthenticationProvider :: !(Maybe Value)-  , apiGatewayRequestContextIdentityUserArn                       :: !(Maybe Text)-  , apiGatewayRequestContextIdentityUserAgent                     :: !(Maybe Text)-  , apiGatewayRequestContextIdentityUser                          :: !(Maybe Text)-  } deriving (Show)--instance FromJSON ApiGatewayRequestContextIdentity where-  parseJSON (Object v) = ApiGatewayRequestContextIdentity <$>-    v .: "cognitoIdentityPoolId" <*>-    v .: "accountId" <*>-    v .: "cognitoIdentityId" <*>-    v .: "caller" <*>-    v .: "sourceIp" <*>-    v .: "principalOrgId" <*>-    v .: "accessKey" <*>-    v .: "cognitoAuthenticationType" <*>-    v .: "cognitoAuthenticationProvider" <*>-    v .: "userArn" <*>-    v .: "userAgent" <*>-    v .: "user"-  parseJSON _ = fail "Expected ApiGatewayRequestContextIdentity to be an object."--newtype ApiGatewayResponseBody =-  ApiGatewayResponseBody Text-  deriving newtype (ToJSON, FromJSON)--class ToApiGatewayResponseBody a where-  toApiGatewayResponseBody :: a -> ApiGatewayResponseBody---- We special case Text and String to avoid unneeded encoding which will wrap them in quotes-instance {-# OVERLAPPING #-} ToApiGatewayResponseBody Text where-  toApiGatewayResponseBody = ApiGatewayResponseBody--instance {-# OVERLAPPING #-} ToApiGatewayResponseBody String where-  toApiGatewayResponseBody = ApiGatewayResponseBody . T.pack--instance ToJSON a => ToApiGatewayResponseBody a where-  toApiGatewayResponseBody = ApiGatewayResponseBody . toJSONText--data ApiGatewayResponse body = ApiGatewayResponse-  { apiGatewayResponseStatusCode      :: !Int-  , apiGatewayResponseHeaders         :: !ResponseHeaders-  , apiGatewayResponseBody            :: !body-  , apiGatewayResponseIsBase64Encoded :: !Bool-  } deriving (Generic, Show)--instance Functor ApiGatewayResponse where-  fmap f v = v { apiGatewayResponseBody = f (apiGatewayResponseBody v) }--instance ToJSON body => ToJSON (ApiGatewayResponse body)  where-  toJSON = apiGatewayResponseToJSON toJSON--apiGatewayResponseToJSON :: (body -> Value) -> ApiGatewayResponse body -> Value-apiGatewayResponseToJSON bodyTransformer ApiGatewayResponse {..} = object-  [ "statusCode" .= apiGatewayResponseStatusCode-  , "body" .= bodyTransformer apiGatewayResponseBody-  , "headers" .= object (map headerToPair apiGatewayResponseHeaders)-  , "isBase64Encoded" .= apiGatewayResponseIsBase64Encoded-  ]--mkApiGatewayResponse :: Int -> payload -> ApiGatewayResponse payload-mkApiGatewayResponse code payload =-  ApiGatewayResponse code [] payload False--headerToPair :: Header -> T.Pair-headerToPair (cibyte, bstr) = k .= v- where-  k = (T.decodeUtf8 . CI.original) cibyte-  v = T.decodeUtf8 bstr

src/Aws/Lambda/Runtime/ApiInfo.hs view

@@ -1,43 +1,45 @@ module Aws.Lambda.Runtime.ApiInfo-  ( Event(..)-  , fetchEvent-  ) where--import qualified Control.Monad as Monad-import qualified Text.Read as Read+  ( Event (..),+    fetchEvent,+  )+where +import qualified Aws.Lambda.Runtime.API.Endpoints as Endpoints+import qualified Aws.Lambda.Runtime.Error as Error import Control.Exception (IOException) import Control.Exception.Safe.Checked+import qualified Control.Monad as Monad import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as ByteString import qualified Data.ByteString.Lazy.Char8 as Lazy+import Data.Text (Text, pack)+import qualified Data.Text as Text import qualified Network.HTTP.Client as Http import qualified Network.HTTP.Types.Header as Http--import qualified Aws.Lambda.Runtime.API.Endpoints as Endpoints-import qualified Aws.Lambda.Runtime.Error as Error+import qualified Text.Read as Read  -- | Event that is fetched out of the AWS Lambda API data Event = Event-  { deadlineMs         :: !Int-  , traceId            :: !String-  , awsRequestId       :: !String-  , invokedFunctionArn :: !String-  , event              :: !Lazy.ByteString-  } deriving (Show)+  { deadlineMs :: !Int,+    traceId :: !Text,+    awsRequestId :: !Text,+    invokedFunctionArn :: !Text,+    event :: !Lazy.ByteString+  }+  deriving (Show)  -- | Performs a GET to the endpoint that provides the next event-fetchEvent :: Throws Error.Parsing => Http.Manager -> String -> IO Event+fetchEvent :: Throws Error.Parsing => Http.Manager -> Text -> IO Event fetchEvent manager lambdaApi = do   response <- fetchApiData manager lambdaApi   let body = Http.responseBody response       headers = Http.responseHeaders response   Monad.foldM reduceEvent (initialEvent body) headers -fetchApiData :: Http.Manager -> String -> IO (Http.Response Lazy.ByteString)+fetchApiData :: Http.Manager -> Text -> IO (Http.Response Lazy.ByteString) fetchApiData manager lambdaApi = do   let Endpoints.Endpoint endpoint = Endpoints.nextInvocation lambdaApi-  request <- Http.parseRequest endpoint+  request <- Http.parseRequest . Text.unpack $ endpoint   keepRetrying $ Http.httpLbs request manager  reduceEvent :: Throws Error.Parsing => Event -> (Http.HeaderName, ByteString) -> IO Event@@ -45,33 +47,30 @@   case header of     ("Lambda-Runtime-Deadline-Ms", value) ->       case Read.readMaybe $ ByteString.unpack value of-        Just ms -> pure event { deadlineMs = ms }-        Nothing -> throw (Error.Parsing "Could not parse deadlineMs." (ByteString.unpack value) "deadlineMs")-+        Just ms -> pure event {deadlineMs = ms}+        Nothing -> throw (Error.Parsing "Could not parse deadlineMs." (pack $ ByteString.unpack value) "deadlineMs")     ("Lambda-Runtime-Trace-Id", value) ->-      pure event { traceId = ByteString.unpack value }-+      pure event {traceId = pack $ ByteString.unpack value}     ("Lambda-Runtime-Aws-Request-Id", value) ->-      pure event { awsRequestId = ByteString.unpack value }-+      pure event {awsRequestId = pack $ ByteString.unpack value}     ("Lambda-Runtime-Invoked-Function-Arn", value) ->-      pure event { invokedFunctionArn = ByteString.unpack value }-+      pure event {invokedFunctionArn = pack $ ByteString.unpack value}     _ ->       pure event  initialEvent :: Lazy.ByteString -> Event-initialEvent body = Event-  { deadlineMs = 0-  , traceId = ""-  , awsRequestId = ""-  , invokedFunctionArn = ""-  , event = body-  }+initialEvent body =+  Event+    { deadlineMs = 0,+      traceId = "",+      awsRequestId = "",+      invokedFunctionArn = "",+      event = body+    }  keepRetrying :: IO (Http.Response Lazy.ByteString) -> IO (Http.Response Lazy.ByteString) keepRetrying action = do   result <- try action :: IO (Either IOException (Http.Response Lazy.ByteString))   case result of     Right success -> pure success-    _             -> keepRetrying action+    _ -> keepRetrying action

src/Aws/Lambda/Runtime/Common.hs view

@@ -1,90 +1,73 @@-{-# LANGUAGE DeriveLift                 #-}-{-# LANGUAGE DerivingStrategies         #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}  module Aws.Lambda.Runtime.Common-  ( RunCallback-  , LambdaResult(..)-  , LambdaError(..)-  , LambdaOptions(..)-  , DispatcherOptions(..)-  , ApiGatewayDispatcherOptions(..)-  , DispatcherStrategy(..)-  , ToLambdaResponseBody(..)-  , unLambdaResponseBody-  , defaultDispatcherOptions-  ) where+  ( RunCallback,+    LambdaResult (..),+    LambdaError (..),+    LambdaOptions (..),+    ApiGatewayDispatcherOptions (..),+    HandlerType (..),+    HandlerName (..),+    RawEventObject,+  )+where -import Aws.Lambda.Runtime.ApiGatewayInfo+import Aws.Lambda.Runtime.ALB.Types+import Aws.Lambda.Runtime.APIGateway.Types+  ( ApiGatewayDispatcherOptions (..),+    ApiGatewayResponse,+    ApiGatewayResponseBody,+  ) import Aws.Lambda.Runtime.Context (Context)-import Aws.Lambda.Utilities-import Data.Aeson (FromJSON, ToJSON)+import Aws.Lambda.Runtime.StandaloneLambda.Types+  ( StandaloneLambdaResponseBody,+  ) import qualified Data.ByteString.Lazy as Lazy+import Data.Hashable (Hashable) import Data.Text (Text)-import qualified Data.Text as Text import GHC.Generics (Generic)-import Language.Haskell.TH.Syntax (Lift)---- | API Gateway specific dispatcher options-newtype ApiGatewayDispatcherOptions = ApiGatewayDispatcherOptions-  { propagateImpureExceptions :: Bool-  -- ^ Should impure exceptions be propagated through the API Gateway interface-  } deriving (Lift)---- | Options that the dispatcher generator expects-newtype DispatcherOptions = DispatcherOptions-  { apiGatewayDispatcherOptions :: ApiGatewayDispatcherOptions-  } deriving (Lift)--defaultDispatcherOptions :: DispatcherOptions-defaultDispatcherOptions =-  DispatcherOptions (ApiGatewayDispatcherOptions True)---- | A strategy on how to generate the dispatcher functions-data DispatcherStrategy =-  UseWithAPIGateway |-  StandaloneLambda-  deriving (Lift)+import Data.String (IsString)  -- | Callback that we pass to the dispatcher function-type RunCallback context =-  LambdaOptions context -> IO (Either LambdaError LambdaResult)---- | Wrapper type for lambda response body-newtype LambdaResponseBody =-  LambdaResponseBody { unLambdaResponseBody :: Text }-  deriving newtype (ToJSON, FromJSON)--class ToLambdaResponseBody a where-  toStandaloneLambdaResponse :: a -> LambdaResponseBody---- We need to special case String and Text to avoid unneeded encoding--- which results in extra quotes put around plain text responses-instance {-# OVERLAPPING #-} ToLambdaResponseBody String where-  toStandaloneLambdaResponse = LambdaResponseBody . Text.pack+type RunCallback (handlerType :: HandlerType) context =+  LambdaOptions context -> IO (Either (LambdaError handlerType) (LambdaResult handlerType)) -instance {-# OVERLAPPING #-} ToLambdaResponseBody Text where-  toStandaloneLambdaResponse = LambdaResponseBody+-- | A handler name used to configure the lambda in AWS+newtype HandlerName = HandlerName {unHandlerName :: Text}+  deriving newtype (Eq, Show, Read, Ord, Hashable, IsString) -instance ToJSON a => ToLambdaResponseBody a where-  toStandaloneLambdaResponse = LambdaResponseBody . toJSONText+-- | The type of the handler depending on how you proxy the Lambda+data HandlerType+  = StandaloneHandlerType+  | APIGatewayHandlerType+  | ALBHandlerType  -- | Wrapper type for lambda execution results-data LambdaError =-  StandaloneLambdaError LambdaResponseBody |-  ApiGatewayLambdaError (ApiGatewayResponse ApiGatewayResponseBody)+data LambdaError (handlerType :: HandlerType) where+  StandaloneLambdaError :: StandaloneLambdaResponseBody -> LambdaError 'StandaloneHandlerType+  APIGatewayLambdaError :: ApiGatewayResponse ApiGatewayResponseBody -> LambdaError 'APIGatewayHandlerType+  ALBLambdaError :: ALBResponse ALBResponseBody -> LambdaError 'ALBHandlerType  -- | Wrapper type to handle the result of the user-data LambdaResult =-  StandaloneLambdaResult LambdaResponseBody |-  ApiGatewayResult (ApiGatewayResponse ApiGatewayResponseBody)+data LambdaResult (handlerType :: HandlerType) where+  StandaloneLambdaResult :: StandaloneLambdaResponseBody -> LambdaResult 'StandaloneHandlerType+  APIGatewayResult :: ApiGatewayResponse ApiGatewayResponseBody -> LambdaResult 'APIGatewayHandlerType+  ALBResult :: ALBResponse ALBResponseBody -> LambdaResult 'ALBHandlerType +-- | The event received by the lambda before any processing+type RawEventObject = Lazy.ByteString+ -- | Options that the generated main expects data LambdaOptions context = LambdaOptions-  { eventObject     :: !Lazy.ByteString-  , functionHandler :: !String-  , executionUuid   :: !String-  , contextObject   :: !(Context context)-  } deriving (Generic)+  { eventObject :: !RawEventObject,+    functionHandler :: !HandlerName,+    executionUuid :: !Text,+    contextObject :: !(Context context)+  }+  deriving (Generic)

+ src/Aws/Lambda/Runtime/Configuration.hs view

@@ -0,0 +1,16 @@+module Aws.Lambda.Runtime.Configuration+  ( DispatcherOptions (..),+    defaultDispatcherOptions,+  )+where++import Aws.Lambda.Runtime.APIGateway.Types (ApiGatewayDispatcherOptions (..))++-- | Options that the dispatcher generator expects+newtype DispatcherOptions = DispatcherOptions+  { apiGatewayDispatcherOptions :: ApiGatewayDispatcherOptions+  }++defaultDispatcherOptions :: DispatcherOptions+defaultDispatcherOptions =+  DispatcherOptions (ApiGatewayDispatcherOptions True)

src/Aws/Lambda/Runtime/Context.hs view

@@ -1,69 +1,72 @@ module Aws.Lambda.Runtime.Context-  ( Context(..)-  , initialize-  , setEventData-  ) where--import Control.Exception.Safe.Checked-import Data.IORef+  ( Context (..),+    initialize,+    setEventData,+  )+where  import qualified Aws.Lambda.Runtime.ApiInfo as ApiInfo import qualified Aws.Lambda.Runtime.Environment as Environment import qualified Aws.Lambda.Runtime.Error as Error+import Control.Exception.Safe.Checked (Throws)+import Data.IORef (IORef)+import Data.Text (Text)  -- | Context that is passed to all the handlers data Context context = Context-  { memoryLimitInMb    :: !Int-  , functionName       :: !String-  , functionVersion    :: !String-  , invokedFunctionArn :: !String-  , awsRequestId       :: !String-  , xrayTraceId        :: !String-  , logStreamName      :: !String-  , logGroupName       :: !String-  , deadline           :: !Int-  , customContext      :: !(IORef context)+  { memoryLimitInMb :: !Int,+    functionName :: !Text,+    functionVersion :: !Text,+    invokedFunctionArn :: !Text,+    awsRequestId :: !Text,+    xrayTraceId :: !Text,+    logStreamName :: !Text,+    logGroupName :: !Text,+    deadline :: !Int,+    customContext :: !(IORef context)   }  -- | Initializes the context out of the environment-initialize-  :: Throws Error.Parsing-  => Throws Error.EnvironmentVariableNotSet-  => IORef context-  -> IO (Context context)+initialize ::+  Throws Error.Parsing =>+  Throws Error.EnvironmentVariableNotSet =>+  IORef context ->+  IO (Context context) initialize customContextRef = do-  functionName          <- Environment.functionName-  version               <- Environment.functionVersion-  logStream             <- Environment.logStreamName-  logGroup              <- Environment.logGroupName-  memoryLimitInMb       <- Environment.functionMemory--  pure $ Context-    { functionName       = functionName-    , functionVersion    = version-    , logStreamName      = logStream-    , logGroupName       = logGroup-    , memoryLimitInMb    = memoryLimitInMb-    , customContext      = customContextRef+  functionName <- Environment.functionName+  version <- Environment.functionVersion+  logStream <- Environment.logStreamName+  logGroup <- Environment.logGroupName+  memoryLimitInMb <- Environment.functionMemory -    -- We set those to "empty" values because they will be assigned-    -- from the incoming event once one has been received. (see setEventData)-    , invokedFunctionArn = mempty-    , xrayTraceId        = mempty-    , awsRequestId       = mempty-    , deadline           = 0-    }+  pure $+    Context+      { functionName = functionName,+        functionVersion = version,+        logStreamName = logStream,+        logGroupName = logGroup,+        memoryLimitInMb = memoryLimitInMb,+        customContext = customContextRef,+        -- We set those to "empty" values because they will be assigned+        -- from the incoming event once one has been received. (see setEventData)+        invokedFunctionArn = mempty,+        xrayTraceId = mempty,+        awsRequestId = mempty,+        deadline = 0+      }  -- | Sets the context's event data-setEventData-  :: Context context-  -> ApiInfo.Event-  -> IO (Context context)-setEventData context ApiInfo.Event{..} = do+setEventData ::+  Context context ->+  ApiInfo.Event ->+  IO (Context context)+setEventData context ApiInfo.Event {..} = do   Environment.setXRayTrace traceId -  return $ context-    { invokedFunctionArn = invokedFunctionArn-    , xrayTraceId        = traceId-    , awsRequestId       = awsRequestId-    , deadline           = deadlineMs }+  return $+    context+      { invokedFunctionArn = invokedFunctionArn,+        xrayTraceId = traceId,+        awsRequestId = awsRequestId,+        deadline = deadlineMs+      }

src/Aws/Lambda/Runtime/Environment.hs view

@@ -1,51 +1,52 @@-{-| Provides all the values out of-the environment variables of the system--}+-- | Provides all the values out of+-- the environment variables of the system module Aws.Lambda.Runtime.Environment-  ( functionMemory-  , apiEndpoint-  , handlerName-  , taskRoot-  , functionName-  , functionVersion-  , logStreamName-  , logGroupName-  , setXRayTrace-  ) where+  ( functionMemory,+    apiEndpoint,+    handlerName,+    taskRoot,+    functionName,+    functionVersion,+    logStreamName,+    logGroupName,+    setXRayTrace,+  )+where  import qualified Aws.Lambda.Runtime.Error as Error-import Control.Exception.Safe.Checked+import Control.Exception.Safe.Checked (Throws, throw)+import Data.Text (Text, pack, unpack) import qualified System.Environment as Environment import qualified Text.Read as Read -logGroupName :: Throws Error.EnvironmentVariableNotSet => IO String+logGroupName :: Throws Error.EnvironmentVariableNotSet => IO Text logGroupName =   readEnvironmentVariable "AWS_LAMBDA_LOG_GROUP_NAME" -logStreamName :: Throws Error.EnvironmentVariableNotSet => IO String+logStreamName :: Throws Error.EnvironmentVariableNotSet => IO Text logStreamName =   readEnvironmentVariable "AWS_LAMBDA_LOG_STREAM_NAME" -functionVersion :: Throws Error.EnvironmentVariableNotSet => IO String+functionVersion :: Throws Error.EnvironmentVariableNotSet => IO Text functionVersion =   readEnvironmentVariable "AWS_LAMBDA_FUNCTION_VERSION" -functionName :: Throws Error.EnvironmentVariableNotSet => IO String+functionName :: Throws Error.EnvironmentVariableNotSet => IO Text functionName =   readEnvironmentVariable "AWS_LAMBDA_FUNCTION_NAME" -setXRayTrace :: String -> IO ()-setXRayTrace = Environment.setEnv "_X_AMZN_TRACE_ID"+setXRayTrace :: Text -> IO ()+setXRayTrace = Environment.setEnv "_X_AMZN_TRACE_ID" . unpack -taskRoot :: Throws Error.EnvironmentVariableNotSet => IO String+taskRoot :: Throws Error.EnvironmentVariableNotSet => IO Text taskRoot =   readEnvironmentVariable "LAMBDA_TASK_ROOT" -handlerName :: Throws Error.EnvironmentVariableNotSet => IO String+handlerName :: Throws Error.EnvironmentVariableNotSet => IO Text handlerName =   readEnvironmentVariable "_HANDLER" -apiEndpoint :: Throws Error.EnvironmentVariableNotSet => IO String+apiEndpoint :: Throws Error.EnvironmentVariableNotSet => IO Text apiEndpoint =   readEnvironmentVariable "AWS_LAMBDA_RUNTIME_API" @@ -53,13 +54,13 @@ functionMemory = do   let envVar = "AWS_LAMBDA_FUNCTION_MEMORY_SIZE"   memoryValue <- readEnvironmentVariable envVar-  case Read.readMaybe memoryValue of+  case Read.readMaybe (unpack memoryValue) of     Just value -> pure value-    Nothing    -> throw (Error.Parsing envVar memoryValue envVar)+    Nothing -> throw (Error.Parsing envVar memoryValue envVar) -readEnvironmentVariable :: Throws Error.EnvironmentVariableNotSet => String -> IO String+readEnvironmentVariable :: Throws Error.EnvironmentVariableNotSet => Text -> IO Text readEnvironmentVariable envVar = do-  v <- Environment.lookupEnv envVar+  v <- Environment.lookupEnv (unpack envVar)   case v of-    Just value -> pure value-    Nothing    -> throw (Error.EnvironmentVariableNotSet envVar)+    Just value -> pure . pack $ value+    Nothing -> throw (Error.EnvironmentVariableNotSet envVar)

src/Aws/Lambda/Runtime/Error.hs view

@@ -1,38 +1,42 @@-{-| All the errors that the runtime can throw--}+-- | All the errors that the runtime can throw module Aws.Lambda.Runtime.Error-  ( EnvironmentVariableNotSet(..)-  , Parsing(..)-  , Invocation(..)-  ) where+  ( EnvironmentVariableNotSet (..),+    Parsing (..),+    Invocation (..),+  )+where -import Control.Exception.Safe.Checked-import Data.Aeson (ToJSON (..), object, (.=), Value)+import Control.Exception.Safe.Checked (Exception)+import Data.Aeson (ToJSON (..), Value, object, (.=))+import Data.Text (Text) -newtype EnvironmentVariableNotSet =-  EnvironmentVariableNotSet String+newtype EnvironmentVariableNotSet+  = EnvironmentVariableNotSet Text   deriving (Show, Exception)  instance ToJSON EnvironmentVariableNotSet where-  toJSON (EnvironmentVariableNotSet msg) = object-    [ "errorType" .= ("EnvironmentVariableNotSet" :: String)-    , "errorMessage" .= msg-    ]+  toJSON (EnvironmentVariableNotSet msg) =+    object+      [ "errorType" .= ("EnvironmentVariableNotSet" :: Text),+        "errorMessage" .= msg+      ]  data Parsing = Parsing-  { errorMessage :: String-  , actualValue  :: String-  , valueName    :: String-  } deriving (Show, Exception)+  { errorMessage :: Text,+    actualValue :: Text,+    valueName :: Text+  }+  deriving (Show, Exception)  instance ToJSON Parsing where-  toJSON (Parsing errorMessage _ valueName) = object-    [ "errorType" .= ("Parsing" :: String)-    , "errorMessage" .= ("Could not parse '" <> valueName <> "': " <> errorMessage)-    ]+  toJSON (Parsing errorMessage _ valueName) =+    object+      [ "errorType" .= ("Parsing" :: Text),+        "errorMessage" .= ("Could not parse '" <> valueName <> "': " <> errorMessage)+      ] -newtype Invocation =-  Invocation Value+newtype Invocation+  = Invocation Value   deriving (Show, Exception)  instance ToJSON Invocation where

src/Aws/Lambda/Runtime/Publish.hs view

@@ -1,62 +1,71 @@-{-| Publishing of results/errors back to the-AWS Lambda runtime API -}-module Aws.Lambda.Runtime.Publish-  ( result-  , invocationError-  , parsingError-  , runtimeInitError-  ) where+{-# LANGUAGE GADTs #-} -import Control.Monad (void)-import Data.Aeson-import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Client as Http+-- | Publishing of results/errors back to the+-- AWS Lambda runtime API+module Aws.Lambda.Runtime.Publish+  ( result,+    invocationError,+    parsingError,+    runtimeInitError,+  )+where  import qualified Aws.Lambda.Runtime.API.Endpoints as Endpoints import Aws.Lambda.Runtime.Common import Aws.Lambda.Runtime.Context (Context (..)) import qualified Aws.Lambda.Runtime.Error as Error+import Aws.Lambda.Runtime.StandaloneLambda.Types+import Control.Monad (void)+import Data.Aeson+import Data.Text (Text, unpack)+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Client as Http  -- | Publishes the result back to AWS Lambda-result :: LambdaResult -> String -> Context context -> Http.Manager -> IO ()+result :: LambdaResult handlerType -> Text -> Context context -> Http.Manager -> IO () result lambdaResult lambdaApi context manager = do   let Endpoints.Endpoint endpoint = Endpoints.response lambdaApi (awsRequestId context)-  rawRequest <- Http.parseRequest endpoint+  rawRequest <- Http.parseRequest . unpack $ endpoint    let requestBody = case lambdaResult of-        (StandaloneLambdaResult res) -> Http.RequestBodyBS (T.encodeUtf8 . unLambdaResponseBody $ res)-        (ApiGatewayResult res)       -> Http.RequestBodyLBS (encode res)-      request = rawRequest-                { Http.method = "POST"-                , Http.requestBody = requestBody-                }+        (StandaloneLambdaResult res) -> Http.RequestBodyBS (T.encodeUtf8 . unStandaloneLambdaResponseBody $ res)+        (APIGatewayResult res) -> Http.RequestBodyLBS (encode res)+        (ALBResult res) -> Http.RequestBodyLBS (encode res)+      request =+        rawRequest+          { Http.method = "POST",+            Http.requestBody = requestBody+          }    void $ Http.httpNoBody request manager  -- | Publishes an invocation error back to AWS Lambda-invocationError :: Error.Invocation -> String -> Context context -> Http.Manager -> IO ()+invocationError :: Error.Invocation -> Text -> Context context -> Http.Manager -> IO () invocationError err lambdaApi context =   publish err (Endpoints.invocationError lambdaApi $ awsRequestId context) context  -- | Publishes a parsing error back to AWS Lambda-parsingError :: Error.Parsing -> String -> Context context -> Http.Manager -> IO ()+parsingError :: Error.Parsing -> Text -> Context context -> Http.Manager -> IO () parsingError err lambdaApi context =-  publish err (Endpoints.invocationError lambdaApi $ awsRequestId context)+  publish+    err+    (Endpoints.invocationError lambdaApi $ awsRequestId context)     context  -- | Publishes a runtime initialization error back to AWS Lambda-runtimeInitError :: ToJSON err => err -> String -> Context context -> Http.Manager -> IO ()+runtimeInitError :: ToJSON err => err -> Text -> Context context -> Http.Manager -> IO () runtimeInitError err lambdaApi =   publish err (Endpoints.runtimeInitError lambdaApi)  publish :: ToJSON err => err -> Endpoints.Endpoint -> Context context -> Http.Manager -> IO ()-publish err (Endpoints.Endpoint endpoint) Context{..} manager = do-  rawRequest <- Http.parseRequest endpoint+publish err (Endpoints.Endpoint endpoint) _context manager = do+  rawRequest <- Http.parseRequest . unpack $ endpoint    let requestBody = Http.RequestBodyLBS (encode err)-      request = rawRequest-                { Http.method = "POST"-                , Http.requestBody = requestBody-                }+      request =+        rawRequest+          { Http.method = "POST",+            Http.requestBody = requestBody+          }    void $ Http.httpNoBody request manager

+ src/Aws/Lambda/Runtime/StandaloneLambda/Types.hs view

@@ -0,0 +1,33 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Aws.Lambda.Runtime.StandaloneLambda.Types+  ( StandaloneLambdaResponseBody (..),+    ToStandaloneLambdaResponseBody (..),+  )+where++import Aws.Lambda.Utilities (toJSONText)+import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import qualified Data.Text as Text++-- | Wrapper type for lambda response body+newtype StandaloneLambdaResponseBody = StandaloneLambdaResponseBody {unStandaloneLambdaResponseBody :: Text}+  deriving newtype (ToJSON, FromJSON)++class ToStandaloneLambdaResponseBody a where+  toStandaloneLambdaResponse :: a -> StandaloneLambdaResponseBody++-- We need to special case String and Text to avoid unneeded encoding+-- which results in extra quotes put around plain text responses+instance {-# OVERLAPPING #-} ToStandaloneLambdaResponseBody String where+  toStandaloneLambdaResponse = StandaloneLambdaResponseBody . Text.pack++instance {-# OVERLAPPING #-} ToStandaloneLambdaResponseBody Text where+  toStandaloneLambdaResponse = StandaloneLambdaResponseBody++instance ToJSON a => ToStandaloneLambdaResponseBody a where+  toStandaloneLambdaResponse = StandaloneLambdaResponseBody . toJSONText

+ src/Aws/Lambda/Setup.hs view

@@ -0,0 +1,211 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Aws.Lambda.Setup+  ( Handler (..),+    HandlerName (..),+    Handlers,+    run,+    addStandaloneLambdaHandler,+    addAPIGatewayHandler,+    addALBHandler,+    runLambdaHaskellRuntime,+  )+where++import Aws.Lambda.Runtime (runLambda)+import Aws.Lambda.Runtime.ALB.Types+  ( ALBRequest,+    ALBResponse,+    ToALBResponseBody (..),+    mkALBResponse,+  )+import Aws.Lambda.Runtime.APIGateway.Types+  ( ApiGatewayDispatcherOptions (propagateImpureExceptions),+    ApiGatewayRequest,+    ApiGatewayResponse,+    ToApiGatewayResponseBody (..),+    mkApiGatewayResponse,+  )+import Aws.Lambda.Runtime.Common+  ( HandlerName (..),+    HandlerType (..),+    LambdaError (..),+    LambdaOptions (LambdaOptions),+    LambdaResult (..),+    RawEventObject,+  )+import Aws.Lambda.Runtime.Configuration+  ( DispatcherOptions (apiGatewayDispatcherOptions),+  )+import Aws.Lambda.Runtime.Context (Context)+import Aws.Lambda.Runtime.StandaloneLambda.Types+  ( ToStandaloneLambdaResponseBody (..),+  )+import Aws.Lambda.Utilities (decodeObj)+import Control.Exception (SomeException)+import Control.Monad.Catch (MonadCatch (catch), throwM)+import Control.Monad.State as State+  ( MonadIO (..),+    MonadState,+    StateT (..),+    modify,+  )+import Data.Aeson (FromJSON)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as Text+import Data.Typeable (Typeable)+import GHC.IO.Handle.FD (stderr)+import GHC.IO.Handle.Text (hPutStr)++type Handlers handlerType m context request response error =+  HM.HashMap HandlerName (Handler handlerType m context request response error)++type StandaloneCallback m context request response error =+  (request -> Context context -> m (Either error response))++type APIGatewayCallback m context request response error =+  (ApiGatewayRequest request -> Context context -> m (Either (ApiGatewayResponse error) (ApiGatewayResponse response)))++type ALBCallback m context request response error =+  (ALBRequest request -> Context context -> m (Either (ALBResponse error) (ALBResponse response)))++data Handler (handlerType :: HandlerType) m context request response error where+  StandaloneLambdaHandler :: StandaloneCallback m context request response error -> Handler 'StandaloneHandlerType m context request response error+  APIGatewayHandler :: APIGatewayCallback m context request response error -> Handler 'APIGatewayHandlerType m context request response error+  ALBHandler :: ALBCallback m context request response error -> Handler 'ALBHandlerType m context request response error++newtype HandlersM (handlerType :: HandlerType) m context request response error a = HandlersM+  {runHandlersM :: StateT (Handlers handlerType m context request response error) IO a}+  deriving newtype+    ( Functor,+      Applicative,+      Monad,+      MonadState (Handlers handlerType m context request response error)+    )++type RuntimeContext (handlerType :: HandlerType) m context request response error =+  ( MonadIO m,+    MonadCatch m,+    ToStandaloneLambdaResponseBody error,+    ToStandaloneLambdaResponseBody response,+    ToApiGatewayResponseBody error,+    ToApiGatewayResponseBody response,+    ToALBResponseBody error,+    ToALBResponseBody response,+    FromJSON (ApiGatewayRequest request),+    FromJSON (ALBRequest request),+    FromJSON request,+    Typeable request+  )++runLambdaHaskellRuntime ::+  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 options initializeContext mToIO initHandlers = do+  handlers <- fmap snd . flip runStateT HM.empty . runHandlersM $ initHandlers+  runLambda initializeContext (run options mToIO handlers)++run ::+  RuntimeContext handlerType m context request response error =>+  DispatcherOptions ->+  (forall a. m a -> IO a) ->+  Handlers handlerType m context request response error ->+  LambdaOptions context ->+  IO (Either (LambdaError handlerType) (LambdaResult handlerType))+run dispatcherOptions mToIO handlers (LambdaOptions eventObject functionHandler _executionUuid contextObject) = do+  let asIOCallbacks = HM.map (mToIO . handlerToCallback dispatcherOptions eventObject contextObject) handlers+  case HM.lookup functionHandler asIOCallbacks of+    Just handlerToCall -> handlerToCall+    Nothing ->+      throwM $+        userError $+          "Could not find handler '" <> (Text.unpack . unHandlerName $ functionHandler) <> "'."++addStandaloneLambdaHandler ::+  HandlerName ->+  StandaloneCallback m context request response error ->+  HandlersM 'StandaloneHandlerType m context request response error ()+addStandaloneLambdaHandler handlerName handler =+  State.modify (HM.insert handlerName (StandaloneLambdaHandler handler))++addAPIGatewayHandler ::+  HandlerName ->+  APIGatewayCallback m context request response error ->+  HandlersM 'APIGatewayHandlerType m context request response error ()+addAPIGatewayHandler handlerName handler =+  State.modify (HM.insert handlerName (APIGatewayHandler handler))++addALBHandler ::+  HandlerName ->+  ALBCallback m context request response error ->+  HandlersM 'ALBHandlerType m context request response error ()+addALBHandler handlerName handler =+  State.modify (HM.insert handlerName (ALBHandler handler))++handlerToCallback ::+  forall handlerType m context request response error.+  RuntimeContext handlerType m context request response error =>+  DispatcherOptions ->+  RawEventObject ->+  Context context ->+  Handler handlerType m context request response error ->+  m (Either (LambdaError handlerType) (LambdaResult handlerType))+handlerToCallback dispatcherOptions rawEventObject context handlerToCall =+  call `catch` handleError+  where+    call =+      case handlerToCall of+        StandaloneLambdaHandler handler ->+          case decodeObj @request rawEventObject of+            Right request ->+              either+                (Left . StandaloneLambdaError . toStandaloneLambdaResponse)+                (Right . StandaloneLambdaResult . toStandaloneLambdaResponse)+                <$> handler request context+            Left err -> return . Left . StandaloneLambdaError . toStandaloneLambdaResponse $ err+        APIGatewayHandler handler -> do+          case decodeObj @(ApiGatewayRequest request) rawEventObject of+            Right request ->+              either+                (Left . APIGatewayLambdaError . fmap toApiGatewayResponseBody)+                (Right . APIGatewayResult . fmap toApiGatewayResponseBody)+                <$> handler request context+            Left err -> apiGatewayErr 400 . toApiGatewayResponseBody . Text.pack . show $ err+        ALBHandler handler ->+          case decodeObj @(ALBRequest request) rawEventObject of+            Right request ->+              either+                (Left . ALBLambdaError . fmap toALBResponseBody)+                (Right . ALBResult . fmap toALBResponseBody)+                <$> handler request context+            Left err -> albErr 400 . toALBResponseBody . Text.pack . show $ err++    handleError (exception :: SomeException) = do+      liftIO $ hPutStr stderr . show $ exception+      case handlerToCall of+        StandaloneLambdaHandler _ ->+          return . Left . StandaloneLambdaError . toStandaloneLambdaResponse . Text.pack . show $ exception+        ALBHandler _ ->+          albErr 500 . toALBResponseBody . Text.pack . show $ exception+        APIGatewayHandler _ ->+          if propagateImpureExceptions . apiGatewayDispatcherOptions $ dispatcherOptions+            then apiGatewayErr 500 . toApiGatewayResponseBody . Text.pack . show $ exception+            else apiGatewayErr 500 . toApiGatewayResponseBody . Text.pack $ "Something went wrong."++    apiGatewayErr statusCode =+      pure . Left . APIGatewayLambdaError . mkApiGatewayResponse statusCode []++    albErr statusCode =+      pure . Left . ALBLambdaError . mkALBResponse statusCode []

src/Aws/Lambda/Utilities.hs view

@@ -1,9 +1,30 @@-module Aws.Lambda.Utilities (toJSONText) where+module Aws.Lambda.Utilities+  ( toJSONText,+    tshow,+    decodeObj,+  )+where -import Data.Aeson+import qualified Aws.Lambda.Runtime.Error as Error+import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import qualified Data.ByteString.Lazy.Char8 as LazyByteString-import Data.Text+import Data.Text (Text, pack)+import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Data.Typeable (Proxy (..), Typeable, typeRep)  toJSONText :: ToJSON a => a -> Text toJSONText = T.decodeUtf8 . LazyByteString.toStrict . encode++tshow :: Show a => a -> Text+tshow = T.pack . show++-- | Helper function that the dispatcher will use to+-- decode the JSON that comes as an AWS Lambda event into the+-- appropriate type expected by the handler.+decodeObj :: forall a. (FromJSON a, Typeable a) => LazyByteString.ByteString -> Either Error.Parsing a+decodeObj x =+  let objName = pack . show $ typeRep (Proxy :: Proxy a)+   in case eitherDecode x of+        Left e -> Left $ Error.Parsing (pack e) (pack . LazyByteString.unpack $ x) objName+        Right v -> return v

test/Spec.hs view

@@ -1,7 +1,7 @@-import           Test.Hspec-+import Test.Hspec  main :: IO ()-main = hspec $ describe "Useless test spec" $ do-  it "runs" $ do-    (1 + 1 :: Int) `shouldBe` (2 :: Int)+main = hspec $+  describe "Useless test spec" $ do+    it "runs" $ do+      (1 + 1 :: Int) `shouldBe` (2 :: Int)