diff --git a/hal.cabal b/hal.cabal --- a/hal.cabal +++ b/hal.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2175dc8b8db69d64e82ae49c3130cc5d820d63bc28a956f8d4aa3af961c4ddb5 +-- hash: d43ec18e49bb7ce77fd444cdf150662cb6ff0f3c8ba1349dbd4318e6b5bc7e29 name: hal -version: 0.4.5 +version: 0.4.6 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,8 @@ exposed-modules: AWS.Lambda.Combinators AWS.Lambda.Context + AWS.Lambda.Events.ApiGateway.ProxyRequest + AWS.Lambda.Events.ApiGateway.ProxyResponse AWS.Lambda.Events.S3 AWS.Lambda.Events.SQS AWS.Lambda.Internal @@ -42,12 +44,14 @@ Paths_hal hs-source-dirs: src - default-extensions: OverloadedStrings BangPatterns DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms ScopedTypeVariables + default-extensions: OverloadedStrings BangPatterns DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DuplicateRecordFields EmptyCase GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms ScopedTypeVariables ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-partial-type-signatures -fno-warn-name-shadowing -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns build-depends: aeson , base >=4.7 && <5 + , base64-bytestring , bytestring + , case-insensitive , conduit , conduit-extra , containers @@ -59,4 +63,5 @@ , mtl , text , time + , unordered-containers default-language: Haskell2010 diff --git a/src/AWS/Lambda/Events/ApiGateway/ProxyRequest.hs b/src/AWS/Lambda/Events/ApiGateway/ProxyRequest.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Events/ApiGateway/ProxyRequest.hs @@ -0,0 +1,174 @@ +{-| +Module : AWS.Lambda.Events.ApiGateway.ProxyRequest +Description : Data types that represent typical lambda responses +Copyright : (c) Nike, Inc., 2019 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : stable + +This module exposes types used to model incoming __proxy__ requests from AWS +API Gateway. These types are a light pass over the incoming JSON +representation. +-} +module AWS.Lambda.Events.ApiGateway.ProxyRequest + ( ProxyRequest(..) + , RequestContext(..) + , Identity(..) + , NoAuthorizer + , StrictlyNoAuthorizer + ) where + +import Data.Aeson (FromJSON, Value, parseJSON, + withObject, (.:), (.:?)) +import Data.ByteString.Base64.Lazy (decodeLenient) +import Data.ByteString.Lazy (ByteString) +import Data.CaseInsensitive (CI, mk) +import Data.Foldable (fold) +import Data.HashMap.Strict (HashMap, foldrWithKey, insert) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Void (Void) +import GHC.Generics (Generic (..)) + +-- This function is available in Data.Functor as of base 4.11, but we define it +-- here for compatibility. +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) x f = f <$> x + +infixl 1 <&> + +data Identity = Identity + { cognitoIdentityPoolId :: Maybe Text + , accountId :: Maybe Text + , cognitoIdentityId :: Maybe Text + , caller :: Maybe Text + , apiKey :: Maybe Text + , sourceIp :: Text + , accessKey :: Maybe Text + , cognitoAuthenticationType :: Maybe Text + , cognitoAuthenticationProvider :: Maybe Text + , userArn :: Maybe Text + , apiKeyId :: Maybe Text + , userAgent :: Maybe Text + , user :: Maybe Text + } deriving (Generic) + +instance FromJSON Identity + +data RequestContext a = RequestContext + { path :: Text + , accountId :: Text + , authorizer :: Maybe a + , resourceId :: Text + , stage :: Text + , domainPrefix :: Maybe Text + , requestId :: Text + , identity :: Identity + , domainName :: Maybe Text + , resourcePath :: Text + , httpMethod :: Text + , extendedRequestId :: Maybe Text + , apiId :: Text + } + +instance FromJSON a => FromJSON (RequestContext a) where + parseJSON = withObject "ProxyRequest" $ \v -> + RequestContext <$> v .: "path" <*> v .: "accountId" <*> + v .:? "authorizer" <*> + v .: "resourceId" <*> + v .: "stage" <*> + v .:? "domainPrefix" <*> + v .: "requestId" <*> + v .: "identity" <*> + v .:? "domainName" <*> + v .: "resourcePath" <*> + v .: "httpMethod" <*> + v .:? "extendedRequestId" <*> + v .: "apiId" + +-- TODO: Should also include websocket fields +-- | This type is for representing events that come from API Gateway via the +-- Lambda Proxy integration (forwarding HTTP data directly, rather than a +-- custom integration). It will automatically decode the event that comes in. +-- +-- The 'ProxyRequest' notably has one parameter for the type of information +-- returned by the API Gateway's custom authorizer (if applicable). This type +-- must also implement FromJSON so that it can be decoded. If you do not +-- expect this data to be populated we recommended using the 'NoAuthorizer' +-- type exported from this module (which is just an alias for 'Value'). If +-- there _must not_ be authorizer populated (this is unlikely) then use the +-- 'StrictlyNoAuthorizer' type. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns \#-} +-- {-\# LANGUAGE DuplicateRecordFields \#-} +-- +-- module Main where +-- +-- import AWS.Lambda.Runtime (pureRuntime) +-- import AWS.Lambda.Events.ApiGateway.ProxyRequest (ProxyRequest(..), NoAuthorizer) +-- import AWS.Lambda.Events.ApiGateway.ProxyResponse (ProxyResponse(..), textPlain, forbidden403, ok200) +-- +-- myHandler :: ProxyRequest NoAuthorizer -> ProxyResponse +-- myHandler ProxyRequest { httpMethod = \"GET\", path = "/say_hello" } = +-- ProxyResponse +-- { status = ok200 +-- , body = textPlain \"Hello\" +-- , headers = mempty +-- , multiValueHeaders = mempty +-- } +-- myHandler _ = +-- ProxyResponse +-- { status = forbidden403 +-- , body = textPlain \"Forbidden\" +-- , headers = mempty +-- , multiValueHeaders = mempty +-- } +-- +-- main :: IO () +-- main = pureRuntime myHandler +-- @ +data ProxyRequest a = ProxyRequest + { path :: Text + , headers :: HashMap (CI Text) Text + , multiValueHeaders :: HashMap (CI Text) [Text] + , pathParameters :: HashMap Text Text + , stageVariables :: HashMap Text Text + , requestContext :: RequestContext a + , resource :: Text + , httpMethod :: Text + , queryStringParameters :: HashMap Text Text + , multiValueQueryStringParameters :: HashMap Text [Text] + , body :: ByteString + } deriving (Generic) + +toCIHashMap :: HashMap Text a -> HashMap (CI Text) a +toCIHashMap = foldrWithKey (insert . mk) mempty + +toByteString :: Bool -> TL.Text -> ByteString +toByteString isBase64Encoded = + if isBase64Encoded + then decodeLenient . TLE.encodeUtf8 + else TLE.encodeUtf8 + +-- | For ignoring API Gateway custom authorizer values +type NoAuthorizer = Value + +-- | For ensuring that there were no API Gateway custom authorizer values (this +-- is not likely to be useful, you probably want 'NoAuthorizer') +type StrictlyNoAuthorizer = Void + +instance FromJSON a => FromJSON (ProxyRequest a) where + parseJSON = withObject "ProxyRequest" $ \v -> + ProxyRequest <$> v .: "path" <*> + (v .:? "headers" <&> toCIHashMap . fold) <*> + (v .:? "multiValueHeaders" <&> toCIHashMap . fold) <*> + (v .:? "pathParameters" <&> fold) <*> + (v .:? "stageVariables" <&> fold) <*> + v .: "requestContext" <*> + v .: "resource" <*> + v .: "httpMethod" <*> + (v .:? "queryStringParameters" <&> fold) <*> + (v .:? "multiValueQueryStringParameters" <&> fold) <*> + (toByteString <$> v .: "isBase64Encoded" <*> (v .:? "body" <&> fold)) diff --git a/src/AWS/Lambda/Events/ApiGateway/ProxyResponse.hs b/src/AWS/Lambda/Events/ApiGateway/ProxyResponse.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Events/ApiGateway/ProxyResponse.hs @@ -0,0 +1,210 @@ +{-| +Module : AWS.Lambda.Events.ApiGateway.ProxyResponse +Description : Data types that represent typical lambda responses +Copyright : (c) Nike, Inc., 2019 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : stable + +This module enable exposes the required types for responding to API Gateway +Proxy Events. Responses must return a status, body, and optionaly headers. +Multiple smart contructors and helpers are provided to help encapsulated +details like header case-insensitivity, multiple header copies, correct base64 +encoding, and default content type. +-} +module AWS.Lambda.Events.ApiGateway.ProxyResponse + ( ProxyResponse(..) + , response + , addHeader + , setHeader + , ProxyBody(..) + , textPlain + , applicationJson + , genericBinary + , module Network.HTTP.Types.Status + ) where + +import Data.Aeson (ToJSON, encode, object, toJSON, + (.=)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 +import Data.CaseInsensitive (CI, mk, original) +import Data.HashMap.Strict (HashMap, foldrWithKey, insert, + insertWith) +import Data.Semigroup ((<>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Network.HTTP.Types.Status (Status (..), accepted202, + badGateway502, badRequest400, + conflict409, continue100, + created201, expectationFailed417, + forbidden403, found302, + gatewayTimeout504, gone410, + httpVersionNotSupported505, + imATeapot418, + internalServerError500, + lengthRequired411, + methodNotAllowed405, + movedPermanently301, + multipleChoices300, + networkAuthenticationRequired511, + noContent204, nonAuthoritative203, + notAcceptable406, notFound404, + notImplemented501, notModified304, + ok200, partialContent206, + paymentRequired402, + permanentRedirect308, + preconditionFailed412, + preconditionRequired428, + proxyAuthenticationRequired407, + requestEntityTooLarge413, + requestHeaderFieldsTooLarge431, + requestTimeout408, + requestURITooLong414, + requestedRangeNotSatisfiable416, + resetContent205, seeOther303, + serviceUnavailable503, status100, + status101, status200, status201, + status202, status203, status204, + status205, status206, status300, + status301, status302, status303, + status304, status305, status307, + status308, status400, status401, + status402, status403, status404, + status405, status406, status407, + status408, status409, status410, + status411, status412, status413, + status414, status415, status416, + status417, status418, status422, + status426, status428, status429, + status431, status500, status501, + status502, status503, status504, + status505, status511, + switchingProtocols101, + temporaryRedirect307, + tooManyRequests429, unauthorized401, + unprocessableEntity422, + unsupportedMediaType415, + upgradeRequired426, useProxy305) + +-- | Type that represents the body returned to an API Gateway when using HTTP +-- Lambda Proxy integration. It is highly recommended that you do not use this +-- type directly, and instead use the smart constructors exposed such as +-- 'textPlain', 'applicationJson', and 'genericBinary'. These make sure that +-- the base64 encodings work transparently. +data ProxyBody = ProxyBody + { contentType :: T.Text + , serialized :: T.Text + , isBase64Encoded :: Bool + } deriving (Show) + +-- | A response returned to an API Gateway when using the HTTP Lambda Proxy +-- integration. ContentType will be set based on the ProxyBody (recommended) +-- if a value is not present in the headers field. +-- +-- This type can be constructed explicity or via the smart constructor +-- `response`. Headers can then be added incrementally with `addHeader` or +-- `setHeader`. The smart constructor pattern is recommended because it avoids +-- some of the awkwardness of dealing with the multiValueHeaders field's type. +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns \#-} +-- {-\# LANGUAGE DuplicateRecordFields \#-} +-- {-\# LANGUAGE OverloadedStrings \#-} +-- +-- module Main where +-- +-- import AWS.Lambda.Runtime (pureRuntime) +-- import AWS.Lambda.Events.ApiGateway.ProxyRequest (ProxyRequest(..), NoAuthorizer) +-- import AWS.Lambda.Events.ApiGateway.ProxyResponse (ProxyResponse(..), textPlain, forbidden403, ok200, response) +-- +-- myHandler :: ProxyRequest NoAuthorizer -> ProxyResponse +-- myHandler ProxyRequest { httpMethod = \"GET\", path = "/say_hello" } = +-- -- Smart Constructor and added header (recommended) +-- addHeader "My-Custom-Header" "Value" $ +-- response ok200 $ textPlain \"Hello\" +-- myHandler _ = +-- -- Explicit Construction (not recommended) +-- ProxyResponse +-- { status = forbidden403 +-- , body = textPlain \"Forbidden\" +-- , multiValueHeaders = +-- fromList [(mk "My-Custom-Header", ["Other Value])] +-- } +-- +-- main :: IO () +-- main = pureRuntime myHandler +-- @ +data ProxyResponse = ProxyResponse + { status :: Status + , multiValueHeaders :: HashMap (CI T.Text) [T.Text] + , body :: ProxyBody + } deriving (Show) + +-- | Smart constructor for creating a ProxyResponse from a status and a body +response :: Status -> ProxyBody -> ProxyResponse +response = + flip ProxyResponse mempty + +-- | Add a header to the ProxyResponse. If there was already a value for this +-- header, this one is __added__, meaning the response will include multiple +-- copies of this header (valid by the HTTP spec). This does NOT replace any +-- previous headers or their values. +addHeader :: T.Text -> T.Text -> ProxyResponse -> ProxyResponse +addHeader header value (ProxyResponse s mvh b) = + ProxyResponse s (insertWith (<>) (mk header) [value] mvh) b + +-- | Set a header to the ProxyResponse. If there were any previous values for +-- this header they are __all replaced__ by this new value. +setHeader :: T.Text -> T.Text -> ProxyResponse -> ProxyResponse +setHeader header value (ProxyResponse s mvh b) = + ProxyResponse s (insert (mk header) [value] mvh) b + +-- | Smart constructor for creating a ProxyBody with an arbitrary ByteString of +-- the chosen content type. Use this smart constructor to avoid invalid JSON +-- representations of binary data. +-- +-- From here it is easy to make more specific body constructors: +-- +-- @ +-- imageGif :: ByteString -> ProxyBody +-- imageGif = genericBinary "image/gif" +-- +-- imageJpeg :: ByteString -> ProxyBody +-- imageJpeg = genericBinary "image/jpeg" +-- @ +genericBinary :: T.Text -> ByteString -> ProxyBody +genericBinary contentType x = + ProxyBody contentType (TE.decodeUtf8 $ B64.encode x) True + +-- | Smart constructor for creating a simple body of text. +textPlain :: T.Text -> ProxyBody +textPlain x = ProxyBody "text/plain; charset=utf-8" x False + +-- | Smart constructor for creating a simple body of JSON. +applicationJson :: ToJSON a => a -> ProxyBody +applicationJson x = + ProxyBody + "application/json; charset=utf-8" + (TL.toStrict $ TLE.decodeUtf8 $ encode x) + False + +-- | Smart constructor for creating a simple body of a GIF (that has already +-- been converted to a ByteString). + +instance ToJSON ProxyResponse where + toJSON (ProxyResponse status mvh (ProxyBody contentType body isBase64Encoded)) = + let unCI = foldrWithKey (insert . original) mempty + in object + [ "statusCode" .= statusCode status + , "multiValueHeaders" .= + insertWith + (\_ old -> old) + ("Content-Type" :: T.Text) + [contentType] + (unCI mvh) + , "body" .= body + , "isBase64Encoded" .= isBase64Encoded + ] diff --git a/src/AWS/Lambda/Runtime/Value.hs b/src/AWS/Lambda/Runtime/Value.hs --- a/src/AWS/Lambda/Runtime/Value.hs +++ b/src/AWS/Lambda/Runtime/Value.hs @@ -39,98 +39,27 @@ ) where import AWS.Lambda.RuntimeClient (RuntimeClientConfig, getRuntimeClientConfig, - getNextEvent, sendEventError, sendEventSuccess, - sendInitError) + getNextData, sendEventError, sendEventSuccess) 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.Aeson (ToJSON, 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 (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) => RuntimeClientConfig -> StaticContext -> +runtimeLoop :: (HasLambdaContext r, MonadReader r m, MonadCatch m, MonadIO m, ToJSON result) => RuntimeClientConfig -> (Value -> m result) -> m () -runtimeLoop runtimeClientConfig staticContext fn = do +runtimeLoop runtimeClientConfig 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 event = getResponseBody nextRes + (reqIdBS, event, eCtx) <- liftIO $ getNextData runtimeClientConfig result <- case eCtx of Left e -> return $ Left e @@ -198,15 +127,10 @@ 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 StaticContext within - -- RuntimeClientConfig that encapsulates more details runtimeClientConfig <- liftIO getRuntimeClientConfig - possibleStaticCtx <- liftIO $ (decodeEnv :: IO (Either String StaticContext)) + forever $ runtimeLoop runtimeClientConfig fn - case possibleStaticCtx of - Left err -> liftIO $ sendInitError runtimeClientConfig err - Right staticContext -> forever $ runtimeLoop runtimeClientConfig 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 @@ -10,23 +10,32 @@ module AWS.Lambda.RuntimeClient ( RuntimeClientConfig, getRuntimeClientConfig, + getNextData, getNextEvent, sendEventSuccess, sendEventError, - sendInitError ) where +import AWS.Lambda.Context (LambdaContext(..)) +import AWS.Lambda.Internal (DynamicContext(..), StaticContext, + mkContext) +import Control.Applicative ((<*>)) import Control.Concurrent (threadDelay) import Control.Exception (displayException, try, throw) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (encode, Value) +import Data.Aeson (decode, encode, Value) import Data.Aeson.Parser (value') -import Data.Aeson.Types (ToJSON) +import Data.Aeson.Types (FromJSON, ToJSON) import Data.Bifunctor (first) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSW +import qualified Data.ByteString.Internal as BSI import Data.Conduit (ConduitM, runConduit, yield, (.|)) import Data.Conduit.Attoparsec (sinkParser) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import GHC.Generics (Generic (..)) import Network.HTTP.Client (BodyReader, HttpException, Manager, Request, Response, brRead, @@ -37,7 +46,9 @@ managerSetProxy, newManager, noProxy, parseRequest, responseBody, responseTimeoutNone, withResponse) -import Network.HTTP.Simple (getResponseStatus, +import Network.HTTP.Simple (getResponseBody, + getResponseHeader, + getResponseStatus, setRequestBodyJSON, setRequestBodyLBS, setRequestCheckStatus, @@ -45,6 +56,7 @@ setRequestPath) import Network.HTTP.Types.Status (status403, status413, statusIsSuccessful) import System.Environment (getEnv) +import System.Envy (decodeEnv) -- | Lambda runtime error that we pass back to AWS data LambdaError = LambdaError @@ -55,7 +67,7 @@ instance ToJSON LambdaError -data RuntimeClientConfig = RuntimeClientConfig Request Manager +data RuntimeClientConfig = RuntimeClientConfig Request Manager StaticContext -- Exposed Handlers @@ -80,12 +92,56 @@ , managerConnCount = 1 , managerIdleConnectionCount = 1 } - return $ RuntimeClientConfig req man + possibleStaticCtx <- liftIO $ (decodeEnv :: IO (Either String StaticContext)) + + case possibleStaticCtx of + Left err -> do + liftIO $ sendInitError req man err + error err + Right staticCtx -> return $ RuntimeClientConfig req man staticCtx + + +getNextData :: RuntimeClientConfig -> IO (BS.ByteString, Value, Either String LambdaContext) +getNextData runtimeClientConfig@(RuntimeClientConfig _ _ staticContext) = do + nextRes <- getNextEvent runtimeClientConfig + + -- If we got an event but our requestId is invalid/missing, there's no hope of meaningful recovery + let reqIdBS = head $ getResponseHeader "Lambda-Runtime-Aws-Request-Id" nextRes + + let mTraceId = fmap decodeUtf8 $ exactlyOneHeader $ getResponseHeader "Lambda-Runtime-Trace-Id" nextRes + let mFunctionArn = fmap decodeUtf8 $ exactlyOneHeader $ getResponseHeader "Lambda-Runtime-Invoked-Function-Arn" nextRes + let mDeadline = do + header <- exactlyOneHeader (getResponseHeader "Lambda-Runtime-Deadline-Ms" nextRes) + milliseconds :: Double <- readMaybe $ BSC.unpack header + return $ posixSecondsToUTCTime $ realToFrac $ milliseconds / 1000 + + let mClientContext = decodeOptionalHeader $ getResponseHeader "Lambda-Runtime-Client-Context" nextRes + let mIdentity = decodeOptionalHeader $ getResponseHeader "Lambda-Runtime-Cognito-Identity" nextRes + + -- Build out the Dynamic portion of the Lambda Context + let eDynCtx = + maybeToEither "Runtime Error: Unable to decode Context from event response." + -- Build the Dynamic Context, collapsing individual Maybes into a single Maybe + $ DynamicContext (decodeUtf8 reqIdBS) + <$> mFunctionArn + <*> mTraceId + <*> mDeadline + <*> mClientContext + <*> mIdentity + + -- combine our StaticContext and possible DynamicContext into a LambdaContext + let eCtx = fmap (mkContext staticContext) eDynCtx + + let event = getResponseBody nextRes + + -- Return the interesting components + return (reqIdBS, event, eCtx) + -- AWS lambda guarantees that we will get valid JSON, -- so parsing is guaranteed to succeed. getNextEvent :: RuntimeClientConfig -> IO (Response Value) -getNextEvent rcc@(RuntimeClientConfig baseRuntimeRequest manager) = do +getNextEvent (RuntimeClientConfig baseRuntimeRequest manager _) = do resOrEx <- runtimeClientRetryTry $ flip httpValue manager $ toNextEventRequest baseRuntimeRequest let checkStatus res = if not $ statusIsSuccessful $ getResponseStatus res then Left "Unexpected Runtime Error: Could not retrieve next event." @@ -94,12 +150,12 @@ let resOrMsg = first (displayException :: HttpException -> String) resOrEx >>= checkStatus case resOrMsg of Left msg -> do - _ <- sendInitError rcc msg + _ <- sendInitError baseRuntimeRequest manager msg error msg Right y -> return y sendEventSuccess :: ToJSON a => RuntimeClientConfig -> BS.ByteString -> a -> IO () -sendEventSuccess rcc@(RuntimeClientConfig baseRuntimeRequest manager) reqId json = do +sendEventSuccess rcc@(RuntimeClientConfig baseRuntimeRequest manager _) reqId json = do resOrEx <- runtimeClientRetryTry $ flip httpNoBody manager $ toEventSuccessRequest reqId json baseRuntimeRequest let resOrTypedMsg = case resOrEx of @@ -126,12 +182,46 @@ Right () -> return () sendEventError :: RuntimeClientConfig -> BS.ByteString -> String -> IO () -sendEventError (RuntimeClientConfig baseRuntimeRequest manager) reqId e = +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 = +sendInitError :: Request -> Manager -> String -> IO () +sendInitError baseRuntimeRequest manager e = fmap (const ()) $ runtimeClientRetry $ flip httpNoBody manager $ toInitErrorRequest e baseRuntimeRequest + + +-- Helpers (mostly) for Headers + +exactlyOneHeader :: [a] -> Maybe a +exactlyOneHeader [a] = Just a +exactlyOneHeader _ = Nothing + +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither b ma = case ma of + Nothing -> Left b + Just a -> Right a + +-- Note: Does not allow whitespace +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing + +-- TODO: There must be a better way to do this +decodeHeaderValue :: FromJSON a => BSC.ByteString -> Maybe a +decodeHeaderValue = decode . BSW.pack . fmap BSI.c2w . BSC.unpack + +-- An empty array means we successfully decoded, but nothing was there +-- If we have exactly one element, our outer maybe signals successful decode, +-- and our inner maybe signals that there was content sent +-- If we had more than one header value, the event was invalid +decodeOptionalHeader :: FromJSON a => [BSC.ByteString] -> Maybe (Maybe a) +decodeOptionalHeader header = + case header of + [] -> Just Nothing + [x] -> fmap Just $ decodeHeaderValue x + _ -> Nothing + -- Helpers for Requests with JSON Bodies