diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,201 @@ +## OpenAPI Auto-Generated [http-client](https://www.stackage.org/lts-10.0/package/http-client-0.5.7.1) Bindings to `AWS Lambda Runtime API` + +The library in `lib` provides auto-generated-from-OpenAPI [http-client](https://www.stackage.org/lts-10.0/package/http-client-0.5.7.1) bindings to the AWS Lambda Runtime API API. + +OpenApi Version: 3.0.0 + +## Installation + +Installation follows the standard approach to installing Stack-based projects. + +1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README). +2. To build the package, and generate the documentation (recommended): +``` +stack haddock +``` +which will generate docs for this lib in the `docs` folder. + +To generate the docs in the normal location (to enable hyperlinks to external libs), remove +``` +build: + haddock-arguments: + haddock-args: + - "--odir=./docs" +``` +from the stack.yaml file and run `stack haddock` again. + +3. To run unit tests: +``` +stack test +``` + +## OpenAPI-Generator + +The code generator that produced this library, and which explains how +to obtain and use the openapi-generator cli tool lives at + +https://openapi-generator.tech + +The _generator-name_ argument (`--generator-name`) passed to the cli tool used should be + +``` +haskell-http-client +``` + +### Unsupported OpenAPI Features + +* Model Inheritance + +This is beta software; other cases may not be supported. + +### Codegen "additional properties" parameters + +These options allow some customization of the code generation process. + +**haskell-http-client additional properties:** + +| OPTION | DESCRIPTION | DEFAULT | ACTUAL | +| ------------------------------- | ----------------------------------------------------------------------------------------------------------------------------- | -------- | ------------------------------------- | +| allowFromJsonNulls | allow JSON Null during model decoding from JSON | true | true | +| allowNonUniqueOperationIds | allow *different* API modules to contain the same operationId. Each API must be imported qualified | false | false | +| allowToJsonNulls | allow emitting JSON Null during model encoding to JSON | false | false | +| baseModule | Set the base module namespace | | AWSLambdaRuntime | +| cabalPackage | Set the cabal package name, which consists of one or more alphanumeric words separated by hyphens | | aws-lambda-runtime | +| cabalVersion | Set the cabal version number, consisting of a sequence of one or more integers separated by dots | 0.1.0.0 | 0.1.0.0 | +| customTestInstanceModule | test module used to provide typeclass instances for types not known by the generator | | | +| configType | Set the name of the type used for configuration | | AWSLambdaRuntimeConfig | +| dateFormat | format string used to parse/render a date | %Y-%m-%d | %Y-%m-%d | +| dateTimeFormat | format string used to parse/render a datetime. (Defaults to [formatISO8601Millis][1] when not provided) | | | +| generateEnums | Generate specific datatypes for OpenAPI enums | true | true | +| generateFormUrlEncodedInstances | Generate FromForm/ToForm instances for models used by x-www-form-urlencoded operations (model fields must be primitive types) | true | true | +| generateLenses | Generate Lens optics for Models | true | true | +| generateModelConstructors | Generate smart constructors (only supply required fields) for models | true | true | +| inlineMimeTypes | Inline (hardcode) the content-type and accept parameters on operations, when there is only 1 option | true | true | +| modelDeriving | Additional classes to include in the deriving() clause of Models | | | +| requestType | Set the name of the type used to generate requests | | AWSLambdaRuntimeRequest | +| strictFields | Add strictness annotations to all model fields | true | true | +| useKatip | Sets the default value for the UseKatip cabal flag. If true, the katip package provides logging instead of monad-logger | true | true | + +[1]: https://www.stackage.org/haddock/lts-9.0/iso8601-time-0.1.4/Data-Time-ISO8601.html#v:formatISO8601Millis + +An example setting _strictFields_ and _dateTimeFormat_: + +``` +java -jar openapi-generator-cli.jar generate -i petstore.yaml -g haskell-http-client -o output/haskell-http-client -DstrictFields=true -DdateTimeFormat="%Y-%m-%dT%H:%M:%S%Q%z" +``` + +View the full list of Codegen "config option" parameters with the command: + +``` +java -jar openapi-generator-cli.jar config-help -g haskell-http-client +``` + +## Usage Notes + +### Example Petstore Haddock documentation + +An example of the generated haddock documentation targeting the server http://petstore.swagger.io/ (Petstore) can be found [here][2] + +[2]: https://hackage.haskell.org/package/swagger-petstore + +### Example Petstore App + +An example application using the auto-generated haskell-http-client bindings for the server http://petstore.swagger.io/ can be found [here][3] + +[3]: https://github.com/openapitools/openapi-generator/tree/master/samples/client/petstore/haskell-http-client/example-app + +This library is intended to be imported qualified. + +### Modules + +| MODULE | NOTES | +| ------------------- | --------------------------------------------------- | +| AWSLambdaRuntime.Client | use the "dispatch" functions to send requests | +| AWSLambdaRuntime.Core | core funcions, config and request types | +| AWSLambdaRuntime.API | construct api requests | +| AWSLambdaRuntime.Model | describes api models | +| AWSLambdaRuntime.MimeTypes | encoding/decoding MIME types (content-types/accept) | +| AWSLambdaRuntime.ModelLens | lenses for model fields | +| AWSLambdaRuntime.Logging | logging functions and utils | + + +### MimeTypes + +This library adds type safety around what OpenAPI specifies as +Produces and Consumes for each Operation (e.g. the list of MIME types an +Operation can Produce (using 'accept' headers) and Consume (using 'content-type' headers). + +For example, if there is an Operation named _addFoo_, there will be a +data type generated named _AddFoo_ (note the capitalization), which +describes additional constraints and actions on the _addFoo_ operation +via its typeclass instances. These typeclass instances can be viewed +in GHCi or via the Haddocks. + +* required parameters are included as function arguments to _addFoo_ +* optional non-body parameters are included by using `applyOptionalParam` +* optional body parameters are set by using `setBodyParam` + +Example code generated for pretend _addFoo_ operation: + +```haskell +data AddFoo +instance Consumes AddFoo MimeJSON +instance Produces AddFoo MimeJSON +instance Produces AddFoo MimeXML +instance HasBodyParam AddFoo FooModel +instance HasOptionalParam AddFoo FooName +instance HasOptionalParam AddFoo FooId +``` + +this would indicate that: + +* the _addFoo_ operation can consume JSON +* the _addFoo_ operation produces JSON or XML, depending on the argument passed to the dispatch function +* the _addFoo_ operation can set it's body param of _FooModel_ via `setBodyParam` +* the _addFoo_ operation can set 2 different optional parameters via `applyOptionalParam` + +If the OpenAPI spec doesn't declare it can accept or produce a certain +MIME type for a given Operation, you should either add a Produces or +Consumes instance for the desired MIME types (assuming the server +supports it), use `dispatchLbsUnsafe` or modify the OpenAPI spec and +run the generator again. + +New MIME type instances can be added via MimeType/MimeRender/MimeUnrender + +Only JSON instances are generated by default, and in some case +x-www-form-urlencoded instances (FromFrom, ToForm) will also be +generated if the model fields are primitive types, and there are +Operations using x-www-form-urlencoded which use those models. + +### Authentication + +A haskell data type will be generated for each OpenAPI authentication type. + +If for example the AuthMethod `AuthOAuthFoo` is generated for OAuth operations, then +`addAuthMethod` should be used to add the AuthMethod config. + +When a request is dispatched, if a matching auth method is found in +the config, it will be applied to the request. + +### Example + +```haskell +mgr <- newManager defaultManagerSettings +config0 <- withStdoutLogging =<< newConfig +let config = config0 + `addAuthMethod` AuthOAuthFoo "secret-key" + +let addFooRequest = + addFoo + (ContentType MimeJSON) + (Accept MimeXML) + (ParamBar paramBar) + (ParamQux paramQux) + modelBaz + `applyOptionalParam` FooId 1 + `applyOptionalParam` FooName "name" + `setHeader` [("qux_header","xxyy")] +addFooResult <- dispatchMime mgr config addFooRequest +``` + +See the example app and the haddocks for details. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/AWSLambdaRuntime.hs b/lib/AWSLambdaRuntime.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime.hs @@ -0,0 +1,31 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime +-} + +module AWSLambdaRuntime + ( module AWSLambdaRuntime.API + , module AWSLambdaRuntime.Client + , module AWSLambdaRuntime.Core + , module AWSLambdaRuntime.Logging + , module AWSLambdaRuntime.MimeTypes + , module AWSLambdaRuntime.Model + , module AWSLambdaRuntime.ModelLens + ) where + +import AWSLambdaRuntime.API +import AWSLambdaRuntime.Client +import AWSLambdaRuntime.Core +import AWSLambdaRuntime.Logging +import AWSLambdaRuntime.MimeTypes +import AWSLambdaRuntime.Model +import AWSLambdaRuntime.ModelLens diff --git a/lib/AWSLambdaRuntime/API.hs b/lib/AWSLambdaRuntime/API.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/API.hs @@ -0,0 +1,19 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.API +-} + +module AWSLambdaRuntime.API + ( module AWSLambdaRuntime.API.ApiDefault + ) where + +import AWSLambdaRuntime.API.ApiDefault diff --git a/lib/AWSLambdaRuntime/API/ApiDefault.hs b/lib/AWSLambdaRuntime/API/ApiDefault.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/API/ApiDefault.hs @@ -0,0 +1,151 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.API.ApiDefault +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module AWSLambdaRuntime.API.ApiDefault where + +import AWSLambdaRuntime.Core +import AWSLambdaRuntime.MimeTypes +import AWSLambdaRuntime.Model as M + +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Data as P (Typeable, TypeRep, typeOf, typeRep) +import qualified Data.Foldable as P +import qualified Data.Map as Map +import qualified Data.Maybe as P +import qualified Data.Proxy as P (Proxy(..)) +import qualified Data.Set as Set +import qualified Data.String as P +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Time as TI +import qualified Network.HTTP.Client.MultipartFormData as NH +import qualified Network.HTTP.Media as ME +import qualified Network.HTTP.Types as NH +import qualified Web.FormUrlEncoded as WH +import qualified Web.HttpApiData as WH + +import Data.Text (Text) +import GHC.Base ((<|>)) + +import Prelude ((==),(/=),($), (.),(<$>),(<*>),(>>=),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor) +import qualified Prelude as P + +-- * Operations + + +-- ** Default + +-- *** runtimeInitErrorPost + +-- | @POST \/runtime\/init\/error@ +-- +-- Non-recoverable initialization error. Runtime should exit after reporting the error. Error will be served in response to the first invoke. +-- +runtimeInitErrorPost + :: (Consumes RuntimeInitErrorPost contentType) + => ContentType contentType -- ^ request content-type ('MimeType') + -> AWSLambdaRuntimeRequest RuntimeInitErrorPost contentType StatusResponse MimeJSON +runtimeInitErrorPost _ = + _mkRequest "POST" ["/runtime/init/error"] + +data RuntimeInitErrorPost +instance HasBodyParam RuntimeInitErrorPost Body +instance HasOptionalParam RuntimeInitErrorPost LambdaRuntimeFunctionErrorType where + applyOptionalParam req (LambdaRuntimeFunctionErrorType xs) = + req `setHeader` toHeader ("Lambda-Runtime-Function-Error-Type", xs) + +-- | @*/*@ +instance MimeType mtype => Consumes RuntimeInitErrorPost mtype + +-- | @application/json@ +instance Produces RuntimeInitErrorPost MimeJSON + + +-- *** runtimeInvocationAwsRequestIdErrorPost + +-- | @POST \/runtime\/invocation\/{AwsRequestId}\/error@ +-- +-- Runtime makes this request in order to submit an error response. It can be either a function error, or a runtime error. Error will be served in response to the invoke. +-- +runtimeInvocationAwsRequestIdErrorPost + :: (Consumes RuntimeInvocationAwsRequestIdErrorPost contentType) + => ContentType contentType -- ^ request content-type ('MimeType') + -> AwsRequestId -- ^ "awsRequestId" + -> AWSLambdaRuntimeRequest RuntimeInvocationAwsRequestIdErrorPost contentType StatusResponse MimeJSON +runtimeInvocationAwsRequestIdErrorPost _ (AwsRequestId awsRequestId) = + _mkRequest "POST" ["/runtime/invocation/",toPath awsRequestId,"/error"] + +data RuntimeInvocationAwsRequestIdErrorPost +instance HasBodyParam RuntimeInvocationAwsRequestIdErrorPost Body +instance HasOptionalParam RuntimeInvocationAwsRequestIdErrorPost LambdaRuntimeFunctionErrorType where + applyOptionalParam req (LambdaRuntimeFunctionErrorType xs) = + req `setHeader` toHeader ("Lambda-Runtime-Function-Error-Type", xs) + +-- | @*/*@ +instance MimeType mtype => Consumes RuntimeInvocationAwsRequestIdErrorPost mtype + +-- | @application/json@ +instance Produces RuntimeInvocationAwsRequestIdErrorPost MimeJSON + + +-- *** runtimeInvocationAwsRequestIdResponsePost + +-- | @POST \/runtime\/invocation\/{AwsRequestId}\/response@ +-- +-- Runtime makes this request in order to submit a response. +-- +runtimeInvocationAwsRequestIdResponsePost + :: (Consumes RuntimeInvocationAwsRequestIdResponsePost contentType) + => ContentType contentType -- ^ request content-type ('MimeType') + -> AwsRequestId -- ^ "awsRequestId" + -> AWSLambdaRuntimeRequest RuntimeInvocationAwsRequestIdResponsePost contentType StatusResponse MimeJSON +runtimeInvocationAwsRequestIdResponsePost _ (AwsRequestId awsRequestId) = + _mkRequest "POST" ["/runtime/invocation/",toPath awsRequestId,"/response"] + +data RuntimeInvocationAwsRequestIdResponsePost +instance HasBodyParam RuntimeInvocationAwsRequestIdResponsePost Body + +-- | @*/*@ +instance MimeType mtype => Consumes RuntimeInvocationAwsRequestIdResponsePost mtype + +-- | @application/json@ +instance Produces RuntimeInvocationAwsRequestIdResponsePost MimeJSON + + +-- *** runtimeInvocationNextGet + +-- | @GET \/runtime\/invocation\/next@ +-- +-- Runtime makes this HTTP request when it is ready to receive and process a new invoke. +-- +runtimeInvocationNextGet + :: AWSLambdaRuntimeRequest RuntimeInvocationNextGet MimeNoContent A.Value MimeJSON +runtimeInvocationNextGet = + _mkRequest "GET" ["/runtime/invocation/next"] + +data RuntimeInvocationNextGet +-- | @application/json@ +instance Produces RuntimeInvocationNextGet MimeJSON + diff --git a/lib/AWSLambdaRuntime/Client.hs b/lib/AWSLambdaRuntime/Client.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/Client.hs @@ -0,0 +1,217 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.Client +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module AWSLambdaRuntime.Client where + +import AWSLambdaRuntime.Core +import AWSLambdaRuntime.Logging +import AWSLambdaRuntime.MimeTypes + +import qualified Control.Exception.Safe as E +import qualified Control.Monad.IO.Class as P +import qualified Control.Monad as P +import qualified Data.Aeson.Types as A +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BCL +import qualified Data.Proxy as P (Proxy(..)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Client as NH +import qualified Network.HTTP.Client.MultipartFormData as NH +import qualified Network.HTTP.Types as NH +import qualified Web.FormUrlEncoded as WH +import qualified Web.HttpApiData as WH + +import Data.Function ((&)) +import Data.Monoid ((<>)) +import Data.Text (Text) +import GHC.Exts (IsString(..)) + +-- * Dispatch + +-- ** Lbs + +-- | send a request returning the raw http response +dispatchLbs + :: (Produces req accept, MimeType contentType) + => NH.Manager -- ^ http-client Connection manager + -> AWSLambdaRuntimeConfig -- ^ config + -> AWSLambdaRuntimeRequest req contentType res accept -- ^ request + -> IO (NH.Response BCL.ByteString) -- ^ response +dispatchLbs manager config request = do + initReq <- _toInitRequest config request + dispatchInitUnsafe manager config initReq + +-- ** Mime + +-- | pair of decoded http body and http response +data MimeResult res = + MimeResult { mimeResult :: Either MimeError res -- ^ decoded http body + , mimeResultResponse :: NH.Response BCL.ByteString -- ^ http response + } + deriving (Show, Functor, Foldable, Traversable) + +-- | pair of unrender/parser error and http response +data MimeError = + MimeError { + mimeError :: String -- ^ unrender/parser error + , mimeErrorResponse :: NH.Response BCL.ByteString -- ^ http response + } deriving (Eq, Show) + +-- | send a request returning the 'MimeResult' +dispatchMime + :: forall req contentType res accept. (Produces req accept, MimeUnrender accept res, MimeType contentType) + => NH.Manager -- ^ http-client Connection manager + -> AWSLambdaRuntimeConfig -- ^ config + -> AWSLambdaRuntimeRequest req contentType res accept -- ^ request + -> IO (MimeResult res) -- ^ response +dispatchMime manager config request = do + httpResponse <- dispatchLbs manager config request + let statusCode = NH.statusCode . NH.responseStatus $ httpResponse + parsedResult <- + runConfigLogWithExceptions "Client" config $ + do if (statusCode >= 400 && statusCode < 600) + then do + let s = "error statusCode: " ++ show statusCode + _log "Client" levelError (T.pack s) + pure (Left (MimeError s httpResponse)) + else case mimeUnrender (P.Proxy :: P.Proxy accept) (NH.responseBody httpResponse) of + Left s -> do + _log "Client" levelError (T.pack s) + pure (Left (MimeError s httpResponse)) + Right r -> pure (Right r) + return (MimeResult parsedResult httpResponse) + +-- | like 'dispatchMime', but only returns the decoded http body +dispatchMime' + :: (Produces req accept, MimeUnrender accept res, MimeType contentType) + => NH.Manager -- ^ http-client Connection manager + -> AWSLambdaRuntimeConfig -- ^ config + -> AWSLambdaRuntimeRequest req contentType res accept -- ^ request + -> IO (Either MimeError res) -- ^ response +dispatchMime' manager config request = do + MimeResult parsedResult _ <- dispatchMime manager config request + return parsedResult + +-- ** Unsafe + +-- | like 'dispatchReqLbs', but does not validate the operation is a 'Producer' of the "accept" 'MimeType'. (Useful if the server's response is undocumented) +dispatchLbsUnsafe + :: (MimeType accept, MimeType contentType) + => NH.Manager -- ^ http-client Connection manager + -> AWSLambdaRuntimeConfig -- ^ config + -> AWSLambdaRuntimeRequest req contentType res accept -- ^ request + -> IO (NH.Response BCL.ByteString) -- ^ response +dispatchLbsUnsafe manager config request = do + initReq <- _toInitRequest config request + dispatchInitUnsafe manager config initReq + +-- | dispatch an InitRequest +dispatchInitUnsafe + :: NH.Manager -- ^ http-client Connection manager + -> AWSLambdaRuntimeConfig -- ^ config + -> InitRequest req contentType res accept -- ^ init request + -> IO (NH.Response BCL.ByteString) -- ^ response +dispatchInitUnsafe manager config (InitRequest req) = do + runConfigLogWithExceptions src config $ + do _log src levelInfo requestLogMsg + _log src levelDebug requestDbgLogMsg + res <- P.liftIO $ NH.httpLbs req manager + _log src levelInfo (responseLogMsg res) + _log src levelDebug ((T.pack . show) res) + return res + where + src = "Client" + endpoint = + T.pack $ + BC.unpack $ + NH.method req <> " " <> NH.host req <> NH.path req <> NH.queryString req + requestLogMsg = "REQ:" <> endpoint + requestDbgLogMsg = + "Headers=" <> (T.pack . show) (NH.requestHeaders req) <> " Body=" <> + (case NH.requestBody req of + NH.RequestBodyLBS xs -> T.decodeUtf8 (BL.toStrict xs) + _ -> "") + responseStatusCode = (T.pack . show) . NH.statusCode . NH.responseStatus + responseLogMsg res = + "RES:statusCode=" <> responseStatusCode res <> " (" <> endpoint <> ")" + +-- * InitRequest + +-- | wraps an http-client 'Request' with request/response type parameters +newtype InitRequest req contentType res accept = InitRequest + { unInitRequest :: NH.Request + } deriving (Show) + +-- | Build an http-client 'Request' record from the supplied config and request +_toInitRequest + :: (MimeType accept, MimeType contentType) + => AWSLambdaRuntimeConfig -- ^ config + -> AWSLambdaRuntimeRequest req contentType res accept -- ^ request + -> IO (InitRequest req contentType res accept) -- ^ initialized request +_toInitRequest config req0 = + runConfigLogWithExceptions "Client" config $ do + parsedReq <- P.liftIO $ NH.parseRequest $ BCL.unpack $ BCL.append (configHost config) (BCL.concat (rUrlPath req0)) + req1 <- P.liftIO $ _applyAuthMethods req0 config + P.when + (configValidateAuthMethods config && (not . null . rAuthTypes) req1) + (E.throw $ AuthMethodException $ "AuthMethod not configured: " <> (show . head . rAuthTypes) req1) + let req2 = req1 & _setContentTypeHeader & _setAcceptHeader + reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders (rParams req2) + reqQuery = NH.renderQuery True (paramsQuery (rParams req2)) + pReq = parsedReq { NH.method = (rMethod req2) + , NH.requestHeaders = reqHeaders + , NH.queryString = reqQuery + } + outReq <- case paramsBody (rParams req2) of + ParamBodyNone -> pure (pReq { NH.requestBody = mempty }) + ParamBodyB bs -> pure (pReq { NH.requestBody = NH.RequestBodyBS bs }) + ParamBodyBL bl -> pure (pReq { NH.requestBody = NH.RequestBodyLBS bl }) + ParamBodyFormUrlEncoded form -> pure (pReq { NH.requestBody = NH.RequestBodyLBS (WH.urlEncodeForm form) }) + ParamBodyMultipartFormData parts -> NH.formDataBody parts pReq + + pure (InitRequest outReq) + +-- | modify the underlying Request +modifyInitRequest :: InitRequest req contentType res accept -> (NH.Request -> NH.Request) -> InitRequest req contentType res accept +modifyInitRequest (InitRequest req) f = InitRequest (f req) + +-- | modify the underlying Request (monadic) +modifyInitRequestM :: Monad m => InitRequest req contentType res accept -> (NH.Request -> m NH.Request) -> m (InitRequest req contentType res accept) +modifyInitRequestM (InitRequest req) f = fmap InitRequest (f req) + +-- ** Logging + +-- | Run a block using the configured logger instance +runConfigLog + :: P.MonadIO m + => AWSLambdaRuntimeConfig -> LogExec m +runConfigLog config = configLogExecWithContext config (configLogContext config) + +-- | Run a block using the configured logger instance (logs exceptions) +runConfigLogWithExceptions + :: (E.MonadCatch m, P.MonadIO m) + => T.Text -> AWSLambdaRuntimeConfig -> LogExec m +runConfigLogWithExceptions src config = runConfigLog config . logExceptions src diff --git a/lib/AWSLambdaRuntime/Core.hs b/lib/AWSLambdaRuntime/Core.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/Core.hs @@ -0,0 +1,544 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.Core +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} + +module AWSLambdaRuntime.Core where + +import AWSLambdaRuntime.MimeTypes +import AWSLambdaRuntime.Logging + +import qualified Control.Arrow as P (left) +import qualified Control.DeepSeq as NF +import qualified Control.Exception.Safe as E +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64.Lazy as BL64 +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BCL +import qualified Data.CaseInsensitive as CI +import qualified Data.Data as P (Data, Typeable, TypeRep, typeRep) +import qualified Data.Foldable as P +import qualified Data.Ix as P +import qualified Data.Maybe as P +import qualified Data.Proxy as P (Proxy(..)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Time as TI +import qualified Data.Time.ISO8601 as TI +import qualified GHC.Base as P (Alternative) +import qualified Lens.Micro as L +import qualified Network.HTTP.Client.MultipartFormData as NH +import qualified Network.HTTP.Types as NH +import qualified Prelude as P +import qualified Web.FormUrlEncoded as WH +import qualified Web.HttpApiData as WH +import qualified Text.Printf as T + +import Control.Applicative ((<|>)) +import Control.Applicative (Alternative) +import Data.Function ((&)) +import Data.Foldable(foldlM) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Prelude (($), (.), (<$>), (<*>), Maybe(..), Bool(..), Char, String, fmap, mempty, pure, return, show, IO, Monad, Functor) + +-- * AWSLambdaRuntimeConfig + +-- | +data AWSLambdaRuntimeConfig = AWSLambdaRuntimeConfig + { configHost :: BCL.ByteString -- ^ host supplied in the Request + , configUserAgent :: Text -- ^ user-agent supplied in the Request + , configLogExecWithContext :: LogExecWithContext -- ^ Run a block using a Logger instance + , configLogContext :: LogContext -- ^ Configures the logger + , configAuthMethods :: [AnyAuthMethod] -- ^ List of configured auth methods + , configValidateAuthMethods :: Bool -- ^ throw exceptions if auth methods are not configured + } + +-- | display the config +instance P.Show AWSLambdaRuntimeConfig where + show c = + T.printf + "{ configHost = %v, configUserAgent = %v, ..}" + (show (configHost c)) + (show (configUserAgent c)) + +-- | constructs a default AWSLambdaRuntimeConfig +-- +-- configHost: +-- +-- @http://localhost/2018-06-01@ +-- +-- configUserAgent: +-- +-- @"aws-lambda-runtime/0.1.0.0"@ +-- +newConfig :: IO AWSLambdaRuntimeConfig +newConfig = do + logCxt <- initLogContext + return $ AWSLambdaRuntimeConfig + { configHost = "http://localhost/2018-06-01" + , configUserAgent = "aws-lambda-runtime/0.1.0.0" + , configLogExecWithContext = runDefaultLogExecWithContext + , configLogContext = logCxt + , configAuthMethods = [] + , configValidateAuthMethods = True + } + +-- | updates config use AuthMethod on matching requests +addAuthMethod :: AuthMethod auth => AWSLambdaRuntimeConfig -> auth -> AWSLambdaRuntimeConfig +addAuthMethod config@AWSLambdaRuntimeConfig {configAuthMethods = as} a = + config { configAuthMethods = AnyAuthMethod a : as} + +-- | updates the config to use stdout logging +withStdoutLogging :: AWSLambdaRuntimeConfig -> IO AWSLambdaRuntimeConfig +withStdoutLogging p = do + logCxt <- stdoutLoggingContext (configLogContext p) + return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt } + +-- | updates the config to use stderr logging +withStderrLogging :: AWSLambdaRuntimeConfig -> IO AWSLambdaRuntimeConfig +withStderrLogging p = do + logCxt <- stderrLoggingContext (configLogContext p) + return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt } + +-- | updates the config to disable logging +withNoLogging :: AWSLambdaRuntimeConfig -> AWSLambdaRuntimeConfig +withNoLogging p = p { configLogExecWithContext = runNullLogExec} + +-- * AWSLambdaRuntimeRequest + +-- | Represents a request. +-- +-- Type Variables: +-- +-- * req - request operation +-- * contentType - 'MimeType' associated with request body +-- * res - response model +-- * accept - 'MimeType' associated with response body +data AWSLambdaRuntimeRequest req contentType res accept = AWSLambdaRuntimeRequest + { rMethod :: NH.Method -- ^ Method of AWSLambdaRuntimeRequest + , rUrlPath :: [BCL.ByteString] -- ^ Endpoint of AWSLambdaRuntimeRequest + , rParams :: Params -- ^ params of AWSLambdaRuntimeRequest + , rAuthTypes :: [P.TypeRep] -- ^ types of auth methods + } + deriving (P.Show) + +-- | 'rMethod' Lens +rMethodL :: Lens_' (AWSLambdaRuntimeRequest req contentType res accept) NH.Method +rMethodL f AWSLambdaRuntimeRequest{..} = (\rMethod -> AWSLambdaRuntimeRequest { rMethod, ..} ) <$> f rMethod +{-# INLINE rMethodL #-} + +-- | 'rUrlPath' Lens +rUrlPathL :: Lens_' (AWSLambdaRuntimeRequest req contentType res accept) [BCL.ByteString] +rUrlPathL f AWSLambdaRuntimeRequest{..} = (\rUrlPath -> AWSLambdaRuntimeRequest { rUrlPath, ..} ) <$> f rUrlPath +{-# INLINE rUrlPathL #-} + +-- | 'rParams' Lens +rParamsL :: Lens_' (AWSLambdaRuntimeRequest req contentType res accept) Params +rParamsL f AWSLambdaRuntimeRequest{..} = (\rParams -> AWSLambdaRuntimeRequest { rParams, ..} ) <$> f rParams +{-# INLINE rParamsL #-} + +-- | 'rParams' Lens +rAuthTypesL :: Lens_' (AWSLambdaRuntimeRequest req contentType res accept) [P.TypeRep] +rAuthTypesL f AWSLambdaRuntimeRequest{..} = (\rAuthTypes -> AWSLambdaRuntimeRequest { rAuthTypes, ..} ) <$> f rAuthTypes +{-# INLINE rAuthTypesL #-} + +-- * HasBodyParam + +-- | Designates the body parameter of a request +class HasBodyParam req param where + setBodyParam :: forall contentType res accept. (Consumes req contentType, MimeRender contentType param) => AWSLambdaRuntimeRequest req contentType res accept -> param -> AWSLambdaRuntimeRequest req contentType res accept + setBodyParam req xs = + req `_setBodyLBS` mimeRender (P.Proxy :: P.Proxy contentType) xs & _setContentTypeHeader + +-- * HasOptionalParam + +-- | Designates the optional parameters of a request +class HasOptionalParam req param where + {-# MINIMAL applyOptionalParam | (-&-) #-} + + -- | Apply an optional parameter to a request + applyOptionalParam :: AWSLambdaRuntimeRequest req contentType res accept -> param -> AWSLambdaRuntimeRequest req contentType res accept + applyOptionalParam = (-&-) + {-# INLINE applyOptionalParam #-} + + -- | infix operator \/ alias for 'addOptionalParam' + (-&-) :: AWSLambdaRuntimeRequest req contentType res accept -> param -> AWSLambdaRuntimeRequest req contentType res accept + (-&-) = applyOptionalParam + {-# INLINE (-&-) #-} + +infixl 2 -&- + +-- | Request Params +data Params = Params + { paramsQuery :: NH.Query + , paramsHeaders :: NH.RequestHeaders + , paramsBody :: ParamBody + } + deriving (P.Show) + +-- | 'paramsQuery' Lens +paramsQueryL :: Lens_' Params NH.Query +paramsQueryL f Params{..} = (\paramsQuery -> Params { paramsQuery, ..} ) <$> f paramsQuery +{-# INLINE paramsQueryL #-} + +-- | 'paramsHeaders' Lens +paramsHeadersL :: Lens_' Params NH.RequestHeaders +paramsHeadersL f Params{..} = (\paramsHeaders -> Params { paramsHeaders, ..} ) <$> f paramsHeaders +{-# INLINE paramsHeadersL #-} + +-- | 'paramsBody' Lens +paramsBodyL :: Lens_' Params ParamBody +paramsBodyL f Params{..} = (\paramsBody -> Params { paramsBody, ..} ) <$> f paramsBody +{-# INLINE paramsBodyL #-} + +-- | Request Body +data ParamBody + = ParamBodyNone + | ParamBodyB B.ByteString + | ParamBodyBL BL.ByteString + | ParamBodyFormUrlEncoded WH.Form + | ParamBodyMultipartFormData [NH.Part] + deriving (P.Show) + +-- ** AWSLambdaRuntimeRequest Utils + +_mkRequest :: NH.Method -- ^ Method + -> [BCL.ByteString] -- ^ Endpoint + -> AWSLambdaRuntimeRequest req contentType res accept -- ^ req: Request Type, res: Response Type +_mkRequest m u = AWSLambdaRuntimeRequest m u _mkParams [] + +_mkParams :: Params +_mkParams = Params [] [] ParamBodyNone + +setHeader :: AWSLambdaRuntimeRequest req contentType res accept -> [NH.Header] -> AWSLambdaRuntimeRequest req contentType res accept +setHeader req header = + req `removeHeader` P.fmap P.fst header & + L.over (rParamsL . paramsHeadersL) (header P.++) + +removeHeader :: AWSLambdaRuntimeRequest req contentType res accept -> [NH.HeaderName] -> AWSLambdaRuntimeRequest req contentType res accept +removeHeader req header = + req & + L.over + (rParamsL . paramsHeadersL) + (P.filter (\h -> cifst h `P.notElem` P.fmap CI.mk header)) + where + cifst = CI.mk . P.fst + + +_setContentTypeHeader :: forall req contentType res accept. MimeType contentType => AWSLambdaRuntimeRequest req contentType res accept -> AWSLambdaRuntimeRequest req contentType res accept +_setContentTypeHeader req = + case mimeType (P.Proxy :: P.Proxy contentType) of + Just m -> req `setHeader` [("content-type", BC.pack $ P.show m)] + Nothing -> req `removeHeader` ["content-type"] + +_setAcceptHeader :: forall req contentType res accept. MimeType accept => AWSLambdaRuntimeRequest req contentType res accept -> AWSLambdaRuntimeRequest req contentType res accept +_setAcceptHeader req = + case mimeType (P.Proxy :: P.Proxy accept) of + Just m -> req `setHeader` [("accept", BC.pack $ P.show m)] + Nothing -> req `removeHeader` ["accept"] + +setQuery :: AWSLambdaRuntimeRequest req contentType res accept -> [NH.QueryItem] -> AWSLambdaRuntimeRequest req contentType res accept +setQuery req query = + req & + L.over + (rParamsL . paramsQueryL) + ((query P.++) . P.filter (\q -> cifst q `P.notElem` P.fmap cifst query)) + where + cifst = CI.mk . P.fst + +addForm :: AWSLambdaRuntimeRequest req contentType res accept -> WH.Form -> AWSLambdaRuntimeRequest req contentType res accept +addForm req newform = + let form = case paramsBody (rParams req) of + ParamBodyFormUrlEncoded _form -> _form + _ -> mempty + in req & L.set (rParamsL . paramsBodyL) (ParamBodyFormUrlEncoded (newform <> form)) + +_addMultiFormPart :: AWSLambdaRuntimeRequest req contentType res accept -> NH.Part -> AWSLambdaRuntimeRequest req contentType res accept +_addMultiFormPart req newpart = + let parts = case paramsBody (rParams req) of + ParamBodyMultipartFormData _parts -> _parts + _ -> [] + in req & L.set (rParamsL . paramsBodyL) (ParamBodyMultipartFormData (newpart : parts)) + +_setBodyBS :: AWSLambdaRuntimeRequest req contentType res accept -> B.ByteString -> AWSLambdaRuntimeRequest req contentType res accept +_setBodyBS req body = + req & L.set (rParamsL . paramsBodyL) (ParamBodyB body) + +_setBodyLBS :: AWSLambdaRuntimeRequest req contentType res accept -> BL.ByteString -> AWSLambdaRuntimeRequest req contentType res accept +_setBodyLBS req body = + req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body) + +_hasAuthType :: AuthMethod authMethod => AWSLambdaRuntimeRequest req contentType res accept -> P.Proxy authMethod -> AWSLambdaRuntimeRequest req contentType res accept +_hasAuthType req proxy = + req & L.over rAuthTypesL (P.typeRep proxy :) + +-- ** Params Utils + +toPath + :: WH.ToHttpApiData a + => a -> BCL.ByteString +toPath = BB.toLazyByteString . WH.toEncodedUrlPiece + +toHeader :: WH.ToHttpApiData a => (NH.HeaderName, a) -> [NH.Header] +toHeader x = [fmap WH.toHeader x] + +toForm :: WH.ToHttpApiData v => (BC.ByteString, v) -> WH.Form +toForm (k,v) = WH.toForm [(BC.unpack k,v)] + +toQuery :: WH.ToHttpApiData a => (BC.ByteString, Maybe a) -> [NH.QueryItem] +toQuery x = [(fmap . fmap) toQueryParam x] + where toQueryParam = T.encodeUtf8 . WH.toQueryParam + +-- *** OpenAPI `CollectionFormat` Utils + +-- | Determines the format of the array if type array is used. +data CollectionFormat + = CommaSeparated -- ^ CSV format for multiple parameters. + | SpaceSeparated -- ^ Also called "SSV" + | TabSeparated -- ^ Also called "TSV" + | PipeSeparated -- ^ `value1|value2|value2` + | MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. This is valid only for parameters in "query" ('NH.Query') or "formData" ('WH.Form') + +toHeaderColl :: WH.ToHttpApiData a => CollectionFormat -> (NH.HeaderName, [a]) -> [NH.Header] +toHeaderColl c xs = _toColl c toHeader xs + +toFormColl :: WH.ToHttpApiData v => CollectionFormat -> (BC.ByteString, [v]) -> WH.Form +toFormColl c xs = WH.toForm $ fmap unpack $ _toColl c toHeader $ pack xs + where + pack (k,v) = (CI.mk k, v) + unpack (k,v) = (BC.unpack (CI.original k), BC.unpack v) + +toQueryColl :: WH.ToHttpApiData a => CollectionFormat -> (BC.ByteString, Maybe [a]) -> NH.Query +toQueryColl c xs = _toCollA c toQuery xs + +_toColl :: P.Traversable f => CollectionFormat -> (f a -> [(b, BC.ByteString)]) -> f [a] -> [(b, BC.ByteString)] +_toColl c encode xs = fmap (fmap P.fromJust) (_toCollA' c fencode BC.singleton (fmap Just xs)) + where fencode = fmap (fmap Just) . encode . fmap P.fromJust + {-# INLINE fencode #-} + +_toCollA :: (P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t BC.ByteString)]) -> f (t [a]) -> [(b, t BC.ByteString)] +_toCollA c encode xs = _toCollA' c encode BC.singleton xs + +_toCollA' :: (P.Monoid c, P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t c)]) -> (Char -> c) -> f (t [a]) -> [(b, t c)] +_toCollA' c encode one xs = case c of + CommaSeparated -> go (one ',') + SpaceSeparated -> go (one ' ') + TabSeparated -> go (one '\t') + PipeSeparated -> go (one '|') + MultiParamArray -> expandList + where + go sep = + [P.foldl1 (\(sk, sv) (_, v) -> (sk, (combine sep <$> sv <*> v) <|> sv <|> v)) expandList] + combine sep x y = x <> sep <> y + expandList = (P.concatMap encode . (P.traverse . P.traverse) P.toList) xs + {-# INLINE go #-} + {-# INLINE expandList #-} + {-# INLINE combine #-} + +-- * AuthMethods + +-- | Provides a method to apply auth methods to requests +class P.Typeable a => + AuthMethod a where + applyAuthMethod + :: AWSLambdaRuntimeConfig + -> a + -> AWSLambdaRuntimeRequest req contentType res accept + -> IO (AWSLambdaRuntimeRequest req contentType res accept) + +-- | An existential wrapper for any AuthMethod +data AnyAuthMethod = forall a. AuthMethod a => AnyAuthMethod a deriving (P.Typeable) + +instance AuthMethod AnyAuthMethod where applyAuthMethod config (AnyAuthMethod a) req = applyAuthMethod config a req + +-- | indicates exceptions related to AuthMethods +data AuthMethodException = AuthMethodException String deriving (P.Show, P.Typeable) + +instance E.Exception AuthMethodException + +-- | apply all matching AuthMethods in config to request +_applyAuthMethods + :: AWSLambdaRuntimeRequest req contentType res accept + -> AWSLambdaRuntimeConfig + -> IO (AWSLambdaRuntimeRequest req contentType res accept) +_applyAuthMethods req config@(AWSLambdaRuntimeConfig {configAuthMethods = as}) = + foldlM go req as + where + go r (AnyAuthMethod a) = applyAuthMethod config a r + +-- * Utils + +-- | Removes Null fields. (OpenAPI-Specification 2.0 does not allow Null in JSON) +_omitNulls :: [(Text, A.Value)] -> A.Value +_omitNulls = A.object . P.filter notNull + where + notNull (_, A.Null) = False + notNull _ = True + +-- | Encodes fields using WH.toQueryParam +_toFormItem :: (WH.ToHttpApiData a, Functor f) => t -> f a -> f (t, [Text]) +_toFormItem name x = (name,) . (:[]) . WH.toQueryParam <$> x + +-- | Collapse (Just "") to Nothing +_emptyToNothing :: Maybe String -> Maybe String +_emptyToNothing (Just "") = Nothing +_emptyToNothing x = x +{-# INLINE _emptyToNothing #-} + +-- | Collapse (Just mempty) to Nothing +_memptyToNothing :: (P.Monoid a, P.Eq a) => Maybe a -> Maybe a +_memptyToNothing (Just x) | x P.== P.mempty = Nothing +_memptyToNothing x = x +{-# INLINE _memptyToNothing #-} + +-- * DateTime Formatting + +newtype DateTime = DateTime { unDateTime :: TI.UTCTime } + deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData,TI.ParseTime,TI.FormatTime) +instance A.FromJSON DateTime where + parseJSON = A.withText "DateTime" (_readDateTime . T.unpack) +instance A.ToJSON DateTime where + toJSON (DateTime t) = A.toJSON (_showDateTime t) +instance WH.FromHttpApiData DateTime where + parseUrlPiece = P.left T.pack . _readDateTime . T.unpack +instance WH.ToHttpApiData DateTime where + toUrlPiece (DateTime t) = T.pack (_showDateTime t) +instance P.Show DateTime where + show (DateTime t) = _showDateTime t +instance MimeRender MimeMultipartFormData DateTime where + mimeRender _ = mimeRenderDefaultMultipartFormData + +-- | @_parseISO8601@ +_readDateTime :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t +_readDateTime = + _parseISO8601 +{-# INLINE _readDateTime #-} + +-- | @TI.formatISO8601Millis@ +_showDateTime :: (t ~ TI.UTCTime, TI.FormatTime t) => t -> String +_showDateTime = + TI.formatISO8601Millis +{-# INLINE _showDateTime #-} + +-- | parse an ISO8601 date-time string +_parseISO8601 :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t +_parseISO8601 t = + P.asum $ + P.flip (TI.parseTimeM True TI.defaultTimeLocale) t <$> + ["%FT%T%QZ", "%FT%T%Q%z", "%FT%T%Q%Z"] +{-# INLINE _parseISO8601 #-} + +-- * Date Formatting + +newtype Date = Date { unDate :: TI.Day } + deriving (P.Enum,P.Eq,P.Data,P.Ord,P.Ix,NF.NFData,TI.ParseTime,TI.FormatTime) +instance A.FromJSON Date where + parseJSON = A.withText "Date" (_readDate . T.unpack) +instance A.ToJSON Date where + toJSON (Date t) = A.toJSON (_showDate t) +instance WH.FromHttpApiData Date where + parseUrlPiece = P.left T.pack . _readDate . T.unpack +instance WH.ToHttpApiData Date where + toUrlPiece (Date t) = T.pack (_showDate t) +instance P.Show Date where + show (Date t) = _showDate t +instance MimeRender MimeMultipartFormData Date where + mimeRender _ = mimeRenderDefaultMultipartFormData + +-- | @TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d"@ +_readDate :: (TI.ParseTime t, Monad m) => String -> m t +_readDate = + TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d" +{-# INLINE _readDate #-} + +-- | @TI.formatTime TI.defaultTimeLocale "%Y-%m-%d"@ +_showDate :: TI.FormatTime t => t -> String +_showDate = + TI.formatTime TI.defaultTimeLocale "%Y-%m-%d" +{-# INLINE _showDate #-} + +-- * Byte/Binary Formatting + + +-- | base64 encoded characters +newtype ByteArray = ByteArray { unByteArray :: BL.ByteString } + deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData) + +instance A.FromJSON ByteArray where + parseJSON = A.withText "ByteArray" _readByteArray +instance A.ToJSON ByteArray where + toJSON = A.toJSON . _showByteArray +instance WH.FromHttpApiData ByteArray where + parseUrlPiece = P.left T.pack . _readByteArray +instance WH.ToHttpApiData ByteArray where + toUrlPiece = _showByteArray +instance P.Show ByteArray where + show = T.unpack . _showByteArray +instance MimeRender MimeMultipartFormData ByteArray where + mimeRender _ = mimeRenderDefaultMultipartFormData + +-- | read base64 encoded characters +_readByteArray :: Monad m => Text -> m ByteArray +_readByteArray = P.either P.fail (pure . ByteArray) . BL64.decode . BL.fromStrict . T.encodeUtf8 +{-# INLINE _readByteArray #-} + +-- | show base64 encoded characters +_showByteArray :: ByteArray -> Text +_showByteArray = T.decodeUtf8 . BL.toStrict . BL64.encode . unByteArray +{-# INLINE _showByteArray #-} + +-- | any sequence of octets +newtype Binary = Binary { unBinary :: BL.ByteString } + deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData) + +instance A.FromJSON Binary where + parseJSON = A.withText "Binary" _readBinaryBase64 +instance A.ToJSON Binary where + toJSON = A.toJSON . _showBinaryBase64 +instance WH.FromHttpApiData Binary where + parseUrlPiece = P.left T.pack . _readBinaryBase64 +instance WH.ToHttpApiData Binary where + toUrlPiece = _showBinaryBase64 +instance P.Show Binary where + show = T.unpack . _showBinaryBase64 +instance MimeRender MimeMultipartFormData Binary where + mimeRender _ = unBinary + +_readBinaryBase64 :: Monad m => Text -> m Binary +_readBinaryBase64 = P.either P.fail (pure . Binary) . BL64.decode . BL.fromStrict . T.encodeUtf8 +{-# INLINE _readBinaryBase64 #-} + +_showBinaryBase64 :: Binary -> Text +_showBinaryBase64 = T.decodeUtf8 . BL.toStrict . BL64.encode . unBinary +{-# INLINE _showBinaryBase64 #-} + +-- * Lens Type Aliases + +type Lens_' s a = Lens_ s s a a +type Lens_ s t a b = forall (f :: * -> *). Functor f => (a -> f b) -> s -> f t diff --git a/lib/AWSLambdaRuntime/Logging.hs b/lib/AWSLambdaRuntime/Logging.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/Logging.hs @@ -0,0 +1,33 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.Logging +Logging functions +-} +{-# LANGUAGE CPP #-} + +#ifdef USE_KATIP + +module AWSLambdaRuntime.Logging + ( module AWSLambdaRuntime.LoggingKatip + ) where + +import AWSLambdaRuntime.LoggingKatip + +#else + +module AWSLambdaRuntime.Logging + ( module AWSLambdaRuntime.LoggingMonadLogger + ) where + +import AWSLambdaRuntime.LoggingMonadLogger + +#endif diff --git a/lib/AWSLambdaRuntime/LoggingKatip.hs b/lib/AWSLambdaRuntime/LoggingKatip.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/LoggingKatip.hs @@ -0,0 +1,118 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.LoggingKatip +Katip Logging functions +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module AWSLambdaRuntime.LoggingKatip where + +import qualified Control.Exception.Safe as E +import qualified Control.Monad.IO.Class as P +import qualified Control.Monad.Trans.Reader as P +import qualified Data.Text as T +import qualified Lens.Micro as L +import qualified System.IO as IO + +import Data.Text (Text) +import GHC.Exts (IsString(..)) + +import qualified Katip as LG + +-- * Type Aliases (for compatibility) + +-- | Runs a Katip logging block with the Log environment +type LogExecWithContext = forall m. P.MonadIO m => + LogContext -> LogExec m + +-- | A Katip logging block +type LogExec m = forall a. LG.KatipT m a -> m a + +-- | A Katip Log environment +type LogContext = LG.LogEnv + +-- | A Katip Log severity +type LogLevel = LG.Severity + +-- * default logger + +-- | the default log environment +initLogContext :: IO LogContext +initLogContext = LG.initLogEnv "AWSLambdaRuntime" "dev" + +-- | Runs a Katip logging block with the Log environment +runDefaultLogExecWithContext :: LogExecWithContext +runDefaultLogExecWithContext = LG.runKatipT + +-- * stdout logger + +-- | Runs a Katip logging block with the Log environment +stdoutLoggingExec :: LogExecWithContext +stdoutLoggingExec = runDefaultLogExecWithContext + +-- | A Katip Log environment which targets stdout +stdoutLoggingContext :: LogContext -> IO LogContext +stdoutLoggingContext cxt = do + handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stdout (LG.permitItem LG.InfoS) LG.V2 + LG.registerScribe "stdout" handleScribe LG.defaultScribeSettings cxt + +-- * stderr logger + +-- | Runs a Katip logging block with the Log environment +stderrLoggingExec :: LogExecWithContext +stderrLoggingExec = runDefaultLogExecWithContext + +-- | A Katip Log environment which targets stderr +stderrLoggingContext :: LogContext -> IO LogContext +stderrLoggingContext cxt = do + handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stderr (LG.permitItem LG.InfoS) LG.V2 + LG.registerScribe "stderr" handleScribe LG.defaultScribeSettings cxt + +-- * Null logger + +-- | Disables Katip logging +runNullLogExec :: LogExecWithContext +runNullLogExec le (LG.KatipT f) = P.runReaderT f (L.set LG.logEnvScribes mempty le) + +-- * Log Msg + +-- | Log a katip message +_log :: (Applicative m, LG.Katip m) => Text -> LogLevel -> Text -> m () +_log src level msg = do + LG.logMsg (fromString $ T.unpack src) level (LG.logStr msg) + +-- * Log Exceptions + +-- | re-throws exceptions after logging them +logExceptions + :: (LG.Katip m, E.MonadCatch m, Applicative m) + => Text -> m a -> m a +logExceptions src = + E.handle + (\(e :: E.SomeException) -> do + _log src LG.ErrorS ((T.pack . show) e) + E.throw e) + +-- * Log Level + +levelInfo :: LogLevel +levelInfo = LG.InfoS + +levelError :: LogLevel +levelError = LG.ErrorS + +levelDebug :: LogLevel +levelDebug = LG.DebugS + diff --git a/lib/AWSLambdaRuntime/LoggingMonadLogger.hs b/lib/AWSLambdaRuntime/LoggingMonadLogger.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/LoggingMonadLogger.hs @@ -0,0 +1,127 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.LoggingMonadLogger +monad-logger Logging functions +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module AWSLambdaRuntime.LoggingMonadLogger where + +import qualified Control.Exception.Safe as E +import qualified Control.Monad.IO.Class as P +import qualified Data.Text as T +import qualified Data.Time as TI + +import Data.Monoid ((<>)) +import Data.Text (Text) + +import qualified Control.Monad.Logger as LG + +-- * Type Aliases (for compatibility) + +-- | Runs a monad-logger block with the filter predicate +type LogExecWithContext = forall m. P.MonadIO m => + LogContext -> LogExec m + +-- | A monad-logger block +type LogExec m = forall a. LG.LoggingT m a -> m a + +-- | A monad-logger filter predicate +type LogContext = LG.LogSource -> LG.LogLevel -> Bool + +-- | A monad-logger log level +type LogLevel = LG.LogLevel + +-- * default logger + +-- | the default log environment +initLogContext :: IO LogContext +initLogContext = pure infoLevelFilter + +-- | Runs a monad-logger block with the filter predicate +runDefaultLogExecWithContext :: LogExecWithContext +runDefaultLogExecWithContext = runNullLogExec + +-- * stdout logger + +-- | Runs a monad-logger block targeting stdout, with the filter predicate +stdoutLoggingExec :: LogExecWithContext +stdoutLoggingExec cxt = LG.runStdoutLoggingT . LG.filterLogger cxt + +-- | @pure@ +stdoutLoggingContext :: LogContext -> IO LogContext +stdoutLoggingContext = pure + +-- * stderr logger + +-- | Runs a monad-logger block targeting stderr, with the filter predicate +stderrLoggingExec :: LogExecWithContext +stderrLoggingExec cxt = LG.runStderrLoggingT . LG.filterLogger cxt + +-- | @pure@ +stderrLoggingContext :: LogContext -> IO LogContext +stderrLoggingContext = pure + +-- * Null logger + +-- | Disables monad-logger logging +runNullLogExec :: LogExecWithContext +runNullLogExec = const (`LG.runLoggingT` nullLogger) + +-- | monad-logger which does nothing +nullLogger :: LG.Loc -> LG.LogSource -> LG.LogLevel -> LG.LogStr -> IO () +nullLogger _ _ _ _ = return () + +-- * Log Msg + +-- | Log a message using the current time +_log :: (P.MonadIO m, LG.MonadLogger m) => Text -> LG.LogLevel -> Text -> m () +_log src level msg = do + now <- P.liftIO (formatTimeLog <$> TI.getCurrentTime) + LG.logOtherNS ("AWSLambdaRuntime." <> src) level ("[" <> now <> "] " <> msg) + where + formatTimeLog = + T.pack . TI.formatTime TI.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Z" + +-- * Log Exceptions + +-- | re-throws exceptions after logging them +logExceptions + :: (LG.MonadLogger m, E.MonadCatch m, P.MonadIO m) + => Text -> m a -> m a +logExceptions src = + E.handle + (\(e :: E.SomeException) -> do + _log src LG.LevelError ((T.pack . show) e) + E.throw e) + +-- * Log Level + +levelInfo :: LogLevel +levelInfo = LG.LevelInfo + +levelError :: LogLevel +levelError = LG.LevelError + +levelDebug :: LogLevel +levelDebug = LG.LevelDebug + +-- * Level Filter + +minLevelFilter :: LG.LogLevel -> LG.LogSource -> LG.LogLevel -> Bool +minLevelFilter l _ l' = l' >= l + +infoLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool +infoLevelFilter = minLevelFilter LG.LevelInfo diff --git a/lib/AWSLambdaRuntime/MimeTypes.hs b/lib/AWSLambdaRuntime/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/MimeTypes.hs @@ -0,0 +1,203 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.MimeTypes +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module AWSLambdaRuntime.MimeTypes where + +import qualified Control.Arrow as P (left) +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BCL +import qualified Data.Data as P (Typeable) +import qualified Data.Proxy as P (Proxy(..)) +import qualified Data.String as P +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Media as ME +import qualified Web.FormUrlEncoded as WH +import qualified Web.HttpApiData as WH + +import Prelude (($), (.),(<$>),(<*>),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty) +import qualified Prelude as P + +-- * ContentType MimeType + +data ContentType a = MimeType a => ContentType { unContentType :: a } + +-- * Accept MimeType + +data Accept a = MimeType a => Accept { unAccept :: a } + +-- * Consumes Class + +class MimeType mtype => Consumes req mtype where + +-- * Produces Class + +class MimeType mtype => Produces req mtype where + +-- * Default Mime Types + +data MimeJSON = MimeJSON deriving (P.Typeable) +data MimeXML = MimeXML deriving (P.Typeable) +data MimePlainText = MimePlainText deriving (P.Typeable) +data MimeFormUrlEncoded = MimeFormUrlEncoded deriving (P.Typeable) +data MimeMultipartFormData = MimeMultipartFormData deriving (P.Typeable) +data MimeOctetStream = MimeOctetStream deriving (P.Typeable) +data MimeNoContent = MimeNoContent deriving (P.Typeable) +data MimeAny = MimeAny deriving (P.Typeable) + +-- | A type for responses without content-body. +data NoContent = NoContent + deriving (P.Show, P.Eq, P.Typeable) + + +-- * MimeType Class + +class P.Typeable mtype => MimeType mtype where + {-# MINIMAL mimeType | mimeTypes #-} + + mimeTypes :: P.Proxy mtype -> [ME.MediaType] + mimeTypes p = + case mimeType p of + Just x -> [x] + Nothing -> [] + + mimeType :: P.Proxy mtype -> Maybe ME.MediaType + mimeType p = + case mimeTypes p of + [] -> Nothing + (x:_) -> Just x + + mimeType' :: mtype -> Maybe ME.MediaType + mimeType' _ = mimeType (P.Proxy :: P.Proxy mtype) + mimeTypes' :: mtype -> [ME.MediaType] + mimeTypes' _ = mimeTypes (P.Proxy :: P.Proxy mtype) + +-- Default MimeType Instances + +-- | @application/json; charset=utf-8@ +instance MimeType MimeJSON where + mimeType _ = Just $ P.fromString "application/json" +-- | @application/xml; charset=utf-8@ +instance MimeType MimeXML where + mimeType _ = Just $ P.fromString "application/xml" +-- | @application/x-www-form-urlencoded@ +instance MimeType MimeFormUrlEncoded where + mimeType _ = Just $ P.fromString "application/x-www-form-urlencoded" +-- | @multipart/form-data@ +instance MimeType MimeMultipartFormData where + mimeType _ = Just $ P.fromString "multipart/form-data" +-- | @text/plain; charset=utf-8@ +instance MimeType MimePlainText where + mimeType _ = Just $ P.fromString "text/plain" +-- | @application/octet-stream@ +instance MimeType MimeOctetStream where + mimeType _ = Just $ P.fromString "application/octet-stream" +-- | @"*/*"@ +instance MimeType MimeAny where + mimeType _ = Just $ P.fromString "*/*" +instance MimeType MimeNoContent where + mimeType _ = Nothing + +-- * MimeRender Class + +class MimeType mtype => MimeRender mtype x where + mimeRender :: P.Proxy mtype -> x -> BL.ByteString + mimeRender' :: mtype -> x -> BL.ByteString + mimeRender' _ x = mimeRender (P.Proxy :: P.Proxy mtype) x + + +mimeRenderDefaultMultipartFormData :: WH.ToHttpApiData a => a -> BL.ByteString +mimeRenderDefaultMultipartFormData = BL.fromStrict . T.encodeUtf8 . WH.toQueryParam + +-- Default MimeRender Instances + +-- | `A.encode` +instance A.ToJSON a => MimeRender MimeJSON a where mimeRender _ = A.encode +-- | @WH.urlEncodeAsForm@ +instance WH.ToForm a => MimeRender MimeFormUrlEncoded a where mimeRender _ = WH.urlEncodeAsForm + +-- | @P.id@ +instance MimeRender MimePlainText BL.ByteString where mimeRender _ = P.id +-- | @BL.fromStrict . T.encodeUtf8@ +instance MimeRender MimePlainText T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8 +-- | @BCL.pack@ +instance MimeRender MimePlainText String where mimeRender _ = BCL.pack + +-- | @P.id@ +instance MimeRender MimeOctetStream BL.ByteString where mimeRender _ = P.id +-- | @BL.fromStrict . T.encodeUtf8@ +instance MimeRender MimeOctetStream T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8 +-- | @BCL.pack@ +instance MimeRender MimeOctetStream String where mimeRender _ = BCL.pack + +instance MimeRender MimeMultipartFormData BL.ByteString where mimeRender _ = P.id + +instance MimeRender MimeMultipartFormData Bool where mimeRender _ = mimeRenderDefaultMultipartFormData +instance MimeRender MimeMultipartFormData Char where mimeRender _ = mimeRenderDefaultMultipartFormData +instance MimeRender MimeMultipartFormData Double where mimeRender _ = mimeRenderDefaultMultipartFormData +instance MimeRender MimeMultipartFormData Float where mimeRender _ = mimeRenderDefaultMultipartFormData +instance MimeRender MimeMultipartFormData Int where mimeRender _ = mimeRenderDefaultMultipartFormData +instance MimeRender MimeMultipartFormData Integer where mimeRender _ = mimeRenderDefaultMultipartFormData +instance MimeRender MimeMultipartFormData String where mimeRender _ = mimeRenderDefaultMultipartFormData +instance MimeRender MimeMultipartFormData T.Text where mimeRender _ = mimeRenderDefaultMultipartFormData + +-- | @P.Right . P.const NoContent@ +instance MimeRender MimeNoContent NoContent where mimeRender _ = P.const BCL.empty + + +-- * MimeUnrender Class + +class MimeType mtype => MimeUnrender mtype o where + mimeUnrender :: P.Proxy mtype -> BL.ByteString -> P.Either String o + mimeUnrender' :: mtype -> BL.ByteString -> P.Either String o + mimeUnrender' _ x = mimeUnrender (P.Proxy :: P.Proxy mtype) x + +-- Default MimeUnrender Instances + +-- | @A.eitherDecode@ +instance A.FromJSON a => MimeUnrender MimeJSON a where mimeUnrender _ = A.eitherDecode +-- | @P.left T.unpack . WH.urlDecodeAsForm@ +instance WH.FromForm a => MimeUnrender MimeFormUrlEncoded a where mimeUnrender _ = P.left T.unpack . WH.urlDecodeAsForm +-- | @P.Right . P.id@ + +instance MimeUnrender MimePlainText BL.ByteString where mimeUnrender _ = P.Right . P.id +-- | @P.left P.show . TL.decodeUtf8'@ +instance MimeUnrender MimePlainText T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict +-- | @P.Right . BCL.unpack@ +instance MimeUnrender MimePlainText String where mimeUnrender _ = P.Right . BCL.unpack + +-- | @P.Right . P.id@ +instance MimeUnrender MimeOctetStream BL.ByteString where mimeUnrender _ = P.Right . P.id +-- | @P.left P.show . T.decodeUtf8' . BL.toStrict@ +instance MimeUnrender MimeOctetStream T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict +-- | @P.Right . BCL.unpack@ +instance MimeUnrender MimeOctetStream String where mimeUnrender _ = P.Right . BCL.unpack + +-- | @P.Right . P.const NoContent@ +instance MimeUnrender MimeNoContent NoContent where mimeUnrender _ = P.Right . P.const NoContent + + diff --git a/lib/AWSLambdaRuntime/Model.hs b/lib/AWSLambdaRuntime/Model.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/Model.hs @@ -0,0 +1,180 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.Model +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module AWSLambdaRuntime.Model where + +import AWSLambdaRuntime.Core +import AWSLambdaRuntime.MimeTypes + +import Data.Aeson ((.:),(.:!),(.:?),(.=)) + +import qualified Control.Arrow as P (left) +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.Data as P (Typeable, TypeRep, typeOf, typeRep) +import qualified Data.Foldable as P +import qualified Data.HashMap.Lazy as HM +import qualified Data.Map as Map +import qualified Data.Maybe as P +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Time as TI +import qualified Lens.Micro as L +import qualified Web.FormUrlEncoded as WH +import qualified Web.HttpApiData as WH + +import Control.Applicative ((<|>)) +import Control.Applicative (Alternative) +import Data.Function ((&)) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Prelude (($),(/=),(.),(<$>),(<*>),(>>=),(=<<),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor) + +import qualified Prelude as P + + + +-- * Parameter newtypes + + +-- ** AwsRequestId +newtype AwsRequestId = AwsRequestId { unAwsRequestId :: Text } deriving (P.Eq, P.Show) + +-- ** Body +newtype Body = Body { unBody :: A.Value } deriving (P.Eq, P.Show, A.ToJSON) + +-- ** LambdaRuntimeFunctionErrorType +newtype LambdaRuntimeFunctionErrorType = LambdaRuntimeFunctionErrorType { unLambdaRuntimeFunctionErrorType :: Text } deriving (P.Eq, P.Show) + +-- * Models + + +-- ** ErrorRequest +-- | ErrorRequest +data ErrorRequest = ErrorRequest + { errorRequestErrorMessage :: !(Maybe Text) -- ^ "errorMessage" + , errorRequestErrorType :: !(Maybe Text) -- ^ "errorType" + , errorRequestStackTrace :: !(Maybe [Text]) -- ^ "stackTrace" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON ErrorRequest +instance A.FromJSON ErrorRequest where + parseJSON = A.withObject "ErrorRequest" $ \o -> + ErrorRequest + <$> (o .:? "errorMessage") + <*> (o .:? "errorType") + <*> (o .:? "stackTrace") + +-- | ToJSON ErrorRequest +instance A.ToJSON ErrorRequest where + toJSON ErrorRequest {..} = + _omitNulls + [ "errorMessage" .= errorRequestErrorMessage + , "errorType" .= errorRequestErrorType + , "stackTrace" .= errorRequestStackTrace + ] + + +-- | Construct a value of type 'ErrorRequest' (by applying it's required fields, if any) +mkErrorRequest + :: ErrorRequest +mkErrorRequest = + ErrorRequest + { errorRequestErrorMessage = Nothing + , errorRequestErrorType = Nothing + , errorRequestStackTrace = Nothing + } + +-- ** ErrorResponse +-- | ErrorResponse +data ErrorResponse = ErrorResponse + { errorResponseErrorMessage :: !(Maybe Text) -- ^ "errorMessage" + , errorResponseErrorType :: !(Maybe Text) -- ^ "errorType" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON ErrorResponse +instance A.FromJSON ErrorResponse where + parseJSON = A.withObject "ErrorResponse" $ \o -> + ErrorResponse + <$> (o .:? "errorMessage") + <*> (o .:? "errorType") + +-- | ToJSON ErrorResponse +instance A.ToJSON ErrorResponse where + toJSON ErrorResponse {..} = + _omitNulls + [ "errorMessage" .= errorResponseErrorMessage + , "errorType" .= errorResponseErrorType + ] + + +-- | Construct a value of type 'ErrorResponse' (by applying it's required fields, if any) +mkErrorResponse + :: ErrorResponse +mkErrorResponse = + ErrorResponse + { errorResponseErrorMessage = Nothing + , errorResponseErrorType = Nothing + } + +-- ** StatusResponse +-- | StatusResponse +data StatusResponse = StatusResponse + { statusResponseStatus :: !(Maybe Text) -- ^ "status" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON StatusResponse +instance A.FromJSON StatusResponse where + parseJSON = A.withObject "StatusResponse" $ \o -> + StatusResponse + <$> (o .:? "status") + +-- | ToJSON StatusResponse +instance A.ToJSON StatusResponse where + toJSON StatusResponse {..} = + _omitNulls + [ "status" .= statusResponseStatus + ] + + +-- | Construct a value of type 'StatusResponse' (by applying it's required fields, if any) +mkStatusResponse + :: StatusResponse +mkStatusResponse = + StatusResponse + { statusResponseStatus = Nothing + } + + + + + diff --git a/lib/AWSLambdaRuntime/ModelLens.hs b/lib/AWSLambdaRuntime/ModelLens.hs new file mode 100644 --- /dev/null +++ b/lib/AWSLambdaRuntime/ModelLens.hs @@ -0,0 +1,79 @@ +{- + AWS Lambda Runtime API + + AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + + OpenAPI Version: 3.0.0 + AWS Lambda Runtime API API version: 1.0.3 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : AWSLambdaRuntime.Lens +-} + +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module AWSLambdaRuntime.ModelLens where + +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BL +import qualified Data.Data as P (Data, Typeable) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Time as TI + +import Data.Text (Text) + +import Prelude (($), (.),(<$>),(<*>),(=<<),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor) +import qualified Prelude as P + +import AWSLambdaRuntime.Model +import AWSLambdaRuntime.Core + + +-- * ErrorRequest + +-- | 'errorRequestErrorMessage' Lens +errorRequestErrorMessageL :: Lens_' ErrorRequest (Maybe Text) +errorRequestErrorMessageL f ErrorRequest{..} = (\errorRequestErrorMessage -> ErrorRequest { errorRequestErrorMessage, ..} ) <$> f errorRequestErrorMessage +{-# INLINE errorRequestErrorMessageL #-} + +-- | 'errorRequestErrorType' Lens +errorRequestErrorTypeL :: Lens_' ErrorRequest (Maybe Text) +errorRequestErrorTypeL f ErrorRequest{..} = (\errorRequestErrorType -> ErrorRequest { errorRequestErrorType, ..} ) <$> f errorRequestErrorType +{-# INLINE errorRequestErrorTypeL #-} + +-- | 'errorRequestStackTrace' Lens +errorRequestStackTraceL :: Lens_' ErrorRequest (Maybe [Text]) +errorRequestStackTraceL f ErrorRequest{..} = (\errorRequestStackTrace -> ErrorRequest { errorRequestStackTrace, ..} ) <$> f errorRequestStackTrace +{-# INLINE errorRequestStackTraceL #-} + + + +-- * ErrorResponse + +-- | 'errorResponseErrorMessage' Lens +errorResponseErrorMessageL :: Lens_' ErrorResponse (Maybe Text) +errorResponseErrorMessageL f ErrorResponse{..} = (\errorResponseErrorMessage -> ErrorResponse { errorResponseErrorMessage, ..} ) <$> f errorResponseErrorMessage +{-# INLINE errorResponseErrorMessageL #-} + +-- | 'errorResponseErrorType' Lens +errorResponseErrorTypeL :: Lens_' ErrorResponse (Maybe Text) +errorResponseErrorTypeL f ErrorResponse{..} = (\errorResponseErrorType -> ErrorResponse { errorResponseErrorType, ..} ) <$> f errorResponseErrorType +{-# INLINE errorResponseErrorTypeL #-} + + + +-- * StatusResponse + +-- | 'statusResponseStatus' Lens +statusResponseStatusL :: Lens_' StatusResponse (Maybe Text) +statusResponseStatusL f StatusResponse{..} = (\statusResponseStatus -> StatusResponse { statusResponseStatus, ..} ) <$> f statusResponseStatus +{-# INLINE statusResponseStatusL #-} + + diff --git a/lib/Zeit/Now.hs b/lib/Zeit/Now.hs new file mode 100644 --- /dev/null +++ b/lib/Zeit/Now.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Zeit.Now + ( NowInput(..) + , NowOutput(..) + , NowOutputBody(..) + , EventHandler + , runloop + , module Network.HTTP.Types.Header + , module Network.HTTP.Types.Method + , module Network.HTTP.Types.Status + ) where + +import Control.Exception +import Control.Monad +import qualified Data.Aeson as A +import AWSLambdaRuntime +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHC.Stack +import System.Environment +import Data.ByteArray.Encoding +import Network.HTTP.Client +import Network.HTTP.Types.Header (HeaderName) +import Network.HTTP.Types.Method (Method) +import Network.HTTP.Types.Status +import Network.Wai.Internal +-- import Text.Show.Pretty + +type EventHandler i o = i -> IO o + +hostPath :: L.ByteString +hostPath = "/2018-06-01" + +data NowInput = NowInput + { nowInputMethod :: Method + , nowInputHost :: T.Text + , nowInputPath :: T.Text + , nowInputHeaders :: H.HashMap HeaderName ByteString + , nowInputEncoding :: T.Text + , nowInputBody :: T.Text + } deriving (Show, Eq) + +instance A.FromJSON NowInput where + parseJSON = A.withObject "NowInput" $ \o -> do + nowInputMethod <- T.encodeUtf8 <$> o A..: "method" + nowInputHost <- o A..: "host" + nowInputPath <- o A..: "path" + textHeaders' <- o A..: "headers" + let nowInputHeaders = H.fromList $ + map (\(k, v) -> + ( CI.mk $ T.encodeUtf8 k + , T.encodeUtf8 v + )) $ H.toList textHeaders' + nowInputEncoding <- o A..: "encoding" + nowInputBody <- o A..: "body" + pure $ NowInput{..} + + +postRuntimeError :: Manager -> AWSLambdaRuntimeConfig -> AwsRequestId -> SomeException -> IO () +postRuntimeError man conf req e = + void $ do + let cs = callStack + strTrace <- case getCallStack cs of + [] -> map T.pack <$> whoCreated e + items -> pure $ T.lines $ T.pack $ prettyCallStack cs + void $ dispatchLbs man conf $ + setBodyParam + (runtimeInvocationAwsRequestIdErrorPost (ContentType MimeJSON) req) $ Body $ A.toJSON $ + ErrorRequest + { errorRequestErrorMessage = Just $ T.pack $ show e + , errorRequestErrorType = Nothing + , errorRequestStackTrace = Just strTrace + } + -- print resp + +runloop :: EventHandler NowInput NowOutput -> IO () +runloop h = do + man <- newManager defaultManagerSettings + __conf <- newConfig + apiEndpoint <- getEnv "AWS_LAMBDA_RUNTIME_API" + let conf = __conf { configHost = "http://" <> L.pack apiEndpoint <> hostPath } + forever $ do + nextResp <- dispatchLbs man conf runtimeInvocationNextGet + let (Just reqIdHdr) = lookup "Lambda-Runtime-Aws-Request-Id" $ responseHeaders nextResp + let reqId = AwsRequestId $ T.decodeUtf8 reqIdHdr + let dec = do + outer <- A.eitherDecode' $ responseBody nextResp + decodeInvocation outer + -- pPrint $ responseHeaders nextResp + handle (postRuntimeError man conf reqId) $ do + let ok = either error id dec + b <- h ok + void $ dispatchLbs man conf $ setBodyParam (runtimeInvocationAwsRequestIdResponsePost (ContentType MimeJSON) reqId) (Body $ A.toJSON b) + -- print respResp + +type Action = T.Text + +data Invocation a = Invocation + { invocationAction :: !Action + , invocationBody :: a + } deriving (Show, Eq) + +instance A.FromJSON a => A.FromJSON (Invocation a) where + parseJSON = A.withObject "Invocation" $ \o -> do + invocationAction <- o A..: "Action" + invocationBody <- o A..: "body" + pure $ Invocation{..} + +decodeInvocation :: A.FromJSON a => Invocation T.Text -> Either String a +decodeInvocation = A.eitherDecodeStrict' . T.encodeUtf8 . invocationBody + +data NowOutputBody + = TextBody !T.Text + | BytesBody !ByteString + +-- newtype Reversed f a = Reversed (f a) + +data NowOutput = NowOutput + { nowOutputStatus :: Status + , nowOutputHeaders :: !(H.HashMap HeaderName ByteString) + -- , nowOutputMultiValueHeaders :: !(H.HashMap T.Text (Reversed [] T.Text)) + , nowOutputBody :: !NowOutputBody + } + +instance A.ToJSON NowOutput where + toJSON (NowOutput s hs b) = A.object $ concat [statusFields, bodyFields, ["headers" A..= convertedHeaders]] + where + -- TODO can this be nicer? + convertedHeaders = H.fromList . map (\(k, v) -> (T.decodeUtf8 $ CI.foldedCase k, T.decodeUtf8 v)) $ H.toList hs + statusFields = + [ "statusCode" A..= statusCode s + , "statusDescription" A..= (T.decodeUtf8 $ statusMessage s) + ] + bodyFields = case b of + TextBody t -> + [ "body" A..= t + , "isBase64Encoded" A..= False + ] + BytesBody bs -> + [ "body" A..= T.decodeUtf8 (convertToBase Base64 bs) + , "isBase64Encoded" A..= True + ] diff --git a/now-haskell.cabal b/now-haskell.cabal new file mode 100644 --- /dev/null +++ b/now-haskell.cabal @@ -0,0 +1,140 @@ +name: now-haskell +version: 0.1.0.0 +synopsis: Zeit Now haskell-side integration and introspection tools. +description: . + Client library for calling the AWS Lambda Runtime API API based on http-client. + . + host: localhost + . + base path: http://localhost/2018-06-01 + . + AWS Lambda Runtime API API version: 1.0.3 + . + OpenAPI version: 3.0.0 + . +category: Web +author: Ian Duncan +maintainer: ian@iankduncan.com +copyright: 2019 - Ian Duncan +license: MIT +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + openapi.yaml + +Flag UseKatip + Description: Use the katip package to provide logging (if false, use the default monad-logger package) + Default: True + Manual: True + +library + hs-source-dirs: + lib + ghc-options: -Wall -funbox-strict-fields + build-depends: + aeson >=1.0 && <2.0 + , base >=4.7 && <5.0 + , base64-bytestring >1.0 && <2.0 + , bytestring >=0.10.0 && <0.11 + , case-insensitive + , containers >=0.5.0.0 && <0.8 + , deepseq >= 1.4 && <1.6 + , exceptions >= 0.4 + , http-api-data >= 0.3.4 && <0.5 + , http-client >=0.5 && <0.6 + , http-client-tls + , http-media >= 0.4 && < 0.8 + , http-types >=0.8 && <0.13 + , iso8601-time >=0.1.3 && <0.2.0 + , microlens >= 0.4.3 && <0.5 + , mtl >=2.2.1 + , network >=2.6.2 && <2.9 + , random >=1.1 + , safe-exceptions <0.2 + , text >=0.11 && <1.3 + , time >=1.5 && <1.10 + , transformers >=0.4.0.0 + , unordered-containers + , vector >=0.10.9 && <0.13 + , memory + , wai + other-modules: + Paths_now_haskell + AWSLambdaRuntime + AWSLambdaRuntime.API + AWSLambdaRuntime.API.ApiDefault + AWSLambdaRuntime.Client + AWSLambdaRuntime.Core + AWSLambdaRuntime.Logging + AWSLambdaRuntime.MimeTypes + AWSLambdaRuntime.Model + AWSLambdaRuntime.ModelLens + exposed-modules: + Zeit.Now + default-language: Haskell2010 + + if flag(UseKatip) + build-depends: katip >=0.8 && < 1.0 + other-modules: AWSLambdaRuntime.LoggingKatip + cpp-options: -DUSE_KATIP + else + build-depends: monad-logger >=0.3 && <0.4 + other-modules: AWSLambdaRuntime.LoggingMonadLogger + cpp-options: -DUSE_MONAD_LOGGER + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: + tests + ghc-options: -Wall -fno-warn-orphans + build-depends: + aws-lambda-runtime + , QuickCheck + , aeson + , base >=4.7 && <5.0 + , bytestring >=0.10.0 && <0.11 + , containers + , hspec >=1.8 + , iso8601-time + , mtl >=2.2.1 + , semigroups + , text + , time + , transformers >=0.4.0.0 + , unordered-containers + , vector + other-modules: + ApproxEq + Instances + PropMime + default-language: Haskell2010 + +executable module-scanner + main-is: Main.hs + other-modules: CabalScanner, + ModuleScanner + default-extensions: OverloadedStrings, + FlexibleContexts, + FlexibleInstances + hs-source-dirs: + src + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5.0 + , containers + , Cabal + , ghc-lib-parser + , yaml + , aeson + , aeson-pretty + , stack + , fused-effects + , bytestring + , text + , filepath + , directory + default-language: Haskell2010 + diff --git a/openapi.yaml b/openapi.yaml new file mode 100644 --- /dev/null +++ b/openapi.yaml @@ -0,0 +1,219 @@ +openapi: 3.0.0 +info: + description: AWS Lambda Runtime API is an HTTP API for implementing custom runtimes + title: AWS Lambda Runtime API + version: 1.0.3 +servers: +- url: /2018-06-01 +paths: + /runtime/init/error: + post: + parameters: + - explode: false + in: header + name: Lambda-Runtime-Function-Error-Type + required: false + schema: + type: string + style: simple + requestBody: + content: + '*/*': + schema: {} + responses: + 202: + content: + application/json: + schema: + $ref: '#/components/schemas/StatusResponse' + description: Accepted + 403: + content: + application/json: + schema: + $ref: '#/components/schemas/ErrorResponse' + description: Forbidden + 500: + description: | + Container error. Non-recoverable state. Runtime should exit promptly. + summary: | + Non-recoverable initialization error. Runtime should exit after reporting the error. Error will be served in response to the first invoke. + /runtime/invocation/next: + get: + responses: + 200: + content: + application/json: + schema: + $ref: '#/components/schemas/EventResponse' + description: | + This is an iterator-style blocking API call. Response contains event JSON document, specific to the invoking service. + headers: + Lambda-Runtime-Aws-Request-Id: + description: AWS request ID associated with the request. + explode: false + schema: + type: string + style: simple + Lambda-Runtime-Trace-Id: + description: X-Ray tracing header. + explode: false + schema: + type: string + style: simple + Lambda-Runtime-Client-Context: + description: | + Information about the client application and device when invoked through the AWS Mobile SDK. + explode: false + schema: + type: string + style: simple + Lambda-Runtime-Cognito-Identity: + description: | + Information about the Amazon Cognito identity provider when invoked through the AWS Mobile SDK. + explode: false + schema: + type: string + style: simple + Lambda-Runtime-Deadline-Ms: + description: | + Function execution deadline counted in milliseconds since the Unix epoch. + explode: false + schema: + type: string + style: simple + Lambda-Runtime-Invoked-Function-Arn: + description: | + The ARN requested. This can be different in each invoke that executes the same version. + explode: false + schema: + type: string + style: simple + 403: + content: + application/json: + schema: + $ref: '#/components/schemas/ErrorResponse' + description: Forbidden + 500: + description: | + Container error. Non-recoverable state. Runtime should exit promptly. + summary: | + Runtime makes this HTTP request when it is ready to receive and process a new invoke. + /runtime/invocation/{AwsRequestId}/response: + post: + parameters: + - explode: false + in: path + name: AwsRequestId + required: true + schema: + type: string + style: simple + requestBody: + content: + '*/*': + schema: {} + responses: + 202: + content: + application/json: + schema: + $ref: '#/components/schemas/StatusResponse' + description: Accepted + 400: + content: + application/json: + schema: + $ref: '#/components/schemas/ErrorResponse' + description: Bad Request + 403: + content: + application/json: + schema: + $ref: '#/components/schemas/ErrorResponse' + description: Forbidden + 413: + content: + application/json: + schema: + $ref: '#/components/schemas/ErrorResponse' + description: Payload Too Large + 500: + description: | + Container error. Non-recoverable state. Runtime should exit promptly. + summary: Runtime makes this request in order to submit a response. + /runtime/invocation/{AwsRequestId}/error: + post: + parameters: + - explode: false + in: path + name: AwsRequestId + required: true + schema: + type: string + style: simple + - explode: false + in: header + name: Lambda-Runtime-Function-Error-Type + required: false + schema: + type: string + style: simple + requestBody: + content: + '*/*': + schema: {} + responses: + 202: + content: + application/json: + schema: + $ref: '#/components/schemas/StatusResponse' + description: Accepted + 400: + content: + application/json: + schema: + $ref: '#/components/schemas/ErrorResponse' + description: Bad Request + 403: + content: + application/json: + schema: + $ref: '#/components/schemas/ErrorResponse' + description: Forbidden + 500: + description: | + Container error. Non-recoverable state. Runtime should exit promptly. + summary: | + Runtime makes this request in order to submit an error response. It can be either a function error, or a runtime error. Error will be served in response to the invoke. +components: + schemas: + StatusResponse: + example: + status: status + properties: + status: + type: string + type: object + ErrorResponse: + properties: + errorMessage: + type: string + errorType: + type: string + type: object + ErrorRequest: + properties: + errorMessage: + type: string + errorType: + type: string + stackTrace: + items: + type: string + type: array + type: object + EventResponse: + type: object diff --git a/src/CabalScanner.hs b/src/CabalScanner.hs new file mode 100644 --- /dev/null +++ b/src/CabalScanner.hs @@ -0,0 +1,165 @@ +module CabalScanner where + +import Data.Aeson +import qualified Data.Text as T + +-- Cabal things +import Distribution.Verbosity (normal) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration (flattenPackageDescription) -- TODO replace with finalizePD +import Distribution.PackageDescription.Parsec +import Distribution.Types.UnqualComponentName +import Distribution.ModuleName (ModuleName, fromComponents) +import Distribution.Simple.Utils + +import Data.List (inits) +import System.Directory +import System.Environment +import System.FilePath +import qualified ModuleScanner as Mod + +data Output + = PackageUsedOutput PackageInfo + | ModuleUsedOutput ModuleInfo + +instance ToJSON Output where + toJSON o = case o of + PackageUsedOutput p -> object + [ "type" .= ("package" :: T.Text) + , "data" .= p + ] + ModuleUsedOutput m -> object + [ "type" .= ("module" :: T.Text) + , "data" .= m + ] + +data ModulePackage + = Dangling + | InPackageLibrary FilePath + | InPackageExecutable + String -- ^ Executable name + FilePath + | InOtherPackageStanza FilePath + +data ModuleInfo = ModuleInfo + { moduleInfoPackage :: ModulePackage + , moduleInfoAnalysis :: Mod.Analyze + } + +instance ToJSON ModuleInfo where + toJSON (ModuleInfo p a) = object + [ "package" .= case p of + Dangling -> Null + InPackageLibrary fp -> object ["library" .= (takeBaseName fp), "path" .= fp] + InPackageExecutable e fp -> object ["executable" .= e, "path" .= fp] + InOtherPackageStanza fp -> object ["path" .= fp] + , "analysis" .= a + ] + +data PackageInfo = PackageInfo + { packageInfoExecutables :: [String] + } + +instance ToJSON PackageInfo where + toJSON (PackageInfo exes) = object + [ "executables" .= exes + {- + From cabal: + executables[].modulePath :: FilePath + resolve libraries[].modules with buildInfo + dataFiles :: [FilePath] + dataDir :: FilePath + extraSrcFiles :: [FilePath] + extraTmpFiles :: [FilePath] + extraDocFiles :: [FilePath] + -} + , "files" .= object + [ "executableModules" .= ([] :: [FilePath]) + ] + ] + +dispatchFileScan :: FilePath -> IO (Either ModuleInfo PackageInfo) +dispatchFileScan fp = case takeFileName fp of + "package.yml" -> error "hpack package.yml" + "package.yaml" -> error "hpack package.yaml" + other -> case takeExtension other of + ".hs" -> Left <$> performHaskellModuleScan fp + ".lhs" -> Left <$> performHaskellModuleScan fp + -- TODO + -- "chs" -> _ + ".cabal" -> Right <$> (produceFlatPackage fp >>= performCabalPackageScan) + unsupported -> error ("." ++ unsupported ++ " file extension is not a supported Haskell builder type.") + +performHaskellModuleScan :: FilePath -> IO ModuleInfo +performHaskellModuleScan relFp = do + fp <- canonicalizePath relFp + mCabalFile <- findClosestAncestorCabalFile fp + analysis <- Mod.readDesiredModule relFp + + case mCabalFile of + Nothing -> do + pure $ ModuleInfo Dangling analysis + Just cf -> do + flatPack <- produceFlatPackage cf + case library flatPack of + Nothing -> do + pure $ ModuleInfo (InOtherPackageStanza cf) analysis + Just l -> do + let relativeModulePath = makeRelative (takeDirectory cf) fp + desiredModule = fileToModule (hsSourceDirs $ libBuildInfo l) relativeModulePath + if desiredModule `isExposedFromLibrary` l + then do + pure $ ModuleInfo (InPackageLibrary cf) analysis + else error "TODO: not sure what to do here..." + +getCabalPackage :: FilePath -> IO PackageDescription +getCabalPackage p = do + efp <- findPackageDesc p + let fp = either error id efp + produceFlatPackage fp + +produceFlatPackage :: FilePath -> IO PackageDescription +produceFlatPackage fp = do + gpd <- readGenericPackageDescription normal fp + pure $ flattenPackageDescription gpd + +performCabalPackageScan :: PackageDescription -> IO PackageInfo +performCabalPackageScan gpd = do + let exes = map (unUnqualComponentName . exeName) $ executables gpd + pure $ PackageInfo exes + +-- Takes a path and searches for a cabal file up the directory hierarchy. returns a cabal file if found +findClosestAncestorCabalFile :: FilePath -> IO (Maybe FilePath) +findClosestAncestorCabalFile fp = do + isDir <- doesDirectoryExist fp + let startingDir = if isDir then fp else takeDirectory fp + dir <- canonicalizePath startingDir + let chunkedDir = splitPath dir + allPaths = map joinPath $ reverse $ tail $ inits chunkedDir + -- print allPaths + go allPaths + where + go [] = pure Nothing + go (path:ps) = do + res <- findPackageDesc path + case res of + Left _ -> go ps + Right p -> pure $ Just p + + +fileToModule + :: [FilePath] -- Search paths + -- -> [FilePath] -- Extensions + -> FilePath -- Haskell File + -> ModuleName +fileToModule searchPs startP = go searchPs + where + extensionless = dropExtension startP + go [] = fromComponents $ splitDirectories extensionless + go (p:ps) = let rel = makeRelative p extensionless in + if rel == extensionless + then go ps + else fromComponents $ splitDirectories rel + +isExposedFromLibrary :: ModuleName -> Library -> Bool +isExposedFromLibrary m l = m `elem` exposedModules l diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,34 @@ +module Main where + +import CabalScanner + +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy.Char8 as L +import System.Directory +import System.Environment + + + + +main :: IO () +main = do + (basePath:_) <- getArgs + isDir <- doesDirectoryExist basePath + out <- if isDir + then do + gpd <- getCabalPackage basePath + packInfo <- performCabalPackageScan gpd + -- TODO useful things here + pure $ PackageUsedOutput packInfo + else do + scan <- dispatchFileScan basePath + case scan of + Left modInfo -> do + case modInfo of + -- (ModuleInfo (InPackageLibrary fp) analysis) -> + _ -> return () + pure $ ModuleUsedOutput modInfo + Right packInfo -> do + -- TODO useful things here + pure $ PackageUsedOutput packInfo + L.putStrLn $ encodePretty out diff --git a/src/ModuleScanner.hs b/src/ModuleScanner.hs new file mode 100644 --- /dev/null +++ b/src/ModuleScanner.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE ViewPatterns #-} +module ModuleScanner where + +import Control.Effect +import Control.Effect.Reader +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Either (either) +import Data.Maybe +import Data.IORef +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as L + +-- GHC lib tasks +import Config +import DynFlags +import FastString +import Fingerprint +import HeaderInfo +import HsSyn +import Module +import Lexer +import Outputable +import Pretty +import Parser +import Platform +import RdrName +import StringBuffer +import SrcLoc + +import qualified Data.Map.Strict as Map +import System.IO + +import System.FilePath + +{- +TODO figure out how to 'flatten' GenericPackageDescription into PackageDescription +TODO figure out how to *write* package descriptions back out? +-} + +fakeLlvmConfig :: (LlvmTargets, LlvmPasses) +fakeLlvmConfig = ([], []) + +data Analyze = Analyze + { moduleName :: T.Text + -- , moduleType :: ModuleType + , functionName :: ModuleExports + , watch :: [FilePath] -- Local modules + } + +instance ToJSON Analyze where + toJSON (Analyze mn fn w) = object + [ "moduleName" .= mn + -- , "moduleType" .= mt + , "functionName" .= fn + , "watch" .= w + ] + +fakeSettings :: Settings +fakeSettings = + Settings + { sTargetPlatform = platform + , sPlatformConstants = platformConstants + , sProjectVersion = cProjectVersion + , sProgramName = "ghc" + , sOpt_P_fingerprint = fingerprint0 + , sTmpDir = "." + } + where + platform = + Platform + { platformWordSize = 8 + , platformOS = OSUnknown + , platformUnregisterised = True + } + -- This bit may need to be conditional on OS. + platformConstants = + PlatformConstants + { pc_DYNAMIC_BY_DEFAULT = False + , pc_WORD_SIZE = 8 + , pc_STD_HDR_SIZE = 1 + , pc_TAG_BITS = 3 + , pc_BLOCKS_PER_MBLOCK = 252 + , pc_BLOCK_SIZE = 4096 + , pc_MIN_PAYLOAD_SIZE = 1 + , pc_MAX_Real_Vanilla_REG = 6 + , pc_MAX_Vanilla_REG = 10 + , pc_MAX_Real_Long_REG = 0 + } + + + +readDesiredModule :: FilePath -> IO Analyze +readDesiredModule file = do + (flags, res) <- loadModule file + case res of + POk _ lm -> runM $ runReader flags $ do + -- printForUser flags stdout neverQualify (ppr $ unLoc lm) + r <- findMainOrHandler $ unLoc lm + let modName = T.pack $ maybe "Main" (moduleNameString . unLoc) $ hsmodName $ unLoc lm + pure $ Analyze modName r [] -- TODO + _ -> error "Failed to parse module!" + +mkDynFlags :: String -> String -> IO DynFlags +mkDynFlags filename s = do + dirs_to_clean <- newIORef Map.empty + files_to_clean <- newIORef emptyFilesToClean + next_temp_suffix <- newIORef 0 + let baseFlags = + (defaultDynFlags fakeSettings fakeLlvmConfig) { + ghcLink = NoLink + , hscTarget = HscNothing + , pkgDatabase = Just [] + , dirsToClean = dirs_to_clean + , filesToClean = files_to_clean + , nextTempSuffix = next_temp_suffix + , thisInstalledUnitId = toInstalledUnitId (stringToUnitId "module-scanner") + } + parsePragmasIntoDynFlags filename s baseFlags + where + parsePragmasIntoDynFlags :: String -> String -> DynFlags -> IO DynFlags + parsePragmasIntoDynFlags fp contents dflags0 = do + let opts = getOptions dflags0 (stringToStringBuffer contents) fp + (dflags, _, _) <- parseDynamicFilePragma dflags0 opts + return dflags + +runParser :: FilePath -> DynFlags -> String -> P a -> Lexer.ParseResult a +runParser p flags str parser = unP parser parseState + where + filename = p + location = mkRealSrcLoc (mkFastString filename) 1 1 + _buf = stringToStringBuffer str + parseState = mkPState flags _buf location + +loadModule :: FilePath -> IO (DynFlags, Lexer.ParseResult (Located (HsModule GhcPs))) +loadModule fp = do + contents <- readFile fp + flags <- mkDynFlags fp contents + pure (flags, runParser fp flags contents parseModule) + + +data ModuleExports + = ExportsMain + | ExportsHandler + | NoSupportedExport + deriving (Show) + +instance ToJSON ModuleExports where + toJSON e = case e of + ExportsMain -> String "main" + ExportsHandler -> String "handler" + NoSupportedExport -> Null + +data ModuleType + = Executable + | Library + deriving (Show) + +instance ToJSON ModuleType where + toJSON x = case x of + Executable -> String "Executable" + Library -> String "Library" + +findMainOrHandler :: (Member (Reader DynFlags) sig, Carrier sig m, MonadIO m) => HsModule GhcPs -> m ModuleExports +findMainOrHandler m = case hsmodExports m of + Nothing -> scanListDecls $ hsmodDecls m + Just lExps -> case map unLoc $ unLoc lExps of + [] -> pure NoSupportedExport + -- TODO handle other cases + exps -> do + expMs <- mapM checkExport exps + pure $ case expMs of + (r:_) -> r + _ -> NoSupportedExport + +rdrNameCheck :: RdrName -> ModuleExports +rdrNameCheck name = if mkVarUnqual (mkFastString "main") == name + then ExportsMain + else if mkVarUnqual (mkFastString "handler") == name + then ExportsHandler + else NoSupportedExport + +prettyPrintDump :: (Member (Reader DynFlags) sig, Carrier sig m, MonadIO m, Outputable a) => a -> m () +prettyPrintDump x = do + flags <- ask + liftIO $ printForUser flags stdout neverQualify (ppr x) + +checkExport :: (Member (Reader DynFlags) sig, Carrier sig m, MonadIO m) => IE GhcPs -> m ModuleExports +checkExport ie = do + -- prettyPrintDump ie + case ie of + IEVar _ wrappedName -> case unLoc wrappedName of + IEName name -> pure $ rdrNameCheck $ unLoc name + IEPattern _ -> pure NoSupportedExport + IEType _ -> pure NoSupportedExport + IEThingAbs _ _ -> pure NoSupportedExport + IEThingAll _ _ -> pure NoSupportedExport -- TODO + IEThingWith _ _ _ _ _ -> pure NoSupportedExport -- TODO + IEModuleContents _ _ -> pure NoSupportedExport -- TODO + IEGroup _ _ _ -> pure NoSupportedExport + IEDoc _ _ -> pure NoSupportedExport + IEDocNamed _ _ -> pure NoSupportedExport + XIE _ -> pure NoSupportedExport + +scanListDecls :: (Member (Reader DynFlags) sig, Carrier sig m, MonadIO m) => [LHsDecl GhcPs] -> m ModuleExports +scanListDecls decls = do + declMs <- mapM (scanDecl . unLoc) decls + pure $ case declMs of + [] -> NoSupportedExport + (r:_) -> r + +scanDecl :: (Member (Reader DynFlags) sig, Carrier sig m, MonadIO m) => HsDecl GhcPs -> m ModuleExports +scanDecl (ValD _ bind) = case bind of + (FunBind _ fid _ _ _) -> do + -- prettyPrintDump fid + pure $ rdrNameCheck $ unLoc fid + _ -> pure NoSupportedExport +scanDecl _ = pure NoSupportedExport diff --git a/tests/ApproxEq.hs b/tests/ApproxEq.hs new file mode 100644 --- /dev/null +++ b/tests/ApproxEq.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module ApproxEq where + +import Data.Text (Text) +import Data.Time.Clock +import Test.QuickCheck +import GHC.Generics as G + +(==~) + :: (ApproxEq a, Show a) + => a -> a -> Property +a ==~ b = counterexample (show a ++ " !=~ " ++ show b) (a =~ b) + +class GApproxEq f where + gApproxEq :: f a -> f a -> Bool + +instance GApproxEq U1 where + gApproxEq U1 U1 = True + +instance (GApproxEq a, GApproxEq b) => + GApproxEq (a :+: b) where + gApproxEq (L1 a) (L1 b) = gApproxEq a b + gApproxEq (R1 a) (R1 b) = gApproxEq a b + gApproxEq _ _ = False + +instance (GApproxEq a, GApproxEq b) => + GApproxEq (a :*: b) where + gApproxEq (a1 :*: b1) (a2 :*: b2) = gApproxEq a1 a2 && gApproxEq b1 b2 + +instance (ApproxEq a) => + GApproxEq (K1 i a) where + gApproxEq (K1 a) (K1 b) = a =~ b + +instance (GApproxEq f) => + GApproxEq (M1 i t f) where + gApproxEq (M1 a) (M1 b) = gApproxEq a b + +class ApproxEq a where + (=~) :: a -> a -> Bool + default (=~) :: (Generic a, GApproxEq (Rep a)) => a -> a -> Bool + a =~ b = gApproxEq (G.from a) (G.from b) + +instance ApproxEq Text where + (=~) = (==) + +instance ApproxEq Char where + (=~) = (==) + +instance ApproxEq Bool where + (=~) = (==) + +instance ApproxEq Int where + (=~) = (==) + +instance ApproxEq Double where + (=~) = (==) + +instance ApproxEq a => + ApproxEq (Maybe a) + +instance ApproxEq UTCTime where + (=~) = (==) + +instance ApproxEq a => + ApproxEq [a] where + as =~ bs = and (zipWith (=~) as bs) + +instance (ApproxEq l, ApproxEq r) => + ApproxEq (Either l r) where + Left a =~ Left b = a =~ b + Right a =~ Right b = a =~ b + _ =~ _ = False + +instance (ApproxEq l, ApproxEq r) => + ApproxEq (l, r) where + (=~) (l1, r1) (l2, r2) = l1 =~ l2 && r1 =~ r2 diff --git a/tests/Instances.hs b/tests/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Instances.hs @@ -0,0 +1,136 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} + +module Instances where + +import AWSLambdaRuntime.Model +import AWSLambdaRuntime.Core + +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Time as TI +import qualified Data.Vector as V + +import Control.Monad +import Data.Char (isSpace) +import Data.List (sort) +import Test.QuickCheck + +import ApproxEq + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary TI.Day where + arbitrary = TI.ModifiedJulianDay . (2000 +) <$> arbitrary + shrink = (TI.ModifiedJulianDay <$>) . shrink . TI.toModifiedJulianDay + +instance Arbitrary TI.UTCTime where + arbitrary = + TI.UTCTime <$> arbitrary <*> (TI.secondsToDiffTime <$> choose (0, 86401)) + +instance Arbitrary BL.ByteString where + arbitrary = BL.pack <$> arbitrary + shrink xs = BL.pack <$> shrink (BL.unpack xs) + +instance Arbitrary ByteArray where + arbitrary = ByteArray <$> arbitrary + shrink (ByteArray xs) = ByteArray <$> shrink xs + +instance Arbitrary Binary where + arbitrary = Binary <$> arbitrary + shrink (Binary xs) = Binary <$> shrink xs + +instance Arbitrary DateTime where + arbitrary = DateTime <$> arbitrary + shrink (DateTime xs) = DateTime <$> shrink xs + +instance Arbitrary Date where + arbitrary = Date <$> arbitrary + shrink (Date xs) = Date <$> shrink xs + +-- | A naive Arbitrary instance for A.Value: +instance Arbitrary A.Value where + arbitrary = frequency [(3, simpleTypes), (1, arrayTypes), (1, objectTypes)] + where + simpleTypes :: Gen A.Value + simpleTypes = + frequency + [ (1, return A.Null) + , (2, liftM A.Bool (arbitrary :: Gen Bool)) + , (2, liftM (A.Number . fromIntegral) (arbitrary :: Gen Int)) + , (2, liftM (A.String . T.pack) (arbitrary :: Gen String)) + ] + mapF (k, v) = (T.pack k, v) + simpleAndArrays = frequency [(1, sized sizedArray), (4, simpleTypes)] + arrayTypes = sized sizedArray + objectTypes = sized sizedObject + sizedArray n = liftM (A.Array . V.fromList) $ replicateM n simpleTypes + sizedObject n = + liftM (A.object . map mapF) $ + replicateM n $ (,) <$> (arbitrary :: Gen String) <*> simpleAndArrays + +-- | Checks if a given list has no duplicates in _O(n log n)_. +hasNoDups + :: (Ord a) + => [a] -> Bool +hasNoDups = go Set.empty + where + go _ [] = True + go s (x:xs) + | s' <- Set.insert x s + , Set.size s' > Set.size s = go s' xs + | otherwise = False + +instance ApproxEq TI.Day where + (=~) = (==) + +arbitraryReduced :: Arbitrary a => Int -> Gen a +arbitraryReduced n = resize (n `div` 2) arbitrary + +arbitraryReducedMaybe :: Arbitrary a => Int -> Gen (Maybe a) +arbitraryReducedMaybe 0 = elements [Nothing] +arbitraryReducedMaybe n = arbitraryReduced n + +arbitraryReducedMaybeValue :: Int -> Gen (Maybe A.Value) +arbitraryReducedMaybeValue 0 = elements [Nothing] +arbitraryReducedMaybeValue n = do + generated <- arbitraryReduced n + if generated == Just A.Null + then return Nothing + else return generated + +-- * Models + +instance Arbitrary ErrorRequest where + arbitrary = sized genErrorRequest + +genErrorRequest :: Int -> Gen ErrorRequest +genErrorRequest n = + ErrorRequest + <$> arbitraryReducedMaybe n -- errorRequestErrorMessage :: Maybe Text + <*> arbitraryReducedMaybe n -- errorRequestErrorType :: Maybe Text + <*> arbitraryReducedMaybe n -- errorRequestStackTrace :: Maybe [Text] + +instance Arbitrary ErrorResponse where + arbitrary = sized genErrorResponse + +genErrorResponse :: Int -> Gen ErrorResponse +genErrorResponse n = + ErrorResponse + <$> arbitraryReducedMaybe n -- errorResponseErrorMessage :: Maybe Text + <*> arbitraryReducedMaybe n -- errorResponseErrorType :: Maybe Text + +instance Arbitrary StatusResponse where + arbitrary = sized genStatusResponse + +genStatusResponse :: Int -> Gen StatusResponse +genStatusResponse n = + StatusResponse + <$> arbitraryReducedMaybe n -- statusResponseStatus :: Maybe Text + + + + diff --git a/tests/PropMime.hs b/tests/PropMime.hs new file mode 100644 --- /dev/null +++ b/tests/PropMime.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module PropMime where + +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.Monoid ((<>)) +import Data.Typeable (Proxy(..), typeOf, Typeable) +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Property +import Test.Hspec.QuickCheck (prop) + +import AWSLambdaRuntime.MimeTypes + +import ApproxEq + +-- * Type Aliases + +type ArbitraryMime mime a = ArbitraryRoundtrip (MimeUnrender mime) (MimeRender mime) a + +type ArbitraryRoundtrip from to a = (from a, to a, Arbitrary' a) + +type Arbitrary' a = (Arbitrary a, Show a, Typeable a) + +-- * Mime + +propMime + :: forall a b mime. + (ArbitraryMime mime a, Testable b) + => String -> (a -> a -> b) -> mime -> Proxy a -> Spec +propMime eqDescr eq m _ = + prop + (show (typeOf (undefined :: a)) <> " " <> show (typeOf (undefined :: mime)) <> " roundtrip " <> eqDescr) $ + \(x :: a) -> + let rendered = mimeRender' m x + actual = mimeUnrender' m rendered + expected = Right x + failMsg = + "ACTUAL: " <> show actual <> "\nRENDERED: " <> BL8.unpack rendered + in counterexample failMsg $ + either reject property (eq <$> actual <*> expected) + where + reject = property . const rejected + +propMimeEq :: (ArbitraryMime mime a, Eq a) => mime -> Proxy a -> Spec +propMimeEq = propMime "(EQ)" (==) diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module Main where + +import Data.Typeable (Proxy(..)) +import Test.Hspec +import Test.Hspec.QuickCheck + +import PropMime +import Instances () + +import AWSLambdaRuntime.Model +import AWSLambdaRuntime.MimeTypes + +main :: IO () +main = + hspec $ modifyMaxSize (const 10) $ do + describe "JSON instances" $ do + pure () + propMimeEq MimeJSON (Proxy :: Proxy ErrorRequest) + propMimeEq MimeJSON (Proxy :: Proxy ErrorResponse) + propMimeEq MimeJSON (Proxy :: Proxy StatusResponse) +