diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Nike, Inc. (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,170 @@ +# hal + +A runtime environment for [Haskell] applications running on [AWS Lambda]. + +#### Flexible + +This library uniquely supports different types of AWS Lambda Handlers for your needs/comfort with advanced Haskell. +Instead of exposing a single function that constructs a Lambda, this library exposes many. + +For lambdas that are pure and safe, then `pureRuntime` is ideal. +It accepts a handler with the signature `(FromJSON a, ToJSON b) => a -> b`. +This runtime guarantees that side-effects cannot occur. + +For advanced use cases `mRuntimeWithContext` unlocks the full power of Monad Transformers. +It accepts handlers with the signature `(HasLambdaContext r, MonadCatch m, MonadReader r m, MonadIO m, FromJSON event, ToJSON result) => (event -> m result)` +This enables users to add caching logic or expose complex environments. + +With numerous options in between these two, developers can choose the right balance of flexibility vs simplicity. + +#### Performant + +Measuring lambda performance is tricky, so investigation and optimization is ongoing. +Current indications show a _warm_ execution overhead of only ~20% more than the official [Rust Runtime] (a much lower level language). + +#### Robust + +While testing continues, we have executed over 30k test events without error caused by the runtime. +Naive approaches lead to error rates well over 10%. + +## Table of Contents + + - [Quick Start](#quick-start) + - [Usage](#usage) + - [Local Testing](#local-testing) + +## Quick Start + +This quick start assumes you have the following tools installed: + + - [Stack][stack.yaml] + - [Docker] + - [aws-cli] + +Add `hal` to your [stack.yaml]'s [`extra-deps`] and enable +[Docker] integration so that your binary is automatically compiled in a +compatible environment for AWS. Also add `hal` to your project's +dependency list (either `project-name.cabal` or `package.yaml`) + +```yaml +#... +packages: + - '.' + - hal-0.1.0 +# ... +docker: + enable: true +# ... +``` + +Then, define your types and handler: + +```haskell +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveGeneric #-} + +module Main where + +import AWS.Lambda.Runtime (simpleLambdaRuntime) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data Request = Request { + input :: String +} deriving (Generic) + +instance FromJSON Request + +data Response = Response { + output :: String +} deriving (Generic) + +instance ToJSON Response + +idHandler :: Request -> Response +idHandler Request { input } = Response { output = input } + +main :: IO () +main = simpleLambdaRuntime idHandler +``` + +Don't forget to define your [CloudFormation] stack: + +```yaml +# file: template.yaml +AWSTemplateFormatVersion: '2010-09-09' +Transform: 'AWS::Serverless-2016-10-31' +Description: Test for the Haskell Runtime. +Resources: + HelloWorldApp: + Type: 'AWS::Serverless::Function' + Properties: + Handler: NOT_USED + Runtime: provided + CodeUri: .stack-work/docker/_home/.local/bin/ + Description: My Haskell runtime. + MemorySize: 128 + Timeout: 3 +``` + +Finally, build, upload and test your lambda! + +```bash +# Build the binary, make sure your executable is named `bootstrap` +stack build --copy-bins + +# Create your function package +aws cloudformation package \ + --template-file template.yaml + --s3-bucket your-existing-bucket > \ + deployment_stack.yaml + +# Deploy your function +aws cloudformation deploy \ + --stack-name "hello-world-haskell" \ + --region us-west-2 \ + --capabilities CAPABILITY_IAM \ + --template-file deployment_stack.yaml + +# Take it for a spin! +aws lambda invoke \ + --function-name your-function-name \ + --region us-west-2 + --payload '{"input": "foo"}' + output.txt +``` + +## Usage + +TODO + +## Local Testing + +### Dependencies + + - [Stack][stack.yaml] + - [Docker] + - [aws-sam-cli] (>v0.8.0) + +### Build + +```bash +docker pull fpco/stack-build:lts-12.21 #first build only +stack build --copy-bins +``` + +### Execute + +```bash +echo '{ "accountId": "byebye" }' | sam local invoke --region us-east-1 +``` + +[AWS Lambda]: https://docs.aws.amazon.com/lambda/latest/dg/welcome.html +[Haskell]: https://www.haskell.org/ +[stack.yaml]: https://docs.haskellstack.org/ +[`extra-deps`]: https://docs.haskellstack.org/en/stable/yaml_configuration/#yaml-configuration +[Docker]: https://www.docker.com/why-docker +[aws-cli]: https://aws.amazon.com/cli/ +[CloudFormation]: https://aws.amazon.com/cloudformation/ +[aws-sam-cli]: https://github.com/awslabs/aws-sam-cli +[Rust Runtime]: https://github.com/awslabs/aws-lambda-rust-runtime diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hal.cabal b/hal.cabal new file mode 100644 --- /dev/null +++ b/hal.cabal @@ -0,0 +1,52 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 9e95d1b7a42420d7a38abcd2683add3ad06324396c38400f285f6ef0dea5ec98 + +name: hal +version: 0.1.0 +synopsis: Please see the README.md file for this project. +description: A runtime environment for Haskell applications running on AWS Lambda. +category: Web,AWS +homepage: https://github.com/Nike-inc/hal#readme +bug-reports: https://github.com/Nike-inc/hal/issues +author: Nike, Inc. +maintainer: nikeoss +copyright: 2018 Nike, Inc. +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/Nike-inc/hal + +library + exposed-modules: + AWS.Lambda.Context + AWS.Lambda.Internal + AWS.Lambda.Runtime + AWS.Lambda.RuntimeClient + other-modules: + Paths_hal + hs-source-dirs: + src + default-extensions: OverloadedStrings BangPatterns DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies 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 <2.0.0 + , base >=4.7 && <5 + , bytestring <1.0.0 + , containers <1.0.0 + , envy <2.0.0 + , exceptions <1.0.0 + , http-conduit <3.0.0 + , http-types <1.0.0 + , mtl <3.0.0 + , text <2.0.0 + , time <2.0.0 + default-language: Haskell2010 diff --git a/src/AWS/Lambda/Context.hs b/src/AWS/Lambda/Context.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Context.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} + +{-| +Module : AWS.Lambda.Context +Description : AWS Lambda Context classes and related methods. +Copyright : (c) Nike, Inc., 2018 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : stable +-} + +module AWS.Lambda.Context ( + ClientApplication(..), + ClientContext(..), + CognitoIdentity(..), + LambdaContext(..), + HasLambdaContext(..), + defConfig, + getRemainingTime +) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Text (Text) +import Data.Time.Clock (DiffTime, UTCTime, + diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import GHC.Generics (Generic) +import System.Envy (DefConfig (..)) + +data ClientApplication = ClientApplication + { appTitle :: Text, + appVersionName :: Text, + appVersionCode :: Text, + appPackageName :: Text + } deriving (Show, Generic) + +instance ToJSON ClientApplication +instance FromJSON ClientApplication + +data ClientContext = ClientContext + { client :: ClientApplication, + custom :: Map Text Text, + environment :: Map Text Text + } deriving (Show, Generic) + +instance ToJSON ClientContext +instance FromJSON ClientContext + +data CognitoIdentity = CognitoIdentity + { identityId :: Text + , identityPoolId :: Text + } deriving (Show, Generic) + +instance ToJSON CognitoIdentity +instance FromJSON CognitoIdentity + +getRemainingTime :: MonadIO m => LambdaContext -> m DiffTime +getRemainingTime LambdaContext { deadline } = + liftIO $ fmap (realToFrac . diffUTCTime deadline) getCurrentTime + +data LambdaContext = LambdaContext + { functionName :: Text, + functionVersion :: Text, + functionMemorySize :: Int, + logGroupName :: Text, + logStreamName :: Text, + -- The following context values come from headers rather than env vars. + awsRequestId :: Text, + invokedFunctionArn :: Text, + xRayTraceId :: Text, + deadline :: UTCTime, + clientContext :: Maybe ClientContext, + identity :: Maybe CognitoIdentity + } deriving (Show, Generic) + +class HasLambdaContext r where + withContext :: (LambdaContext -> r -> r) + +instance HasLambdaContext LambdaContext where + withContext = const + +instance DefConfig LambdaContext where + defConfig = LambdaContext "" "" 0 "" "" "" "" "" (posixSecondsToUTCTime 0) Nothing Nothing diff --git a/src/AWS/Lambda/Internal.hs b/src/AWS/Lambda/Internal.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Internal.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : AWS.Lambda.Internal +Description : Internal hal helper methods. +Copyright : (c) Nike, Inc., 2018 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : unstable +-} + +module AWS.Lambda.Internal ( + StaticContext(..), + DynamicContext(..), + mkContext +) where + +import AWS.Lambda.Context (ClientContext, CognitoIdentity, + LambdaContext (LambdaContext)) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) +import System.Envy (DefConfig (..), FromEnv, Option (..), + fromEnv, gFromEnvCustom) + +data StaticContext = StaticContext + { functionName :: Text, + functionVersion :: Text, + functionMemorySize :: Int, + logGroupName :: Text, + logStreamName :: Text + } deriving (Show, Generic) + +instance DefConfig StaticContext where + defConfig = StaticContext "" "" 0 "" "" + +instance FromEnv StaticContext where + fromEnv = gFromEnvCustom Option { + dropPrefixCount = 0, + customPrefix = "AWS_LAMBDA" + } + +data DynamicContext = DynamicContext + { awsRequestId :: Text, + invokedFunctionArn :: Text, + xRayTraceId :: Text, + deadline :: UTCTime, + clientContext :: Maybe ClientContext, + identity :: Maybe CognitoIdentity + } deriving (Show) + +mkContext :: StaticContext -> DynamicContext -> LambdaContext +mkContext static dynamic = + LambdaContext + (functionName static) + (functionVersion static) + (functionMemorySize static) + (logGroupName static) + (logStreamName static) + (awsRequestId dynamic) + (invokedFunctionArn dynamic) + (xRayTraceId dynamic) + (deadline dynamic) + (clientContext dynamic) + (identity dynamic) diff --git a/src/AWS/Lambda/Runtime.hs b/src/AWS/Lambda/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/Runtime.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE FlexibleContexts #-} + +{-| +Module : AWS.Lambda.Runtime +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 +-} + +module AWS.Lambda.Runtime ( + pureRuntime, + pureRuntimeWithContext, + fallibleRuntime, + fallibleRuntimeWithContext, + ioRuntime, + ioRuntimeWithContext, + readerTRuntime, + mRuntimeWithContext +) where + +import AWS.Lambda.RuntimeClient (getBaseRuntimeRequest, getNextEvent, + sendEventError, sendEventSuccess, sendInitError) +import AWS.Lambda.Context (LambdaContext(..), HasLambdaContext(..)) +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, ask, local, + runReaderT) +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 (Request, getResponseBody, + getResponseHeader) +import System.Environment (setEnv) +import System.Envy (decodeEnv, defConfig) + +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) => Request -> StaticContext -> + (event -> 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 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 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. +-- +-- 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(..)) +-- import AWS.Lambda.Runtime (mRuntimeWithContext) +-- import Control.Monad.Reader (ReaderT, ask) +-- import Control.Monad.State.Lazy (StateT, runStateT, get, put) +-- import Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- +-- data Named = { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: Named -> StateT Int (ReaderT LambdaContext IO String) +-- myHandler Named { name } = do +-- LambdaContext { functionName } <- ask +-- greeting <- getEnv \"GREETING\" +-- +-- greetingCount <- get +-- put $ greetingCount + 1 +-- +-- return $ greeting ++ name ++ " (" ++ show greetingCount ++ ") from " ++ unpack functionName ++ "!" +-- +-- main :: IO () +-- main = runStateT (mRuntimeWithContext myHandler) 0 +-- @ +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 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 + +-- | Helper for using arbitrary monads with only the LambdaContext in its Reader +readerTRuntimeWithContext :: ReaderT LambdaContext m a -> m a +readerTRuntimeWithContext = flip runReaderT defConfig + +-- | 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 Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- +-- data Named = { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: Named -> ReaderT LambdaContext IO String +-- myHandler Named { name } = do +-- LambdaContext { functionName } <- ask +-- greeting <- getEnv \"GREETING\" +-- return $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" +-- +-- main :: IO () +-- main = readerTRuntime myHandler +-- @ +readerTRuntime :: (FromJSON event, ToJSON result) => + (event -> ReaderT LambdaContext IO result) -> IO () +readerTRuntime = readerTRuntimeWithContext . 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 Data.Aeson (FromJSON) +-- import Data.Text (unpack) +-- import System.Environment (getEnv) +-- +-- data Named = { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: LambdaContext -> Named -> IO String +-- myHandler (LambdaContext { functionName }) (Named { name }) = do +-- greeting <- getEnv \"GREETING\" +-- return $ greeting ++ name ++ " from " ++ unpack functionName ++ "!" +-- +-- main :: IO () +-- main = ioRuntimeWithContext myHandler +-- @ +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 + ) + +-- | 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 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 = ioRuntime myHandler +-- @ +ioRuntime :: (FromJSON event, ToJSON result) => + (event -> IO (Either String result)) -> IO () +ioRuntime fn = ioRuntimeWithContext wrapped + where wrapped _ e = fn e + +-- | 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 (FromJSON) +-- import Data.Text (unpack) +-- +-- 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 = fallibleRuntimeWithContext myHandler +-- @ +fallibleRuntimeWithContext :: (FromJSON event, ToJSON result) => + (LambdaContext -> event -> Either String result) -> IO () +fallibleRuntimeWithContext fn = ioRuntimeWithContext wrapped + where wrapped c e = return $ fn c e + +-- | 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 (FromJSON) +-- +-- data Named = { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: Named -> Either String String +-- myHandler (Named { name }) = +-- if name == \"World\" then +-- Right "Hello, World!" +-- else +-- Left "Can only greet the world." +-- +-- main :: IO () +-- main = fallibleRuntime myHandler +-- @ +fallibleRuntime :: (FromJSON event, ToJSON result) => + (event -> Either String result) -> IO () +fallibleRuntime fn = fallibleRuntimeWithContext wrapped + where + wrapped _ e = fn e + +-- | 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 (FromJSON) +-- import Data.Text (unpack) +-- +-- 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 = pureRuntimeWithContext myHandler +-- @ +pureRuntimeWithContext :: (FromJSON event, ToJSON result) => + (LambdaContext -> event -> result) -> IO () +pureRuntimeWithContext fn = fallibleRuntimeWithContext wrapped + where wrapped c e = Right $ fn c e + +-- | 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 (FromJSON) +-- +-- data Named = { +-- name :: String +-- } deriving Generic +-- instance FromJSON Named +-- +-- myHandler :: Named -> String +-- myHandler Named { name } = "Hello, " ++ name ++ "!" +-- +-- main :: IO () +-- main = pureRuntime myHandler +-- @ +pureRuntime :: (FromJSON event, ToJSON result) => (event -> result) -> IO () +pureRuntime fn = fallibleRuntime (Right . fn) diff --git a/src/AWS/Lambda/RuntimeClient.hs b/src/AWS/Lambda/RuntimeClient.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/RuntimeClient.hs @@ -0,0 +1,148 @@ +{-| +Module : AWS.Lambda.RuntimeClient +Description : HTTP related machinery for talking to the AWS Lambda Custom Runtime interface. +Copyright : (c) Nike, Inc., 2018 +License : BSD3 +Maintainer : nathan.fairhurst@nike.com, fernando.freire@nike.com +Stability : stable +-} + +module AWS.Lambda.RuntimeClient ( + getBaseRuntimeRequest, + getNextEvent, + sendEventSuccess, + sendEventError, + sendInitError +) where + +import Control.Concurrent (threadDelay) +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 GHC.Generics (Generic (..)) +import Network.HTTP.Simple (HttpException, JSONException, + Request, Response, + getResponseStatus, httpJSONEither, + httpNoBody, parseRequest, + setRequestBodyJSON, + setRequestBodyLBS, + setRequestCheckStatus, + setRequestHeader, setRequestMethod, + setRequestPath) +import Network.HTTP.Types.Status (status413, statusIsSuccessful) +import System.Environment (getEnv) + +-- | Lambda runtime error that we pass back to AWS +data LambdaError = LambdaError + { errorMessage :: String, + errorType :: String, + stackTrace :: [String] + } deriving (Show, Generic) + +instance ToJSON LambdaError + +-- Exposed Handlers + +-- TODO: It would be interesting if we could make the interface a sort of +-- "chained" callback API. So instead of getting back a base request to kick +-- 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. +getBaseRuntimeRequest :: IO Request +getBaseRuntimeRequest = do + awsLambdaRuntimeApi <- getEnv "AWS_LAMBDA_RUNTIME_API" + parseRequest $ "http://" ++ awsLambdaRuntimeApi + +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 retrieve next event." + else + Right res + let resOrMsg = first (displayException :: HttpException -> String) resOrEx >>= checkStatus + case resOrMsg of + Left msg -> do + _ <- sendInitError baseRuntimeRequest msg + error msg + Right y -> return y + +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 -> + -- aka NonRecoverable + Left $ Left $ displayException (ex :: HttpException) + Right res -> + if getResponseStatus res == status413 then + -- TODO Get the real error info from the response + -- aka Recoverable + Left (Right "Payload Too Large") + else if not $ statusIsSuccessful $ getResponseStatus res then + --aka NonRecoverable + Left (Left "Unexpected Runtime Error: Could not post handler result.") + else + --aka Success + Right () + + case resOrTypedMsg of + Left (Left msg) -> + -- If an exception occurs here, we want that to propogate + sendEventError baseRuntimeRequest reqId msg + Left (Right msg) -> error msg + Right () -> return () + +sendEventError :: Request -> BS.ByteString -> String -> IO () +sendEventError baseRuntimeRequest reqId e = + fmap (const ()) $ runtimeClientRetry $ httpNoBody $ toEventErrorRequest reqId e baseRuntimeRequest + +sendInitError :: Request -> String -> IO () +sendInitError baseRuntimeRequest e = + fmap (const ()) $ runtimeClientRetry $ httpNoBody $ toInitErrorRequest e baseRuntimeRequest + +-- Retry Helpers + +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' 3 + +runtimeClientRetry :: IO (Response a) -> IO (Response a) +runtimeClientRetry = fmap (either throw id) . runtimeClientRetryTry + + +-- Request Transformers + +toNextEventRequest :: Request -> Request +toNextEventRequest = setRequestPath "2018-06-01/runtime/invocation/next" + +toEventSuccessRequest :: ToJSON a => BS.ByteString -> a -> Request -> Request +toEventSuccessRequest reqId json = + setRequestBodyJSON json . + setRequestMethod "POST" . + setRequestPath (BS.concat ["2018-06-01/runtime/invocation/", reqId, "/response"]) + +toBaseErrorRequest :: String -> Request -> Request +toBaseErrorRequest e = + setRequestBodyLBS (encode (LambdaError { errorMessage = e, stackTrace = [], errorType = "User"})) + . setRequestHeader "Content-Type" ["application/vnd.aws.lambda.error+json"] + . setRequestMethod "POST" + . setRequestCheckStatus + +toEventErrorRequest :: BS.ByteString -> String -> Request -> Request +toEventErrorRequest reqId e = + setRequestPath (BS.concat ["2018-06-01/runtime/invocation/", reqId, "/error"]) . toBaseErrorRequest e + +toInitErrorRequest :: String -> Request -> Request +toInitErrorRequest e = + setRequestPath "2018-06-01/runtime/init/error" . toBaseErrorRequest e