diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,74 @@ +# Change log + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog][chg] and this project adheres to +[Haskell's Package Versioning Policy][pvp] + +## `0.4.8` - 2021-05-07 + + - Add `ToJSON` instances for `ProxyRequest` types, and test + round-tripping as much as possible + - Add `FromJSON` instance for `ProxyResponse`, and test + round-tripping as much as possible + +## `0.4.7` - 2021-04-12 + + - Drop http-conduit as a dependency for potentially smaller binaries + - Add more detailed error messages to context parsing failures + - Increase compatibility by loosening envy version bounds + - Add mRuntimeWithContext' and mRuntime + - Deprecate withIoInterface, withFallibleInterface, withPureInterface, HasLambdaContext, runRaderTLambdaContext, mRuntimeWithContext + +## `0.4.2` - 2020-07-23 + + - Fix an issue where errors from the runtime were not retried + +## `0.4.1` - 2020-01-22 + + - Constrain the envy version for correctly building with Cabal + - Fix documentation examples for Runtime and Combinators + +## `0.4.0` - 2020-01-22 + + - Add support for Value-based runtimes for handling JSON conversion errors explicitly + +## `0.3.1` - 2020-07-23 + + - Fix an issue where errors from the runtime were not retried + +## `0.3.0` - 2019-02-26 + + - Add support for triggered S3 events + +## `0.2.1` - 2020-07-23 + + - Fix an issue where errors from the runtime were not retried + +## `0.2.0` - 2019-02-07 + + - Expose `AWS.Lambda.Combinators` package for building other runtimes + (e.g. to support Lambda Event triggers) + +## `0.1.3` - 2020-07-23 + + - Fix an issue where errors from the runtime were not retried + +## `0.1.2` - 2019-01-10 + + - Fix PVP bounds when building/uploading the package + +## `0.1.1` - 2019-01-08 + +### Fixed + + - Incorrect error message when getting events from AWS + +## `0.1.0` - 2018-12-20 + +### Added + + - Initial release! + +[chg]: http://keepachangelog.com +[pvp]: http://pvp.haskell.org diff --git a/hal.cabal b/hal.cabal --- a/hal.cabal +++ b/hal.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: ac72c27a2329613830cbbdeaf5c590a17af49cb9f6987d444b538ded08a8d451 +-- hash: e76a8db81a6c7a721b849d1efca110b833ece7559f999740e5ac5c2d6cdd36e1 name: hal -version: 0.4.7 +version: 0.4.8 synopsis: A runtime environment for Haskell applications running on AWS Lambda. description: This library uniquely supports different types of AWS Lambda Handlers for your needs/comfort with advanced Haskell. Instead of exposing a single function @@ -23,6 +23,7 @@ build-type: Simple extra-source-files: README.md + CHANGELOG.md source-repository head type: git @@ -45,7 +46,25 @@ Paths_hal hs-source-dirs: src - default-extensions: OverloadedStrings BangPatterns DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DuplicateRecordFields EmptyCase GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms ScopedTypeVariables + default-extensions: + OverloadedStrings + BangPatterns + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DuplicateRecordFields + EmptyCase + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + PatternSynonyms + ScopedTypeVariables ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-partial-type-signatures -fno-warn-name-shadowing -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns build-depends: aeson @@ -58,6 +77,7 @@ , containers , envy , exceptions + , hashable , http-client , http-types , mtl @@ -70,18 +90,51 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen + AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen.Parameters + AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen.Resource + AWS.Lambda.Events.ApiGateway.ProxyResponse.Gen + Gen.Header Paths_hal hs-source-dirs: test - default-extensions: OverloadedStrings BangPatterns DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DuplicateRecordFields EmptyCase GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms ScopedTypeVariables + default-extensions: + OverloadedStrings + BangPatterns + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DuplicateRecordFields + EmptyCase + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + PatternSynonyms + ScopedTypeVariables ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-partial-type-signatures -fno-warn-name-shadowing -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base >=4.7 && <5 + , base64-bytestring + , bytestring + , case-insensitive , containers , hal + , hedgehog >=1.0.3 && <1.1 , hspec + , hspec-hedgehog , http-client - , http-types + , http-types >=0.12.2 && <0.13 + , scientific + , text , time + , transformers + , unordered-containers + , vector default-language: Haskell2010 diff --git a/src/AWS/Lambda/Events/ApiGateway/ProxyRequest.hs b/src/AWS/Lambda/Events/ApiGateway/ProxyRequest.hs --- a/src/AWS/Lambda/Events/ApiGateway/ProxyRequest.hs +++ b/src/AWS/Lambda/Events/ApiGateway/ProxyRequest.hs @@ -18,13 +18,16 @@ , StrictlyNoAuthorizer ) where -import Data.Aeson (FromJSON, Value, parseJSON, - withObject, (.:), (.:?)) -import Data.ByteString.Base64.Lazy (decodeLenient) +import Data.Aeson (FromJSON(..), ToJSON(..), + Value(..), object, withObject, + (.=), (.:), (.:?)) +import Data.ByteString.Base64.Lazy (decodeLenient, encode) import Data.ByteString.Lazy (ByteString) -import Data.CaseInsensitive (CI, mk) +import Data.CaseInsensitive (CI, FoldCase, mk, original) import Data.Foldable (fold) +import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap, foldrWithKey, insert) +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE @@ -52,9 +55,10 @@ , apiKeyId :: Maybe Text , userAgent :: Maybe Text , user :: Maybe Text - } deriving (Generic) + } deriving (Eq, Generic, Show) instance FromJSON Identity +instance ToJSON Identity data RequestContext a = RequestContext { path :: Text @@ -70,7 +74,7 @@ , httpMethod :: Text , extendedRequestId :: Maybe Text , apiId :: Text - } + } deriving (Eq, Generic, Show) instance FromJSON a => FromJSON (RequestContext a) where parseJSON = withObject "ProxyRequest" $ \v -> @@ -87,6 +91,24 @@ v .:? "extendedRequestId" <*> v .: "apiId" +-- | @since 0.4.8 +instance ToJSON a => ToJSON (RequestContext a) where + toJSON r = object $ catMaybes + [ Just $ "path" .= path (r :: RequestContext a) + , Just $ "accountId" .= accountId (r :: RequestContext a) + , ("authorizer" .=) <$> authorizer r + , Just $ "resourceId" .= resourceId r + , Just $ "stage" .= stage r + , ("domainPrefix" .=) <$> domainPrefix r + , Just $ "requestId" .= requestId r + , Just $ "identity" .= identity r + , ("domainName" .=) <$> domainName r + , Just $ "resourcePath" .= resourcePath r + , Just $ "httpMethod" .= httpMethod (r :: RequestContext a) + , ("extendedRequestId" .=) <$> extendedRequestId r + , Just $ "apiId" .= apiId r + ] + -- TODO: Should also include websocket fields -- | This type is for representing events that come from API Gateway via the -- Lambda Proxy integration (forwarding HTTP data directly, rather than a @@ -141,17 +163,23 @@ , queryStringParameters :: HashMap Text Text , multiValueQueryStringParameters :: HashMap Text [Text] , body :: ByteString - } deriving (Generic) + } deriving (Eq, Generic, Show) -toCIHashMap :: HashMap Text a -> HashMap (CI Text) a +toCIHashMap :: (Eq k, FoldCase k, Hashable k) => HashMap k a -> HashMap (CI k) a toCIHashMap = foldrWithKey (insert . mk) mempty +fromCIHashMap :: (Eq k, Hashable k) => HashMap (CI k) a -> HashMap k a +fromCIHashMap = foldrWithKey (insert . original) mempty + toByteString :: Bool -> TL.Text -> ByteString toByteString isBase64Encoded = if isBase64Encoded then decodeLenient . TLE.encodeUtf8 else TLE.encodeUtf8 +toMaybe :: Bool -> a -> Maybe a +toMaybe b a = if b then Just a else Nothing + -- | For ignoring API Gateway custom authorizer values type NoAuthorizer = Value @@ -172,3 +200,27 @@ (v .:? "queryStringParameters" <&> fold) <*> (v .:? "multiValueQueryStringParameters" <&> fold) <*> (toByteString <$> v .: "isBase64Encoded" <*> (v .:? "body" <&> fold)) + +-- | @since 0.4.8 +instance ToJSON a => ToJSON (ProxyRequest a) where + toJSON r = object $ catMaybes + [ Just $ "path" .= path (r :: ProxyRequest a) + , toMaybe (not . null $ headers r) $ + "headers" .= fromCIHashMap (headers r) + , toMaybe (not . null $ multiValueHeaders r) $ + "multiValueHeaders" .= fromCIHashMap (multiValueHeaders r) + , toMaybe (not . null $ pathParameters r) $ + "pathParameters" .= pathParameters r + , toMaybe (not . null $ stageVariables r) $ + "stageVariables" .= stageVariables r + , Just $ "requestContext" .= requestContext r + , Just $ "resource" .= resource r + , Just $ "httpMethod" .= httpMethod (r :: ProxyRequest a) + , toMaybe (not . null $ queryStringParameters r) $ + "queryStringParameters" .= queryStringParameters r + , toMaybe (not . null $ multiValueQueryStringParameters r) $ + "multiValueQueryStringParameters" .= + multiValueQueryStringParameters r + , Just $ "isBase64Encoded" .= True + , Just $ "body" .= TLE.decodeUtf8 (encode (body r)) + ] diff --git a/src/AWS/Lambda/Events/ApiGateway/ProxyResponse.hs b/src/AWS/Lambda/Events/ApiGateway/ProxyResponse.hs --- a/src/AWS/Lambda/Events/ApiGateway/ProxyResponse.hs +++ b/src/AWS/Lambda/Events/ApiGateway/ProxyResponse.hs @@ -24,18 +24,23 @@ , module Network.HTTP.Types.Status ) where -import Data.Aeson (ToJSON, encode, object, toJSON, - (.=)) +import Data.Aeson (FromJSON(..), ToJSON, encode, + object, toJSON, withObject, (.:), + (.:?), (.=)) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 -import Data.CaseInsensitive (CI, mk, original) -import Data.HashMap.Strict (HashMap, foldrWithKey, insert, - insertWith) +import Data.CaseInsensitive (CI, FoldCase, mk, original) +import qualified Data.CaseInsensitive as CI +import Data.Foldable (fold) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H import Data.Semigroup ((<>)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE +import Network.HTTP.Types.Header (hContentType) import Network.HTTP.Types.Status (Status (..), accepted202, badGateway502, badRequest400, conflict409, continue100, @@ -88,7 +93,15 @@ unprocessableEntity422, unsupportedMediaType415, upgradeRequired426, useProxy305) +import GHC.Generics (Generic (..)) +-- This function is available in Data.Functor as of base 4.11, but we define it +-- here for compatibility. +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) x f = f <$> x + +infixl 1 <&> + -- | Type that represents the body returned to an API Gateway when using HTTP -- Lambda Proxy integration. It is highly recommended that you do not use this -- type directly, and instead use the smart constructors exposed such as @@ -98,7 +111,7 @@ { contentType :: T.Text , serialized :: T.Text , isBase64Encoded :: Bool - } deriving (Show) + } deriving (Eq, Generic, Show) -- | A response returned to an API Gateway when using the HTTP Lambda Proxy -- integration. ContentType will be set based on the ProxyBody (recommended) @@ -141,8 +154,11 @@ { status :: Status , multiValueHeaders :: HashMap (CI T.Text) [T.Text] , body :: ProxyBody - } deriving (Show) + } deriving (Eq, Generic, Show) +toCIHashMap :: (Eq k, FoldCase k, Hashable k) => HashMap k a -> HashMap (CI k) a +toCIHashMap = H.foldrWithKey (H.insert . mk) mempty + -- | Smart constructor for creating a ProxyResponse from a status and a body response :: Status -> ProxyBody -> ProxyResponse response = @@ -154,13 +170,13 @@ -- previous headers or their values. addHeader :: T.Text -> T.Text -> ProxyResponse -> ProxyResponse addHeader header value (ProxyResponse s mvh b) = - ProxyResponse s (insertWith (<>) (mk header) [value] mvh) b + ProxyResponse s (H.insertWith (<>) (mk header) [value] mvh) b -- | Set a header to the ProxyResponse. If there were any previous values for -- this header they are __all replaced__ by this new value. setHeader :: T.Text -> T.Text -> ProxyResponse -> ProxyResponse setHeader header value (ProxyResponse s mvh b) = - ProxyResponse s (insert (mk header) [value] mvh) b + ProxyResponse s (H.insert (mk header) [value] mvh) b -- | Smart constructor for creating a ProxyBody with an arbitrary ByteString of -- the chosen content type. Use this smart constructor to avoid invalid JSON @@ -191,16 +207,13 @@ (TL.toStrict $ TLE.decodeUtf8 $ encode x) False --- | Smart constructor for creating a simple body of a GIF (that has already --- been converted to a ByteString). - instance ToJSON ProxyResponse where toJSON (ProxyResponse status mvh (ProxyBody contentType body isBase64Encoded)) = - let unCI = foldrWithKey (insert . original) mempty + let unCI = H.foldrWithKey (H.insert . original) mempty in object [ "statusCode" .= statusCode status , "multiValueHeaders" .= - insertWith + H.insertWith (\_ old -> old) ("Content-Type" :: T.Text) [contentType] @@ -208,3 +221,20 @@ , "body" .= body , "isBase64Encoded" .= isBase64Encoded ] + +-- | @since 0.4.8 +instance FromJSON ProxyResponse where + parseJSON = withObject "ProxyResponse" $ \v -> do + headers <- v .:? "multiValueHeaders" <&> toCIHashMap . fold + -- Move the "Content-Type" header into the ProxyBody. This is + -- necessary to ensure round-tripping. + let contentTypeHeader = CI.map TE.decodeUtf8 hContentType + contentType = case H.lookup contentTypeHeader headers of + Just (h:_) -> h + _ -> "application/octet-stream" + headers' = H.delete contentTypeHeader headers + status <- v .: "statusCode" <&> toEnum + proxyBody <- ProxyBody contentType + <$> v .: "body" + <*> v .: "isBase64Encoded" + pure $ ProxyResponse status headers' proxyBody diff --git a/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen.hs b/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen.hs new file mode 100644 --- /dev/null +++ b/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen.hs @@ -0,0 +1,113 @@ +module AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen where + +import qualified AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen.Resource as Resource +import qualified AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen.Parameters as Parameters +import AWS.Lambda.Events.ApiGateway.ProxyRequest +import Control.Applicative (liftA2) +import Data.Aeson (Value(..)) +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as H +import Data.Scientific (fromFloatDigits) +import qualified Data.Vector as V +import qualified Gen.Header as Header +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Network.HTTP.Types (renderStdMethod) +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +proxyRequest :: Gen (ProxyRequest NoAuthorizer) +proxyRequest = do + segments <- Resource.segments + pathParameters <- Resource.vars segments + let path = Resource.path pathParameters segments + resource = Resource.resource segments + multiValueHeaders <- Header.multiValueHeaders + let headers = head <$> multiValueHeaders + stageVariables <- fmap head <$> Parameters.multiParameters + httpMethod <- method + requestContext <- context path resource httpMethod + multiValueQueryStringParameters <- Parameters.multiParameters + let queryStringParameters = head <$> multiValueQueryStringParameters + body <- BL.fromStrict <$> Gen.bytes (Range.exponential 1 1000) + pure $ ProxyRequest + { path = path + , headers = headers + , multiValueHeaders = multiValueHeaders + , pathParameters = pathParameters + , stageVariables = stageVariables + , requestContext = requestContext + , resource = resource + , httpMethod = httpMethod + , queryStringParameters = queryStringParameters + , multiValueQueryStringParameters = multiValueQueryStringParameters + , body = body + } + +method :: Gen Text +method = TE.decodeUtf8 . renderStdMethod <$> Gen.enumBounded + +context :: Text -> Text -> Text -> Gen (RequestContext NoAuthorizer) +context path resourcePath httpMethod = do + accountId <- Gen.text (Range.singleton 12) Gen.digit + authorizer <- Gen.maybe authJson + resourceId <- text + stage <- text + domainPrefix <- Gen.maybe $ Gen.text (Range.linear 1 15) Gen.alphaNum + requestId <- text + identity <- ident + domainName <- Gen.maybe text + extendedRequestId <- Gen.maybe text + apiId <- text + pure $ RequestContext + { path = path + , accountId = accountId + , authorizer = authorizer + , resourceId = resourceId + , stage = stage + , domainPrefix = domainPrefix + , requestId = requestId + , identity = identity + , domainName = domainName + , resourcePath = resourcePath + , httpMethod = httpMethod + , extendedRequestId = extendedRequestId + , apiId = apiId + } + +ident :: Gen Identity +ident = Identity + <$> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + <*> text + <*> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + <*> Gen.maybe text + +text :: Gen Text +text = Gen.text (Range.linear 1 15) Gen.unicode + +-- | Generate JSON for an authorizer blob. +-- +-- __NOTE:__ We do not generate @null@s, because they kill +-- round-tripping: '.:?' deserializes both @null@ and missing keys to +-- @Nothing@. +authJson :: Gen Value +authJson = Gen.recursive Gen.choice + [string, number, Bool <$> Gen.bool] + [object, array] + where + object = Object . H.fromList <$> Gen.list (Range.linear 1 50) entry + entry = liftA2 (,) text authJson + array = Array . V.fromList <$> Gen.list (Range.linear 1 50) authJson + string = String <$> Gen.text (Range.exponential 1 200) Gen.unicode + number = Number . fromFloatDigits <$> + Gen.double (Range.exponentialFloatFrom 0 (-10**23) (10**23)) diff --git a/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen/Parameters.hs b/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen/Parameters.hs new file mode 100644 --- /dev/null +++ b/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen/Parameters.hs @@ -0,0 +1,39 @@ +module AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen.Parameters where + +import Control.Monad.Trans.State +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H +import Data.Semigroup ((<>)) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +multiParameters :: Gen (HashMap Text [Text]) +multiParameters = H.fromListWith (<>) <$> + evalStateT (Gen.list (Range.linear 1 10) parameter) S.empty + +parameter :: StateT (Set Text) Gen (Text, [Text]) +parameter = Gen.choice [fresh, clash] where + fresh = do + vars <- get + newVar <- Gen.filterT (not . (`S.member` vars)) var + put $ S.insert newVar vars + v <- val + pure (newVar, [v]) + clash = do + vars <- get + if null vars + then fresh + else do + var <- Gen.element $ S.toList vars + v <- val + pure (var, [v]) + +var :: MonadGen g => g Text +var = Gen.text (Range.linear 1 10) Gen.alpha + +val :: MonadGen g => g Text +val = Gen.text (Range.linear 1 15) Gen.unicode diff --git a/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen/Resource.hs b/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen/Resource.hs new file mode 100644 --- /dev/null +++ b/test/AWS/Lambda/Events/ApiGateway/ProxyRequest/Gen/Resource.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE LambdaCase #-} + +module AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen.Resource where + +import Control.Monad (foldM) +import Control.Monad.Trans.State (StateT, evalStateT, get, put) +import Data.Foldable (toList) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Semigroup ((<>)) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +data ResourceSegment = Literal Text | Variable Text deriving (Eq, Show) + +segments :: Gen (NonEmpty ResourceSegment) +segments = flip evalStateT S.empty + . fmap NE.fromList + . Gen.list (Range.linear 1 10) + $ Gen.choice + [ Literal <$> Gen.text (Range.linear 1 10) Gen.alpha + , Variable <$> var + ] + +-- | Generate a variable mapping for a resource path. +vars :: Foldable t => t ResourceSegment -> Gen (HashMap Text Text) +vars = foldM addVar H.empty + where + addVar m = \case + Literal{} -> pure m + Variable v -> do + value <- Gen.text (Range.linear 1 20) Gen.unicode + pure $ H.insert v value m + +-- | Instantiate vars in a resource path. +path :: HashMap Text Text -> NonEmpty ResourceSegment -> Text +path vars = ("/" <>) . T.intercalate "/" . toList . fmap toText + where + toText = \case + Literal t -> t + Variable v -> vars H.! v + +-- | Render a resource path with @{var}@ to indicate variables +resource :: NonEmpty ResourceSegment -> Text +resource = ("/" <>) . T.intercalate "/" . toList . fmap toText + where + toText = \case + Literal t -> t + Variable v -> "{" <> v <> "}" + +-- | Generate one variable name for a resource path, and don't reuse +-- variable names. +var :: StateT (S.Set Text) Gen Text +var = do + vars <- get + newVar <- Gen.filterT (not . (`S.member` vars)) $ + Gen.text (Range.linear 1 10) Gen.alpha + put $ S.insert newVar vars + pure newVar diff --git a/test/AWS/Lambda/Events/ApiGateway/ProxyResponse/Gen.hs b/test/AWS/Lambda/Events/ApiGateway/ProxyResponse/Gen.hs new file mode 100644 --- /dev/null +++ b/test/AWS/Lambda/Events/ApiGateway/ProxyResponse/Gen.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TupleSections #-} + +module AWS.Lambda.Events.ApiGateway.ProxyResponse.Gen where + +import AWS.Lambda.Events.ApiGateway.ProxyResponse +import qualified Data.ByteString.Base64 as B64 +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.HashMap.Strict (HashMap) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import qualified Gen.Header as Header +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Network.HTTP.Types (hContentType) + +proxyResponse :: Gen ProxyResponse +proxyResponse = ProxyResponse + <$> responseStatus + <*> responseHeaders + <*> responseBody + +responseStatus :: Gen Status +responseStatus = Gen.element + [ continue100 + , switchingProtocols101 + , ok200 + , created201 + , accepted202 + , nonAuthoritative203 + , noContent204 + , resetContent205 + , partialContent206 + , multipleChoices300 + , movedPermanently301 + , found302 + , seeOther303 + , notModified304 + , useProxy305 + , temporaryRedirect307 + , permanentRedirect308 + , badRequest400 + , unauthorized401 + , paymentRequired402 + , forbidden403 + , notFound404 + , methodNotAllowed405 + , notAcceptable406 + , proxyAuthenticationRequired407 + , requestTimeout408 + , conflict409 + , gone410 + , lengthRequired411 + , preconditionFailed412 + , requestEntityTooLarge413 + , requestURITooLong414 + , unsupportedMediaType415 + , requestedRangeNotSatisfiable416 + , expectationFailed417 + , imATeapot418 + , unprocessableEntity422 + , upgradeRequired426 + , preconditionRequired428 + , tooManyRequests429 + , requestHeaderFieldsTooLarge431 + , internalServerError500 + , notImplemented501 + , badGateway502 + , serviceUnavailable503 + , gatewayTimeout504 + , httpVersionNotSupported505 + , networkAuthenticationRequired511 + ] + +-- | Do not generate @Content-Type@ headers, as they will break +-- round-tripping: the 'ToJSON' instance for 'ProxyResponse' drops the +-- 'contentType' of the 'ProxyBody' if such a header is present. +responseHeaders :: Gen (HashMap (CI Text) [Text]) +responseHeaders = Header.multiValueHeadersExcept + . S.singleton + $ CI.map TE.decodeUtf8 hContentType + +responseBody :: Gen ProxyBody +responseBody = do + contentType <- Gen.text (Range.linear 1 20) Gen.latin1 + (serialized, isBase64Encoded) <- Gen.choice + [ (, False) <$> Gen.text (Range.exponential 1 2000) Gen.unicode + , (, True) . TE.decodeUtf8 . B64.encode <$> + Gen.bytes (Range.exponential 1 2000) + ] + pure $ ProxyBody contentType serialized isBase64Encoded diff --git a/test/Gen/Header.hs b/test/Gen/Header.hs new file mode 100644 --- /dev/null +++ b/test/Gen/Header.hs @@ -0,0 +1,123 @@ +module Gen.Header where + +import Control.Monad.Trans.State +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Char (toUpper, toLower) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H +import Data.Semigroup ((<>)) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Traversable (for) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Network.HTTP.Types.Header + +multiValueHeaders :: Gen (HashMap (CI Text) [Text]) +multiValueHeaders = multiValueHeadersExcept S.empty + +multiValueHeadersExcept :: Set (CI Text) -> Gen (HashMap (CI Text) [Text]) +multiValueHeadersExcept exclusions = H.fromListWith (<>) <$> + evalStateT + (Gen.list (Range.linear 1 30) $ singleHeaderExcept exclusions) + S.empty + +singleHeaderExcept :: Set (CI Text) -> StateT (Set (CI Text)) Gen (CI Text, [Text]) +singleHeaderExcept exclusions = Gen.choice [fresh, clash] where + fresh = do + headers <- get + newHeader <- Gen.filterT + (\h -> not $ S.member h headers || S.member h exclusions) + header + put $ S.insert newHeader headers + headerVal <- val + pure (newHeader, [headerVal]) + clash = do + headers <- get + if null headers + then fresh + else do + header <- Gen.filterT + (\h -> not $ S.member h exclusions) + (Gen.element (S.toList headers)) + >>= unfoldCase + headerVal <- val + pure (header, [headerVal]) + +header :: MonadGen g => g (CI Text) +header = Gen.choice + [ CI.mk <$> Gen.text (Range.linear 1 15) Gen.alpha + , standardHeader + ] + +standardHeader :: MonadGen g => g (CI Text) +standardHeader = CI.map TE.decodeUtf8 <$> Gen.element + [ hAccept + , hAcceptCharset + , hAcceptEncoding + , hAcceptLanguage + , hAcceptRanges + , hAge + , hAllow + , hAuthorization + , hCacheControl + , hConnection + , hContentEncoding + , hContentLanguage + , hContentLength + , hContentLocation + , hContentMD5 + , hContentRange + , hContentType + , hDate + , hETag + , hExpect + , hExpires + , hFrom + , hHost + , hIfMatch + , hIfModifiedSince + , hIfNoneMatch + , hIfRange + , hIfUnmodifiedSince + , hLastModified + , hLocation + , hMaxForwards + , hOrigin + , hPragma + , hPrefer + , hPreferenceApplied + , hProxyAuthenticate + , hProxyAuthorization + , hRange + , hReferer + , hRetryAfter + , hServer + , hTE + , hTrailer + , hTransferEncoding + , hUpgrade + , hUserAgent + , hVary + , hVia + , hWWWAuthenticate + , hWarning + , hContentDisposition + , hMIMEVersion + , hCookie + , hSetCookie + ] + +-- | Create some permutation of the input text, that compares as equal +-- under 'CI'. +unfoldCase :: MonadGen g => CI Text -> g (CI Text) +unfoldCase t = CI.mk . T.pack <$> for (T.unpack $ CI.original t) flipCase + where flipCase c = Gen.element [toUpper c, toLower c] + +val :: MonadGen g => g Text +val = Gen.text (Range.linear 1 15) Gen.unicode diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,16 +2,24 @@ ClientContext (..), CognitoIdentity (..), LambdaContext (..)) +import qualified Gen.Header as Header +import qualified AWS.Lambda.Events.ApiGateway.ProxyRequest.Gen as ProxyRequest +import qualified AWS.Lambda.Events.ApiGateway.ProxyResponse.Gen as ProxyResponse import AWS.Lambda.Internal (StaticContext (..)) import AWS.Lambda.RuntimeClient.Internal (eventResponseToNextData) -import Data.Aeson (Value (Null)) +import Data.Aeson (Value (Null), decode, encode) +import qualified Data.CaseInsensitive as CI import Data.Map (singleton) import Data.Semigroup ((<>)) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Network.HTTP.Client.Internal (Response (..)) import Network.HTTP.Types (Header) import Test.Hspec (describe, it, shouldBe, - shouldStartWith) + shouldStartWith, specify) +import Test.Hspec.Hedgehog (hedgehog) import Test.Hspec.Runner (hspec) main :: IO () @@ -198,6 +206,25 @@ context `shouldBe` (Left "Runtime Error: Unable to decode Context from event response.\nCould not parse deadline") + + describe "properties" $ do + specify "Header.unfoldCase preserves equality" $ + hedgehog $ do + -- CI only promises equality over the Latin-1 set + s <- forAll $ CI.mk <$> Gen.text (Range.linear 1 100) Gen.latin1 + t <- forAll $ Header.unfoldCase s + s === t + + specify "ProxyRequest tripping" $ + hedgehog $ do + request <- forAll ProxyRequest.proxyRequest + tripping request encode decode + + specify "ProxyResponse tripping" $ + hedgehog $ do + request <- forAll ProxyResponse.proxyResponse + tripping request encode decode + minResponse :: [Header] -> a -> Response a minResponse headers body =