diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# The Library for Easily Writing Your Lambdas in Haskell + +Historically, if you wanted to use Haskell to write your Lambdas, you had to use +[a custom runtime](https://theam.github.io/aws-lambda-haskell-runtime/). However, +[AWS now allows you to use Docker images instead](https://aws.amazon.com/blogs/aws/new-for-aws-lambda-container-image-support/), +which simplifies deployments and +[avoids some nasty problems](https://theam.github.io/aws-lambda-haskell-runtime/05-common-errors.html). + +This library provides the translation layer that you need in order to fully leverage Lambda. It is implemented +in a classy way for maximum flexibility, even if it makes the type signatures a bit complicated. There is an +example of an implementation in the `example` folder, including a demonstration of how to do deployment. +Here's the simplest usage, adapted slightly from the example: + +```haskell + +import AWS.Lambda.RuntimeAPI ( runLambda ) +import AWS.Lambda.RuntimeAPI.Types ( LambdaResult(..), LambdaInvocation(..) ) +import Data.Aeson ( encode, Value ) +import qualified Data.ByteString.Lazy.Char8 as C8 + +-- Two lines of boilerplate +main :: IO () +main = runLambda handler + +-- Your implementation's code +handler :: LambdaInvocation Value -> IO (LambdaResult String) +handler request = do + putStrLn . C8.unpack $ encode request + return $ LambdaSuccess "This is the result payload" + +``` + +The request payload is wrapped in a `LambdaInvocation` type, which provides access to the +particular invocation that is being processed. In this case, we're treating the type as an +Aeson `Value`, which represents any arbitrary JSON structure. + +Your handler is responsible for consuming that request and producing a `LambdaResult`. A +`LambdaResult` instance is usually either `LambdaSuccess payload` or `LambdaError (Text, Text)`. +In the case of `LambdaSuccess`, the payload defines the "result" of the Lambda, and will be +transformed into JSON via the `ToJSON` typeclass. In the case of +`LambdaError`, the payload is `(ErrorType, ErrorMessage)`, which is passed to the Lambda +Runtime API in order to give a meaningful error to the user. There is also `LambdaNop` +which does nothing, but that's intended for internal use only. + +All of this executes in the `IO` monad in the example above, but you can use any +monad that implements `MonadUnliftIO`, `MonadFail`, and `MonadThrow`. + +And that's pretty much it. 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/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,25 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to + diff --git a/hs-aws-lambda.cabal b/hs-aws-lambda.cabal new file mode 100644 --- /dev/null +++ b/hs-aws-lambda.cabal @@ -0,0 +1,69 @@ +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.34.3. +-- +-- see: https://github.com/sol/hpack + +name: hs-aws-lambda +version: 0.1.0.1 +synopsis: A modern and easy-to-use wrapper for Docker-based Lambda implementations +description: Please see the README on GitHub at +category: AWS +homepage: https://github.com/RobertFischer/hs-aws-lambda#readme +bug-reports: https://github.com/RobertFischer/hs-aws-lambda/issues +author: Robert Fischer +maintainer: smokejumperit@gmail.com +copyright: Released under the Unlicense: https://unlicense.org/ +license: PublicDomain +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + UNLICENSE + +source-repository head + type: git + location: https://github.com/RobertFischer/hs-aws-lambda + +library + exposed-modules: + AWS.Lambda.RuntimeAPI + AWS.Lambda.RuntimeAPI.Types + other-modules: + Paths_hs_aws_lambda + autogen-modules: + Paths_hs_aws_lambda + hs-source-dirs: + src + default-extensions: BangPatterns BinaryLiterals CPP ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification ExtendedDefaultRules FlexibleContexts FlexibleInstances ForeignFunctionInterface FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MagicHash MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedLists OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PolyKinds QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving StaticPointers TemplateHaskell TupleSections TypeFamilies TypeOperators TypeSynonymInstances UnboxedTuples UnliftedFFITypes ViewPatterns TypeFamilyDependencies + ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -fprint-expanded-synonyms -fprint-explicit-coercions -fprint-equality-relations -fprint-typechecker-elaboration -freverse-errors -funclutter-valid-hole-fits -fhelpful-errors -fshow-warning-groups -fPIC -fno-warn-tabs -fno-warn-type-defaults -Werror=compat -Werror=partial-fields -Werror=missing-fields -Werror=incomplete-patterns -Werror=overlapping-patterns -Werror=redundant-constraints -feager-blackholing -fexcess-precision -flate-dmd-anal -fmax-inline-alloc-size=1024 -fmax-simplifier-iterations=16 -fsimplifier-phases=8 -fspec-constr-keen -fspec-constr-count=12 -fspecialise-aggressively -flate-specialise -fstatic-argument-transformation + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , case-insensitive + , containers + , deepseq + , http-client + , http-types + , safe-exceptions + , text + , text-conversions + , unliftio + default-language: Haskell2010 + +test-suite aws-lambda-runtime-api-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_hs_aws_lambda + autogen-modules: + Paths_hs_aws_lambda + hs-source-dirs: + test + default-extensions: BangPatterns BinaryLiterals CPP ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification ExtendedDefaultRules FlexibleContexts FlexibleInstances ForeignFunctionInterface FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MagicHash MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedLists OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PolyKinds QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving StaticPointers TemplateHaskell TupleSections TypeFamilies TypeOperators TypeSynonymInstances UnboxedTuples UnliftedFFITypes ViewPatterns TypeFamilyDependencies + ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -fprint-expanded-synonyms -fprint-explicit-coercions -fprint-equality-relations -fprint-typechecker-elaboration -freverse-errors -funclutter-valid-hole-fits -fhelpful-errors -fshow-warning-groups -fPIC -fno-warn-tabs -fno-warn-type-defaults -Werror=compat -Werror=partial-fields -Werror=missing-fields -Werror=incomplete-patterns -Werror=overlapping-patterns -Werror=redundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aws-lambda-runtime-api + , base >=4.7 && <5 + default-language: Haskell2010 diff --git a/src/AWS/Lambda/RuntimeAPI.hs b/src/AWS/Lambda/RuntimeAPI.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/RuntimeAPI.hs @@ -0,0 +1,203 @@ +module AWS.Lambda.RuntimeAPI + ( runLambda + ) where + +import AWS.Lambda.RuntimeAPI.Types +import Data.Aeson ( encode, eitherDecode' ) +import Data.List ( find ) +import System.Environment ( lookupEnv ) +import Text.Read ( readMaybe ) +import UnliftIO +import qualified Data.ByteString.Char8 as C8 +import qualified Data.CaseInsensitive as CI +import qualified Data.Map.Strict as Map +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.Internal as HTTP +import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types.Status as HTTP + +mkLambdaHeaderName :: (CI.FoldCase s, Semigroup s, IsString s) => s -> CI.CI s +mkLambdaHeaderName str = CI.mk $ "Lambda-Runtime-" <> str + +requestIdHeader :: HTTP.HeaderName +requestIdHeader = mkLambdaHeaderName "Aws-Request-Id" + +invokedFunctionArnHeader :: HTTP.HeaderName +invokedFunctionArnHeader = mkLambdaHeaderName "Invoked-Function-Arn" + +traceIdHeader :: HTTP.HeaderName +traceIdHeader = mkLambdaHeaderName "Trace-Id" + +clientContextHeader :: HTTP.HeaderName +clientContextHeader = mkLambdaHeaderName "Client-Context" + +cognitoIdentityHeader :: HTTP.HeaderName +cognitoIdentityHeader = mkLambdaHeaderName "Cognito-Identity" + +unhandledErrorHeader :: HTTP.Header +unhandledErrorHeader = ( mkLambdaHeaderName "Function-Error-Type", "Unhandled" ) + +apiVersion :: String +apiVersion = "2018-06-01" + +apiHostEnvVarName :: String +apiHostEnvVarName = "AWS_LAMBDA_RUNTIME_API" + +-- | This function is intended to be your `main` implementation. Given a handler for 'LambdaInvocation' instances, +-- it loops indefinitely (until AWS terminates the process) on the retrieval of invocations. It feeds each of those +-- invocations into the handler that was passed in as an argument. It then posts the result back to AWS and begins +-- the loop again. +runLambda :: (MonadUnliftIO m, MonadFail m, MonadThrow m, FromJSON a, ToJSON b, NFData a, NFData b) => (LambdaInvocation a -> m (LambdaResult b)) -> m () +runLambda handler = do + ctx <- lookupLEC handler + forever $ doRound ctx + +lookupLEC :: (MonadUnliftIO m, MonadFail m) => (LambdaInvocation a -> m (LambdaResult b)) -> m (LambdaExecutionContext a m b) +lookupLEC lecHandler = do + apiHost <- lookupApiHost + let lecApiPrefix = "http://" <> apiHost <> "/" <> apiVersion + lecHttpManager <- liftIO $ HTTP.newManager managerSettings + return LambdaExecutionContext{..} + where + lookupApiHost = liftIO ( lookupEnv apiHostEnvVarName ) >>= \case + Nothing -> fail $ "No API host environment variable name found: " <> apiHostEnvVarName + Just val -> return val + managerSettings = HTTP.defaultManagerSettings + { HTTP.managerResponseTimeout = HTTP.responseTimeoutNone + , HTTP.managerIdleConnectionCount = 1 + } + +doRound :: (MonadUnliftIO m, MonadThrow m, MonadFail m, FromJSON a, ToJSON b, NFData a, NFData b) => LambdaExecutionContext a m b -> m () +doRound ctx = getNextInvocation >>= \case + Nothing -> return () + Just request -> processRequest request >>= postResult ctx request + where + getNextInvocation = handleAnyDeep handleTopException ( Just <$> fetchNext ctx ) + handler = lecHandler ctx + processRequest invoc = handleAnyDeep handleException $ handler invoc + handleException e = return $ LambdaError (ct $ exToTypeStr e, ct $ exToHumanStr e) + handleTopException err = handleInvocationException ctx err >> return Nothing + +exToTypeStr :: (Exception e) => e -> String +exToTypeStr = show . typeOf + +exToHumanStr :: (Exception e) => e -> String +exToHumanStr = displayException + +handleInvocationException :: (MonadIO m, Exception e) => LambdaExecutionContext a m b -> e -> m () +handleInvocationException + LambdaExecutionContext{lecApiPrefix, lecHttpManager} + err + = liftIO $ do + putStrLn "!!!Invocation Exception!!!" + putStrLn "\tThis is a problem with the Lambda Runtime API or AWS." + putStrLn "\tThe problem is not in your code. Scroll down for details." + putStrLn "\tThe Runtime API will now attempt to get another invocation." + putStrLn "" + printTypeStr + printHumanStr + putStrLn "^^^Invocation Exception^^^" + initReq <- makeHttpRequest "POST" url body + let req = initReq + { HTTP.requestHeaders = unhandledErrorHeader : HTTP.requestHeaders initReq + } + response <- HTTP.httpNoBody req lecHttpManager + checkResponseStatus response + where + url = lecApiPrefix <> "/runtime/init/error" + body = Just $ Map.fromList + [ ( "errorMessage", humanStr ) + , ( "errorType", typeStr ) + ] + typeStr = exToTypeStr err + humanStr = exToHumanStr err + printTypeStr = putStrLn typeStr + printHumanStr = + if typeStr == humanStr then + return () + else + putStrLn $ exToHumanStr err + +checkResponseStatus :: MonadFail m => HTTP.Response body -> m () +checkResponseStatus response = + let status = HTTP.responseStatus response in + if HTTP.statusIsSuccessful $ HTTP.responseStatus response then + return () + else + fail $ "Received non-successful status when trying to fetch: " <> show status + +fetchNext :: (MonadUnliftIO m, MonadThrow m, MonadFail m, FromJSON a) => LambdaExecutionContext a m b -> m (LambdaInvocation a) +fetchNext LambdaExecutionContext{lecApiPrefix, lecHttpManager} = do + req <- makeHttpRequest "GET" url (Nothing::Maybe ()) + response <- liftIO $ HTTP.httpLbs req lecHttpManager + checkResponseStatus response + liPayload <- readPayload response + liAwsRequestId <- readHeader response requestIdHeader + liDeadlineMs <- readDeadline response + liInvokedFunctionArn <- readHeader response invokedFunctionArnHeader + liTraceId <- readHeader response traceIdHeader + let liMobileMetadata = readMobileMetadata response + return $ LambdaInvocation{..} + where + url = lecApiPrefix <> "/runtime/invocation/next" + readMobileMetadata response = do + mimClientContext <- readHeader response clientContextHeader + mimCognitoIdentity <- readHeader response cognitoIdentityHeader + return $ MobileInvocationMetadata{..} + readHeader response headerName = + let headers = HTTP.responseHeaders response in + let finder (otherHeaderName, _) = headerName == otherHeaderName in + case find finder headers of + Just (_,value) -> return . ct $ C8.unpack value + Nothing -> fail $ "Could not find header: " <> show headerName + readDeadline response = do + headerValue <- readHeader response "Lambda-Runtime-Deadline-Ms" + case readMaybe headerValue of + Nothing -> fail $ "Could not parse deadline header value: " <> headerValue + Just parsed -> return parsed + readPayload response = + let body = HTTP.responseBody response in + case eitherDecode' body of + Left err -> fail $ "Could not parse the body of the next invocation: " <> err + Right value -> return value + +makeHttpRequest :: (MonadThrow m, ToJSON b) => String -> String -> Maybe b -> m HTTP.Request +makeHttpRequest method url maybeBody = + customizeRequest <$> HTTP.parseUrlThrow (method <> " " <> url) + where + customizeRequest initReq = initReq + { HTTP.decompress = HTTP.alwaysDecompress + , HTTP.requestHeaders = + [ ( HTTP.hAccept, "application/json" ) + , ( HTTP.hContentType, "application/json" ) + ] + , HTTP.requestBody = HTTP.RequestBodyLBS $ case maybeBody of + Nothing -> "" + Just body -> encode body + } + +postResult :: (MonadUnliftIO m, MonadThrow m, ToJSON b) => LambdaExecutionContext a m b -> LambdaInvocation a -> LambdaResult b -> m () +postResult + LambdaExecutionContext{lecApiPrefix, lecHttpManager} + LambdaInvocation{liAwsRequestId, liTraceId} + result = + case result of + LambdaNop -> return () + (LambdaSuccess payload) -> do + let url = lecApiPrefix <> "/runtime/invocation/" <> ct liAwsRequestId <> "/response" + let body = Just payload + req <- addTraceId <$> makeHttpRequest "POST" url body + void . liftIO $ HTTP.httpNoBody req lecHttpManager + LambdaError (errType, errMsg) -> do + let url = lecApiPrefix <> "/runtime/invocation/" <> ct liAwsRequestId <> "/error" + let body = Just $ Map.fromList + [ ( "errorMessage", errMsg ) + , ( "errorType", errType ) + ] + req <- makeHttpRequest "POST" url body + void . liftIO $ HTTP.httpNoBody req lecHttpManager + where + addTraceId req = req + { HTTP.requestHeaders + = (traceIdHeader, C8.pack $ ct liTraceId) : HTTP.requestHeaders req + } diff --git a/src/AWS/Lambda/RuntimeAPI/Types.hs b/src/AWS/Lambda/RuntimeAPI/Types.hs new file mode 100644 --- /dev/null +++ b/src/AWS/Lambda/RuntimeAPI/Types.hs @@ -0,0 +1,105 @@ +module AWS.Lambda.RuntimeAPI.Types + ( LambdaInvocation(..) + , LambdaResult(..) + , LambdaExecutionContext(..) + , MobileInvocationMetadata(..) + , Text + , ct + , module Control.DeepSeq + , module Control.Exception.Safe + , module Control.Monad + , module Data.Aeson + , module Data.Function + , module Data.String + , module Data.Text.Conversions + , module Data.Typeable + , module Data.Word + , module GHC.Generics + ) where + +import Control.Exception.Safe (throw, MonadThrow) +import Control.Monad ( void, forever ) +import Data.Aeson (ToJSON, FromJSON, Options, FromJSON1, ToJSON1) +import Data.Function ( (&) ) +import Data.String ( fromString, IsString(..) ) +import Data.Text (Text) +import Data.Text.Conversions ( ToText, FromText, convertText ) +import Data.Typeable (typeOf) +import Data.Word (Word64) +import GHC.Generics +import Control.DeepSeq ( NFData, NFData1 ) +import qualified Data.Aeson as JSON +import qualified Data.Char as Char +import qualified Network.HTTP.Client as HTTP + +-- | Shorthand for 'convertText' from 'Data.Text.Conversions' +ct :: (ToText a, FromText b) => a -> b +ct = convertText + +-- | Our implementation of how to map the field names to JSON labels +modifyFieldLabel :: String -> String +modifyFieldLabel str = + if null trimmed then + str + else + trimmed + where + trimmed = dropWhile Char.isLower str + +jsonOptions :: Options +jsonOptions = JSON.defaultOptions + { JSON.fieldLabelModifier = modifyFieldLabel + , JSON.omitNothingFields = True + , JSON.unwrapUnaryRecords = True + , JSON.tagSingleConstructors = False + } + +-- | Additional information available only when the Lambda is invoked through the +-- AWS Mobile SDK. This data is currently unstructured, but will be updated to +-- be structured in some future major release. +-- +-- (Pull requests very welcome.) +data MobileInvocationMetadata = MobileInvocationMetadata + { mimClientContext :: Text -- ^ the client's execution context + , mimCognitoIdentity :: Text -- ^ the client's identity + } deriving (Eq, Generic, NFData) + +instance ToJSON MobileInvocationMetadata where + toJSON = JSON.genericToJSON jsonOptions + toEncoding = JSON.genericToEncoding jsonOptions + +instance FromJSON MobileInvocationMetadata where + parseJSON = JSON.genericParseJSON jsonOptions + +-- | Represents the data provided to an invocation of the lambda +data LambdaInvocation payload = LambdaInvocation + { liAwsRequestId :: Text -- ^ The unique ID for this request + , liDeadlineMs :: Word64 -- ^ The timetsamp of the deadline in Unix time + , liInvokedFunctionArn :: Text -- ^ This function's ARN + , liTraceId :: Text -- ^ The details about this AWS X-Ray trace + , liMobileMetadata :: Maybe MobileInvocationMetadata -- ^ The mobile data if the Lambda was called from the AWS Mobile SDK + , liPayload :: payload -- ^ The input to the Lambda + } deriving (Eq, Generic, ToJSON, FromJSON, Generic1, ToJSON1, FromJSON1) + +instance (NFData payload) => NFData (LambdaInvocation payload) +instance NFData1 LambdaInvocation + +type ErrorType = Text +type ErrorMessage = Text +type ErrorInfo = (ErrorType, ErrorMessage) + +-- | The two possible results of a Lambda execution: success or failure +data LambdaResult payload + = LambdaSuccess payload -- ^ Denotes success and provides the value to return + | LambdaError ErrorInfo -- ^ Denotes failure and provides details + | LambdaNop -- ^ Denotes that no invocation was provided + deriving (Eq, Generic, ToJSON, FromJSON, Generic1, ToJSON1, FromJSON1) + +instance (NFData payload) => NFData (LambdaResult payload) +instance NFData1 LambdaResult + +data LambdaExecutionContext a m b = LambdaExecutionContext + { lecApiPrefix :: String + , lecHttpManager :: HTTP.Manager + , lecHandler :: LambdaInvocation a -> m (LambdaResult b) + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"