diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 98f7f9c..b83f499 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -12,30 +12,34 @@ jobs: runs-on: ubuntu-16.04 strategy: matrix: - cabal: ["2.4"] + cabal: ["3.2"] ghc: - - "8.6.5" + - "8.10.1" steps: - - uses: actions/checkout@v2 - if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' + - uses: actions/checkout@v2 + if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - - uses: actions/setup-haskell@v1 - name: Setup Haskell - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} + - uses: actions/setup-haskell@v1 + name: Setup Haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} - - uses: actions/cache@v1 - name: Cache ~/.cabal/store - with: - path: ~/.cabal/store - key: ${{ runner.os }}-${{ matrix.ghc }}-cabal + - uses: actions/cache@v1 + name: Cache ~/.cabal/store + with: + path: ~/.cabal/store + key: ${{ runner.os }}-${{ matrix.ghc }}-cabal - - name: Build - run: | - cabal v2-update - cabal v2-build --enable-tests --enable-benchmarks - - name: Test - run: | - cabal v2-test --enable-tests \ No newline at end of file + - name: Install hspec-discover + run: | + cabal v1-install hspec-discover + + - name: Build + run: | + cabal v2-update + cabal v2-build --enable-tests --enable-benchmarks + - name: Test + run: | + cabal v2-test --enable-tests diff --git a/.gitignore b/.gitignore index 7219515..280d058 100644 --- a/.gitignore +++ b/.gitignore @@ -10,6 +10,7 @@ dist-* cabal-dev *.o *.hi +*.hie *.chi *.chs.h *.dyn_o diff --git a/aws-lambda-haskell-runtime.cabal b/aws-lambda-haskell-runtime.cabal index b935adc..0622eba 100644 --- a/aws-lambda-haskell-runtime.cabal +++ b/aws-lambda-haskell-runtime.cabal @@ -1,13 +1,6 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.1. --- --- see: https://github.com/sol/hpack --- --- hash: c833537a67bfa0d976f4297649380558f7db943dcac5a1b180e2ee2401abb3f7 - +cabal-version: 2.2 name: aws-lambda-haskell-runtime -version: 3.0.4 +version: 4.0.0 synopsis: Haskell runtime for AWS Lambda description: Please see the README on GitHub at category: AWS @@ -15,7 +8,7 @@ homepage: https://github.com/theam/aws-lambda-haskell-runtime#readme bug-reports: https://github.com/theam/aws-lambda-haskell-runtime/issues author: Nikita Tchayka maintainer: hackers@theagilemonkeys.com -copyright: 2018 The Agile Monkeys SL +copyright: 2020 The Agile Monkeys SL license: Apache-2.0 license-file: LICENSE build-type: Simple @@ -26,20 +19,71 @@ source-repository head type: git location: https://github.com/theam/aws-lambda-haskell-runtime +common common-options + build-depends: base >= 4.14 && < 4.15 + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields + default-language: Haskell2010 + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DerivingStrategies + DeriveTraversable + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralisedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + library + import: common-options exposed-modules: Aws.Lambda Aws.Lambda.Runtime + Aws.Lambda.Events other-modules: - Aws.Lambda.Configuration - Aws.Lambda.Meta.Common - Aws.Lambda.Meta.Discover - Aws.Lambda.Meta.Dispatch - Aws.Lambda.Meta.Main - Aws.Lambda.Meta.Run + Aws.Lambda.Events.ApiGateway Aws.Lambda.Runtime.API.Endpoints Aws.Lambda.Runtime.API.Version - Aws.Lambda.Runtime.ApiGatewayInfo Aws.Lambda.Runtime.ApiInfo Aws.Lambda.Runtime.Common Aws.Lambda.Runtime.Context @@ -47,36 +91,28 @@ library Aws.Lambda.Runtime.Error Aws.Lambda.Runtime.Publish Aws.Lambda.Utilities - Paths_aws_lambda_haskell_runtime hs-source-dirs: src - default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables DeriveGeneric TypeApplications FlexibleContexts DeriveAnyClass QuasiQuotes - ghc-options: -Wall -fno-warn-orphans -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -Wmissing-export-lists -Wpartial-fields -fhide-source-paths -freverse-errors build-depends: aeson - , base >=4.7 && <5 , bytestring , case-insensitive , http-client , http-types , path >0.7 , path-io - , safe-exceptions-checked , template-haskell , text , unordered-containers default-language: Haskell2010 test-suite aws-lambda-haskell-runtime-test + import: common-options type: exitcode-stdio-1.0 main-is: Spec.hs - other-modules: - Paths_aws_lambda_haskell_runtime hs-source-dirs: test - default-extensions: TemplateHaskell OverloadedStrings RecordWildCards ScopedTypeVariables DeriveGeneric TypeApplications FlexibleContexts DeriveAnyClass QuasiQuotes - ghc-options: -Wall -fno-warn-orphans -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -Wmissing-export-lists -Wpartial-fields -fhide-source-paths -freverse-errors -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 - , hspec + hspec + , hspec-discover default-language: Haskell2010 diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..836808a --- /dev/null +++ b/hie.yaml @@ -0,0 +1,7 @@ +cradle: + stack: + - path: "./src" + component: "aws-lambda-haskell-runtime:lib" + + - path: "./test" + component: "aws-lambda-haskell-runtime:test:aws-lambda-haskell-runtime-test" diff --git a/package.yaml b/package.yaml deleted file mode 100644 index ac93081..0000000 --- a/package.yaml +++ /dev/null @@ -1,71 +0,0 @@ -name: aws-lambda-haskell-runtime -version: 3.0.2 -github: "theam/aws-lambda-haskell-runtime" -license: Apache-2.0 -author: Nikita Tchayka -maintainer: hackers@theagilemonkeys.com -copyright: 2018 The Agile Monkeys SL - -extra-source-files: - - README.md - -synopsis: Haskell runtime for AWS Lambda -category: AWS -description: Please see the README on GitHub at - -dependencies: - - base >= 4.7 && < 5 - -library: - dependencies: - - aeson - - bytestring - - http-client - - http-types - - template-haskell - - text - - safe-exceptions-checked - - path > 0.7 - - path-io - - unordered-containers - - case-insensitive - source-dirs: src - exposed-modules: - - Aws.Lambda - - Aws.Lambda.Runtime - -tests: - aws-lambda-haskell-runtime-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - hspec - -default-extensions: - - TemplateHaskell - - OverloadedStrings - - RecordWildCards - - ScopedTypeVariables - - DeriveGeneric - - TypeApplications - - FlexibleContexts - - DeriveAnyClass - - QuasiQuotes - -ghc-options: - - -Wall - - -fno-warn-orphans - - -optP-Wno-nonportable-include-path - - -Wincomplete-uni-patterns - - -Wincomplete-record-updates - - -Wcompat - - -Widentities - - -Wredundant-constraints - - -Wmissing-export-lists - - -Wpartial-fields - - -fhide-source-paths - - -freverse-errors diff --git a/src/Aws/Lambda.hs b/src/Aws/Lambda.hs index cb1ff97..d76448d 100644 --- a/src/Aws/Lambda.hs +++ b/src/Aws/Lambda.hs @@ -1,8 +1,8 @@ module Aws.Lambda - ( module Reexported - ) where + ( module Reexported, + ) +where -import Aws.Lambda.Configuration as Reexported import Aws.Lambda.Runtime as Reexported +import Aws.Lambda.Events as Reexported import Aws.Lambda.Runtime.Context as Reexported -import Aws.Lambda.Runtime.ApiGatewayInfo as Reexported diff --git a/src/Aws/Lambda/Configuration.hs b/src/Aws/Lambda/Configuration.hs deleted file mode 100644 index bfa7ec9..0000000 --- a/src/Aws/Lambda/Configuration.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-} -module Aws.Lambda.Configuration - ( Main.LambdaOptions(..) - , generateLambdaDispatcher - , Dispatch.decodeObj - ) -where - -import qualified Language.Haskell.TH as Meta - -import qualified Aws.Lambda.Meta.Dispatch as Dispatch -import qualified Aws.Lambda.Meta.Main as Main -import qualified Aws.Lambda.Meta.Run as Run - -{-| Generates a @main@ function that acts as a dispatcher --} -generateLambdaDispatcher :: Main.DispatcherStrategy -> Main.DispatcherOptions -> Meta.DecsQ -generateLambdaDispatcher strategy options = do - main <- Main.generate - run <- Run.generate options strategy - return (main <> [run]) diff --git a/src/Aws/Lambda/Events.hs b/src/Aws/Lambda/Events.hs new file mode 100644 index 0000000..65d7123 --- /dev/null +++ b/src/Aws/Lambda/Events.hs @@ -0,0 +1,5 @@ +module Aws.Lambda.Events + ( module Aws.Lambda.Events.ApiGateway ) + where + +import Aws.Lambda.Events.ApiGateway diff --git a/src/Aws/Lambda/Events/ApiGateway.hs b/src/Aws/Lambda/Events/ApiGateway.hs new file mode 100644 index 0000000..b0930f1 --- /dev/null +++ b/src/Aws/Lambda/Events/ApiGateway.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Aws.Lambda.Events.ApiGateway + ( ApiGatewayRequest (..), + ApiGatewayRequestContext (..), + ApiGatewayRequestContextIdentity (..), + ApiGatewayResponse (..), + ApiGatewayResponseBody (..), + ToApiGatewayResponseBody (..), + mkApiGatewayResponse, + ) +where + +import Aws.Lambda.Utilities +import Data.Aeson +import Data.Aeson.Types (Parser) +import qualified Data.Aeson.Types as T +import qualified Data.CaseInsensitive as CI +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHC.Generics (Generic) +import Network.HTTP.Types + +data ApiGatewayRequest body = ApiGatewayRequest + { apiGatewayRequestResource :: !Text + , apiGatewayRequestPath :: !Text + , apiGatewayRequestHttpMethod :: !Text + , apiGatewayRequestHeaders :: !(Maybe (HashMap Text Text)) + , apiGatewayRequestQueryStringParameters :: !(Maybe (HashMap Text Text)) + , apiGatewayRequestPathParameters :: !(Maybe (HashMap Text Text)) + , apiGatewayRequestStageVariables :: !(Maybe (HashMap Text Text)) + , apiGatewayRequestIsBase64Encoded :: !Bool + , apiGatewayRequestRequestContext :: !ApiGatewayRequestContext + , apiGatewayRequestBody :: !(Maybe body) + } deriving (Show) + +-- We special case String and Text in order +-- to avoid unneeded encoding which will wrap them in quotes and break parsing +instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest Text) where + parseJSON = parseApiGatewayRequest (.:) + +instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest String) where + parseJSON = parseApiGatewayRequest (.:) + +instance FromJSON body => FromJSON (ApiGatewayRequest body) where + parseJSON = parseApiGatewayRequest parseObjectFromStringField + +-- We need this because API Gateway is going to send us the payload as a JSON string +parseObjectFromStringField :: FromJSON a => Object -> Text -> Parser (Maybe a) +parseObjectFromStringField obj fieldName = do + fieldContents <- obj .: fieldName + case fieldContents of + String stringContents -> + case eitherDecodeStrict (T.encodeUtf8 stringContents) of + Right success -> pure success + Left err -> fail err + Null -> pure Nothing + other -> T.typeMismatch "String or Null" other + +parseApiGatewayRequest :: (Object -> Text -> Parser (Maybe body)) -> Value -> Parser (ApiGatewayRequest body) +parseApiGatewayRequest bodyParser (Object v) = + ApiGatewayRequest + <$> v .: "resource" + <*> v .: "path" + <*> v .: "httpMethod" + <*> v .: "headers" + <*> v .: "queryStringParameters" + <*> v .: "pathParameters" + <*> v .: "stageVariables" + <*> v .: "isBase64Encoded" + <*> v .: "requestContext" + <*> v `bodyParser` "body" +parseApiGatewayRequest _ _ = fail "Expected ApiGatewayRequest to be an object." + +data ApiGatewayRequestContext + = ApiGatewayRequestContext + { apiGatewayRequestContextResourceId :: !Text, + apiGatewayRequestContextResourcePath :: !Text, + apiGatewayRequestContextHttpMethod :: !Text, + apiGatewayRequestContextExtendedRequestId :: !Text, + apiGatewayRequestContextRequestTime :: !Text, + apiGatewayRequestContextPath :: !Text, + apiGatewayRequestContextAccountId :: !Text, + apiGatewayRequestContextProtocol :: !Text, + apiGatewayRequestContextStage :: !Text, + apiGatewayRequestContextDomainPrefix :: !Text, + apiGatewayRequestContextRequestId :: !Text, + apiGatewayRequestContextDomainName :: !Text, + apiGatewayRequestContextApiId :: !Text, + apiGatewayRequestContextIdentity :: !ApiGatewayRequestContextIdentity + } + deriving (Show) + +instance FromJSON ApiGatewayRequestContext where + parseJSON (Object v) = + ApiGatewayRequestContext + <$> v .: "resourceId" + <*> v .: "path" + <*> v .: "httpMethod" + <*> v .: "extendedRequestId" + <*> v .: "requestTime" + <*> v .: "path" + <*> v .: "accountId" + <*> v .: "protocol" + <*> v .: "stage" + <*> v .: "domainPrefix" + <*> v .: "requestId" + <*> v .: "domainName" + <*> v .: "apiId" + <*> v .: "identity" + parseJSON _ = fail "Expected ApiGatewayRequestContext to be an object." + +data ApiGatewayRequestContextIdentity + = ApiGatewayRequestContextIdentity + { apiGatewayRequestContextIdentityCognitoIdentityPoolId :: !(Maybe Text), + apiGatewayRequestContextIdentityAccountId :: !(Maybe Text), + apiGatewayRequestContextIdentityCognitoIdentityId :: !(Maybe Text), + apiGatewayRequestContextIdentityCaller :: !(Maybe Text), + apiGatewayRequestContextIdentitySourceIp :: !(Maybe Text), + apiGatewayRequestContextIdentityPrincipalOrgId :: !(Maybe Text), + apiGatewayRequestContextIdentityAccesskey :: !(Maybe Text), + apiGatewayRequestContextIdentityCognitoAuthenticationType :: !(Maybe Text), + apiGatewayRequestContextIdentityCognitoAuthenticationProvider :: !(Maybe Value), + apiGatewayRequestContextIdentityUserArn :: !(Maybe Text), + apiGatewayRequestContextIdentityUserAgent :: !(Maybe Text), + apiGatewayRequestContextIdentityUser :: !(Maybe Text) + } + deriving (Show) + +instance FromJSON ApiGatewayRequestContextIdentity where + parseJSON (Object v) = + ApiGatewayRequestContextIdentity + <$> v .: "cognitoIdentityPoolId" + <*> v .: "accountId" + <*> v .: "cognitoIdentityId" + <*> v .: "caller" + <*> v .: "sourceIp" + <*> v .: "principalOrgId" + <*> v .: "accessKey" + <*> v .: "cognitoAuthenticationType" + <*> v .: "cognitoAuthenticationProvider" + <*> v .: "userArn" + <*> v .: "userAgent" + <*> v .: "user" + parseJSON _ = fail "Expected ApiGatewayRequestContextIdentity to be an object." + +newtype ApiGatewayResponseBody + = ApiGatewayResponseBody Text + deriving newtype (ToJSON, FromJSON) + +class ToApiGatewayResponseBody a where + toApiGatewayResponseBody :: a -> ApiGatewayResponseBody + +-- We special case Text and String to avoid unneeded encoding which will wrap them in quotes +instance {-# OVERLAPPING #-} ToApiGatewayResponseBody Text where + toApiGatewayResponseBody = ApiGatewayResponseBody + +instance {-# OVERLAPPING #-} ToApiGatewayResponseBody String where + toApiGatewayResponseBody = ApiGatewayResponseBody . T.pack + +instance ToJSON a => ToApiGatewayResponseBody a where + toApiGatewayResponseBody = ApiGatewayResponseBody . toJSONText + +data ApiGatewayResponse body + = ApiGatewayResponse + { apiGatewayResponseStatusCode :: !Int, + apiGatewayResponseHeaders :: !ResponseHeaders, + apiGatewayResponseBody :: !body, + apiGatewayResponseIsBase64Encoded :: !Bool + } + deriving (Generic, Show) + +instance Functor ApiGatewayResponse where + fmap f v = v {apiGatewayResponseBody = f (apiGatewayResponseBody v)} + +instance ToJSON body => ToJSON (ApiGatewayResponse body) where + toJSON = apiGatewayResponseToJSON toJSON + +apiGatewayResponseToJSON :: (body -> Value) -> ApiGatewayResponse body -> Value +apiGatewayResponseToJSON bodyTransformer ApiGatewayResponse {..} = + object + [ "statusCode" .= apiGatewayResponseStatusCode, + "body" .= bodyTransformer apiGatewayResponseBody, + "headers" .= object (map headerToPair apiGatewayResponseHeaders), + "isBase64Encoded" .= apiGatewayResponseIsBase64Encoded + ] + +mkApiGatewayResponse :: Int -> payload -> ApiGatewayResponse payload +mkApiGatewayResponse code payload = + ApiGatewayResponse code [] payload False + +headerToPair :: Header -> T.Pair +headerToPair (cibyte, bstr) = k .= v + where + k = (T.decodeUtf8 . CI.original) cibyte + v = T.decodeUtf8 bstr diff --git a/src/Aws/Lambda/Meta/Common.hs b/src/Aws/Lambda/Meta/Common.hs deleted file mode 100644 index 25c7b9b..0000000 --- a/src/Aws/Lambda/Meta/Common.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-| Helper functions to make code generation easier -} -module Aws.Lambda.Meta.Common - ( declarationName - , expressionName - , getFieldsFrom - , constructorName - ) where - -import Data.Text (Text) -import qualified Data.Text as Text -import Language.Haskell.TH - --- | Helper for defining names in declarations --- think of @myValue@ in @myValue = 2@ -declarationName :: Text -> Q Pat -declarationName = pure . VarP . mkName . Text.unpack - --- | Helper for defining names in expressions --- think of @myFunction@ in @quux = myFunction 3@ -expressionName :: Text -> Q Exp -expressionName = pure . VarE . mkName . Text.unpack - --- | Helper for defining names for constructors --- think of @Foo@ in @quux = Foo 3@ -constructorName :: Text -> Q Exp -constructorName = pure . ConE . mkName . Text.unpack - --- | Helper for extracting fields of a specified record --- it expects the constructor name as the first parameter, --- and the list of fields to bring into scope as second --- think of @Person@, and @personAge@, @personName@ in --- @myFunction Person { personAge, personName } = ...@ -getFieldsFrom :: Text -> [Text] -> Q Pat -getFieldsFrom name fields = do - extractedFields <- traverse extractField fields - pure $ RecP (mkName $ Text.unpack name) extractedFields - where - -- | Helper for extracting fields of records - -- think of @personAge@ in @myFunction Person { personAge = personAge } = ...@ - extractField :: Text -> Q FieldPat - extractField n = pure (mkName $ Text.unpack n, VarP $ mkName $ Text.unpack n) diff --git a/src/Aws/Lambda/Meta/Discover.hs b/src/Aws/Lambda/Meta/Discover.hs deleted file mode 100644 index 7e6c52b..0000000 --- a/src/Aws/Lambda/Meta/Discover.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-| Discovery of AWS Lambda handlers -A handler is basically a function that has a type definition that -starts with "handler " and two colons. - -} -module Aws.Lambda.Meta.Discover - ( handlers - ) where - -import qualified Control.Monad as Monad -import Data.Function ((&)) -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as Text - -import Path -import qualified Path.IO as PathIO - --- | Paths to ignore during compilation -ignoredPaths :: [Text] -ignoredPaths = - [ "node_modules" - , ".stack-work" - , ".serverless" - ] - -{-| Returns a list of handler paths that look like - -@src/Foo/Bar/Quux.handler@ - -It is the path to the source file, but changing the -extension for ".handler" --} -handlers :: IO [Text] -handlers = do - (_, files) <- PathIO.listDirRecurRel [reldir|.|] - handlerFiles <- modulesWithHandler files - pure (handlerNames handlerFiles) - -modulesWithHandler :: [Path Rel File] -> IO [Path Rel File] -modulesWithHandler files = - filter isHaskellModule files - & Monad.filterM containsHandler - where - isHaskellModule file = - fileExtension file == Just ".hs" - && isNotIgnoredPath file - - isNotIgnoredPath file = - filter (\ignoredPath -> ignoredPath `Text.isInfixOf` (Text.pack $ toFilePath file)) ignoredPaths - & null - -handlerNames :: [Path Rel File] -> [Text] -handlerNames modules = - fmap changeExtensionToHandler modules - & fmap (Text.pack . toFilePath) - where - changeExtensionToHandler file = - replaceExtension ".handler" file - & Maybe.fromJust -- The path will be always parsable, as we just replace the extension - -containsHandler :: Path Rel File -> IO Bool -containsHandler file = do - fileContents <- readFile $ toFilePath file - lines fileContents - & filter (Text.isPrefixOf "handler :: " . Text.pack) - & (not . null) - & pure diff --git a/src/Aws/Lambda/Meta/Dispatch.hs b/src/Aws/Lambda/Meta/Dispatch.hs deleted file mode 100644 index f2d8b27..0000000 --- a/src/Aws/Lambda/Meta/Dispatch.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -{-| Dispatcher generation -} -module Aws.Lambda.Meta.Dispatch - ( generate - , decodeObj - , Runtime.LambdaResult(..) - ) where - -import qualified Data.Char as Char -import Data.Function ((&)) -import Data.Text (Text) -import qualified Data.Text as Text - -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as LazyByteString -import qualified Language.Haskell.TH as Meta - -import Aws.Lambda.Meta.Common -import qualified Aws.Lambda.Meta.Main as Main -import qualified Aws.Lambda.Runtime.ApiGatewayInfo as ApiGatewayInfo -import Aws.Lambda.Runtime.Common (toStandaloneLambdaResponse) -import qualified Aws.Lambda.Runtime.Common as Runtime -import qualified Aws.Lambda.Runtime.Error as Error -import qualified Control.Exception as Unchecked -import Data.Typeable (Proxy (..), Typeable, typeRep) - -{-| Helper function that the dispatcher will use to -decode the JSON that comes as an AWS Lambda event into the -appropriate type expected by the handler. --} -decodeObj :: forall a. (FromJSON a, Typeable a) => LazyByteString.ByteString -> Either Error.Parsing a -decodeObj x = - let objName = show (typeRep (Proxy :: Proxy a)) in - case (eitherDecode x) of - Left e -> Left $ Error.Parsing e (LazyByteString.unpack x) objName - Right v -> return v - -{-| Generates the dispatcher out of a list of -handler names in the form @src/Foo/Bar.handler@ - -This dispatcher has a case for each of the handlers that calls -the appropriate qualified function. In the case of the example above, -the dispatcher will call @Foo.Bar.handler@. --} -generate :: Main.DispatcherOptions -> Main.DispatcherStrategy -> [Text] -> Meta.ExpQ -generate options strategy handlerNames = do - caseExp <- expressionName "functionHandler" - case strategy of - Main.StandaloneLambda -> do - matches <- traverse standaloneLambdaHandlerCase handlerNames - unmatched <- standaloneLambdaUnmatchedCase - pure $ Meta.CaseE caseExp (matches <> [unmatched]) - Main.UseWithAPIGateway -> do - matches <- traverse (apiGatewayHandlerCase options) handlerNames - unmatched <- apiGatewayUnmatchedCase - pure $ Meta.CaseE caseExp (matches <> [unmatched]) - -standaloneLambdaHandlerCase :: Text -> Meta.MatchQ -standaloneLambdaHandlerCase lambdaHandler = do - let pat = Meta.LitP (Meta.StringL $ Text.unpack lambdaHandler) - body <- [e|do - case decodeObj $(expressionName "eventObject") of - Right eventObject -> (do - result <- $(expressionName (qualifiedHandlerName lambdaHandler)) eventObject contextObject - either (pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse) (pure . Right . Runtime.StandaloneLambdaResult . toStandaloneLambdaResponse) result) - `Unchecked.catch` \(handlerError :: Unchecked.SomeException) -> pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse . show $ handlerError - Left err -> pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse $ err|] - pure $ Meta.Match pat (Meta.NormalB body) [] - -standaloneLambdaUnmatchedCase :: Meta.MatchQ -standaloneLambdaUnmatchedCase = do - let pattern = Meta.WildP - body <- [e| - pure . Left . Runtime.StandaloneLambdaError . toStandaloneLambdaResponse $ ("Handler " <> $(expressionName "functionHandler") <> " does not exist on project" :: String) - |] - pure $ Meta.Match pattern (Meta.NormalB body) [] - -apiGatewayHandlerCase :: Main.DispatcherOptions -> Text -> Meta.MatchQ -apiGatewayHandlerCase options lambdaHandler = do - let pat = Meta.LitP (Meta.StringL $ Text.unpack lambdaHandler) - body <- [e|do - let returnErr statusCode = pure . Left . Runtime.ApiGatewayLambdaError . ApiGatewayInfo.mkApiGatewayResponse statusCode - case decodeObj $(expressionName "eventObject") of - Right eventObject -> do - resultE <- Unchecked.try $ $(expressionName (qualifiedHandlerName lambdaHandler)) eventObject contextObject - case resultE of - Right result -> - either (pure . Left . Runtime.ApiGatewayLambdaError . fmap toApiGatewayResponseBody) (pure . Right . Runtime.ApiGatewayResult . fmap toApiGatewayResponseBody) result - Left (handlerError :: Unchecked.SomeException) -> - if (Runtime.propagateImpureExceptions . Runtime.apiGatewayDispatcherOptions $ options) - then returnErr 500 . toApiGatewayResponseBody . show $ handlerError - else returnErr 500 . toApiGatewayResponseBody . Text.pack $ "Something went wrong." - Left err -> returnErr 400 . toApiGatewayResponseBody . show $ err|] - pure $ Meta.Match pat (Meta.NormalB body) [] - -apiGatewayUnmatchedCase :: Meta.MatchQ -apiGatewayUnmatchedCase = do - let pattern = Meta.WildP - body <- [e| - pure . Left . Runtime.ApiGatewayLambdaError . ApiGatewayInfo.mkApiGatewayResponse 500 . toApiGatewayResponseBody $ ("Handler " <> $(expressionName "functionHandler") <> " does not exist on project") - |] - pure $ Meta.Match pattern (Meta.NormalB body) [] - -qualifiedHandlerName :: Text -> Text -qualifiedHandlerName lambdaHandler = - lambdaHandler - & Text.splitOn "/" - & filter (Char.isUpper . Text.head) - & Text.intercalate "." diff --git a/src/Aws/Lambda/Meta/Main.hs b/src/Aws/Lambda/Meta/Main.hs deleted file mode 100644 index b5418d2..0000000 --- a/src/Aws/Lambda/Meta/Main.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-| main function generation for interoperation with the layer -} -module Aws.Lambda.Meta.Main - ( Runtime.LambdaOptions(..) - , Runtime.DispatcherStrategy(..) - , Runtime.DispatcherOptions(..) - , Runtime.ApiGatewayDispatcherOptions(..) - , Runtime.defaultDispatcherOptions - , generate - ) where - -import qualified Language.Haskell.TH as Meta - -import Aws.Lambda.Meta.Common -import qualified Aws.Lambda.Runtime.Common as Runtime - --- | Generate the main function with the dispatcher -generate :: Meta.DecsQ -generate = [d| - $(declarationName "main") = $(directCallBody) - |] - where - directCallBody = - [e| - runLambda initializeContext run - |] \ No newline at end of file diff --git a/src/Aws/Lambda/Meta/Run.hs b/src/Aws/Lambda/Meta/Run.hs deleted file mode 100644 index cb32974..0000000 --- a/src/Aws/Lambda/Meta/Run.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Aws.Lambda.Meta.Run - ( generate - ) where - -import qualified Language.Haskell.TH as Meta - -import Aws.Lambda.Meta.Common -import qualified Aws.Lambda.Meta.Discover as Discover -import qualified Aws.Lambda.Meta.Dispatch as Dispatch -import qualified Aws.Lambda.Meta.Main as Main - -generate :: Main.DispatcherOptions -> Main.DispatcherStrategy -> Meta.DecQ -generate options strategy = do - handlers <- Meta.runIO Discover.handlers - clause' <- getFieldsFrom "LambdaOptions" ["functionHandler", "contextObject", "eventObject", "executionUuid"] - body <- Dispatch.generate options strategy handlers - pure $ Meta.FunD (Meta.mkName "run") [Meta.Clause [clause'] (Meta.NormalB body) []] diff --git a/src/Aws/Lambda/Runtime.hs b/src/Aws/Lambda/Runtime.hs index 4ec58a9..1c0c3dd 100644 --- a/src/Aws/Lambda/Runtime.hs +++ b/src/Aws/Lambda/Runtime.hs @@ -1,26 +1,17 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Aws.Lambda.Runtime - ( runLambda - , Runtime.LambdaResult(..) - , Runtime.DispatcherStrategy(..) - , Runtime.DispatcherOptions(..) - , Runtime.ApiGatewayDispatcherOptions(..) - , Runtime.defaultDispatcherOptions - , Error.Parsing(..) - ) where - -import Control.Exception.Safe.Checked -import qualified Control.Exception.Safe.Checked as Checked -import Control.Monad (forever) -import System.IO (hFlush, stdout, stderr) -import qualified Network.HTTP.Client as Http - -import Data.Aeson -import Data.IORef + ( runLambda, + Runtime.LambdaResult (..), + Runtime.DispatcherStrategy (..), + Runtime.DispatcherOptions (..), + Runtime.ApiGatewayDispatcherOptions (..), + Runtime.defaultDispatcherOptions, + Error.Parsing (..), + ) +where import qualified Aws.Lambda.Runtime.ApiInfo as ApiInfo import qualified Aws.Lambda.Runtime.Common as Runtime @@ -28,66 +19,95 @@ import qualified Aws.Lambda.Runtime.Context as Context import qualified Aws.Lambda.Runtime.Environment as Environment import qualified Aws.Lambda.Runtime.Error as Error import qualified Aws.Lambda.Runtime.Publish as Publish -import qualified Control.Exception as Unchecked +import Control.Exception +import Control.Monad (forever) +import Data.Aeson +import Data.IORef +import qualified Network.HTTP.Client as Http +import System.IO (hFlush, stderr, stdout) + +runLambda :: + ( FromJSON event, + Runtime.ToLambdaResponseBody error, + Runtime.ToLambdaResponseBody result + ) => + IO context -> + (event -> Context.Context context -> IO (Either error result)) -> + IO () +runLambda initializer userCode = + runtime initializer (wrapStandaloneLambda userCode) --- | Runs the user @haskell_lambda@ executable and posts back the --- results. This is called from the layer's @main@ function. -runLambda :: forall context. IO context -> Runtime.RunCallback context -> IO () -runLambda initializeCustomContext callback = do +wrapStandaloneLambda :: + ( FromJSON event, + Runtime.ToLambdaResponseBody error, + Runtime.ToLambdaResponseBody result + ) => + (event -> Context.Context context -> IO (Either error result)) -> + Runtime.LambdaOptions context -> + IO (Either Runtime.LambdaError Runtime.LambdaResult) +wrapStandaloneLambda userCode Runtime.LambdaOptions {..} = + case eitherDecode eventObject of + Left err -> + pure . Left . Runtime.StandaloneLambdaError $ Runtime.toStandaloneLambdaResponse err + Right event -> do + result <- userCode event contextObject + case result of + Left err -> + pure . Left . Runtime.StandaloneLambdaError $ Runtime.toStandaloneLambdaResponse err + Right ok -> + pure . Right . Runtime.StandaloneLambdaResult $ Runtime.toStandaloneLambdaResponse ok + +runtime :: forall context. IO context -> Runtime.RunCallback context -> IO () +runtime initializeCustomContext callback = do manager <- Http.newManager httpManagerSettings customContext <- initializeCustomContext customContextRef <- newIORef customContext - context <- Context.initialize @context customContextRef `catch` errorParsing `catch` variableNotSet + context <- Context.initialize @context customContextRef `catch` errorParsing `catch` variableNotSet forever $ do lambdaApi <- Environment.apiEndpoint `catch` variableNotSet - event <- ApiInfo.fetchEvent manager lambdaApi `catch` errorParsing - + event <- ApiInfo.fetchEvent manager lambdaApi `catch` errorParsing -- Purposefully shadowing to prevent using the initial "empty" context context <- Context.setEventData context event - - (((invokeAndRun callback manager lambdaApi event context - `Checked.catch` \err -> Publish.parsingError err lambdaApi context manager) - `Checked.catch` \err -> Publish.invocationError err lambdaApi context manager) - `Checked.catch` \(err :: Error.EnvironmentVariableNotSet) -> Publish.runtimeInitError err lambdaApi context manager) - `Unchecked.catch` \err -> Publish.invocationError err lambdaApi context manager + invokeAndRun callback manager lambdaApi event context + `catches` [ Handler $ \err -> Publish.parsingError err lambdaApi context manager, + Handler $ \err -> Publish.invocationError err lambdaApi context manager, + Handler $ \(err :: Error.EnvironmentVariableNotSet) -> Publish.runtimeInitError err lambdaApi context manager, + Handler $ \err -> Publish.invocationError err lambdaApi context manager + ] httpManagerSettings :: Http.ManagerSettings httpManagerSettings = -- We set the timeout to none, as AWS Lambda freezes the containers. Http.defaultManagerSettings - { Http.managerResponseTimeout = Http.responseTimeoutNone - } + { Http.managerResponseTimeout = Http.responseTimeoutNone + } -invokeAndRun - :: Throws Error.Invocation - => Throws Error.EnvironmentVariableNotSet - => Runtime.RunCallback context - -> Http.Manager - -> String - -> ApiInfo.Event - -> Context.Context context - -> IO () +invokeAndRun :: + Runtime.RunCallback context -> + Http.Manager -> + String -> + ApiInfo.Event -> + Context.Context context -> + IO () invokeAndRun callback manager lambdaApi event context = do result <- invokeWithCallback callback event context - Publish.result result lambdaApi context manager `catch` \err -> Publish.invocationError err lambdaApi context manager -invokeWithCallback - :: Throws Error.Invocation - => Throws Error.EnvironmentVariableNotSet - => Runtime.RunCallback context - -> ApiInfo.Event - -> Context.Context context - -> IO Runtime.LambdaResult +invokeWithCallback :: + Runtime.RunCallback context -> + ApiInfo.Event -> + Context.Context context -> + IO Runtime.LambdaResult invokeWithCallback callback event context = do handlerName <- Environment.handlerName - let lambdaOptions = Runtime.LambdaOptions - { eventObject = ApiInfo.event event - , functionHandler = handlerName - , executionUuid = "" -- DirectCall doesnt use UUID - , contextObject = context - } + let lambdaOptions = + Runtime.LambdaOptions + { eventObject = ApiInfo.event event, + functionHandler = handlerName, + executionUuid = "", -- DirectCall doesnt use UUID + contextObject = context + } result <- callback lambdaOptions -- Flush output to insure output goes into CloudWatch logs flushOutput @@ -105,11 +125,11 @@ variableNotSet (Error.EnvironmentVariableNotSet env) = error ("Error initializing, variable not set: " <> env) errorParsing :: Error.Parsing -> IO a -errorParsing Error.Parsing{..} = +errorParsing Error.Parsing {..} = error ("Failed parsing " <> errorMessage <> ", got" <> actualValue) -- | Flush standard output ('stdout') and standard error output ('stderr') handlers flushOutput :: IO () flushOutput = do hFlush stdout - hFlush stderr \ No newline at end of file + hFlush stderr diff --git a/src/Aws/Lambda/Runtime/ApiGatewayInfo.hs b/src/Aws/Lambda/Runtime/ApiGatewayInfo.hs deleted file mode 100644 index 57d621f..0000000 --- a/src/Aws/Lambda/Runtime/ApiGatewayInfo.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Aws.Lambda.Runtime.ApiGatewayInfo - ( ApiGatewayRequest(..) - , ApiGatewayRequestContext(..) - , ApiGatewayRequestContextIdentity(..) - , ApiGatewayResponse(..) - , ApiGatewayResponseBody(..) - , ToApiGatewayResponseBody(..) - , mkApiGatewayResponse ) where - -import Aws.Lambda.Utilities -import Data.Aeson -import Data.Aeson.Types (Parser) -import qualified Data.Aeson.Types as T -import qualified Data.CaseInsensitive as CI -import Data.HashMap.Strict (HashMap) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import GHC.Generics (Generic) -import Network.HTTP.Types - -data ApiGatewayRequest body = ApiGatewayRequest - { apiGatewayRequestResource :: !Text - , apiGatewayRequestPath :: !Text - , apiGatewayRequestHttpMethod :: !Text - , apiGatewayRequestHeaders :: !(Maybe (HashMap Text Text)) - , apiGatewayRequestQueryStringParameters :: !(Maybe (HashMap Text Text)) - , apiGatewayRequestPathParameters :: !(Maybe (HashMap Text Text)) - , apiGatewayRequestStageVariables :: !(Maybe (HashMap Text Text)) - , apiGatewayRequestIsBase64Encoded :: !Bool - , apiGatewayRequestRequestContext :: !ApiGatewayRequestContext - , apiGatewayRequestBody :: !(Maybe body) - } deriving (Show) - --- We special case String and Text in order --- to avoid unneeded encoding which will wrap them in quotes and break parsing -instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest Text) where - parseJSON = parseApiGatewayRequest (.:) - -instance {-# OVERLAPPING #-} FromJSON (ApiGatewayRequest String) where - parseJSON = parseApiGatewayRequest (.:) - -instance FromJSON body => FromJSON (ApiGatewayRequest body) where - parseJSON = parseApiGatewayRequest parseObjectFromStringField - --- We need this because API Gateway is going to send us the payload as a JSON string -parseObjectFromStringField :: FromJSON a => Object -> Text -> Parser (Maybe a) -parseObjectFromStringField obj fieldName = do - fieldContents <- obj .: fieldName - case fieldContents of - String stringContents -> - case eitherDecodeStrict (T.encodeUtf8 stringContents) of - Right success -> pure success - Left err -> fail err - Null -> pure Nothing - other -> T.typeMismatch "String or Null" other - -parseApiGatewayRequest :: (Object -> Text -> Parser (Maybe body)) -> Value -> Parser (ApiGatewayRequest body) -parseApiGatewayRequest bodyParser (Object v) = ApiGatewayRequest <$> - v .: "resource" <*> - v .: "path" <*> - v .: "httpMethod" <*> - v .: "headers" <*> - v .: "queryStringParameters" <*> - v .: "pathParameters" <*> - v .: "stageVariables" <*> - v .: "isBase64Encoded" <*> - v .: "requestContext" <*> - v `bodyParser` "body" -parseApiGatewayRequest _ _ = fail "Expected ApiGatewayRequest to be an object." - -data ApiGatewayRequestContext = ApiGatewayRequestContext - { apiGatewayRequestContextResourceId :: !Text - , apiGatewayRequestContextResourcePath :: !Text - , apiGatewayRequestContextHttpMethod :: !Text - , apiGatewayRequestContextExtendedRequestId :: !Text - , apiGatewayRequestContextRequestTime :: !Text - , apiGatewayRequestContextPath :: !Text - , apiGatewayRequestContextAccountId :: !Text - , apiGatewayRequestContextProtocol :: !Text - , apiGatewayRequestContextStage :: !Text - , apiGatewayRequestContextDomainPrefix :: !Text - , apiGatewayRequestContextRequestId :: !Text - , apiGatewayRequestContextDomainName :: !Text - , apiGatewayRequestContextApiId :: !Text - , apiGatewayRequestContextIdentity :: !ApiGatewayRequestContextIdentity - } deriving (Show) - -instance FromJSON ApiGatewayRequestContext where - parseJSON (Object v) = ApiGatewayRequestContext <$> - v .: "resourceId" <*> - v .: "path" <*> - v .: "httpMethod" <*> - v .: "extendedRequestId" <*> - v .: "requestTime" <*> - v .: "path" <*> - v .: "accountId" <*> - v .: "protocol" <*> - v .: "stage" <*> - v .: "domainPrefix" <*> - v .: "requestId" <*> - v .: "domainName" <*> - v .: "apiId" <*> - v .: "identity" - parseJSON _ = fail "Expected ApiGatewayRequestContext to be an object." - -data ApiGatewayRequestContextIdentity = ApiGatewayRequestContextIdentity - { apiGatewayRequestContextIdentityCognitoIdentityPoolId :: !(Maybe Text) - , apiGatewayRequestContextIdentityAccountId :: !(Maybe Text) - , apiGatewayRequestContextIdentityCognitoIdentityId :: !(Maybe Text) - , apiGatewayRequestContextIdentityCaller :: !(Maybe Text) - , apiGatewayRequestContextIdentitySourceIp :: !(Maybe Text) - , apiGatewayRequestContextIdentityPrincipalOrgId :: !(Maybe Text) - , apiGatewayRequestContextIdentityAccesskey :: !(Maybe Text) - , apiGatewayRequestContextIdentityCognitoAuthenticationType :: !(Maybe Text) - , apiGatewayRequestContextIdentityCognitoAuthenticationProvider :: !(Maybe Value) - , apiGatewayRequestContextIdentityUserArn :: !(Maybe Text) - , apiGatewayRequestContextIdentityUserAgent :: !(Maybe Text) - , apiGatewayRequestContextIdentityUser :: !(Maybe Text) - } deriving (Show) - -instance FromJSON ApiGatewayRequestContextIdentity where - parseJSON (Object v) = ApiGatewayRequestContextIdentity <$> - v .: "cognitoIdentityPoolId" <*> - v .: "accountId" <*> - v .: "cognitoIdentityId" <*> - v .: "caller" <*> - v .: "sourceIp" <*> - v .: "principalOrgId" <*> - v .: "accessKey" <*> - v .: "cognitoAuthenticationType" <*> - v .: "cognitoAuthenticationProvider" <*> - v .: "userArn" <*> - v .: "userAgent" <*> - v .: "user" - parseJSON _ = fail "Expected ApiGatewayRequestContextIdentity to be an object." - -newtype ApiGatewayResponseBody = - ApiGatewayResponseBody Text - deriving newtype (ToJSON, FromJSON) - -class ToApiGatewayResponseBody a where - toApiGatewayResponseBody :: a -> ApiGatewayResponseBody - --- We special case Text and String to avoid unneeded encoding which will wrap them in quotes -instance {-# OVERLAPPING #-} ToApiGatewayResponseBody Text where - toApiGatewayResponseBody = ApiGatewayResponseBody - -instance {-# OVERLAPPING #-} ToApiGatewayResponseBody String where - toApiGatewayResponseBody = ApiGatewayResponseBody . T.pack - -instance ToJSON a => ToApiGatewayResponseBody a where - toApiGatewayResponseBody = ApiGatewayResponseBody . toJSONText - -data ApiGatewayResponse body = ApiGatewayResponse - { apiGatewayResponseStatusCode :: !Int - , apiGatewayResponseHeaders :: !ResponseHeaders - , apiGatewayResponseBody :: !body - , apiGatewayResponseIsBase64Encoded :: !Bool - } deriving (Generic, Show) - -instance Functor ApiGatewayResponse where - fmap f v = v { apiGatewayResponseBody = f (apiGatewayResponseBody v) } - -instance ToJSON body => ToJSON (ApiGatewayResponse body) where - toJSON = apiGatewayResponseToJSON toJSON - -apiGatewayResponseToJSON :: (body -> Value) -> ApiGatewayResponse body -> Value -apiGatewayResponseToJSON bodyTransformer ApiGatewayResponse {..} = object - [ "statusCode" .= apiGatewayResponseStatusCode - , "body" .= bodyTransformer apiGatewayResponseBody - , "headers" .= object (map headerToPair apiGatewayResponseHeaders) - , "isBase64Encoded" .= apiGatewayResponseIsBase64Encoded - ] - -mkApiGatewayResponse :: Int -> payload -> ApiGatewayResponse payload -mkApiGatewayResponse code payload = - ApiGatewayResponse code [] payload False - -headerToPair :: Header -> T.Pair -headerToPair (cibyte, bstr) = k .= v - where - k = (T.decodeUtf8 . CI.original) cibyte - v = T.decodeUtf8 bstr diff --git a/src/Aws/Lambda/Runtime/ApiInfo.hs b/src/Aws/Lambda/Runtime/ApiInfo.hs index 800587c..99d3b1a 100644 --- a/src/Aws/Lambda/Runtime/ApiInfo.hs +++ b/src/Aws/Lambda/Runtime/ApiInfo.hs @@ -1,33 +1,33 @@ module Aws.Lambda.Runtime.ApiInfo - ( Event(..) - , fetchEvent - ) where + ( Event (..), + fetchEvent, + ) +where +import qualified Aws.Lambda.Runtime.API.Endpoints as Endpoints +import qualified Aws.Lambda.Runtime.Error as Error +import Control.Exception (IOException, throw, try) import qualified Control.Monad as Monad -import qualified Text.Read as Read - -import Control.Exception (IOException) -import Control.Exception.Safe.Checked import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as ByteString import qualified Data.ByteString.Lazy.Char8 as Lazy import qualified Network.HTTP.Client as Http import qualified Network.HTTP.Types.Header as Http - -import qualified Aws.Lambda.Runtime.API.Endpoints as Endpoints -import qualified Aws.Lambda.Runtime.Error as Error +import qualified Text.Read as Read -- | Event that is fetched out of the AWS Lambda API -data Event = Event - { deadlineMs :: !Int - , traceId :: !String - , awsRequestId :: !String - , invokedFunctionArn :: !String - , event :: !Lazy.ByteString - } deriving (Show) +data Event + = Event + { deadlineMs :: !Int, + traceId :: !String, + awsRequestId :: !String, + invokedFunctionArn :: !String, + event :: !Lazy.ByteString + } + deriving (Show) -- | Performs a GET to the endpoint that provides the next event -fetchEvent :: Throws Error.Parsing => Http.Manager -> String -> IO Event +fetchEvent :: Http.Manager -> String -> IO Event fetchEvent manager lambdaApi = do response <- fetchApiData manager lambdaApi let body = Http.responseBody response @@ -40,38 +40,35 @@ fetchApiData manager lambdaApi = do request <- Http.parseRequest endpoint keepRetrying $ Http.httpLbs request manager -reduceEvent :: Throws Error.Parsing => Event -> (Http.HeaderName, ByteString) -> IO Event +reduceEvent :: Event -> (Http.HeaderName, ByteString) -> IO Event reduceEvent event header = case header of ("Lambda-Runtime-Deadline-Ms", value) -> case Read.readMaybe $ ByteString.unpack value of - Just ms -> pure event { deadlineMs = ms } + Just ms -> pure event {deadlineMs = ms} Nothing -> throw (Error.Parsing "Could not parse deadlineMs." (ByteString.unpack value) "deadlineMs") - ("Lambda-Runtime-Trace-Id", value) -> - pure event { traceId = ByteString.unpack value } - + pure event {traceId = ByteString.unpack value} ("Lambda-Runtime-Aws-Request-Id", value) -> - pure event { awsRequestId = ByteString.unpack value } - + pure event {awsRequestId = ByteString.unpack value} ("Lambda-Runtime-Invoked-Function-Arn", value) -> - pure event { invokedFunctionArn = ByteString.unpack value } - + pure event {invokedFunctionArn = ByteString.unpack value} _ -> pure event initialEvent :: Lazy.ByteString -> Event -initialEvent body = Event - { deadlineMs = 0 - , traceId = "" - , awsRequestId = "" - , invokedFunctionArn = "" - , event = body - } +initialEvent body = + Event + { deadlineMs = 0, + traceId = "", + awsRequestId = "", + invokedFunctionArn = "", + event = body + } keepRetrying :: IO (Http.Response Lazy.ByteString) -> IO (Http.Response Lazy.ByteString) keepRetrying action = do result <- try action :: IO (Either IOException (Http.Response Lazy.ByteString)) case result of Right success -> pure success - _ -> keepRetrying action + _ -> keepRetrying action diff --git a/src/Aws/Lambda/Runtime/Common.hs b/src/Aws/Lambda/Runtime/Common.hs index b816d65..07f64b8 100644 --- a/src/Aws/Lambda/Runtime/Common.hs +++ b/src/Aws/Lambda/Runtime/Common.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Aws.Lambda.Runtime.Common - ( RunCallback - , LambdaResult(..) - , LambdaError(..) - , LambdaOptions(..) - , DispatcherOptions(..) - , ApiGatewayDispatcherOptions(..) - , DispatcherStrategy(..) - , ToLambdaResponseBody(..) - , unLambdaResponseBody - , defaultDispatcherOptions - ) where + ( RunCallback, + LambdaResult (..), + LambdaError (..), + LambdaOptions (..), + DispatcherOptions (..), + ApiGatewayDispatcherOptions (..), + DispatcherStrategy (..), + ToLambdaResponseBody (..), + LambdaResponseBody (..), + defaultDispatcherOptions, + ) +where -import Aws.Lambda.Runtime.ApiGatewayInfo +import Aws.Lambda.Events.ApiGateway import Aws.Lambda.Runtime.Context (Context) import Aws.Lambda.Utilities import Data.Aeson (FromJSON, ToJSON) @@ -28,24 +29,28 @@ import GHC.Generics (Generic) import Language.Haskell.TH.Syntax (Lift) -- | API Gateway specific dispatcher options -newtype ApiGatewayDispatcherOptions = ApiGatewayDispatcherOptions - { propagateImpureExceptions :: Bool - -- ^ Should impure exceptions be propagated through the API Gateway interface - } deriving (Lift) +newtype ApiGatewayDispatcherOptions + = ApiGatewayDispatcherOptions + { -- | Should impure exceptions be propagated through the API Gateway interface + propagateImpureExceptions :: Bool + } + deriving (Lift) -- | Options that the dispatcher generator expects -newtype DispatcherOptions = DispatcherOptions - { apiGatewayDispatcherOptions :: ApiGatewayDispatcherOptions - } deriving (Lift) +newtype DispatcherOptions + = DispatcherOptions + { apiGatewayDispatcherOptions :: ApiGatewayDispatcherOptions + } + deriving (Lift) defaultDispatcherOptions :: DispatcherOptions defaultDispatcherOptions = DispatcherOptions (ApiGatewayDispatcherOptions True) -- | A strategy on how to generate the dispatcher functions -data DispatcherStrategy = - UseWithAPIGateway | - StandaloneLambda +data DispatcherStrategy + = UseWithAPIGateway + | StandaloneLambda deriving (Lift) -- | Callback that we pass to the dispatcher function @@ -53,8 +58,8 @@ type RunCallback context = LambdaOptions context -> IO (Either LambdaError LambdaResult) -- | Wrapper type for lambda response body -newtype LambdaResponseBody = - LambdaResponseBody { unLambdaResponseBody :: Text } +newtype LambdaResponseBody + = LambdaResponseBody {unLambdaResponseBody :: Text} deriving newtype (ToJSON, FromJSON) class ToLambdaResponseBody a where @@ -72,19 +77,21 @@ instance ToJSON a => ToLambdaResponseBody a where toStandaloneLambdaResponse = LambdaResponseBody . toJSONText -- | Wrapper type for lambda execution results -data LambdaError = - StandaloneLambdaError LambdaResponseBody | - ApiGatewayLambdaError (ApiGatewayResponse ApiGatewayResponseBody) +data LambdaError + = StandaloneLambdaError LambdaResponseBody + | ApiGatewayLambdaError (ApiGatewayResponse ApiGatewayResponseBody) -- | Wrapper type to handle the result of the user -data LambdaResult = - StandaloneLambdaResult LambdaResponseBody | - ApiGatewayResult (ApiGatewayResponse ApiGatewayResponseBody) +data LambdaResult + = StandaloneLambdaResult LambdaResponseBody + | ApiGatewayResult (ApiGatewayResponse ApiGatewayResponseBody) -- | Options that the generated main expects -data LambdaOptions context = LambdaOptions - { eventObject :: !Lazy.ByteString - , functionHandler :: !String - , executionUuid :: !String - , contextObject :: !(Context context) - } deriving (Generic) +data LambdaOptions context + = LambdaOptions + { eventObject :: !Lazy.ByteString, + functionHandler :: !String, + executionUuid :: !String, + contextObject :: !(Context context) + } + deriving (Generic) diff --git a/src/Aws/Lambda/Runtime/Context.hs b/src/Aws/Lambda/Runtime/Context.hs index 6b58426..c50a616 100644 --- a/src/Aws/Lambda/Runtime/Context.hs +++ b/src/Aws/Lambda/Runtime/Context.hs @@ -1,69 +1,66 @@ module Aws.Lambda.Runtime.Context - ( Context(..) - , initialize - , setEventData - ) where - -import Control.Exception.Safe.Checked -import Data.IORef + ( Context (..), + initialize, + setEventData, + ) +where import qualified Aws.Lambda.Runtime.ApiInfo as ApiInfo import qualified Aws.Lambda.Runtime.Environment as Environment -import qualified Aws.Lambda.Runtime.Error as Error +import Data.IORef -- | Context that is passed to all the handlers -data Context context = Context - { memoryLimitInMb :: !Int - , functionName :: !String - , functionVersion :: !String - , invokedFunctionArn :: !String - , awsRequestId :: !String - , xrayTraceId :: !String - , logStreamName :: !String - , logGroupName :: !String - , deadline :: !Int - , customContext :: !(IORef context) - } +data Context context + = Context + { memoryLimitInMb :: !Int, + functionName :: !String, + functionVersion :: !String, + invokedFunctionArn :: !String, + awsRequestId :: !String, + xrayTraceId :: !String, + logStreamName :: !String, + logGroupName :: !String, + deadline :: !Int, + customContext :: !(IORef context) + } -- | Initializes the context out of the environment -initialize - :: Throws Error.Parsing - => Throws Error.EnvironmentVariableNotSet - => IORef context - -> IO (Context context) +initialize :: + IORef context -> + IO (Context context) initialize customContextRef = do - functionName <- Environment.functionName - version <- Environment.functionVersion - logStream <- Environment.logStreamName - logGroup <- Environment.logGroupName - memoryLimitInMb <- Environment.functionMemory - - pure $ Context - { functionName = functionName - , functionVersion = version - , logStreamName = logStream - , logGroupName = logGroup - , memoryLimitInMb = memoryLimitInMb - , customContext = customContextRef - - -- We set those to "empty" values because they will be assigned - -- from the incoming event once one has been received. (see setEventData) - , invokedFunctionArn = mempty - , xrayTraceId = mempty - , awsRequestId = mempty - , deadline = 0 - } + functionName <- Environment.functionName + version <- Environment.functionVersion + logStream <- Environment.logStreamName + logGroup <- Environment.logGroupName + memoryLimitInMb <- Environment.functionMemory + pure $ + Context + { functionName = functionName, + functionVersion = version, + logStreamName = logStream, + logGroupName = logGroup, + memoryLimitInMb = memoryLimitInMb, + customContext = customContextRef, + -- We set those to "empty" values because they will be assigned + -- from the incoming event once one has been received. (see setEventData) + invokedFunctionArn = mempty, + xrayTraceId = mempty, + awsRequestId = mempty, + deadline = 0 + } -- | Sets the context's event data -setEventData - :: Context context - -> ApiInfo.Event - -> IO (Context context) -setEventData context ApiInfo.Event{..} = do +setEventData :: + Context context -> + ApiInfo.Event -> + IO (Context context) +setEventData context ApiInfo.Event {..} = do Environment.setXRayTrace traceId - - return $ context - { invokedFunctionArn = invokedFunctionArn - , xrayTraceId = traceId - , awsRequestId = awsRequestId - , deadline = deadlineMs } \ No newline at end of file + return $ + context + { invokedFunctionArn = invokedFunctionArn, + xrayTraceId = traceId, + awsRequestId = awsRequestId, + deadline = deadlineMs + } diff --git a/src/Aws/Lambda/Runtime/Environment.hs b/src/Aws/Lambda/Runtime/Environment.hs index 1171756..e65186d 100644 --- a/src/Aws/Lambda/Runtime/Environment.hs +++ b/src/Aws/Lambda/Runtime/Environment.hs @@ -1,65 +1,65 @@ -{-| Provides all the values out of -the environment variables of the system --} +-- | Provides all the values out of +-- the environment variables of the system module Aws.Lambda.Runtime.Environment - ( functionMemory - , apiEndpoint - , handlerName - , taskRoot - , functionName - , functionVersion - , logStreamName - , logGroupName - , setXRayTrace - ) where + ( functionMemory, + apiEndpoint, + handlerName, + taskRoot, + functionName, + functionVersion, + logStreamName, + logGroupName, + setXRayTrace, + ) +where import qualified Aws.Lambda.Runtime.Error as Error -import Control.Exception.Safe.Checked +import Control.Exception (throw) import qualified System.Environment as Environment import qualified Text.Read as Read -logGroupName :: Throws Error.EnvironmentVariableNotSet => IO String +logGroupName :: IO String logGroupName = readEnvironmentVariable "AWS_LAMBDA_LOG_GROUP_NAME" -logStreamName :: Throws Error.EnvironmentVariableNotSet => IO String +logStreamName :: IO String logStreamName = readEnvironmentVariable "AWS_LAMBDA_LOG_STREAM_NAME" -functionVersion :: Throws Error.EnvironmentVariableNotSet => IO String +functionVersion :: IO String functionVersion = readEnvironmentVariable "AWS_LAMBDA_FUNCTION_VERSION" -functionName :: Throws Error.EnvironmentVariableNotSet => IO String +functionName :: IO String functionName = readEnvironmentVariable "AWS_LAMBDA_FUNCTION_NAME" setXRayTrace :: String -> IO () setXRayTrace = Environment.setEnv "_X_AMZN_TRACE_ID" -taskRoot :: Throws Error.EnvironmentVariableNotSet => IO String +taskRoot :: IO String taskRoot = readEnvironmentVariable "LAMBDA_TASK_ROOT" -handlerName :: Throws Error.EnvironmentVariableNotSet => IO String +handlerName :: IO String handlerName = readEnvironmentVariable "_HANDLER" -apiEndpoint :: Throws Error.EnvironmentVariableNotSet => IO String +apiEndpoint :: IO String apiEndpoint = readEnvironmentVariable "AWS_LAMBDA_RUNTIME_API" -functionMemory :: Throws Error.Parsing => Throws Error.EnvironmentVariableNotSet => IO Int +functionMemory :: IO Int functionMemory = do let envVar = "AWS_LAMBDA_FUNCTION_MEMORY_SIZE" memoryValue <- readEnvironmentVariable envVar case Read.readMaybe memoryValue of Just value -> pure value - Nothing -> throw (Error.Parsing envVar memoryValue envVar) + Nothing -> throw (Error.Parsing envVar memoryValue envVar) -readEnvironmentVariable :: Throws Error.EnvironmentVariableNotSet => String -> IO String +readEnvironmentVariable :: String -> IO String readEnvironmentVariable envVar = do v <- Environment.lookupEnv envVar case v of Just value -> pure value - Nothing -> throw (Error.EnvironmentVariableNotSet envVar) + Nothing -> throw (Error.EnvironmentVariableNotSet envVar) diff --git a/src/Aws/Lambda/Runtime/Error.hs b/src/Aws/Lambda/Runtime/Error.hs index 46a61e8..8ac9f84 100644 --- a/src/Aws/Lambda/Runtime/Error.hs +++ b/src/Aws/Lambda/Runtime/Error.hs @@ -1,39 +1,49 @@ -{-| All the errors that the runtime can throw --} +-- | All the errors that the runtime can throw module Aws.Lambda.Runtime.Error - ( EnvironmentVariableNotSet(..) - , Parsing(..) - , Invocation(..) - ) where + ( EnvironmentVariableNotSet (..), + Parsing (..), + Invocation (..), + ) +where -import Control.Exception.Safe.Checked -import Data.Aeson (ToJSON (..), object, (.=), Value) +import Control.Exception +import Data.Aeson ((.=), ToJSON (..), Value, object) -newtype EnvironmentVariableNotSet = - EnvironmentVariableNotSet String - deriving (Show, Exception) +newtype EnvironmentVariableNotSet + = EnvironmentVariableNotSet String + deriving (Show) + +instance Exception EnvironmentVariableNotSet instance ToJSON EnvironmentVariableNotSet where - toJSON (EnvironmentVariableNotSet msg) = object - [ "errorType" .= ("EnvironmentVariableNotSet" :: String) - , "errorMessage" .= msg - ] + toJSON (EnvironmentVariableNotSet msg) = + object + [ "errorType" .= ("EnvironmentVariableNotSet" :: String), + "errorMessage" .= msg + ] + +data Parsing + = Parsing + { errorMessage :: String, + actualValue :: String, + valueName :: String + } + deriving (Show) -data Parsing = Parsing - { errorMessage :: String - , actualValue :: String - , valueName :: String - } deriving (Show, Exception) +instance Exception Parsing instance ToJSON Parsing where - toJSON (Parsing errorMessage _ valueName) = object - [ "errorType" .= ("Parsing" :: String) - , "errorMessage" .= ("Could not parse '" <> valueName <> "': " <> errorMessage) - ] - -newtype Invocation = - Invocation Value - deriving (Show, Exception) + toJSON (Parsing errorMessage _ valueName) = + object + [ "errorType" .= ("Parsing" :: String), + "errorMessage" .= ("Could not parse '" <> valueName <> "': " <> errorMessage) + ] + +newtype Invocation + = Invocation Value + deriving (Show) + +instance Exception Invocation instance ToJSON Invocation where -- We return the user error as it is diff --git a/src/Aws/Lambda/Runtime/Publish.hs b/src/Aws/Lambda/Runtime/Publish.hs index b61bb1b..5bb1c8d 100644 --- a/src/Aws/Lambda/Runtime/Publish.hs +++ b/src/Aws/Lambda/Runtime/Publish.hs @@ -1,36 +1,35 @@ -{-| Publishing of results/errors back to the -AWS Lambda runtime API -} +-- | Publishing of results/errors back to the +-- AWS Lambda runtime API module Aws.Lambda.Runtime.Publish - ( result - , invocationError - , parsingError - , runtimeInitError - ) where - -import Control.Monad (void) -import Data.Aeson -import qualified Data.Text.Encoding as T -import qualified Network.HTTP.Client as Http + ( result, + invocationError, + parsingError, + runtimeInitError, + ) +where import qualified Aws.Lambda.Runtime.API.Endpoints as Endpoints import Aws.Lambda.Runtime.Common import Aws.Lambda.Runtime.Context (Context (..)) import qualified Aws.Lambda.Runtime.Error as Error +import Control.Monad (void) +import Data.Aeson +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Client as Http -- | Publishes the result back to AWS Lambda result :: LambdaResult -> String -> Context context -> Http.Manager -> IO () result lambdaResult lambdaApi context manager = do let Endpoints.Endpoint endpoint = Endpoints.response lambdaApi (awsRequestId context) rawRequest <- Http.parseRequest endpoint - let requestBody = case lambdaResult of (StandaloneLambdaResult res) -> Http.RequestBodyBS (T.encodeUtf8 . unLambdaResponseBody $ res) - (ApiGatewayResult res) -> Http.RequestBodyLBS (encode res) - request = rawRequest - { Http.method = "POST" - , Http.requestBody = requestBody - } - + (ApiGatewayResult res) -> Http.RequestBodyLBS (encode res) + request = + rawRequest + { Http.method = "POST", + Http.requestBody = requestBody + } void $ Http.httpNoBody request manager -- | Publishes an invocation error back to AWS Lambda @@ -41,7 +40,9 @@ invocationError err lambdaApi context = -- | Publishes a parsing error back to AWS Lambda parsingError :: Error.Parsing -> String -> Context context -> Http.Manager -> IO () parsingError err lambdaApi context = - publish err (Endpoints.invocationError lambdaApi $ awsRequestId context) + publish + err + (Endpoints.invocationError lambdaApi $ awsRequestId context) context -- | Publishes a runtime initialization error back to AWS Lambda @@ -50,13 +51,12 @@ runtimeInitError err lambdaApi = publish err (Endpoints.runtimeInitError lambdaApi) publish :: ToJSON err => err -> Endpoints.Endpoint -> Context context -> Http.Manager -> IO () -publish err (Endpoints.Endpoint endpoint) Context{..} manager = do +publish err (Endpoints.Endpoint endpoint) Context {} manager = do rawRequest <- Http.parseRequest endpoint - let requestBody = Http.RequestBodyLBS (encode err) - request = rawRequest - { Http.method = "POST" - , Http.requestBody = requestBody - } - + request = + rawRequest + { Http.method = "POST", + Http.requestBody = requestBody + } void $ Http.httpNoBody request manager diff --git a/src/Aws/Lambda/Utilities.hs b/src/Aws/Lambda/Utilities.hs index 16f14e1..ea3a152 100644 --- a/src/Aws/Lambda/Utilities.hs +++ b/src/Aws/Lambda/Utilities.hs @@ -3,7 +3,7 @@ module Aws.Lambda.Utilities (toJSONText) where import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LazyByteString import Data.Text -import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding as TE toJSONText :: ToJSON a => a -> Text -toJSONText = T.decodeUtf8 . LazyByteString.toStrict . encode +toJSONText = TE.decodeUtf8 . LazyByteString.toStrict . encode diff --git a/stack.yaml b/stack.yaml index d6b1ef6..f812667 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,42 +1,8 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml resolver: lts-15.5 -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# subdirs: -# - auto-update -# - wai packages: - . -# Dependency packages to be pulled from upstream that are not in the resolver -# using the same syntax as the packages field. -# (e.g., acme-missiles-0.3) + extra-deps: - require-0.4.2 - cheapskate-0.1.1.2@sha256:b8ae3cbb826610ea45e6840b7fde0af2c2ea6690cb311edfe9683f61c0a50d96,3072 @@ -44,29 +10,10 @@ extra-deps: - megaparsec-7.0.5@sha256:45e1f1348fab2783646fdb4d9e6097568981a740951c7356d36d794e2baba305,3902 - github: theam/tintin commit: 4355dda4a4b3dfd8e8f5fe1764330f7f59bd25b1 -# Override default flag values for local packages and extra-deps -# flags: {} -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.9" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor nix: packages: - zlib + +ghc-options: + "$locals": -fwrite-ide-info diff --git a/test/Spec.hs b/test/Spec.hs index bc39f14..5814e3e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1 @@ -import Test.Hspec - - -main :: IO () -main = hspec $ describe "Useless test spec" $ do - it "runs" $ do - (1 + 1 :: Int) `shouldBe` (2 :: Int) +{-# OPTIONS_GHC -F -pgmF hspec-discover -fno-warn-missing-export-lists #-} diff --git a/weeder.dhall b/weeder.dhall new file mode 100644 index 0000000..9e8efde --- /dev/null +++ b/weeder.dhall @@ -0,0 +1,7 @@ +{ roots = + [ "^Aws.Lambda.Runtime.runLambda$" + , "^Main.spec$" + , "^Main.main$" + ] +, type-class-roots = True +}