hs-aws-lambda 0.1.0.4 → 0.2.0.0
raw patch · 5 files changed
+300/−17 lines, 5 filesdep +base64dep +timedep +vector
Dependencies added: base64, time, vector
Files
- hs-aws-lambda.cabal +14/−6
- src/AWS/ApiGateway/RuntimeAPI.hs +61/−0
- src/AWS/ApiGateway/RuntimeAPI/Types.hs +218/−0
- src/AWS/Lambda/RuntimeAPI.hs +1/−3
- src/AWS/Lambda/RuntimeAPI/Types.hs +6/−8
hs-aws-lambda.cabal view
@@ -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 <https://github.com/RobertFischer/hs-aws-lambda#readme> 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
+ src/AWS/ApiGateway/RuntimeAPI.hs view
@@ -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)+ ]
+ src/AWS/ApiGateway/RuntimeAPI/Types.hs view
@@ -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'
src/AWS/Lambda/RuntimeAPI.hs view
@@ -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 ()
src/AWS/Lambda/RuntimeAPI/Types.hs view
@@ -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)