hal 0.2.4 → 0.3.0
raw patch · 5 files changed
+171/−128 lines, 5 filesdep −conduitdep −conduit-extradep −http-clientdep ~aesondep ~bytestringdep ~containers
Dependencies removed: conduit, conduit-extra, http-client
Dependency ranges changed: aeson, bytestring, containers, envy, exceptions, http-conduit, http-types, mtl, text, time
Files
- README.md +2/−0
- hal.cabal +4/−6
- src/AWS/Lambda/Events/S3.hs +114/−0
- src/AWS/Lambda/Runtime.hs +18/−17
- 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].
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: b29d57401029cbe26aebf326a5291bf8a05d26bc749e7389a54ed9a52fc6b3d5+-- hash: 811e290f1780d180d8868adb2a10e2715dc938423a42a8eea7d6c73c821c7a24 name: hal-version: 0.2.4+version: 0.3.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@@ -32,6 +32,7 @@ exposed-modules: AWS.Lambda.Combinators AWS.Lambda.Context+ AWS.Lambda.Events.S3 AWS.Lambda.Internal AWS.Lambda.Runtime AWS.Lambda.RuntimeClient@@ -45,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/Events/S3.hs view
@@ -0,0 +1,114 @@+{-|+Module : AWS.Lambda.Events.S3+Description : Data types for working with S3 events.+Copyright : (c) Nike, Inc., 2019+License : BSD3+Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com+Stability : stable+-}++{-# LANGUAGE DuplicateRecordFields #-}++module AWS.Lambda.Events.S3 (+ PrincipalIdentity(..),+ Records(..),+ RequestParameters(..),+ ResponseElements(..),+ S3Bucket(..),+ S3Config(..),+ S3Event(..),+ S3Object(..)+) where++import Data.Aeson (FromJSON (..), Value (Object), withObject, (.:), (.:?))+import Data.Aeson.Types (typeMismatch)+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import GHC.Generics (Generic)++newtype Records = Records {+ records :: [S3Event]+} deriving (Show, Eq)++instance FromJSON Records where+ parseJSON = withObject "Records" $ \v -> Records <$> v .: "Records"++data PrincipalIdentity = PrincipalIdentity {+ principalId :: Text+} deriving (Show, Eq, Generic)++instance FromJSON PrincipalIdentity++data S3Bucket = S3Bucket {+ arn :: Text,+ name :: Text,+ ownerIdentity :: PrincipalIdentity+} deriving (Show, Eq, Generic)++instance FromJSON S3Bucket++data S3Config = S3Config {+ bucket :: S3Bucket,+ configurationId :: Text,+ object :: S3Object,+ s3SchemaVersion :: Text+} deriving (Show, Eq, Generic)++instance FromJSON S3Config++data ResponseElements = ResponseElements {+ amazonId :: Text,+ amazonRequestId :: Text+} deriving (Show, Eq)++instance FromJSON ResponseElements where+ parseJSON = withObject "ResponseElements" $ \v ->+ ResponseElements <$> v .: "x-amz-id-2" <*> v .: "x-amz-request-id"++data RequestParameters = RequestParameters {+ sourceIPAddress :: Text+} deriving (Show, Eq, Generic)++instance FromJSON RequestParameters++-- | Event data sent by S3 when triggering a Lambda.+data S3Event = S3Event {+ awsRegion :: Text,+ eventName :: Text,+ eventSource :: Text,+ eventTime :: UTCTime,+ eventVersion :: Text,+ requestParameters :: RequestParameters,+ responseElements :: ResponseElements,+ s3 :: S3Config,+ userIdentity :: PrincipalIdentity+} deriving (Show, Eq, Generic)++instance FromJSON S3Event++-- | S3 object representations based on event type received.+--+-- Currently only Put/Delete events can trigger Lambdas+data S3Object =+ PutObject {+ eTag :: Text,+ sequencer :: Text,+ key :: Text,+ size :: Int+ } | DeleteObject {+ sequencer :: Text,+ key :: Text+ } deriving (Show, Eq, Generic)++instance FromJSON S3Object where+ parseJSON (Object o) = do+ maybeEtag <- o .:? "eTag"+ maybeSize <- o .:? "size"+ key' <- o .: "key"+ sequencer' <- o .: "sequencer"++ return $ case (maybeEtag, maybeSize) of+ (Just etag', Just size') -> PutObject etag' sequencer' key' size'+ _ -> DeleteObject sequencer' key'++ parseJSON invalid = typeMismatch "S3Object" invalid
src/AWS/Lambda/Runtime.hs view
@@ -28,10 +28,8 @@ mRuntimeWithContext ) where -import AWS.Lambda.RuntimeClient (RuntimeClientConfig, getNextEvent,- getRuntimeClientConfig,- sendEventError, sendEventSuccess,- sendInitError)+import AWS.Lambda.RuntimeClient (getBaseRuntimeRequest, getNextEvent,+ sendEventError, sendEventSuccess, sendInitError) import AWS.Lambda.Combinators (withIOInterface, withFallibleInterface, withPureInterface,@@ -53,7 +51,8 @@ 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) @@ -88,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@@ -115,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@@ -140,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.@@ -184,15 +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+ 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. --
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