diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ +[![Build Status](https://travis-ci.org/Nike-Inc/hal.svg?branch=master)](https://travis-ci.org/Nike-Inc/hal) + # hal A runtime environment for [Haskell] applications running on [AWS Lambda]. 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.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 diff --git a/src/AWS/Lambda/Events/S3.hs b/src/AWS/Lambda/Events/S3.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Events/S3.hs @@ -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 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,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. -- 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 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