hal 0.1.6 → 0.2.0
raw patch · 7 files changed
+354/−177 lines, 7 filesdep −conduitdep −conduit-extradep −http-clientdep ~aesondep ~containersdep ~http-conduit
Dependencies removed: conduit, conduit-extra, http-client
Dependency ranges changed: aeson, containers, http-conduit
Files
- README.md +28/−22
- hal.cabal +5/−6
- src/AWS/Lambda/Combinators.hs +185/−0
- src/AWS/Lambda/Context.hs +7/−1
- src/AWS/Lambda/Events/S3/PutEvent.hs +56/−0
- src/AWS/Lambda/Runtime.hs +40/−43
- src/AWS/Lambda/RuntimeClient.hs +33/−105
README.md view
@@ -1,3 +1,5 @@+[](https://travis-ci.org/Nike-Inc/hal)+ # hal A runtime environment for [Haskell] applications running on [AWS Lambda].@@ -31,7 +33,6 @@ - [Supported Platforms / GHC Versions](#supported-platforms-ghc-versions) - [Quick Start](#quick-start)- - [Usage](#usage) - [Local Testing](#local-testing) ## Supported Platforms / GHC Versions@@ -64,7 +65,7 @@ #... packages: - '.'- - hal-0.1.0+ - hal-0.1.2 # ... docker: enable: true@@ -74,32 +75,39 @@ Then, define your types and handler: ```haskell+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DeriveGeneric #-} module Main where import AWS.Lambda.Runtime (pureRuntime)-import Data.Aeson (FromJSON, ToJSON)-import GHC.Generics (Generic)+import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generic) -data Request = Request {- input :: String-} deriving (Generic)+data IdEvent = IdEvent { input :: String } deriving Generic+instance FromJSON IdEvent where -instance FromJSON Request+data IdResult = IdResult { output :: String } deriving Generic+instance ToJSON IdResult where -data Response = Response {- output :: String-} deriving (Generic)+handler :: IdEvent -> IdResult+handler IdEvent { input } = IdResult { output = input } -instance ToJSON Response+main :: IO ()+main = pureRuntime handler+``` -idHandler :: Request -> Response-idHandler Request { input } = Response { output = input }+Your binary should be called `bootstrap` in order for the custom runtime+to execute properly: -main :: IO ()-main = pureRuntime idHandler+```yaml+# Example snippet of package.yaml+# ...+executables:+ bootstrap:+ source-dirs: src+ main: Main.hs # e.g. {project root}/src/Main.hs+# ... ``` Don't forget to define your [CloudFormation] stack:@@ -115,6 +123,8 @@ Properties: Handler: NOT_USED Runtime: provided+ # CodeUri is a relative path from the directory that this CloudFormation+ # file is defined. CodeUri: .stack-work/docker/_home/.local/bin/ Description: My Haskell runtime. MemorySize: 128@@ -148,10 +158,6 @@ output.txt ``` -## Usage--TODO- ## Local Testing ### Dependencies@@ -163,7 +169,7 @@ ### Build ```bash-docker pull fpco/stack-build:lts-12.21 #first build only+docker pull fpco/stack-build:lts-{version} # First build only, find the latest version in stack.yaml stack build --copy-bins ```
hal.cabal view
@@ -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.1. -- -- see: https://github.com/sol/hpack ----- hash: e6d4065780637152b7b823fe7342abf134ac94a549bac57f62597faf8daf7a80+-- hash: c9fc7c14f698aaa49f0ba921b13814ab0b22cee9b7c41ba645725672ac7a0382 name: hal-version: 0.1.6+version: 0.2.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@@ -30,7 +30,9 @@ library exposed-modules:+ AWS.Lambda.Combinators AWS.Lambda.Context+ AWS.Lambda.Events.S3.PutEvent AWS.Lambda.Internal AWS.Lambda.Runtime AWS.Lambda.RuntimeClient@@ -44,12 +46,9 @@ aeson , base >=4.7 && <5 , bytestring- , conduit- , conduit-extra , containers , envy , exceptions- , http-client , http-conduit , http-types , mtl
+ src/AWS/Lambda/Combinators.hs view
@@ -0,0 +1,185 @@+{-|+Module : AWS.Lambda.Combinators+Description : Function transformers that can be used to adapt the base runtime into other useful interfaces.+Copyright : (c) Nike, Inc., 2018+License : BSD3+Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com+Stability : stable++These combinators are for those who need to peek below the abstraction of the basic runtimes, for whatever reason.++They map functions (instead of values) to turn basic handlers into handlers compatible with the base runtime. These combinators allow us to expose functionality across many dimensions in an abstract way. It also allows simple building blocks for those who need to "get in the middle" or adapt the basic runtimes in new ways without rebuilding everything from the ground up.+-}++module AWS.Lambda.Combinators (+ withIOInterface,+ withFallibleInterface,+ withPureInterface,+ withoutContext+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader, ask)+++-- Helper for converting an either result into a monad/exception+dropEither :: Monad m => Either String a -> m a+dropEither = \case + 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.+--+-- In the example below, we reconstruct 'AWS.Lambda.Runtime.ioRuntimeWithContext'+-- without actually using it. The 'AWS.Lambda.Runtime.readerTRuntime' expects+-- a handler in the form of @event -> ReaderT LambdaContext IO result@+-- (ignoring constraints). By composing it with `withIOInterface` we get a new runtime which+-- expects a function in the form of @LambdaContext -> event -> IO result@+-- which matches that of `myHandler`.+--+-- @+-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-}+--+-- module Main where+--+-- import AWS.Lambda.Runtime (readerTRuntime)+-- import AWS.Lambda.Combinators (withIOInterface)+-- import Data.Aeson (FromJSON)+-- import System.Environment (getEnv)+--+-- data Named = {+-- name :: String+-- } deriving Generic+-- instance FromJSON Named+--+-- myHandler :: Named -> IO String+-- myHandler (Named { name }) = do+-- greeting <- getEnv \"GREETING\"+-- return $ greeting ++ name+--+-- main :: IO ()+-- main = (readerTRuntime . withIOInterface) myHandler+-- @+withIOInterface :: (MonadReader c m, MonadIO m) => (c -> b -> IO (Either String a)) -> (b -> m a)+withIOInterface fn event = do+ config <- ask+ result <- liftIO $ fn config event+ dropEither result++-- | Upgrades a handler that accepts 'AWS.Lambda.Context.LambdaContext' and+-- an event to return a value inside an `Either` inside into a base runtime handler.+--+-- In the example below, we reconstruct 'AWS.Lambda.Runtime.fallibleRuntimeWithContext'+-- without actually using it. The 'AWS.Lambda.Runtime.readerTRuntime' expects a handler+-- in the form of @event -> ReaderT LambdaContext IO result@ (ignoring constraints).+-- By composing it with `withFallibleInterface` we get a new runtime which+-- expects a function in the form of @LambdaContext -> event -> Either String result@+-- which matches that of `myHandler`.+--+-- @+-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-}+--+-- module Main where+--+-- import AWS.Lambda.Runtime (readerTRuntime)+-- import AWS.Lambda.Combinators (withFallibleInterface)+-- import Data.Aeson (FromJSON)+-- import System.Environment (getEnv)+--+-- data 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."+--+-- main :: IO ()+-- main = (readerTRuntime . withFallibleInterface) myHandler+-- @+withFallibleInterface :: MonadReader c m => (c -> b -> Either String a) -> b -> m a+withFallibleInterface fn event = do+ config <- ask+ dropEither $ fn config event++-- | This combinator takes a handler that accepts both an event and+-- 'AWS.Lambda.Context.LambdaContext' and converts it into a handler that is+-- compatible with the base monadic runtime.+--+-- In the example below, we reconstruct 'AWS.Lambda.Runtime.pureRuntimeWithContext'+-- without actually using it.+-- The 'AWS.Lambda.Runtime.readerTRuntime' expects a handler in the form of+-- @event -> ReaderT LambdaContext IO result@ (ignoring constraints).+-- By composing it with `withPureInterface` we get a new runtime which+-- expects a function in the form of @LambdaContext -> event -> result@+-- which matches that of `myHandler`.+--+-- @+-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-}+--+-- module Main where+--+-- import AWS.Lambda.Runtime (readerTRuntime)+-- import AWS.Lambda.Combinators (withPureInterface)+-- import Data.Aeson (FromJSON)+--+-- data Named = {+-- name :: String+-- } deriving Generic+-- instance FromJSON Named+--+-- myHandler :: LambdaContext -> Named -> String+-- myHandler (LambdaContext { functionName }) (Named { name }) =+-- "Hello, " ++ name ++ " from " ++ unpack functionName ++ "!"+--+-- main :: IO ()+-- main = (readerTRuntime . withPureInterface) myHandler+-- @+withPureInterface :: MonadReader c m => (c -> b -> a) -> b -> m a+withPureInterface fn event = do+ config <- ask+ return $ fn config event++-- | An alias of 'const', this upgrades a handler that does not accept+-- 'AWS.Lambda.Context.LambdaContext' as its first curried argument to one that does.+--+-- This allows us to use other combinators to construct a lambda runtime that accepts+-- a handler that ignores 'AWS.Lambda.Context.LambdaContext'.+--+-- In the example below, we reconstruct 'AWS.Lambda.Runtime.pureRuntime' without actually using it.+-- The 'AWS.Lambda.Runtime.readerTRuntime' expects a handler in the form of+-- @event -> ReaderT LambdaContext IO result@ (ignoring constraints).+-- By composing it with `withPureInterface` we get a new runtime which+-- expects a function in the form of @LambdaContext -> event -> result@,+-- And then finally we also compose `withoutContext` so it accepts the signature+-- @event -> result@ which matches that of `myHandler`.+--+-- @+-- {-\# LANGUAGE NamedFieldPuns, DeriveGeneric \#-}+--+-- module Main where+--+-- import AWS.Lambda.Runtime (readerTRuntime)+-- import AWS.Lambda.Combinators (withPureInterface, withoutContext)+-- import Data.Aeson (FromJSON)+--+-- data Named = {+-- name :: String+-- } deriving Generic+-- instance FromJSON Named+--+-- myHandler :: Named -> String+-- myHandler (Named { name }) =+-- "Hello, " ++ name+--+-- main :: IO ()+-- main = (readerTRuntime . withPureInterface . withoutContext) myHandler+-- @+withoutContext :: a -> b -> a+withoutContext = const
src/AWS/Lambda/Context.hs view
@@ -16,10 +16,12 @@ LambdaContext(..), HasLambdaContext(..), defConfig,- getRemainingTime+ getRemainingTime,+ runReaderTLambdaContext ) where import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, runReaderT) import Data.Aeson (FromJSON, ToJSON) import Data.Map (Map) import Data.Text (Text)@@ -83,3 +85,7 @@ instance DefConfig LambdaContext where defConfig = LambdaContext "" "" 0 "" "" "" "" "" (posixSecondsToUTCTime 0) Nothing Nothing++-- | Helper for using arbitrary monads with only the LambdaContext in its Reader+runReaderTLambdaContext :: ReaderT LambdaContext m a -> m a+runReaderTLambdaContext = flip runReaderT defConfig
+ src/AWS/Lambda/Events/S3/PutEvent.hs view
@@ -0,0 +1,56 @@+module AWS.Lambda.Events.S3.PutEvent (+ PutEvent,+ RequestParameters(..),+ Record(..)+) where++import Data.Text (Text)+import GHC.Generics (Generic)+import Data.Aeson (FromJSON)++type PutEvent = [Record]++data RequestParameters = RequestParameters { sourceIPAddress :: Text } deriving (Show, Eq, Generic)++data Record = Record {+ eventVersion :: Text,+ eventTime :: Text, -- Should be date+ requestParameters :: RequestParameters+}++{-+{+ "eventVersion": "2.0",+ "eventTime": "1970-01-01T00:00:00.000Z",+ "requestParameters": {+ "sourceIPAddress": "127.0.0.1"+ },+ "s3": {+ "configurationId": "testConfigRule",+ "object": {+ "eTag": "0123456789abcdef0123456789abcdef",+ "sequencer": "0A1B2C3D4E5F678901",+ "key": "HappyFace.jpg",+ "size": 1024+ },+ "bucket": {+ "arn": bucketarn,+ "name": "sourcebucket",+ "ownerIdentity": {+ "principalId": "EXAMPLE"+ }+ },+ "s3SchemaVersion": "1.0"+ },+ "responseElements": {+ "x-amz-id-2": "EXAMPLE123/5678abcdefghijklambdaisawesome/mnopqrstuvwxyzABCDEFGH",+ "x-amz-request-id": "EXAMPLE123456789"+ },+ "awsRegion": "us-east-1",+ "eventName": "ObjectCreated:Put",+ "userIdentity": {+ "principalId": "EXAMPLE"+ },+ "eventSource": "aws:s3"+}+-}
src/AWS/Lambda/Runtime.hs view
@@ -7,6 +7,14 @@ 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.++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 (@@ -20,11 +28,13 @@ mRuntimeWithContext ) where -import AWS.Lambda.RuntimeClient (RuntimeClientConfig, getNextEvent,- getRuntimeClientConfig,- sendEventError, sendEventSuccess,- sendInitError)-import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..))+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 ((<*>), liftA2)@@ -32,8 +42,7 @@ import Control.Monad (forever) import Control.Monad.Catch (MonadCatch, try) import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader (MonadReader, ReaderT, ask, local,- runReaderT)+import Control.Monad.Reader (MonadReader, ReaderT, local) import Data.Aeson (FromJSON, ToJSON, decode) import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as BSC@@ -42,9 +51,10 @@ import Data.Text (unpack) import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Network.HTTP.Simple (getResponseBody, getResponseHeader)+import Network.HTTP.Simple (Request, getResponseBody,+ getResponseHeader) import System.Environment (setEnv)-import System.Envy (decodeEnv, defConfig)+import System.Envy (decodeEnv) exactlyOneHeader :: [a] -> Maybe a exactlyOneHeader [a] = Just a@@ -77,11 +87,11 @@ _ -> Nothing -runtimeLoop :: (HasLambdaContext r, MonadReader r m, MonadCatch m, MonadIO m, FromJSON event, ToJSON result) => RuntimeClientConfig -> StaticContext ->+runtimeLoop :: (HasLambdaContext r, MonadReader r m, MonadCatch m, MonadIO m, FromJSON event, ToJSON result) => Request -> StaticContext -> (event -> m result) -> m ()-runtimeLoop runtimeClientConfig staticContext fn = do+runtimeLoop baseRuntimeRequest staticContext fn = do -- Get an event- nextRes <- liftIO $ getNextEvent runtimeClientConfig+ 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@@ -104,8 +114,8 @@ $ 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+ <$> mTraceId+ <*> mFunctionArn <*> mDeadline <*> mClientContext <*> mIdentity@@ -129,8 +139,8 @@ return $ first (displayException :: SomeException -> String) caughtResult liftIO $ case result of- Right r -> sendEventSuccess runtimeClientConfig reqIdBS r- Left e -> sendEventError runtimeClientConfig reqIdBS e+ Right r -> sendEventSuccess baseRuntimeRequest reqIdBS r+ Left e -> sendEventError baseRuntimeRequest reqIdBS e --TODO: Revisit all names before we put them under contract -- | For any monad that supports IO/catch/Reader LambdaContext.@@ -173,19 +183,17 @@ 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+ -- 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 runtimeClientConfig err- Right staticContext -> forever $ runtimeLoop runtimeClientConfig staticContext fn---- | Helper for using arbitrary monads with only the LambdaContext in its Reader-readerTRuntimeWithContext :: ReaderT LambdaContext m a -> m a-readerTRuntimeWithContext = flip runReaderT defConfig+ 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. --@@ -222,7 +230,7 @@ -- @ readerTRuntime :: (FromJSON event, ToJSON result) => (event -> ReaderT LambdaContext IO result) -> IO ()-readerTRuntime = readerTRuntimeWithContext . mRuntimeWithContext+readerTRuntime = runReaderTLambdaContext . mRuntimeWithContext -- | For functions with IO that can fail in a pure way (or via throw). --@@ -257,13 +265,7 @@ -- @ ioRuntimeWithContext :: (FromJSON event, ToJSON result) => (LambdaContext -> event -> IO (Either String result)) -> IO ()-ioRuntimeWithContext fn = readerTRuntime (\event -> do- config <- ask- result <- liftIO $ fn config event- case result of- Left e -> error e- Right x -> return x- )+ioRuntimeWithContext = readerTRuntime . withIOInterface -- | For functions with IO that can fail in a pure way (or via throw). --@@ -295,8 +297,7 @@ -- @ ioRuntime :: (FromJSON event, ToJSON result) => (event -> IO (Either String result)) -> IO ()-ioRuntime fn = ioRuntimeWithContext wrapped- where wrapped _ e = fn e+ioRuntime = readerTRuntime . withIOInterface . withoutContext -- | For pure functions that can still fail. --@@ -330,8 +331,7 @@ -- @ fallibleRuntimeWithContext :: (FromJSON event, ToJSON result) => (LambdaContext -> event -> Either String result) -> IO ()-fallibleRuntimeWithContext fn = ioRuntimeWithContext wrapped- where wrapped c e = return $ fn c e+fallibleRuntimeWithContext = readerTRuntime . withFallibleInterface -- | For pure functions that can still fail. --@@ -363,9 +363,7 @@ -- @ fallibleRuntime :: (FromJSON event, ToJSON result) => (event -> Either String result) -> IO ()-fallibleRuntime fn = fallibleRuntimeWithContext wrapped- where- wrapped _ e = fn e+fallibleRuntime = readerTRuntime . withFallibleInterface . withoutContext -- | For pure functions that can never fail that also need access to the context. --@@ -396,8 +394,7 @@ -- @ pureRuntimeWithContext :: (FromJSON event, ToJSON result) => (LambdaContext -> event -> result) -> IO ()-pureRuntimeWithContext fn = fallibleRuntimeWithContext wrapped- where wrapped c e = Right $ fn c e+pureRuntimeWithContext = readerTRuntime . withPureInterface -- | For pure functions that can never fail. --@@ -423,4 +420,4 @@ -- main = pureRuntime myHandler -- @ pureRuntime :: (FromJSON event, ToJSON result) => (event -> result) -> IO ()-pureRuntime fn = fallibleRuntime (Right . fn)+pureRuntime = readerTRuntime . withPureInterface . withoutContext
src/AWS/Lambda/RuntimeClient.hs view
@@ -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 Control.Exception (displayException, try, throw)+import Data.Aeson (encode) import Data.Aeson.Types (FromJSON, 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, JSONException,+ Request, Response,+ getResponseStatus, httpJSONEither,+ 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,14 @@ -- 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+getNextEvent :: FromJSON a => Request -> IO (Response (Either JSONException a))+getNextEvent baseRuntimeRequest = do+ resOrEx <- runtimeClientRetryTry $ httpJSONEither $ toNextEventRequest baseRuntimeRequest let checkStatus res = if not $ statusIsSuccessful $ getResponseStatus res then Left "Unexpected Runtime Error: Could not retrieve next event." else@@ -95,13 +65,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 +92,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