diff --git a/hal.cabal b/hal.cabal --- a/hal.cabal +++ b/hal.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 8d35e8a815b7bdb309aebceaefc610f970e0bd9fffe62b2356a9611ad61dbeb9 +-- hash: f0a8761c52b07313708798791d5b65ef7ac4ab2fce5c2b8b26beea0bf4f6770e name: hal -version: 0.3.4 +version: 0.4.0 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 @@ -33,8 +33,10 @@ AWS.Lambda.Combinators AWS.Lambda.Context AWS.Lambda.Events.S3 + AWS.Lambda.Events.SQS AWS.Lambda.Internal AWS.Lambda.Runtime + AWS.Lambda.Runtime.Value AWS.Lambda.RuntimeClient other-modules: Paths_hal @@ -46,12 +48,9 @@ aeson , base >=4.7 && <5 , bytestring - , conduit - , conduit-extra , containers , envy , exceptions - , http-client , http-conduit , http-types , mtl 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 @@ -15,11 +15,14 @@ withIOInterface, withFallibleInterface, withPureInterface, - withoutContext + withoutContext, + withInfallibleParse ) where import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ask) +import Data.Aeson (FromJSON, parseJSON, Value) +import Data.Aeson.Types (parseEither) -- Helper for converting an either result into a monad/exception @@ -183,3 +186,22 @@ -- @ withoutContext :: a -> b -> a withoutContext = const + +-- | This modifies a function to accept a JSON AST (Value), instead of its JSON parsable +-- input. It also assumes that the JSON AST passed in will ALWAYS be convertable into the +-- original input type. +-- +-- This allows us to write handlers of the types we're interested in, but then map back +-- to the "native" handler that is only guaranteed JSON (but not necessarily in a useful +-- or restricted structure). +-- +-- This is essentially the glue that converts the "AWS.Lambda.Runtime.Value" to +-- (the more standard) "AWS.Lambda.Runtime". While both export a +-- 'AWS.Lambda.Runtime.mRuntimeWithContext', the difference is that the Value +-- Runtime makes no attempt to convert the JSON AST, the standard Runtime does. +-- +-- Rarely would this function be used directly, and you wouldn't want to use it +-- at all, (directly or indirectly via Runtime runtimes), if you wanted to act +-- on a failure to convert the JSON AST sent to the Lambda. +withInfallibleParse :: FromJSON a => (a -> b) -> Value -> b +withInfallibleParse fn = either error fn . parseEither parseJSON diff --git a/src/AWS/Lambda/Events/SQS.hs b/src/AWS/Lambda/Events/SQS.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Events/SQS.hs @@ -0,0 +1,55 @@ +{-| +Module : AWS.Lambda.Events.SQS +Description : Data types for working with SQS events. +Copyright : (c) Nike, Inc., 2019 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : stable +-} + +module AWS.Lambda.Events.SQS ( + Records (..), + Attributes (..), + SQSEvent (..) +) where + +import Data.Aeson (FromJSON (..), withObject, (.:)) +import Data.Map (Map) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Records = Records { + records :: [SQSEvent] +} deriving (Show, Eq) + +instance FromJSON Records where + parseJSON = withObject "Records" $ \v -> Records <$> v .: "Records" + +data Attributes = Attributes { + approximateReceiveCount :: Text, + sentTimestamp :: Text, + senderId :: Text, + approximateFirstReceiveTimestamp :: Text +} deriving (Show, Eq) + +instance FromJSON Attributes where + parseJSON = withObject "Attributes" $ \v -> + Attributes + <$> v .: "ApproximateReceiveCount" + <*> v .: "SentTimestamp" + <*> v .: "SenderId" + <*> v .: "ApproximateFirstReceiveTimestamp" + +data SQSEvent = SQSEvent { + messageId :: Text, + receiptHandle :: Text, + body :: Text, + attributes :: Attributes, + messageAttributes :: Map Text Text, + md5OfBody :: Text, + eventSource :: Text, + eventSourceARN :: Text, + awsRegion :: Text +} deriving (Show, Eq, Generic) + +instance FromJSON SQSEvent 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 @@ -28,120 +28,17 @@ mRuntimeWithContext ) where -import AWS.Lambda.RuntimeClient (RuntimeClientConfig, getNextEvent, - getRuntimeClientConfig, - sendEventError, sendEventSuccess, - sendInitError) import AWS.Lambda.Combinators (withIOInterface, withFallibleInterface, withPureInterface, - withoutContext) + withoutContext, + withInfallibleParse) import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..), runReaderTLambdaContext) -import AWS.Lambda.Internal (StaticContext, DynamicContext(DynamicContext), - mkContext) -import Control.Applicative ((<*>), liftA2) -import Control.Exception (SomeException, displayException) -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 Data.Aeson (FromJSON, ToJSON, decode) -import Data.Bifunctor (first) -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSW -import qualified Data.ByteString.Internal as BSI -import Data.Text (unpack) -import Data.Text.Encoding (decodeUtf8) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Network.HTTP.Simple (getResponseBody, getResponseHeader) -import System.Environment (setEnv) -import System.Envy (decodeEnv) - -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 - - -runtimeLoop :: (HasLambdaContext r, MonadReader r m, MonadCatch m, MonadIO m, FromJSON event, ToJSON result) => RuntimeClientConfig -> StaticContext -> - (event -> m result) -> m () -runtimeLoop runtimeClientConfig staticContext fn = do - -- Get an event - nextRes <- liftIO $ 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 - - -- Populate the context with values from headers - let eCtx = - -- combine our StaticContext and possible DynamicContext into a LambdaContext - fmap (mkContext staticContext) - -- convert the Maybe DynamicContext into an Either String DynamicContext - $ 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 - - let eEvent = first displayException $ getResponseBody nextRes - - result <- case liftA2 (,) eCtx eEvent of - Left e -> return $ Left e - Right (ctx, event) -> - local (withContext ctx) $ do - -- Propagate the tracing header (Exception safe for this env var name) - liftIO $ setEnv "_X_AMZN_TRACE_ID" $ unpack $ xRayTraceId ctx - - {- 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 - - liftIO $ case result of - Right r -> sendEventSuccess runtimeClientConfig reqIdBS r - Left e -> sendEventError runtimeClientConfig reqIdBS e +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) --TODO: Revisit all names before we put them under contract -- | For any monad that supports IO/catch/Reader LambdaContext. @@ -183,16 +80,7 @@ -- @ mRuntimeWithContext :: (HasLambdaContext r, MonadCatch m, MonadReader r m, MonadIO m, FromJSON event, ToJSON result) => (event -> m result) -> m () -mRuntimeWithContext fn = do - -- TODO: Hide the implementation details of StaticContext within - -- RuntimeClientConfig that encapsulates more details - runtimeClientConfig <- liftIO getRuntimeClientConfig - - possibleStaticCtx <- liftIO $ (decodeEnv :: IO (Either String StaticContext)) - - case possibleStaticCtx of - Left err -> liftIO $ sendInitError runtimeClientConfig err - Right staticContext -> forever $ runtimeLoop runtimeClientConfig staticContext fn +mRuntimeWithContext = ValueRuntime.mRuntimeWithContext . withInfallibleParse -- | For functions that can read the lambda context and use IO within the same monad. -- diff --git a/src/AWS/Lambda/Runtime/Value.hs b/src/AWS/Lambda/Runtime/Value.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Runtime/Value.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE FlexibleContexts #-} + +{-| +Module : AWS.Lambda.Runtime.Value +Description : Runtime methods useful when constructing Haskell handlers for the AWS Lambda Custom Runtime. +Copyright : (c) Nike, Inc., 2018 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : stable + +These are runtimes designed for AWS Lambda, which accept a handler and return +an application that will retreive and execute events as long as a container +continues to exist. + +These runtimes expect handlers that accept a parsed JSON AST +('Data.Aeson.Types.Value') as the input, instead some particular type with a FromJSON +instance. Handlers using these runtimes must take care of the conversion and +handle errors explicitly. Handlers that should throw an exception or never +expect to be invoked with an invalid payload, should simply use the runtimes in +the "AWS.Lambda.Runtime" module. + +Each example shows the conversion from the Value type to the target FromJSON +type. + +Many of these runtimes use "AWS.Lambda.Combinators" under the hood. +For those interested in peeking below the abstractions provided here, +please refer to that module. +-} + +module AWS.Lambda.Runtime.Value ( + pureRuntime, + pureRuntimeWithContext, + fallibleRuntime, + fallibleRuntimeWithContext, + ioRuntime, + ioRuntimeWithContext, + readerTRuntime, + mRuntimeWithContext +) where + +import AWS.Lambda.RuntimeClient (getBaseRuntimeRequest, getNextEvent, + sendEventError, sendEventSuccess, sendInitError) +import AWS.Lambda.Combinators (withIOInterface, + withFallibleInterface, + withPureInterface, + withoutContext) +import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..), runReaderTLambdaContext) +import AWS.Lambda.Internal (StaticContext, DynamicContext(DynamicContext), + mkContext) +import Control.Applicative ((<*>)) +import Control.Exception (SomeException, displayException) +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 Data.Aeson (FromJSON, FromJSON, ToJSON, decode, Value) +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSW +import qualified Data.ByteString.Internal as BSI +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Network.HTTP.Simple (Request, getResponseBody, + getResponseHeader) +import System.Environment (setEnv) +import System.Envy (decodeEnv) + +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 + + +runtimeLoop :: (HasLambdaContext r, MonadReader r m, MonadCatch m, MonadIO m, ToJSON result) => Request -> StaticContext -> + (Value -> m result) -> m () +runtimeLoop baseRuntimeRequest staticContext fn = do + -- Get an event + nextRes <- liftIO $ getNextEvent baseRuntimeRequest + + -- 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 + + -- Populate the context with values from headers + let eCtx = + -- combine our StaticContext and possible DynamicContext into a LambdaContext + fmap (mkContext staticContext) + -- convert the Maybe DynamicContext into an Either String DynamicContext + $ maybeToEither "Runtime Error: Unable to decode Context from event response." + -- Build the Dynamic Context, collapsing individual Maybes into a single Maybe + $ DynamicContext (decodeUtf8 reqIdBS) + <$> mTraceId + <*> mFunctionArn + <*> mDeadline + <*> mClientContext + <*> mIdentity + + let event = getResponseBody nextRes + + 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 + + {- 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 + + liftIO $ case result of + Right r -> sendEventSuccess baseRuntimeRequest reqIdBS r + Left e -> sendEventError baseRuntimeRequest reqIdBS e + + +-- | 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. +-- +-- @ +-- {-\# 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) +-- @ +mRuntimeWithContext :: (HasLambdaContext r, MonadCatch m, MonadReader r m, MonadIO m, ToJSON result) => + (Value -> m result) -> m () +mRuntimeWithContext fn = do + -- TODO: Hide the implementation details of Request and StaticContext. + -- If we instead have a method that returns an opaque RuntimeClientConfig + -- that encapsulates these details, and then all clientMethods accept + -- the RuntimeClientConfig instead of a baseRuntimeRequest. + baseRuntimeRequest <- liftIO getBaseRuntimeRequest + + possibleStaticCtx <- liftIO $ (decodeEnv :: IO (Either String StaticContext)) + + case possibleStaticCtx of + Left err -> liftIO $ sendInitError baseRuntimeRequest err + Right staticContext -> forever $ runtimeLoop baseRuntimeRequest staticContext 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 +-- environment variables or making network requests, and prefer to access the +-- AWS Lambda Context in the same monad. +-- However, do not use this runtime if you need stateful (caching) behaviors. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- 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) +-- +-- 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 ++ "!" +-- +-- main :: IO () +-- main = readerTRuntime myHandler +-- @ +readerTRuntime :: ToJSON result => + (Value -> ReaderT LambdaContext IO result) -> IO () +readerTRuntime = runReaderTLambdaContext . mRuntimeWithContext + +-- | For functions with IO that can fail in a pure way (or via throw). +-- +-- Use this for handlers that need any form of side-effect such as reading +-- environment variables or making network requests, and also need the +-- AWS Lambda Context as input. +-- However, do not use this runtime if you need stateful (caching) behaviors. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- 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) +-- +-- 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 ++ "!" +-- +-- main :: IO () +-- main = ioRuntimeWithContext myHandler +-- @ +ioRuntimeWithContext :: ToJSON result => + (LambdaContext -> Value -> IO (Either String result)) -> IO () +ioRuntimeWithContext = readerTRuntime . withIOInterface + +-- | For functions with IO that can fail in a pure way (or via throw). +-- +-- Use this for handlers that need any form of side-effect such as reading +-- environment variables or making network requests. +-- However, do not use this runtime if you need stateful (caching) behaviors. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- 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) +-- +-- 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 +-- +-- main :: IO () +-- main = ioRuntime myHandler +-- @ +ioRuntime :: ToJSON result => + (Value -> IO (Either String result)) -> IO () +ioRuntime = readerTRuntime . withIOInterface . withoutContext + +-- | For pure functions that can still fail. +-- +-- Use this for simple handlers that just translate input to output without side-effects, +-- but can fail and need the AWS Lambda Context as input. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- 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) +-- +-- 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." +-- +-- main :: IO () +-- main = fallibleRuntimeWithContext myHandler +-- @ +fallibleRuntimeWithContext :: ToJSON result => + (LambdaContext -> Value -> Either String result) -> IO () +fallibleRuntimeWithContext = readerTRuntime . withFallibleInterface + +-- | For pure functions that can still fail. +-- +-- Use this for simple handlers that just translate input to output without side-effects, +-- but can fail. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- module Main where +-- +-- 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 +-- +-- 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 +-- @ +fallibleRuntime :: ToJSON result => + (Value -> Either String result) -> IO () +fallibleRuntime = readerTRuntime . withFallibleInterface . withoutContext + +-- | For pure functions that can never fail that also need access to the context. +-- +-- Use this for simple handlers that just translate input to output without side-effects, +-- but that need the AWS Lambda Context as input. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- 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) +-- +-- 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 ++ "!" +-- +-- main :: IO () +-- main = pureRuntimeWithContext myHandler +-- @ +pureRuntimeWithContext :: ToJSON result => + (LambdaContext -> Value -> result) -> IO () +pureRuntimeWithContext = readerTRuntime . withPureInterface + +-- | For pure functions that can never fail. +-- +-- Use this for simple handlers that just translate input to output without side-effects. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-} +-- +-- module Main where +-- +-- 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 +-- +-- 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 +-- @ +pureRuntime :: ToJSON result => (Value -> result) -> IO () +pureRuntime = readerTRuntime . withPureInterface . 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 @@ -8,8 +8,7 @@ -} module AWS.Lambda.RuntimeClient ( - RuntimeClientConfig, - getRuntimeClientConfig, + getBaseRuntimeRequest, getNextEvent, sendEventSuccess, sendEventError, @@ -17,35 +16,22 @@ ) where import Control.Concurrent (threadDelay) -import Control.Exception (Exception, displayException, throw, - try) -import Control.Monad (unless) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (Result (..), Value, encode, - fromJSON) -import Data.Aeson.Parser (value') -import Data.Aeson.Types (FromJSON, ToJSON) +import Control.Exception (displayException, try, throw) +import Data.Aeson (encode, Value) +import Data.Aeson.Types (ToJSON) import Data.Bifunctor (first) import qualified Data.ByteString as BS -import Data.Conduit (ConduitM, runConduit, yield, (.|)) -import Data.Conduit.Attoparsec (sinkParser) 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 (getResponseStatus, +import Network.HTTP.Simple (HttpException, + Request, Response, + getResponseStatus, httpJSON, + httpNoBody, parseRequest, setRequestBodyJSON, setRequestBodyLBS, setRequestCheckStatus, setRequestHeader, setRequestMethod, setRequestPath) -import Network.HTTP.Types.Status (status403, status413, statusIsSuccessful) +import Network.HTTP.Types.Status (status413, statusIsSuccessful) import System.Environment (getEnv) -- | Lambda runtime error that we pass back to AWS @@ -57,8 +43,6 @@ instance ToJSON LambdaError -data RuntimeClientConfig = RuntimeClientConfig Request Manager - -- Exposed Handlers -- TODO: It would be interesting if we could make the interface a sort of @@ -66,28 +50,16 @@ -- things off we get a 'getNextEvent' handler and then the 'getNextEvent' -- handler returns both the 'success' and 'error' handlers. So things like -- baseRequest and reqId are pre-injected. -getRuntimeClientConfig :: IO RuntimeClientConfig -getRuntimeClientConfig = do +getBaseRuntimeRequest :: IO Request +getBaseRuntimeRequest = do awsLambdaRuntimeApi <- getEnv "AWS_LAMBDA_RUNTIME_API" - req <- parseRequest $ "http://" ++ awsLambdaRuntimeApi - man <- newManager - -- In the off chance that they set a proxy value, we don't want to - -- use it. There's also no reason to spend time reading env vars. - $ managerSetProxy noProxy - $ defaultManagerSettings - -- This is the most important setting, we must not timeout requests - { managerResponseTimeout = responseTimeoutNone - -- We only ever need a single connection, because we'll never make - -- concurrent requests and never talk to more than one host. - , managerConnCount = 1 - , managerIdleConnectionCount = 1 - } - return $ RuntimeClientConfig req man - + parseRequest $ "http://" ++ awsLambdaRuntimeApi -getNextEvent :: FromJSON a => RuntimeClientConfig -> IO (Response (Either JSONParseException a)) -getNextEvent rcc@(RuntimeClientConfig baseRuntimeRequest manager) = do - resOrEx <- runtimeClientRetryTry $ flip httpJSONEither manager $ toNextEventRequest baseRuntimeRequest +-- AWS lambda guarantees that we will get valid JSON, +-- so parsing is guaranteed to succeed. +getNextEvent :: Request -> IO (Response Value) +getNextEvent baseRuntimeRequest = do + resOrEx <- runtimeClientRetryTry $ httpJSON $ toNextEventRequest baseRuntimeRequest let checkStatus res = if not $ statusIsSuccessful $ getResponseStatus res then Left "Unexpected Runtime Error: Could not retrieve next event." else @@ -95,13 +67,13 @@ let resOrMsg = first (displayException :: HttpException -> String) resOrEx >>= checkStatus case resOrMsg of Left msg -> do - _ <- sendInitError rcc msg + _ <- sendInitError baseRuntimeRequest msg error msg Right y -> return y -sendEventSuccess :: ToJSON a => RuntimeClientConfig -> BS.ByteString -> a -> IO () -sendEventSuccess rcc@(RuntimeClientConfig baseRuntimeRequest manager) reqId json = do - resOrEx <- runtimeClientRetryTry $ flip httpNoBody manager $ toEventSuccessRequest reqId json baseRuntimeRequest +sendEventSuccess :: ToJSON a => Request -> BS.ByteString -> a -> IO () +sendEventSuccess baseRuntimeRequest reqId json = do + resOrEx <- runtimeClientRetryTry $ httpNoBody $ toEventSuccessRequest reqId json baseRuntimeRequest let resOrTypedMsg = case resOrEx of Left ex -> @@ -122,72 +94,30 @@ case resOrTypedMsg of Left (Left msg) -> -- If an exception occurs here, we want that to propogate - sendEventError rcc reqId msg + sendEventError baseRuntimeRequest reqId msg Left (Right msg) -> error msg Right () -> return () -sendEventError :: RuntimeClientConfig -> BS.ByteString -> String -> IO () -sendEventError (RuntimeClientConfig baseRuntimeRequest manager) reqId e = - fmap (const ()) $ runtimeClientRetry $ flip httpNoBody manager $ toEventErrorRequest reqId e baseRuntimeRequest - -sendInitError :: RuntimeClientConfig -> String -> IO () -sendInitError (RuntimeClientConfig baseRuntimeRequest manager) e = - fmap (const ()) $ runtimeClientRetry $ flip httpNoBody manager $ toInitErrorRequest e baseRuntimeRequest - --- Helpers for Requests with JSON Bodies - -newtype JSONParseException = JSONParseException { getException :: String } deriving (Show) -instance Exception JSONParseException - -httpJSONEither :: FromJSON a => Request -> Manager -> IO (Response (Either JSONParseException a)) -httpJSONEither request manager = - let toEither v = - case fromJSON v of - Error e -> Left (JSONParseException e) - Success decoded -> Right decoded - in fmap toEither <$> httpValue request manager - -httpValue :: Request -> Manager -> IO (Response Value) -httpValue request manager = - withResponse request manager (\bodyReaderRes -> do - value <- runConduit $ bodyReaderSource (responseBody bodyReaderRes) .| sinkParser value' - return $ fmap (const value) bodyReaderRes - ) +sendEventError :: Request -> BS.ByteString -> String -> IO () +sendEventError baseRuntimeRequest reqId e = + fmap (const ()) $ runtimeClientRetry $ httpNoBody $ toEventErrorRequest reqId e baseRuntimeRequest -bodyReaderSource :: MonadIO m - => BodyReader - -> ConduitM i BS.ByteString m () -bodyReaderSource br = - loop - where - loop = do - bs <- liftIO $ brRead br - unless (BS.null bs) $ do - yield bs - loop +sendInitError :: Request -> String -> IO () +sendInitError baseRuntimeRequest e = + fmap (const ()) $ runtimeClientRetry $ httpNoBody $ toInitErrorRequest e baseRuntimeRequest -- Retry Helpers -runtimeClientRetryTry' :: Int -> Int -> IO (Response a) -> IO (Either HttpException (Response a)) -runtimeClientRetryTry' retries maxRetries f - | retries == maxRetries = try f - | otherwise = do - resOrEx <- try f - let retry = - threadDelay (500 * 2 ^ retries) - >> runtimeClientRetryTry' (retries + 1) maxRetries f - case resOrEx of - Left (_ :: HttpException) -> retry - Right res -> - -- TODO: Explore this further. - -- Before ~July 22nd 2020 it seemed that if a next event request reached - -- the runtime before a new event was available that there would be a - -- network error. After it appears that a 403 is returned. - if getResponseStatus res == status403 then retry - else return $ Right res +runtimeClientRetryTry' :: Int -> IO (Response a) -> IO (Either HttpException (Response a)) +runtimeClientRetryTry' 1 f = try f +runtimeClientRetryTry' i f = do + resOrEx <- try f + case resOrEx of + Left (_ :: HttpException) -> threadDelay 500 >> runtimeClientRetryTry' (i - 1) f + Right res -> return $ Right res runtimeClientRetryTry :: IO (Response a) -> IO (Either HttpException (Response a)) -runtimeClientRetryTry = runtimeClientRetryTry' 0 10 +runtimeClientRetryTry = runtimeClientRetryTry' 3 runtimeClientRetry :: IO (Response a) -> IO (Response a) runtimeClientRetry = fmap (either throw id) . runtimeClientRetryTry