diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -110,6 +110,20 @@ # ... ``` +You'll need to either build on a compatible linux host or inside a compatible docker container (or some other mechanism like nix). +Note that current Stack LTS images are _not_ compatible. +If you see an error message that contains "version 'GLIBC_X.XX' not found" when running (hosted or locally), then your build environment is not compatible. + +Enable stack's docker integration and define an optional image within stack.yaml: + +```yaml +# file: stack.yaml +docker: + enabled: true + # If omitted, this defaults to fpco/stack-build:lts-${YOUR_LTS_VERSION} + image: ${BUILD_IMAGE} +``` + Don't forget to define your [CloudFormation] stack: ```yaml @@ -164,7 +178,6 @@ - [Stack][stack.yaml] - [Docker] - - [aws-sam-cli] (>v0.8.0) ### Build @@ -173,7 +186,18 @@ stack build --copy-bins ``` -### Execute +### Execute w/ Docker + +```bash +echo '{ "accountId": "byebye" }' | docker run -i --rm \ + -e DOCKER_LAMBDA_USE_STDIN=1 \ + -v ${PWD}/.stack-work/docker/_home/.local/bin/:/var/task \ + lambci/lambda:provided +``` + +### Execute w/ SAM Local + +Note that hal currently only supports [aws-sam-cli] on versions <1.0. ```bash echo '{ "accountId": "byebye" }' | sam local invoke --region us-east-1 diff --git a/hal.cabal b/hal.cabal --- a/hal.cabal +++ b/hal.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d43ec18e49bb7ce77fd444cdf150662cb6ff0f3c8ba1349dbd4318e6b5bc7e29 +-- hash: ac72c27a2329613830cbbdeaf5c590a17af49cb9f6987d444b538ded08a8d451 name: hal -version: 0.4.6 +version: 0.4.7 synopsis: A runtime environment for Haskell applications running on AWS Lambda. description: This library uniquely supports different types of AWS Lambda Handlers for your needs/comfort with advanced Haskell. Instead of exposing a single function @@ -40,6 +40,7 @@ AWS.Lambda.Runtime AWS.Lambda.Runtime.Value AWS.Lambda.RuntimeClient + AWS.Lambda.RuntimeClient.Internal other-modules: Paths_hal hs-source-dirs: @@ -55,13 +56,32 @@ , conduit , conduit-extra , containers - , envy <2 + , envy , exceptions , http-client - , http-conduit , http-types , mtl , text , time , unordered-containers + default-language: Haskell2010 + +test-suite hal-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_hal + hs-source-dirs: + test + default-extensions: OverloadedStrings BangPatterns DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DuplicateRecordFields EmptyCase GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms ScopedTypeVariables + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-partial-type-signatures -fno-warn-name-shadowing -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , containers + , hal + , hspec + , http-client + , http-types + , time default-language: Haskell2010 diff --git a/src/AWS/Lambda/Combinators.hs b/src/AWS/Lambda/Combinators.hs --- a/src/AWS/Lambda/Combinators.hs +++ b/src/AWS/Lambda/Combinators.hs @@ -31,7 +31,6 @@ Left e -> error e Right x -> return x - -- | Upgrades a handler that uses the `IO` monad with an `Either` inside into a -- base runtime handler. -- @@ -71,6 +70,7 @@ -- main :: IO () -- main = (readerTRuntime . withIOInterface) myHandler -- @ +{-# DEPRECATED withIOInterface "This combinator is useful when combined with the current mRuntimeWithContext, which is deprecated." #-} withIOInterface :: (MonadReader c m, MonadIO m) => (c -> b -> IO (Either String a)) -> (b -> m a) withIOInterface fn event = do config <- ask @@ -114,6 +114,7 @@ -- main :: IO () -- main = (readerTRuntime . withFallibleInterface) myHandler -- @ +{-# DEPRECATED withFallibleInterface "This combinator is useful when combined with the current mRuntimeWithContext, which is deprecated." #-} withFallibleInterface :: MonadReader c m => (c -> b -> Either String a) -> b -> m a withFallibleInterface fn event = do config <- ask @@ -155,6 +156,7 @@ -- main :: IO () -- main = (readerTRuntime . withPureInterface) myHandler -- @ +{-# DEPRECATED withPureInterface "This combinator is useful when combined with the current mRuntimeWithContext, which is deprecated." #-} withPureInterface :: MonadReader c m => (c -> b -> a) -> b -> m a withPureInterface fn event = do config <- ask diff --git a/src/AWS/Lambda/Context.hs b/src/AWS/Lambda/Context.hs --- a/src/AWS/Lambda/Context.hs +++ b/src/AWS/Lambda/Context.hs @@ -14,9 +14,9 @@ ClientContext(..), CognitoIdentity(..), LambdaContext(..), + getRemainingTime, HasLambdaContext(..), defConfig, - getRemainingTime, runReaderTLambdaContext ) where @@ -36,7 +36,7 @@ appVersionName :: Text, appVersionCode :: Text, appPackageName :: Text - } deriving (Show, Generic) + } deriving (Show, Generic, Eq) instance ToJSON ClientApplication instance FromJSON ClientApplication @@ -45,7 +45,7 @@ { client :: ClientApplication, custom :: Map Text Text, environment :: Map Text Text - } deriving (Show, Generic) + } deriving (Show, Generic, Eq) instance ToJSON ClientContext instance FromJSON ClientContext @@ -53,7 +53,7 @@ data CognitoIdentity = CognitoIdentity { identityId :: Text , identityPoolId :: Text - } deriving (Show, Generic) + } deriving (Show, Generic, Eq) instance ToJSON CognitoIdentity instance FromJSON CognitoIdentity @@ -75,17 +75,24 @@ deadline :: UTCTime, clientContext :: Maybe ClientContext, identity :: Maybe CognitoIdentity - } deriving (Show, Generic) + } deriving (Show, Generic, Eq) +{-# DEPRECATED HasLambdaContext "HasLambdaContext will be removed along with the original mRuntimeWithContext. This utility is no longer necessary without it." #-} class HasLambdaContext r where withContext :: (LambdaContext -> r -> r) instance HasLambdaContext LambdaContext where withContext = const +-- TODO: This sticks around for backwards compatibility, and as a conevient-ish +-- way to runReaderTLambdaContext. In the long term, all runtimes where the +-- LambdaContext is (incorrectly) available outside of the request/response +-- cycle will be removed. This instance (and its dependent package, envy) can +-- be dropped on that breaking change. instance DefConfig LambdaContext where defConfig = LambdaContext "" "" 0 "" "" "" "" "" (posixSecondsToUTCTime 0) Nothing Nothing -- | Helper for using arbitrary monads with only the LambdaContext in its Reader +{-# DEPRECATED runReaderTLambdaContext "runReaderTLambdaContext will be removed along with the original mRuntimeWithContext. This particular approach was problematic, in that it required a default LambdaContext, when in reality, there is no valid instance." #-} runReaderTLambdaContext :: ReaderT LambdaContext m a -> m a runReaderTLambdaContext = flip runReaderT defConfig diff --git a/src/AWS/Lambda/Internal.hs b/src/AWS/Lambda/Internal.hs --- a/src/AWS/Lambda/Internal.hs +++ b/src/AWS/Lambda/Internal.hs @@ -12,16 +12,18 @@ module AWS.Lambda.Internal ( StaticContext(..), DynamicContext(..), + getStaticContext, mkContext ) where import AWS.Lambda.Context (ClientContext, CognitoIdentity, LambdaContext (LambdaContext)) -import Data.Text (Text) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) import Data.Time.Clock (UTCTime) import GHC.Generics (Generic) -import System.Envy (DefConfig (..), FromEnv, Option (..), - fromEnv, gFromEnvCustom) +import System.Environment (getEnv) +import Text.Read (readMaybe) data StaticContext = StaticContext { functionName :: Text, @@ -31,14 +33,14 @@ logStreamName :: Text } deriving (Show, Generic) -instance DefConfig StaticContext where - defConfig = StaticContext "" "" 0 "" "" - -instance FromEnv StaticContext where - fromEnv = gFromEnvCustom Option { - dropPrefixCount = 0, - customPrefix = "AWS_LAMBDA" - } +getStaticContext :: IO StaticContext +getStaticContext = + StaticContext <$> (pack <$> getEnv "AWS_LAMBDA_FUNCTION_NAME") <*> + (pack <$> getEnv "AWS_LAMBDA_FUNCTION_VERSION") <*> + ((fromMaybe (error "AWS_LAMBDA_FUNCTION_MEMORY_SIZE was not an Int") . readMaybe) <$> + getEnv "AWS_LAMBDA_FUNCTION_MEMORY_SIZE") <*> + (pack <$> getEnv "AWS_LAMBDA_LOG_GROUP_NAME") <*> + (pack <$> getEnv "AWS_LAMBDA_LOG_STREAM_NAME") data DynamicContext = DynamicContext { awsRequestId :: Text, diff --git a/src/AWS/Lambda/Runtime.hs b/src/AWS/Lambda/Runtime.hs --- a/src/AWS/Lambda/Runtime.hs +++ b/src/AWS/Lambda/Runtime.hs @@ -25,61 +25,145 @@ ioRuntime, ioRuntimeWithContext, readerTRuntime, + mRuntimeWithContext', + mRuntime, mRuntimeWithContext ) where -import AWS.Lambda.Combinators (withIOInterface, - withFallibleInterface, - withPureInterface, - withoutContext, - withInfallibleParse) -import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..), runReaderTLambdaContext) +import AWS.Lambda.Combinators (withInfallibleParse) +import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..)) import qualified AWS.Lambda.Runtime.Value as ValueRuntime import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader, ReaderT) import Data.Aeson (FromJSON, ToJSON) +-- | For any monad that supports 'IO' and 'catch'. Useful if you need +-- caching behaviours or are comfortable manipulating monad +-- transformers, and want full control over your monadic interface. +-- +-- In a future version, this function will be renamed to +-- @mRuntimeWithContext@ (after the deprecated function is removed). +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric, NamedFieldPuns \#-} +-- +-- module Main where +-- +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (mRuntimeWithContext') +-- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) +-- +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: LambdaContext -> Named -> StateT Int IO String +-- myHandler LambdaContext { functionName } Named { name } = do +-- greeting <- liftIO $ getEnv \"GREETING\" +-- +-- greetingCount <- get +-- put $ greetingCount + 1 +-- +-- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ") from " ++ unpack functionName ++ "!" +-- +-- main :: IO () +-- main = evalStateT (mRuntimeWithContext' myHandler) 0 +-- @ +mRuntimeWithContext' :: (MonadCatch m, MonadIO m, FromJSON event, ToJSON result) => (LambdaContext -> event -> m result) -> m () +mRuntimeWithContext' = ValueRuntime.mRuntimeWithContext' . fmap withInfallibleParse + + +-- | For any monad that supports 'IO' and 'catch'. Useful if you need +-- caching behaviours or are comfortable manipulating monad +-- transformers, want full control over your monadic interface, but +-- don't need to inspect the 'LambdaContext'. +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric, NamedFieldPuns \#-} +-- +-- module Main where +-- +-- import AWS.Lambda.Runtime (mRuntime) +-- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (FromJSON) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) +-- +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: Named -> StateT Int IO String +-- myHandler Named { name } = do +-- greeting <- liftIO $ getEnv \"GREETING\" +-- +-- greetingCount <- get +-- put $ greetingCount + 1 +-- +-- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ")!" +-- +-- main :: IO () +-- main = evalStateT (mRuntime myHandler) 0 +-- @ +mRuntime :: (MonadCatch m, MonadIO m, FromJSON event, ToJSON result) => (event -> m result) -> m () +mRuntime = ValueRuntime.mRuntime . withInfallibleParse + + --TODO: Revisit all names before we put them under contract --- | For any monad that supports IO/catch/Reader LambdaContext. +-- | For any monad that supports IO\/catch\/Reader LambdaContext. -- --- Use this if you need caching behavours or are comfortable --- manipulating monad transformers and want full control over --- your monadic interface. +-- This function is problematic, and has been deprecated. The +-- 'HasLambdaContext' constraint requires that a 'LambdaContext' is +-- settable in the @m@ monad, but that is not the case - we only have +-- a 'LambdaContext' during the request/response cycle. -- +-- If you need caching behavours or are comfortable manipulating monad +-- transformers and want full control over your monadic interface, +-- consider 'mRuntimeWithContext''. +-- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..), runReaderTLambdaContext) --- import AWS.Lambda.Runtime (mRuntimeWithContext) --- import Control.Monad.Reader (ReaderT, ask) --- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) --- import Control.Monad.Trans (liftIO) --- import Data.Aeson (FromJSON) --- import Data.Text (unpack) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..), runReaderTLambdaContext) +-- import AWS.Lambda.Runtime (mRuntimeWithContext) +-- import Control.Monad.Reader (ReaderT, ask) +-- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Named -> StateT Int (ReaderT LambdaContext IO) String --- myHandler Named { name } = do --- LambdaContext { functionName } <- ask --- greeting <- liftIO $ getEnv \"GREETING\" +-- myHandler :: Named -> StateT Int (ReaderT LambdaContext IO) String +-- myHandler Named { name } = do +-- LambdaContext { functionName } <- ask +-- greeting <- liftIO $ getEnv \"GREETING\" -- --- greetingCount <- get --- put $ greetingCount + 1 +-- greetingCount <- get +-- put $ greetingCount + 1 -- --- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ") from " ++ unpack functionName ++ "!" +-- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ") from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = runReaderTLambdaContext (evalStateT (mRuntimeWithContext myHandler) 0) +-- main :: IO () +-- main = runReaderTLambdaContext (evalStateT (mRuntimeWithContext myHandler) 0) -- @ +{-# DEPRECATED mRuntimeWithContext "mRuntimeWithContext will be replaced by mRuntimeWithContext' in a future version. This type signature makes impossible promises - see the haddock for details." #-} mRuntimeWithContext :: (HasLambdaContext r, MonadCatch m, MonadReader r m, MonadIO m, FromJSON event, ToJSON result) => (event -> m result) -> m () mRuntimeWithContext = ValueRuntime.mRuntimeWithContext . withInfallibleParse @@ -92,36 +176,36 @@ -- However, do not use this runtime if you need stateful (caching) behaviors. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (readerTRuntime) --- import Control.Monad.Reader (ReaderT, ask) --- import Control.Monad.Trans (liftIO) --- import Data.Aeson (FromJSON) --- import Data.Text (unpack) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (readerTRuntime) +-- import Control.Monad.Reader (ReaderT, ask) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Named -> ReaderT LambdaContext IO String --- myHandler Named { name } = do --- LambdaContext { functionName } <- ask --- greeting <- liftIO $ getEnv \"GREETING\" --- return $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" +-- myHandler :: Named -> ReaderT LambdaContext IO String +-- myHandler Named { name } = do +-- LambdaContext { functionName } <- ask +-- greeting <- liftIO $ getEnv \"GREETING\" +-- return $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = readerTRuntime myHandler +-- main :: IO () +-- main = readerTRuntime myHandler -- @ readerTRuntime :: (FromJSON event, ToJSON result) => (event -> ReaderT LambdaContext IO result) -> IO () -readerTRuntime = runReaderTLambdaContext . mRuntimeWithContext +readerTRuntime = ValueRuntime.readerTRuntime . withInfallibleParse -- | For functions with IO that can fail in a pure way (or via throw). -- @@ -131,33 +215,33 @@ -- However, do not use this runtime if you need stateful (caching) behaviors. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (ioRuntimeWithContext) --- import Data.Aeson (FromJSON) --- import Data.Text (unpack) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (ioRuntimeWithContext) +-- import Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: LambdaContext -> Named -> IO (Either String String) --- myHandler (LambdaContext { functionName }) (Named { name }) = do --- greeting <- getEnv \"GREETING\" --- return $ pure $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" +-- myHandler :: LambdaContext -> Named -> IO (Either String String) +-- myHandler (LambdaContext { functionName }) (Named { name }) = do +-- greeting <- getEnv \"GREETING\" +-- return $ pure $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = ioRuntimeWithContext myHandler +-- main :: IO () +-- main = ioRuntimeWithContext myHandler -- @ ioRuntimeWithContext :: (FromJSON event, ToJSON result) => (LambdaContext -> event -> IO (Either String result)) -> IO () -ioRuntimeWithContext = readerTRuntime . withIOInterface +ioRuntimeWithContext = ValueRuntime.ioRuntimeWithContext . fmap withInfallibleParse -- | For functions with IO that can fail in a pure way (or via throw). -- @@ -166,31 +250,31 @@ -- However, do not use this runtime if you need stateful (caching) behaviors. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Runtime (ioRuntime) --- import Data.Aeson (FromJSON) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Runtime (ioRuntime) +-- import Data.Aeson (FromJSON) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Named -> IO (Either String String) --- myHandler (Named { name }) = do --- greeting <- getEnv \"GREETING\" --- return $ pure $ greeting ++ name +-- myHandler :: Named -> IO (Either String String) +-- myHandler (Named { name }) = do +-- greeting <- getEnv \"GREETING\" +-- return $ pure $ greeting ++ name -- --- main :: IO () --- main = ioRuntime myHandler +-- main :: IO () +-- main = ioRuntime myHandler -- @ ioRuntime :: (FromJSON event, ToJSON result) => (event -> IO (Either String result)) -> IO () -ioRuntime = readerTRuntime . withIOInterface . withoutContext +ioRuntime = ValueRuntime.ioRuntime . withInfallibleParse -- | For pure functions that can still fail. -- @@ -198,34 +282,34 @@ -- but can fail and need the AWS Lambda Context as input. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (fallibleRuntimeWithContext) --- import Data.Aeson (FromJSON) --- import Data.Text (unpack) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (fallibleRuntimeWithContext) +-- import Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: LambdaContext -> Named -> Either String String --- myHandler (LambdaContext { functionName }) (Named { name }) = --- if name == \"World\" then --- Right $ "Hello, World from " ++ unpack functionName ++ "!" --- else --- Left "Can only greet the world." +-- myHandler :: LambdaContext -> Named -> Either String String +-- myHandler (LambdaContext { functionName }) (Named { name }) = +-- if name == \"World\" then +-- Right $ "Hello, World from " ++ unpack functionName ++ "!" +-- else +-- Left "Can only greet the world." -- --- main :: IO () --- main = fallibleRuntimeWithContext myHandler +-- main :: IO () +-- main = fallibleRuntimeWithContext myHandler -- @ fallibleRuntimeWithContext :: (FromJSON event, ToJSON result) => (LambdaContext -> event -> Either String result) -> IO () -fallibleRuntimeWithContext = readerTRuntime . withFallibleInterface +fallibleRuntimeWithContext = ValueRuntime.fallibleRuntimeWithContext . fmap withInfallibleParse -- | For pure functions that can still fail. -- @@ -233,32 +317,32 @@ -- but can fail. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Runtime (fallibleRuntime) --- import Data.Aeson (FromJSON) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Runtime (fallibleRuntime) +-- import Data.Aeson (FromJSON) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Named -> Either String String --- myHandler (Named { name }) = --- if name == \"World\" then --- Right "Hello, World!" --- else --- Left "Can only greet the world." +-- myHandler :: Named -> Either String String +-- myHandler (Named { name }) = +-- if name == \"World\" then +-- Right "Hello, World!" +-- else +-- Left "Can only greet the world." -- --- main :: IO () --- main = fallibleRuntime myHandler +-- main :: IO () +-- main = fallibleRuntime myHandler -- @ fallibleRuntime :: (FromJSON event, ToJSON result) => (event -> Either String result) -> IO () -fallibleRuntime = readerTRuntime . withFallibleInterface . withoutContext +fallibleRuntime = ValueRuntime.fallibleRuntime . withInfallibleParse -- | For pure functions that can never fail that also need access to the context. -- @@ -266,55 +350,55 @@ -- but that need the AWS Lambda Context as input. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (pureRuntimeWithContext) --- import Data.Aeson (FromJSON) --- import Data.Text (unpack) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (pureRuntimeWithContext) +-- import Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: LambdaContext -> Named -> String --- myHandler (LambdaContext { functionName }) (Named { name }) = --- "Hello, " ++ name ++ " from " ++ unpack functionName ++ "!" +-- myHandler :: LambdaContext -> Named -> String +-- myHandler (LambdaContext { functionName }) (Named { name }) = +-- "Hello, " ++ name ++ " from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = pureRuntimeWithContext myHandler +-- main :: IO () +-- main = pureRuntimeWithContext myHandler -- @ pureRuntimeWithContext :: (FromJSON event, ToJSON result) => (LambdaContext -> event -> result) -> IO () -pureRuntimeWithContext = readerTRuntime . withPureInterface +pureRuntimeWithContext = ValueRuntime.pureRuntimeWithContext . fmap withInfallibleParse -- | For pure functions that can never fail. -- -- Use this for simple handlers that just translate input to output without side-effects. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Runtime (pureRuntime) --- import Data.Aeson (FromJSON) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Runtime (pureRuntime) +-- import Data.Aeson (FromJSON) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Named -> String --- myHandler Named { name } = "Hello, " ++ name ++ "!" +-- myHandler :: Named -> String +-- myHandler Named { name } = "Hello, " ++ name ++ "!" -- --- main :: IO () --- main = pureRuntime myHandler +-- main :: IO () +-- main = pureRuntime myHandler -- @ pureRuntime :: (FromJSON event, ToJSON result) => (event -> result) -> IO () -pureRuntime = readerTRuntime . withPureInterface . withoutContext +pureRuntime = ValueRuntime.pureRuntime . withInfallibleParse diff --git a/src/AWS/Lambda/Runtime/Value.hs b/src/AWS/Lambda/Runtime/Value.hs --- a/src/AWS/Lambda/Runtime/Value.hs +++ b/src/AWS/Lambda/Runtime/Value.hs @@ -35,103 +35,201 @@ ioRuntime, ioRuntimeWithContext, readerTRuntime, + mRuntimeWithContext', + mRuntime, mRuntimeWithContext ) where import AWS.Lambda.RuntimeClient (RuntimeClientConfig, getRuntimeClientConfig, getNextData, sendEventError, sendEventSuccess) -import AWS.Lambda.Combinators (withIOInterface, - withFallibleInterface, - withPureInterface, - withoutContext) -import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..), runReaderTLambdaContext) +import AWS.Lambda.Combinators (withoutContext) +import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..)) import Control.Exception (SomeException, displayException) -import Control.Monad (forever) +import Control.Monad ((<=<), forever) import Control.Monad.Catch (MonadCatch, try) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader, ReaderT, local) +import Control.Monad.Reader (MonadReader, ReaderT, local, runReaderT) import Data.Aeson (ToJSON, Value) import Data.Bifunctor (first) import Data.Text (unpack) import System.Environment (setEnv) -runtimeLoop :: (HasLambdaContext r, MonadReader r m, MonadCatch m, MonadIO m, ToJSON result) => RuntimeClientConfig -> - (Value -> m result) -> m () +runtimeLoop :: (MonadCatch m, MonadIO m, ToJSON result) => RuntimeClientConfig -> (LambdaContext -> Value -> m result) -> m () runtimeLoop runtimeClientConfig fn = do -- Get an event (reqIdBS, event, eCtx) <- liftIO $ getNextData runtimeClientConfig - result <- case eCtx of - Left e -> return $ Left e - Right ctx -> - local (withContext ctx) $ do - -- Propagate the tracing header (Exception safe for this env var name) - liftIO $ setEnv "_X_AMZN_TRACE_ID" $ unpack $ xRayTraceId ctx + -- Propagate the tracing header (Exception safe for this env var name) + liftIO $ either (const (pure ())) (setEnv "_X_AMZN_TRACE_ID" . unpack . xRayTraceId) eCtx - {- Catching like this is _usually_ considered bad practice, but this is a true - case where we want to both catch all errors and propogate information about them. - See: http://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Exception.html#g:4 - -} - -- Put any exceptions in an Either - caughtResult <- try (fn event) - -- Map the Either (via first) so it is an `Either String a` - return $ first (displayException :: SomeException -> String) caughtResult + {- Catching like this is _usually_ considered bad practice, but this is a true + case where we want to both catch all errors and propogate information about them. + See: http://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Exception.html#g:4 + -} + -- Put any exceptions in an Either + caughtResult <- try (fn (either error id eCtx) event) + -- Map the Either (via first) so it is an `Either String result` + let result = first (displayException :: SomeException -> String) caughtResult liftIO $ case result of Right r -> sendEventSuccess runtimeClientConfig reqIdBS r Left e -> sendEventError runtimeClientConfig reqIdBS e - --- | For any monad that supports IO/catch/Reader LambdaContext. +-- | For any monad that supports 'IO' and 'catch'. Useful if you need +-- caching behaviours or are comfortable manipulating monad +-- transformers, and want full control over your monadic interface. -- --- Use this if you need caching behavours or are comfortable manipulating monad --- transformers and want full control over your monadic interface. +-- In a future version, this function will be renamed to +-- @mRuntimeWithContext@ (after the deprecated function is removed). -- +-- A contrived example, that parses the 'Value' argument directly +-- instead of using the higher-level features in +-- @AWS.Lambda.Runtime.Value@: +-- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE DeriveAnyClass, DeriveGeneric, NamedFieldPuns \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..), runReaderTLambdaContext) --- import AWS.Lambda.Runtime (mRuntimeWithContext) --- import Control.Monad.Reader (ReaderT, ask) --- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) --- import Control.Monad.Trans (liftIO) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import Data.Text (unpack) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (mRuntimeWithContext') +-- import Control.Monad.Catch (Exception, throwM) +-- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (FromJSON, Result(..), Value, fromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data AesonParseException = AesonParseException String +-- deriving (Show, Exception) -- --- myHandler :: Value -> StateT Int (ReaderT LambdaContext IO) String --- myHandler jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> return $ "My name is HAL, what's yours?" --- Just Named { name } -> do --- LambdaContext { functionName } <- ask --- greeting <- liftIO $ getEnv \"GREETING\" +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- greetingCount <- get --- put $ greetingCount + 1 +-- myHandler :: LambdaContext -> Value -> StateT Int IO String +-- myHandler LambdaContext { functionName } value = do +-- greeting <- liftIO $ getEnv \"GREETING\" +-- Named { name } <- case fromJSON value of +-- Error err -> throwM $ AesonParseException err +-- Success named -> pure named +-- greetingCount <- get +-- put $ greetingCount + 1 -- --- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ") from " ++ unpack functionName ++ "!" +-- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ") from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = runReaderTLambdaContext (evalStateT (mRuntimeWithContext myHandler) 0) +-- main :: IO () +-- main = evalStateT (mRuntimeWithContext' myHandler) 0 -- @ -mRuntimeWithContext :: (HasLambdaContext r, MonadCatch m, MonadReader r m, MonadIO m, ToJSON result) => - (Value -> m result) -> m () -mRuntimeWithContext fn = do +mRuntimeWithContext' :: (MonadCatch m, MonadIO m, ToJSON result) => (LambdaContext -> Value -> m result) -> m () +mRuntimeWithContext' fn = do runtimeClientConfig <- liftIO getRuntimeClientConfig forever $ runtimeLoop runtimeClientConfig fn +-- | For any monad that supports 'IO' and 'catch'. Useful if you need +-- caching behaviours or are comfortable manipulating monad +-- transformers, want full control over your monadic interface, but +-- don't need to inspect the 'LambdaContext'. +-- +-- A contrived example, that parses the 'Value' argument directly +-- instead of using the higher-level features in +-- @AWS.Lambda.Runtime.Value@: +-- +-- @ +-- {-\# LANGUAGE DeriveAnyClass, DeriveGeneric, NamedFieldPuns \#-} +-- +-- module Main where +-- +-- import AWS.Lambda.Runtime (mRuntime) +-- import Control.Monad.Catch (Exception, throwM) +-- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (FromJSON, Result(..), Value, fromJSON) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) +-- +-- data AesonParseException = AesonParseException String +-- deriving (Show, Exception) +-- +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: Value -> StateT Int IO String +-- myHandler value = do +-- greeting <- liftIO $ getEnv \"GREETING\" +-- Named { name } <- case fromJSON value of +-- Error err -> throwM $ AesonParseException err +-- Success named -> pure named +-- greetingCount <- get +-- put $ greetingCount + 1 +-- +-- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ")!" +-- +-- main :: IO () +-- main = evalStateT (mRuntime myHandler) 0 +-- @ +mRuntime :: (MonadCatch m, MonadIO m, ToJSON result) => (Value -> m result) -> m () +mRuntime = mRuntimeWithContext' . withoutContext +-- | For any monad that supports IO\/catch\/Reader LambdaContext. +-- +-- This function is problematic, and has been deprecated. The +-- 'HasLambdaContext' constraint requires that a 'LambdaContext' is +-- settable in the @m@ monad, but that is not the case - we only have +-- a 'LambdaContext' during the request/response cycle. +-- +-- If you need caching behavours or are comfortable manipulating monad +-- transformers and want full control over your monadic interface, +-- consider 'mRuntimeWithContext''. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- module Main where +-- +-- import AWS.Lambda.Context (LambdaContext(..), runReaderTLambdaContext) +-- import AWS.Lambda.Runtime (mRuntimeWithContext) +-- import Control.Monad.Reader (ReaderT, ask) +-- import Control.Monad.State.Lazy (StateT, evalStateT, get, put) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) +-- +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: Value -> StateT Int (ReaderT LambdaContext IO) String +-- myHandler jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> return $ "My name is HAL, what's yours?" +-- Just Named { name } -> do +-- LambdaContext { functionName } <- ask +-- greeting <- liftIO $ getEnv \"GREETING\" +-- +-- greetingCount <- get +-- put $ greetingCount + 1 +-- +-- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ") from " ++ unpack functionName ++ "!" +-- +-- main :: IO () +-- main = runReaderTLambdaContext (evalStateT (mRuntimeWithContext myHandler) 0) +-- @ +{-# DEPRECATED mRuntimeWithContext "mRuntimeWithContext will be replaced by mRuntimeWithContext' in a future version. This type signature makes impossible promises - see the haddock for details." #-} +mRuntimeWithContext :: (HasLambdaContext r, MonadCatch m, MonadReader r m, MonadIO m, ToJSON result) => + (Value -> m result) -> m () +mRuntimeWithContext fn = mRuntimeWithContext' (\lc -> local (withContext lc) . fn) + + -- | For functions that can read the lambda context and use IO within the same monad. -- -- Use this for handlers that need any form of side-effect such as reading @@ -140,40 +238,40 @@ -- However, do not use this runtime if you need stateful (caching) behaviors. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (readerTRuntime) --- import Control.Monad.Reader (ReaderT, ask) --- import Control.Monad.Trans (liftIO) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import Data.Text (unpack) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (readerTRuntime) +-- import Control.Monad.Reader (ReaderT, ask) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Value -> ReaderT LambdaContext IO String --- myHandler jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> return $ "My name is HAL, what's yours?" --- Just Named { name } -> do --- LambdaContext { functionName } <- ask --- greeting <- liftIO $ getEnv \"GREETING\" --- return $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" +-- myHandler :: Value -> ReaderT LambdaContext IO String +-- myHandler jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> return $ "My name is HAL, what's yours?" +-- Just Named { name } -> do +-- LambdaContext { functionName } <- ask +-- greeting <- liftIO $ getEnv \"GREETING\" +-- return $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = readerTRuntime myHandler +-- main :: IO () +-- main = readerTRuntime myHandler -- @ readerTRuntime :: ToJSON result => (Value -> ReaderT LambdaContext IO result) -> IO () -readerTRuntime = runReaderTLambdaContext . mRuntimeWithContext +readerTRuntime fn = mRuntimeWithContext' $ flip (runReaderT . fn) -- | For functions with IO that can fail in a pure way (or via throw). -- @@ -183,38 +281,38 @@ -- However, do not use this runtime if you need stateful (caching) behaviors. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (ioRuntimeWithContext) --- import Control.Monad.Trans (liftIO) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import Data.Text (unpack) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (ioRuntimeWithContext) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: LambdaContext -> Value -> IO (Either String String) --- myHandler (LambdaContext { functionName }) jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> return $ pure "My name is HAL, what's yours?" --- Just Named { name } -> do --- greeting <- liftIO $ getEnv \"GREETING\" --- return $ pure $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" +-- myHandler :: LambdaContext -> Value -> IO (Either String String) +-- myHandler (LambdaContext { functionName }) jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> return $ pure "My name is HAL, what's yours?" +-- Just Named { name } -> do +-- greeting <- liftIO $ getEnv \"GREETING\" +-- return $ pure $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = ioRuntimeWithContext myHandler +-- main :: IO () +-- main = ioRuntimeWithContext myHandler -- @ ioRuntimeWithContext :: ToJSON result => (LambdaContext -> Value -> IO (Either String result)) -> IO () -ioRuntimeWithContext = readerTRuntime . withIOInterface +ioRuntimeWithContext fn = mRuntimeWithContext' (\lc -> either error pure <=< liftIO . fn lc) -- | For functions with IO that can fail in a pure way (or via throw). -- @@ -223,36 +321,36 @@ -- However, do not use this runtime if you need stateful (caching) behaviors. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Runtime (ioRuntime) --- import Control.Monad.Trans (liftIO) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import System.Environment (getEnv) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Runtime (ioRuntime) +-- import Control.Monad.Trans (liftIO) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import System.Environment (getEnv) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Value -> IO (Either String String) --- myHandler jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> return $ pure "My name is HAL, what's yours?" --- Just Named { name } -> do --- greeting <- liftIO $ getEnv \"GREETING\" --- return $ pure $ greeting ++ name +-- myHandler :: Value -> IO (Either String String) +-- myHandler jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> return $ pure "My name is HAL, what's yours?" +-- Just Named { name } -> do +-- greeting <- liftIO $ getEnv \"GREETING\" +-- return $ pure $ greeting ++ name -- --- main :: IO () --- main = ioRuntime myHandler +-- main :: IO () +-- main = ioRuntime myHandler -- @ ioRuntime :: ToJSON result => (Value -> IO (Either String result)) -> IO () -ioRuntime = readerTRuntime . withIOInterface . withoutContext +ioRuntime = ioRuntimeWithContext . withoutContext -- | For pure functions that can still fail. -- @@ -260,38 +358,38 @@ -- but can fail and need the AWS Lambda Context as input. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (fallibleRuntimeWithContext) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import Data.Text (unpack) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (fallibleRuntimeWithContext) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import Data.Text (unpack) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: LambdaContext -> Value -> Either String String --- myHandler (LambdaContext { functionName }) jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> Right "My name is HAL, what's yours?" --- Just Named { name } -> --- if name == \"World\" then --- Right $ "Hello, World from " ++ unpack functionName ++ "!" --- else --- Left "Can only greet the world." +-- myHandler :: LambdaContext -> Value -> Either String String +-- myHandler (LambdaContext { functionName }) jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> Right "My name is HAL, what's yours?" +-- Just Named { name } -> +-- if name == \"World\" then +-- Right $ "Hello, World from " ++ unpack functionName ++ "!" +-- else +-- Left "Can only greet the world." -- --- main :: IO () --- main = fallibleRuntimeWithContext myHandler +-- main :: IO () +-- main = fallibleRuntimeWithContext myHandler -- @ fallibleRuntimeWithContext :: ToJSON result => (LambdaContext -> Value -> Either String result) -> IO () -fallibleRuntimeWithContext = readerTRuntime . withFallibleInterface +fallibleRuntimeWithContext = mRuntimeWithContext' . fmap (fmap pure) -- | For pure functions that can still fail. -- @@ -299,36 +397,36 @@ -- but can fail. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Runtime (fallibleRuntime) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Runtime (fallibleRuntime) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Value -> Either String String --- myHandler jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> Right "My name is HAL, what's yours?" --- Just Named { name } -> --- if name == \"World\" then --- Right "Hello, World!" --- else --- Left "Can only greet the world." +-- myHandler :: Value -> Either String String +-- myHandler jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> Right "My name is HAL, what's yours?" +-- Just Named { name } -> +-- if name == \"World\" then +-- Right "Hello, World!" +-- else +-- Left "Can only greet the world." -- --- main :: IO () --- main = fallibleRuntime myHandler +-- main :: IO () +-- main = fallibleRuntime myHandler -- @ fallibleRuntime :: ToJSON result => (Value -> Either String result) -> IO () -fallibleRuntime = readerTRuntime . withFallibleInterface . withoutContext +fallibleRuntime = fallibleRuntimeWithContext . withoutContext -- | For pure functions that can never fail that also need access to the context. -- @@ -336,64 +434,64 @@ -- but that need the AWS Lambda Context as input. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Context (LambdaContext(..)) --- import AWS.Lambda.Runtime (pureRuntimeWithContext) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import Data.Text (unpack) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Context (LambdaContext(..)) +-- import AWS.Lambda.Runtime (pureRuntimeWithContext) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import Data.Text (unpack) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: LambdaContext -> Value -> Either String String --- myHandler (LambdaContext { functionName }) jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> Right "My name is HAL, what's yours?" --- Just Named { name } -> --- Right $ "Hello, " ++ name ++ " from " ++ unpack functionName ++ "!" +-- myHandler :: LambdaContext -> Value -> Either String String +-- myHandler (LambdaContext { functionName }) jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> Right "My name is HAL, what's yours?" +-- Just Named { name } -> +-- Right $ "Hello, " ++ name ++ " from " ++ unpack functionName ++ "!" -- --- main :: IO () --- main = pureRuntimeWithContext myHandler +-- main :: IO () +-- main = pureRuntimeWithContext myHandler -- @ pureRuntimeWithContext :: ToJSON result => (LambdaContext -> Value -> result) -> IO () -pureRuntimeWithContext = readerTRuntime . withPureInterface +pureRuntimeWithContext = mRuntimeWithContext' . fmap (fmap pure) -- | For pure functions that can never fail. -- -- Use this for simple handlers that just translate input to output without side-effects. -- -- @ --- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} -- --- module Main where +-- module Main where -- --- import AWS.Lambda.Runtime (pureRuntime) --- import Data.Aeson (Value, FromJSON, parseJSON) --- import Data.Aeson.Types (parseMaybe) --- import GHC.Generics (Generic) +-- import AWS.Lambda.Runtime (pureRuntime) +-- import Data.Aeson (Value, FromJSON, parseJSON) +-- import Data.Aeson.Types (parseMaybe) +-- import GHC.Generics (Generic) -- --- data Named = Named { --- name :: String --- } deriving Generic --- instance FromJSON Named +-- data Named = Named { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named -- --- myHandler :: Value -> String --- myHandler jsonAst = --- case parseMaybe parseJSON jsonAst of --- Nothing -> "My name is HAL, what's yours?" --- Just Named { name } -> --- "Hello, " ++ name ++ "!" +-- myHandler :: Value -> String +-- myHandler jsonAst = +-- case parseMaybe parseJSON jsonAst of +-- Nothing -> "My name is HAL, what's yours?" +-- Just Named { name } -> +-- "Hello, " ++ name ++ "!" -- --- main :: IO () --- main = pureRuntime myHandler +-- main :: IO () +-- main = pureRuntime myHandler -- @ pureRuntime :: ToJSON result => (Value -> result) -> IO () -pureRuntime = readerTRuntime . withPureInterface . withoutContext +pureRuntime = pureRuntimeWithContext . withoutContext diff --git a/src/AWS/Lambda/RuntimeClient.hs b/src/AWS/Lambda/RuntimeClient.hs --- a/src/AWS/Lambda/RuntimeClient.hs +++ b/src/AWS/Lambda/RuntimeClient.hs @@ -16,47 +16,49 @@ sendEventError, ) where -import AWS.Lambda.Context (LambdaContext(..)) -import AWS.Lambda.Internal (DynamicContext(..), StaticContext, - mkContext) -import Control.Applicative ((<*>)) -import Control.Concurrent (threadDelay) -import Control.Exception (displayException, try, throw) -import Control.Monad (unless) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (decode, encode, Value) -import Data.Aeson.Parser (value') -import Data.Aeson.Types (FromJSON, ToJSON) -import Data.Bifunctor (first) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSW -import qualified Data.ByteString.Internal as BSI -import Data.Conduit (ConduitM, runConduit, yield, (.|)) -import Data.Conduit.Attoparsec (sinkParser) -import Data.Text.Encoding (decodeUtf8) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import GHC.Generics (Generic (..)) -import Network.HTTP.Client (BodyReader, HttpException, Manager, - Request, Response, brRead, - defaultManagerSettings, httpNoBody, - managerConnCount, - managerIdleConnectionCount, - managerResponseTimeout, - managerSetProxy, newManager, - noProxy, parseRequest, responseBody, - responseTimeoutNone, withResponse) -import Network.HTTP.Simple (getResponseBody, - getResponseHeader, - getResponseStatus, - setRequestBodyJSON, - setRequestBodyLBS, - setRequestCheckStatus, - setRequestHeader, setRequestMethod, - setRequestPath) -import Network.HTTP.Types.Status (status403, status413, statusIsSuccessful) -import System.Environment (getEnv) -import System.Envy (decodeEnv) +import AWS.Lambda.Context (LambdaContext) +import AWS.Lambda.Internal (StaticContext, getStaticContext) +import AWS.Lambda.RuntimeClient.Internal (eventResponseToNextData) +import Control.Applicative ((<*>)) +import Control.Concurrent (threadDelay) +import Control.Exception (IOException, displayException, + throw, try) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value, encode) +import Data.Aeson.Parser (value') +import Data.Aeson.Types (ToJSON) +import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSW +import Data.Conduit (ConduitM, runConduit, yield, + (.|)) +import Data.Conduit.Attoparsec (sinkParser) +import Data.Semigroup ((<>)) +import GHC.Generics (Generic (..)) +import Network.HTTP.Client (BodyReader, HttpException, + Manager, Request, + RequestBody (RequestBodyLBS), + Response, brRead, + defaultManagerSettings, + httpNoBody, + managerConnCount, + managerIdleConnectionCount, + managerResponseTimeout, + managerSetProxy, method, + newManager, noProxy, + parseRequest, path, + requestBody, requestHeaders, + responseBody, + responseStatus, + responseTimeoutNone, + setRequestCheckStatus, + withResponse) +import Network.HTTP.Types (HeaderName) +import Network.HTTP.Types.Status (Status, status403, + status413, + statusIsSuccessful) +import System.Environment (getEnv) -- | Lambda runtime error that we pass back to AWS data LambdaError = LambdaError @@ -93,7 +95,8 @@ , managerIdleConnectionCount = 1 } - possibleStaticCtx <- liftIO $ (decodeEnv :: IO (Either String StaticContext)) + possibleStaticCtx <- + first (displayException :: IOException -> String) <$> try getStaticContext case possibleStaticCtx of Left err -> do @@ -103,40 +106,8 @@ getNextData :: RuntimeClientConfig -> IO (BS.ByteString, Value, Either String LambdaContext) -getNextData runtimeClientConfig@(RuntimeClientConfig _ _ staticContext) = do - nextRes <- getNextEvent runtimeClientConfig - - -- If we got an event but our requestId is invalid/missing, there's no hope of meaningful recovery - let reqIdBS = head $ getResponseHeader "Lambda-Runtime-Aws-Request-Id" nextRes - - let mTraceId = fmap decodeUtf8 $ exactlyOneHeader $ getResponseHeader "Lambda-Runtime-Trace-Id" nextRes - let mFunctionArn = fmap decodeUtf8 $ exactlyOneHeader $ getResponseHeader "Lambda-Runtime-Invoked-Function-Arn" nextRes - let mDeadline = do - header <- exactlyOneHeader (getResponseHeader "Lambda-Runtime-Deadline-Ms" nextRes) - milliseconds :: Double <- readMaybe $ BSC.unpack header - return $ posixSecondsToUTCTime $ realToFrac $ milliseconds / 1000 - - let mClientContext = decodeOptionalHeader $ getResponseHeader "Lambda-Runtime-Client-Context" nextRes - let mIdentity = decodeOptionalHeader $ getResponseHeader "Lambda-Runtime-Cognito-Identity" nextRes - - -- Build out the Dynamic portion of the Lambda Context - let eDynCtx = - maybeToEither "Runtime Error: Unable to decode Context from event response." - -- Build the Dynamic Context, collapsing individual Maybes into a single Maybe - $ DynamicContext (decodeUtf8 reqIdBS) - <$> mFunctionArn - <*> mTraceId - <*> mDeadline - <*> mClientContext - <*> mIdentity - - -- combine our StaticContext and possible DynamicContext into a LambdaContext - let eCtx = fmap (mkContext staticContext) eDynCtx - - let event = getResponseBody nextRes - - -- Return the interesting components - return (reqIdBS, event, eCtx) +getNextData runtimeClientConfig@(RuntimeClientConfig _ _ staticContext) = + eventResponseToNextData staticContext <$> getNextEvent runtimeClientConfig -- AWS lambda guarantees that we will get valid JSON, -- so parsing is guaranteed to succeed. @@ -190,39 +161,6 @@ fmap (const ()) $ runtimeClientRetry $ flip httpNoBody manager $ toInitErrorRequest e baseRuntimeRequest --- Helpers (mostly) for Headers - -exactlyOneHeader :: [a] -> Maybe a -exactlyOneHeader [a] = Just a -exactlyOneHeader _ = Nothing - -maybeToEither :: b -> Maybe a -> Either b a -maybeToEither b ma = case ma of - Nothing -> Left b - Just a -> Right a - --- Note: Does not allow whitespace -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing - --- TODO: There must be a better way to do this -decodeHeaderValue :: FromJSON a => BSC.ByteString -> Maybe a -decodeHeaderValue = decode . BSW.pack . fmap BSI.c2w . BSC.unpack - --- An empty array means we successfully decoded, but nothing was there --- If we have exactly one element, our outer maybe signals successful decode, --- and our inner maybe signals that there was content sent --- If we had more than one header value, the event was invalid -decodeOptionalHeader :: FromJSON a => [BSC.ByteString] -> Maybe (Maybe a) -decodeOptionalHeader header = - case header of - [] -> Just Nothing - [x] -> fmap Just $ decodeHeaderValue x - _ -> Nothing - - -- Helpers for Requests with JSON Bodies httpValue :: Request -> Manager -> IO (Response Value) @@ -296,3 +234,29 @@ toInitErrorRequest :: String -> Request -> Request toInitErrorRequest e = setRequestPath "2018-06-01/runtime/init/error" . toBaseErrorRequest e + + +-- HTTP Client Type Helpers + +getResponseStatus :: Response a -> Status +getResponseStatus = responseStatus + +setRequestBodyJSON :: ToJSON a => a -> Request -> Request +setRequestBodyJSON = setRequestBodyLBS . encode + +setRequestBodyLBS :: BSW.ByteString -> Request -> Request +setRequestBodyLBS body req = req { requestBody = RequestBodyLBS body } + +setRequestHeader :: HeaderName -> [BS.ByteString] -> Request -> Request +setRequestHeader headerName values req = + let + withoutPrevious = filter ((/=) headerName . fst) $ requestHeaders req + withNew = fmap ((,) headerName) values <> withoutPrevious + in + req { requestHeaders = withNew } + +setRequestMethod :: BS.ByteString -> Request -> Request +setRequestMethod m req = req { method = m } + +setRequestPath :: BS.ByteString -> Request -> Request +setRequestPath p req = req { path = p } diff --git a/src/AWS/Lambda/RuntimeClient/Internal.hs b/src/AWS/Lambda/RuntimeClient/Internal.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/RuntimeClient/Internal.hs @@ -0,0 +1,102 @@ +{-| +Module : AWS.Lambda.RuntimeClient.Internal +Description : Internal HTTP related machinery for talking to the AWS Lambda Custom Runtime interface. +Copyright : (c) Nike, Inc., 2018 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : stable +-} + +module AWS.Lambda.RuntimeClient.Internal ( + eventResponseToNextData, +) where + +import AWS.Lambda.Context (LambdaContext) +import AWS.Lambda.Internal (DynamicContext (..), StaticContext, + mkContext) +import Data.Aeson (Value, eitherDecode) +import Data.Aeson.Types (FromJSON) +import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Internal as BSI +import qualified Data.ByteString.Lazy as BSW +import Data.CaseInsensitive (original) +import Data.Semigroup ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Network.HTTP.Client (Response, responseBody, + responseHeaders) +import Network.HTTP.Types (HeaderName) + +eventResponseToNextData :: StaticContext -> Response Value -> (BS.ByteString, Value, Either String LambdaContext) +eventResponseToNextData staticContext nextRes = + -- If we got an event but our requestId is invalid/missing, there's no hope of meaningful recovery + let + reqIdBS = head $ getResponseHeader "Lambda-Runtime-Aws-Request-Id" nextRes + + eCtx = first ("Runtime Error: Unable to decode Context from event response.\n" <>) $ do + traceId <- fmap decodeUtf8 $ exactlyOneHeader "Lambda-Runtime-Trace-Id" nextRes + functionArn <- fmap decodeUtf8 $ exactlyOneHeader "Lambda-Runtime-Invoked-Function-Arn" nextRes + deadlineHeader <- exactlyOneHeader "Lambda-Runtime-Deadline-Ms" nextRes + milliseconds :: Double <- maybeToEither "Could not parse deadline" $ readMaybe $ BSC.unpack deadlineHeader + let deadline = posixSecondsToUTCTime $ realToFrac $ milliseconds / 1000 + + clientContext <- decodeOptionalHeader "Lambda-Runtime-Client-Context" nextRes + identity <- decodeOptionalHeader "Lambda-Runtime-Cognito-Identity" nextRes + + -- Build out the Dynamic portion of the Lambda Context + let dynCtx = DynamicContext (decodeUtf8 reqIdBS) functionArn traceId deadline clientContext identity + + -- combine our StaticContext and possible DynamicContext into a LambdaContext + return (mkContext staticContext dynCtx) + + -- Return the interesting components + in (reqIdBS, getResponseBody nextRes, eCtx) + + +-- Helpers (mostly) for Headers + +getResponseBody :: Response a -> a +getResponseBody = responseBody + +getResponseHeader :: HeaderName -> Response a -> [BS.ByteString] +getResponseHeader headerName = fmap snd . filter ((==) headerName . fst) . responseHeaders + +headerNameToString :: HeaderName -> String +headerNameToString = fmap BSI.w2c . BS.unpack . original + +exactlyOneHeader :: HeaderName -> Response Value -> Either String BS.ByteString +exactlyOneHeader name res = + let nameStr = headerNameToString name + in case getResponseHeader name res of + [a] -> Right a + [] -> Left ("Missing response header " <> nameStr) + _ -> Left ("Too many values for header " <> nameStr) + +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither b ma = case ma of + Nothing -> Left b + Just a -> Right a + +-- Note: Does not allow whitespace +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing + +-- TODO: There must be a better way to do this +decodeHeaderValue :: FromJSON a => BSC.ByteString -> Either String a +decodeHeaderValue = eitherDecode . BSW.pack . fmap BSI.c2w . BSC.unpack + +-- An empty array means we successfully decoded, but nothing was there +-- If we have exactly one element, our outer maybe signals successful decode, +-- and our inner maybe signals that there was content sent +-- If we had more than one header value, the event was invalid +decodeOptionalHeader :: FromJSON a => HeaderName -> Response Value -> Either String (Maybe a) +decodeOptionalHeader name res = + let nameStr = headerNameToString name + in case getResponseHeader name res of + [] -> Right Nothing + [x] -> first (\e -> "Could not JSON decode header " <> nameStr <> ": " <> e) $ fmap Just $ decodeHeaderValue x + _ -> Left ("Too many values for header " <> nameStr) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,214 @@ +import AWS.Lambda.Context (ClientApplication (..), + ClientContext (..), + CognitoIdentity (..), + LambdaContext (..)) +import AWS.Lambda.Internal (StaticContext (..)) +import AWS.Lambda.RuntimeClient.Internal (eventResponseToNextData) +import Data.Aeson (Value (Null)) +import Data.Map (singleton) +import Data.Semigroup ((<>)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Network.HTTP.Client.Internal (Response (..)) +import Network.HTTP.Types (Header) +import Test.Hspec (describe, it, shouldBe, + shouldStartWith) +import Test.Hspec.Runner (hspec) + +main :: IO () +main = + hspec $ do + describe "Event Response Data" $ do + let staticContext = + StaticContext + { functionName = "name" + , functionVersion = "version" + , functionMemorySize = 128 + , logGroupName = "logGroupName" + , logStreamName = "logStreamName" + } + let basicValidHeaders = + [ ("Lambda-Runtime-Aws-Request-Id", "abc") + , ("Lambda-Runtime-Trace-Id", "123") + , ("Lambda-Runtime-Invoked-Function-Arn", "arn") + , ("Lambda-Runtime-Deadline-Ms", "12332000") + ] + it "Works given valid inputs" $ do + let inputBody = Null + let response = minResponse basicValidHeaders inputBody + let (id, outputBody, context) = + eventResponseToNextData staticContext response + id `shouldBe` "abc" + outputBody `shouldBe` inputBody + context `shouldBe` + (Right + (LambdaContext + { functionName = "name" + , functionVersion = "version" + , functionMemorySize = 128 + , logGroupName = "logGroupName" + , logStreamName = "logStreamName" + , awsRequestId = "abc" + , invokedFunctionArn = "arn" + , xRayTraceId = "123" + , deadline = posixSecondsToUTCTime 12332 + , clientContext = Nothing + , identity = Nothing + })) + it "has clientContext if it was provided" $ do + let headers = + ( "Lambda-Runtime-Client-Context" + , "{ \"client\": { \"appTitle\": \"title\", \"appVersionName\": \"versionName\", \"appVersionCode\": \"versionCode\", \"appPackageName\": \"packageName\" }, \"custom\": { \"key1\": \"value1\" }, \"environment\": { \"key2\": \"value2\" } }") : + basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + fmap clientContext context `shouldBe` + (Right + (Just + (ClientContext + { client = + ClientApplication + { appTitle = "title" + , appVersionName = "versionName" + , appVersionCode = "versionCode" + , appPackageName = "packageName" + } + , custom = singleton "key1" "value1" + , environment = singleton "key2" "value2" + }))) + it "fails to construct the Context if the client context can't be parsed" $ do + let headers = + ("Lambda-Runtime-Client-Context", "{}") : basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + let msg = either id (const (error "Was able to parse a context that should have failed!")) context + msg `shouldStartWith` + "Runtime Error: Unable to decode Context from event response.\nCould not JSON decode header Lambda-Runtime-Client-Context: " + it + "fails to construct the Context if there are two client context headers" $ do + let headers = + [ ("Lambda-Runtime-Client-Context", "{}") + , ("Lambda-Runtime-Client-Context", "{}") + ] <> + basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + fmap clientContext context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nToo many values for header Lambda-Runtime-Client-Context") + it "has identity if it was provided" $ do + let headers = + ( "Lambda-Runtime-Cognito-Identity" + , "{ \"identityId\": \"identityId\", \"identityPoolId\": \"identityPoolId\" }") : + basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + fmap identity context `shouldBe` + (Right + (Just + (CognitoIdentity + { identityId = "identityId" + , identityPoolId = "identityPoolId" + }))) + it + "fails to construct the Context if the cognito identity can't be parsed" $ do + let headers = + ("Lambda-Runtime-Cognito-Identity", "{}") : basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + let msg = either id (const (error "Was able to parse a context that should have failed!")) context + msg `shouldStartWith` + "Runtime Error: Unable to decode Context from event response.\nCould not JSON decode header Lambda-Runtime-Cognito-Identity: " + it + "fails to construct the Context if there are two cognito identity headers" $ do + let headers = + [ ("Lambda-Runtime-Cognito-Identity", "{}") + , ("Lambda-Runtime-Cognito-Identity", "{}") + ] <> + basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + fmap clientContext context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nToo many values for header Lambda-Runtime-Cognito-Identity") + it "fails to create the context if trace Id is not provided" $ do + let headers = + [ ("Lambda-Runtime-Aws-Request-Id", "abc") + , ("Lambda-Runtime-Invoked-Function-Arn", "arn") + , ("Lambda-Runtime-Deadline-Ms", "12332000") + ] + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nMissing response header Lambda-Runtime-Trace-Id") + it "fails to create the context if trace id has multiple values" $ do + let headers = ("Lambda-Runtime-Trace-Id", "123") : basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nToo many values for header Lambda-Runtime-Trace-Id") + it "fails to create the context if function ARN is not provided" $ do + let headers = + [ ("Lambda-Runtime-Aws-Request-Id", "abc") + , ("Lambda-Runtime-Trace-Id", "123") + , ("Lambda-Runtime-Deadline-Ms", "12332000") + ] + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nMissing response header Lambda-Runtime-Invoked-Function-Arn") + it "fails to create the context if function ARN has multiple values" $ do + let headers = + ("Lambda-Runtime-Invoked-Function-Arn", "arn") : basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nToo many values for header Lambda-Runtime-Invoked-Function-Arn") + it "fails to create the context if a deadline is not provided" $ do + let headers = + [ ("Lambda-Runtime-Aws-Request-Id", "abc") + , ("Lambda-Runtime-Trace-Id", "123") + , ("Lambda-Runtime-Invoked-Function-Arn", "arn") + ] + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nMissing response header Lambda-Runtime-Deadline-Ms") + it "fails to create the context if the deadline has multiple values" $ do + let headers = + ("Lambda-Runtime-Deadline-Ms", "12332000") : basicValidHeaders + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nToo many values for header Lambda-Runtime-Deadline-Ms") + it "fails to create the context if the deadline is not a valid timestamp" $ do + let headers = + [ ("Lambda-Runtime-Aws-Request-Id", "abc") + , ("Lambda-Runtime-Trace-Id", "123") + , ("Lambda-Runtime-Invoked-Function-Arn", "arn") + , ("Lambda-Runtime-Deadline-Ms", "not a timestamp") + ] + let (_, _, context) = + eventResponseToNextData staticContext (minJsonResponse headers) + context `shouldBe` + (Left + "Runtime Error: Unable to decode Context from event response.\nCould not parse deadline") + +minResponse :: [Header] -> a -> Response a +minResponse headers body = + Response + { responseStatus = undefined + , responseVersion = undefined + , responseHeaders = headers + , responseBody = body + , responseCookieJar = undefined + , responseClose' = undefined + } + +minJsonResponse :: [Header] -> Response Value +minJsonResponse = flip minResponse Null