diff --git a/hs-aws-lambda.cabal b/hs-aws-lambda.cabal --- a/hs-aws-lambda.cabal +++ b/hs-aws-lambda.cabal @@ -5,8 +5,8 @@ -- see: https://github.com/sol/hpack name: hs-aws-lambda -version: 0.1.0.4 -synopsis: A modern and easy-to-use wrapper for Docker-based Lambda implementations +version: 0.2.0.0 +synopsis: A modern and easy-to-use wrapper for Docker-based Lambda implementations. Now with API Gateway support! description: Please see the README on GitHub at category: AWS homepage: https://github.com/RobertFischer/hs-aws-lambda#readme @@ -27,6 +27,8 @@ library exposed-modules: + AWS.ApiGateway.RuntimeAPI + AWS.ApiGateway.RuntimeAPI.Types AWS.Lambda.RuntimeAPI AWS.Lambda.RuntimeAPI.Types other-modules: @@ -36,17 +38,18 @@ hs-source-dirs: src default-extensions: + TypeApplications BangPatterns BinaryLiterals CPP ConstraintKinds DataKinds DefaultSignatures - DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric + DeriveAnyClass DeriveLift DeriveTraversable DoAndIfThenElse @@ -87,10 +90,11 @@ 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 -Werror=missing-methods -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 + ghc-options: -Wall -Werror=compat -Werror=incomplete-patterns -Werror=missing-fields -Werror=missing-methods -Werror=overlapping-patterns -Werror=partial-fields -Werror=redundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -fPIC -fhelpful-errors -fno-warn-deriving-defaults -fno-warn-tabs -fno-warn-type-defaults -fprint-equality-relations -fprint-expanded-synonyms -fprint-explicit-coercions -fprint-typechecker-elaboration -freverse-errors -fshow-warning-groups -funclutter-valid-hole-fits -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 + , base64 , bytestring , case-insensitive , containers @@ -99,7 +103,9 @@ , http-types , safe-exceptions , text + , time >=1.9.3 && <2 , unliftio + , vector default-language: Haskell2010 test-suite aws-lambda-runtime-api-test @@ -110,17 +116,18 @@ hs-source-dirs: test default-extensions: + TypeApplications BangPatterns BinaryLiterals CPP ConstraintKinds DataKinds DefaultSignatures - DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric + DeriveAnyClass DeriveLift DeriveTraversable DoAndIfThenElse @@ -161,8 +168,9 @@ 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 -Werror=missing-methods -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror=compat -Werror=incomplete-patterns -Werror=missing-fields -Werror=missing-methods -Werror=overlapping-patterns -Werror=partial-fields -Werror=redundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -fPIC -fhelpful-errors -fno-warn-deriving-defaults -fno-warn-tabs -fno-warn-type-defaults -fprint-equality-relations -fprint-expanded-synonyms -fprint-explicit-coercions -fprint-typechecker-elaboration -freverse-errors -fshow-warning-groups -funclutter-valid-hole-fits -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , hs-aws-lambda + , time >=1.9.3 && <2 default-language: Haskell2010 diff --git a/src/AWS/ApiGateway/RuntimeAPI.hs b/src/AWS/ApiGateway/RuntimeAPI.hs new file mode 100644 --- /dev/null +++ b/src/AWS/ApiGateway/RuntimeAPI.hs @@ -0,0 +1,61 @@ +module AWS.ApiGateway.RuntimeAPI + ( runLambda + ) where + +import AWS.ApiGateway.RuntimeAPI.Types +import qualified AWS.Lambda.RuntimeAPI as Lambda +import AWS.Lambda.RuntimeAPI.Types +import Control.DeepSeq (NFData) +import Control.Exception.Safe (MonadThrow) +import Control.Monad (forever, void) +import Data.Aeson (FromJSON, ToJSON, + eitherDecode', encode) +import qualified Data.Aeson as JSON +import Data.ByteString.Base64 (encodeBase64) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import Data.List (find) +import qualified Data.Map.Strict as Map +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (typeOf) +import qualified Data.Vector as V +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 +import System.Environment (lookupEnv) +import Text.Read (readMaybe) +import UnliftIO + +-- | This function is intended to be your `main` implementation. Given a handler for 'ApiGatewayRequest' 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) => + (LambdaInvocation ApiGatewayRequest -> m ApiGatewayResponse) -> m () +runLambda impl = Lambda.runLambda $ handler impl + +handler :: (MonadUnliftIO m) => + (LambdaInvocation ApiGatewayRequest -> m ApiGatewayResponse) -> + LambdaInvocation ApiGatewayRequest -> m (LambdaResult JSON.Value) +handler impl invocation = toLambdaResponse <$> impl invocation + +toLambdaResponse :: ApiGatewayResponse -> LambdaResult JSON.Value +toLambdaResponse ApiGatewayResponse{agrsStatus,agrsBody,agrsCookies,agrsHeaders} = + response $ case agrsBody of + BodyEmpty -> (False, "") + BodyText _ t -> (False, t) + BodyByteString _ bs -> (True, encodeBase64 $ LBS.toStrict bs) + BodyStatusMessage -> (True, encodeBase64 $ HTTP.statusMessage agrsStatus) + where + response (isB64,bodyText) + = LambdaSuccess $ JSON.Object + [ ("cookies", JSON.toJSON agrsCookies) + , ("isBase64Encoded", JSON.toJSON isB64) + , ("statusCode", JSON.toJSON $ HTTP.statusCode agrsStatus) + , ("headers", JSON.toJSON agrsHeaders) + , ("body", JSON.toJSON bodyText) + ] diff --git a/src/AWS/ApiGateway/RuntimeAPI/Types.hs b/src/AWS/ApiGateway/RuntimeAPI/Types.hs new file mode 100644 --- /dev/null +++ b/src/AWS/ApiGateway/RuntimeAPI/Types.hs @@ -0,0 +1,218 @@ +module AWS.ApiGateway.RuntimeAPI.Types + ( ApiGatewayRequest(..) + , ApiGatewayRequestContext(..) + , ApiGatewayRequestHttpInfo(..) + , agrBodyT + , agrBodyJ + , agrBodyBS + , HeaderName(..) + , mkHeaderName + , ApiGatewayResponse(..) + , ApiGatewayResponseBody(..) + , mkApiGatewayResponse + , mkApiGatewayResponseJSON + , mkApiGatewayResponseStatus + , ContentType + ) where + +import Control.DeepSeq (NFData, NFData1) +import Data.Aeson (FromJSON, FromJSON1, FromJSONKey, + Options, ToJSON, ToJSON1, + ToJSONKey) +import qualified Data.Aeson as JSON +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as BSB64 +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy.Char8 as C8L +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import qualified Data.Char as Char +import Data.Map (Map) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding.Base64 as TB64 +import Data.Time.Clock.System (SystemTime (..)) +import Data.Time.LocalTime (ZonedTime (..)) +import Data.Word (Word64) +import GHC.Generics +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTP + +-- | Newtype wrapper around header names to control JSON serialization and work +-- with 'Text' instead of 'ByteString'. +newtype HeaderName = HeaderName (CI Text) deriving (Show, Eq, Generic, NFData, Ord, FromJSONKey, ToJSONKey) + +-- | Converts an arbitrary text value into a 'HeaderName'. +mkHeaderName :: Text -> HeaderName +mkHeaderName = HeaderName . CI.mk + +instance ToJSON HeaderName where + toJSON (HeaderName t) = JSON.toJSON $ CI.foldedCase t + +instance FromJSON HeaderName where + parseJSON = fmap (HeaderName . CI.mk @Text) . JSON.parseJSON + +-- | A Version 2.0 API Gateway Request payload +data ApiGatewayRequest = ApiGatewayRequest + { agrRouteKey :: Text + , agrRawPath :: Text + , agrRawQueryString :: Text + , agrCookies + :: [Text] + , agrHeaders -- ^ Repeated headers have values combined with commas. + :: Map HeaderName Text + , agrQueryStringParameters + :: Map Text Text + , agrRequestContext + :: ApiGatewayRequestContext + , agrBody -- ^ See 'agrBodyT', 'agrBodyBS', and 'agrBodyJ' + :: JSON.Value + , agrPathParameters + :: Map Text Text + , agrStageVariables + :: Map Text Text + , agrIsBase64Encoded :: Bool + } deriving (Show, Generic, NFData, FromJSON) + +-- | Provides a 'ByteString' of the body. If 'agrIsBase64Encoded' is 'True' and the +-- body is JSON text, then the body is decoded from Base64. Otherwise, the JSON value +-- of the body is encoded to 'ByteString'. +agrBodyBS :: (MonadFail m) => ApiGatewayRequest -> m ByteString +agrBodyBS ApiGatewayRequest{agrBody,agrIsBase64Encoded} = + if agrIsBase64Encoded then + case agrBody of + JSON.String t -> + case BSB64.decodeBase64 . C8.pack $ T.unpack t of + Left err -> fail $ T.unpack err + Right value -> return value + value -> + return . C8L.toStrict $ JSON.encode value + else + return . C8L.toStrict $ JSON.encode agrBody + +-- | Provides a 'Text' of the body, decoding +agrBodyT :: (MonadFail m) => ApiGatewayRequest -> m Text +agrBodyT ApiGatewayRequest{agrBody,agrIsBase64Encoded} = case agrBody of + JSON.String t -> + if agrIsBase64Encoded then + case TB64.decodeBase64 t of + Left err -> fail $ T.unpack err + Right value -> return value + else + return t + value -> return . T.pack . C8L.unpack $ JSON.encode value + +-- | Attempts to decode the body value into an instance of 'FromJSON'. +agrBodyJ :: (MonadFail m, FromJSON a) => ApiGatewayRequest -> m a +agrBodyJ agr = agrBodyBS agr >>= \bodybs -> + case JSON.eitherDecode' $ C8L.fromStrict bodybs of + Left err -> fail err + Right val -> return val + +-- | The "requestContext" field of the API Gateway Request payload +data ApiGatewayRequestContext = ApiGatewayRequestContext + { agrcAccountId :: Text + , agrcApiId :: Text + , agrcDomainName :: Text + , agrcDomainPrefix :: Text + , agrcHttp + :: ApiGatewayRequestHttpInfo + , agrcRequestId :: Text + , agrcRouteKey :: Text + , agrcStage :: Text + , agrcTime :: ZonedTime + , agrcTimeEpoch :: SystemTime + } deriving (Show, Generic, NFData) + +instance ToJSON ApiGatewayRequestContext where + toJSON = JSON.genericToJSON jsonOptions' + toEncoding = JSON.genericToEncoding jsonOptions' + +instance FromJSON ApiGatewayRequestContext where + parseJSON = JSON.genericParseJSON jsonOptions' + +-- | Our implementation of how to map the field names to JSON labels +modifyFieldLabel :: String -> String +modifyFieldLabel str = + case dropWhile Char.isLower str of + [] -> str + a:rest -> Char.toLower a : rest + +jsonOptions' :: Options +jsonOptions' = JSON.defaultOptions + { JSON.fieldLabelModifier = modifyFieldLabel + , JSON.omitNothingFields = True + , JSON.unwrapUnaryRecords = True + , JSON.tagSingleConstructors = False + } + +data ApiGatewayResponse = ApiGatewayResponse + { agrsStatus + :: HTTP.Status + , agrsBody + :: ApiGatewayResponseBody + , agrsHeaders + :: Map HeaderName Text + , agrsCookies + :: Map Text Text + } + +type ContentType = Text + +-- | The different ways to express the API Gateway response body. +-- See also 'mkApiGatewayResponseJSON' and 'mkApiGatewayResponseStatus'. +data ApiGatewayResponseBody + = BodyEmpty -- ^ Empty body + | BodyByteString ContentType C8L.ByteString -- ^ Body will be Base64 encoded bytes + | BodyText ContentType Text -- ^ Body will be passed along directly + | BodyStatusMessage -- ^ Body will contain the message associated with the status code + +mkApiGatewayResponse :: ApiGatewayResponseBody -> ApiGatewayResponse +-- ^ Creates an API Gateway response with the provided body and an "OK 200" status code. +mkApiGatewayResponse body = ApiGatewayResponse + { agrsCookies = mempty + , agrsHeaders = [ ( mkHeaderName "content-type", derivedContentType ) ] + , agrsBody = body + , agrsStatus = HTTP.ok200 + } + where + derivedContentType = case body of + BodyEmpty -> "text/plain" + BodyByteString contentType _ -> contentType + BodyText contentType _ -> contentType + BodyStatusMessage -> "text/plain" + + +mkApiGatewayResponseJSON :: (ToJSON a) => a -> ApiGatewayResponse +-- ^ Creates an API Gateway response with the body set to the argument encoded as JSON. +mkApiGatewayResponseJSON a = mkApiGatewayResponse body + where + body = BodyByteString "application/json" $ JSON.encode a + +mkApiGatewayResponseStatus :: HTTP.Status -> ApiGatewayResponse +-- ^ Creates an API Gateway response with the status set to the argument. +-- If the status is `204 No Content` ('HTTP.noContent204'), then the body +-- is set to 'BodyEmpty'; otherwise, the body is set to 'BodyStatusMessage'. +mkApiGatewayResponseStatus status = (mkApiGatewayResponse body) { agrsStatus = status } + where + body = + if status == HTTP.noContent204 then + BodyEmpty + else + BodyStatusMessage + +data ApiGatewayRequestHttpInfo = ApiGatewayRequestHttpInfo + { agrhMethod :: Text + , agrhPath :: Text + , agrhProtocol :: Text + , agrhSourceIp :: Text + , agrhUserAgent :: Text + } deriving (Generic, NFData, Eq, Show) + +instance ToJSON ApiGatewayRequestHttpInfo where + toJSON = JSON.genericToJSON jsonOptions' + toEncoding = JSON.genericToEncoding jsonOptions' + +instance FromJSON ApiGatewayRequestHttpInfo where + parseJSON = JSON.genericParseJSON jsonOptions' diff --git a/src/AWS/Lambda/RuntimeAPI.hs b/src/AWS/Lambda/RuntimeAPI.hs --- a/src/AWS/Lambda/RuntimeAPI.hs +++ b/src/AWS/Lambda/RuntimeAPI.hs @@ -185,9 +185,7 @@ [ ( HTTP.hAccept, "application/json" ) , ( HTTP.hContentType, "application/json" ) ] - , HTTP.requestBody = HTTP.RequestBodyLBS $ case maybeBody of - Nothing -> "" - Just body -> encode body + , HTTP.requestBody = HTTP.RequestBodyLBS $ maybe "" encode maybeBody } postResult :: (MonadUnliftIO m, MonadThrow m, ToJSON b) => LambdaExecutionContext a m b -> LambdaInvocation a -> LambdaResult b -> m () diff --git a/src/AWS/Lambda/RuntimeAPI/Types.hs b/src/AWS/Lambda/RuntimeAPI/Types.hs --- a/src/AWS/Lambda/RuntimeAPI/Types.hs +++ b/src/AWS/Lambda/RuntimeAPI/Types.hs @@ -21,17 +21,14 @@ -- | 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 + case dropWhile Char.isLower str of + [] -> str + rest -> rest jsonOptions :: Options jsonOptions = JSON.defaultOptions { JSON.fieldLabelModifier = modifyFieldLabel - , JSON.omitNothingFields = True + , JSON.omitNothingFields = False , JSON.unwrapUnaryRecords = True , JSON.tagSingleConstructors = False } @@ -73,9 +70,10 @@ 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 + = LambdaSuccess payload -- ^ Denotes success with the value to encode to JSON | LambdaError ErrorInfo -- ^ Denotes failure and provides details | LambdaNop -- ^ Denotes that no invocation was provided deriving (Show, Eq, Generic, ToJSON, FromJSON, Generic1, ToJSON1, FromJSON1)