diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2023 Jake McArthur + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation and/or +other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,203 @@ +## OpenAPI Auto-Generated [http-client](https://www.stackage.org/lts-10.0/package/http-client-0.5.7.1) Bindings to `httpstan` + +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 httpstan API. + +OpenApi Version: 3.0.1 + +## 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 | | Httpstan | +| cabalPackage | Set the cabal package name, which consists of one or more alphanumeric words separated by hyphens | | httpstan | +| 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 | | HttpstanConfig | +| 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) | | | +| dateTimeParseFormat | overrides the format string used to parse a datetime | | | +| 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 | | HttpstanRequest | +| 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 | +| queryExtraUnreserved | Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':' | | | + +[1]: https://www.stackage.org/haddock/lts-9.0/iso8601-time-0.1.4/Data-Time-ISO8601.html#v:formatISO8601Millis + +An example setting _dateTimeFormat_ and _strictFields_: + +``` +java -jar openapi-generator-cli.jar generate -i petstore.yaml -g haskell-http-client -o output/haskell-http-client --additional-properties=dateTimeFormat="%Y-%m-%dT%H:%M:%S%Q%z" --additional-properties=strictFields=false +``` + +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 | +| ------------------- | --------------------------------------------------- | +| Httpstan.Client | use the "dispatch" functions to send requests | +| Httpstan.Core | core functions, config and request types | +| Httpstan.API | construct api requests | +| Httpstan.Model | describes api models | +| Httpstan.MimeTypes | encoding/decoding MIME types (content-types/accept) | +| Httpstan.ModelLens | lenses for model fields | +| Httpstan.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/httpstan.cabal b/httpstan.cabal new file mode 100644 --- /dev/null +++ b/httpstan.cabal @@ -0,0 +1,117 @@ +name: httpstan +version: 0.2.0.0 +synopsis: Auto-generated httpstan API Client +description: . + Client library for calling the httpstan API based on http-client. + . + host: localhost + . + base path: http://localhost + . + httpstan API version: 4.10.0 + . + OpenAPI version: 3.0.1 + . +category: Statistics +homepage: https://github.com/jmcarthur/httpstan-hs +author: Jake McArthur +maintainer: Jake.McArthur@email.com +copyright: 2023 - Jake McArthur +license: BSD3 +license-files: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + openapi.yaml + +source-repository head + type: git + location: git@github.com:jmcarthur/httpstan-hs.git + +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 && <3.0 + , base >=4.7 && <5.0 + , base64-bytestring >1.0 && <2.0 + , bytestring >= 0.11.4 && < 0.12 + , case-insensitive >= 1.2.1 && < 1.3 + , containers >=0.5.0.0 && <0.8 + , deepseq >= 1.4 && <1.6 + , exceptions >= 0.10.4 && < 0.11 + , http-api-data >= 0.3.4 && <0.5 + , http-client >=0.5 && <0.8 + , http-client-tls >= 0.3.6 && < 0.4 + , http-media >= 0.4 && < 0.9 + , http-types >=0.8 && <0.13 + , iso8601-time >=0.1.3 && <0.2.0 + , microlens >= 0.4.13 && < 0.5 + , mtl >= 2.2.2 && < 2.3 + , network >=2.6.2 && <3.9 + , random >= 1.2.1 && < 1.3 + , safe-exceptions <0.2 + , text >=0.11 && <1.3 + , time >= 1.11.1 && < 1.12 + , transformers >= 0.5.6 && < 0.6 + , unordered-containers >= 0.2.19 && < 0.3 + , vector >=0.10.9 && <0.13 + + other-modules: + Paths_httpstan + exposed-modules: + Httpstan + Httpstan.API + Httpstan.API.ApiDefault + Httpstan.Client + Httpstan.Core + Httpstan.Logging + Httpstan.MimeTypes + Httpstan.Model + Httpstan.ModelLens + default-language: Haskell2010 + + if flag(UseKatip) + build-depends: katip >=0.8 && < 1.0 + other-modules: Httpstan.LoggingKatip + cpp-options: -DUSE_KATIP + else + build-depends: monad-logger >=0.3 && <0.4 + other-modules: Httpstan.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: + httpstan + , QuickCheck + , aeson + , base >=4.7 && <5.0 + , bytestring >=0.10.0 + , 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 diff --git a/lib/Httpstan.hs b/lib/Httpstan.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan.hs @@ -0,0 +1,31 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan +-} + +module Httpstan + ( module Httpstan.API + , module Httpstan.Client + , module Httpstan.Core + , module Httpstan.Logging + , module Httpstan.MimeTypes + , module Httpstan.Model + , module Httpstan.ModelLens + ) where + +import Httpstan.API +import Httpstan.Client +import Httpstan.Core +import Httpstan.Logging +import Httpstan.MimeTypes +import Httpstan.Model +import Httpstan.ModelLens diff --git a/lib/Httpstan/API.hs b/lib/Httpstan/API.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/API.hs @@ -0,0 +1,19 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.API +-} + +module Httpstan.API + ( module Httpstan.API.ApiDefault + ) where + +import Httpstan.API.ApiDefault diff --git a/lib/Httpstan/API/ApiDefault.hs b/lib/Httpstan/API/ApiDefault.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/API/ApiDefault.hs @@ -0,0 +1,360 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.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 Httpstan.API.ApiDefault where + +import Httpstan.Core +import Httpstan.MimeTypes +import Httpstan.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 + +-- *** v1HealthGet + +-- | @GET \/v1\/health@ +-- +-- Check if service is running. +-- +v1HealthGet + :: HttpstanRequest V1HealthGet MimeNoContent NoContent MimeNoContent +v1HealthGet = + _mkRequest "GET" ["/v1/health"] + +data V1HealthGet +instance Produces V1HealthGet MimeNoContent + + +-- *** v1ModelsGet + +-- | @GET \/v1\/models@ +-- +-- List cached models. +-- +v1ModelsGet + :: HttpstanRequest V1ModelsGet MimeNoContent V1ModelsGet200Response MimeJSON +v1ModelsGet = + _mkRequest "GET" ["/v1/models"] + +data V1ModelsGet +-- | @application/json@ +instance Produces V1ModelsGet MimeJSON + + +-- *** v1ModelsModelIdDelete + +-- | @DELETE \/v1\/models\/{model_id}@ +-- +-- Delete a model and any associated fits. +-- +-- Delete a model which has been saved in the cache. +-- +v1ModelsModelIdDelete + :: ModelId -- ^ "modelId" - ID of Stan model + -> HttpstanRequest V1ModelsModelIdDelete MimeNoContent NoContent MimeNoContent +v1ModelsModelIdDelete (ModelId modelId) = + _mkRequest "DELETE" ["/v1/models/",toPath modelId] + +data V1ModelsModelIdDelete +instance Produces V1ModelsModelIdDelete MimeNoContent + + +-- *** v1ModelsModelIdFitsFitIdDelete + +-- | @DELETE \/v1\/models\/{model_id}\/fits\/{fit_id}@ +-- +-- Delete a fit. +-- +-- Delete a fit which has been saved in the cache. +-- +v1ModelsModelIdFitsFitIdDelete + :: ModelId -- ^ "modelId" - ID of Stan model associated with the fit. + -> FitId -- ^ "fitId" - ID of fit to be deleted. + -> HttpstanRequest V1ModelsModelIdFitsFitIdDelete MimeNoContent NoContent MimeNoContent +v1ModelsModelIdFitsFitIdDelete (ModelId modelId) (FitId fitId) = + _mkRequest "DELETE" ["/v1/models/",toPath modelId,"/fits/",toPath fitId] + +data V1ModelsModelIdFitsFitIdDelete +instance Produces V1ModelsModelIdFitsFitIdDelete MimeNoContent + + +-- *** v1ModelsModelIdFitsFitIdGet + +-- | @GET \/v1\/models\/{model_id}\/fits\/{fit_id}@ +-- +-- Get results returned by a function. +-- +-- Result (draws, logger messages) from calling a function defined in stan::services. +-- +v1ModelsModelIdFitsFitIdGet + :: ModelId -- ^ "modelId" - ID of Stan model associated with the result + -> FitId -- ^ "fitId" - ID of Stan result (\"fit\") desired + -> HttpstanRequest V1ModelsModelIdFitsFitIdGet MimeNoContent NoContent MimeNoContent +v1ModelsModelIdFitsFitIdGet (ModelId modelId) (FitId fitId) = + _mkRequest "GET" ["/v1/models/",toPath modelId,"/fits/",toPath fitId] + +data V1ModelsModelIdFitsFitIdGet +instance Produces V1ModelsModelIdFitsFitIdGet MimeNoContent + + +-- *** v1ModelsModelIdFitsPost + +-- | @POST \/v1\/models\/{model_id}\/fits@ +-- +-- Call function defined in stan::services. +-- +-- A request to this endpoint starts a long-running operation. Users can retrieve information about the status of the operation by making a GET request to the operations resource endpoint. When the operation is `done`, the \"fit\" may be downloaded. (A \"fit\" collects all logger and writer messages from Stan.) ``function`` indicates the name of the ``stan::services function`` which should be called given the Stan model associated with the id ``model_id``. For example, if sampling using ``stan::services::sample::hmc_nuts_diag_e_adapt`` then ``function`` is the full function name ``stan::services::sample::hmc_nuts_diag_e_adapt``. Sampler parameters which are not supplied will be given default values taken from CmdStan. For example, if ``stan::services::sample::hmc_nuts_diag_e_adapt`` is the function called and the parameter ``num_samples`` is not specified, the value 1000 will be used. For a full list of default values consult the CmdStan documentation. +-- +v1ModelsModelIdFitsPost + :: (Consumes V1ModelsModelIdFitsPost MimeJSON, MimeRender MimeJSON CreateFitRequest) + => CreateFitRequest -- ^ "body" - Full stan::services function name and associated arguments to call with Stan model. + -> ModelId -- ^ "modelId" - ID of Stan model to use + -> HttpstanRequest V1ModelsModelIdFitsPost MimeJSON Fit MimeJSON +v1ModelsModelIdFitsPost body (ModelId modelId) = + _mkRequest "POST" ["/v1/models/",toPath modelId,"/fits"] + `setBodyParam` body + +data V1ModelsModelIdFitsPost + +-- | /Body Param/ "body" - Full stan::services function name and associated arguments to call with Stan model. +instance HasBodyParam V1ModelsModelIdFitsPost CreateFitRequest + +-- | @application/json@ +instance Consumes V1ModelsModelIdFitsPost MimeJSON + +-- | @application/json@ +instance Produces V1ModelsModelIdFitsPost MimeJSON + + +-- *** v1ModelsModelIdLogProbGradPost + +-- | @POST \/v1\/models\/{model_id}\/log_prob_grad@ +-- +-- Return the gradient of the log posterior evaluated at the unconstrained parameters. +-- +-- Returns the output of Stan C++ `stan::model::log_prob_grad`. +-- +v1ModelsModelIdLogProbGradPost + :: (Consumes V1ModelsModelIdLogProbGradPost MimeJSON) + => ModelId -- ^ "modelId" - ID of Stan model to use + -> HttpstanRequest V1ModelsModelIdLogProbGradPost MimeJSON V1ModelsModelIdLogProbGradPost200Response MimeJSON +v1ModelsModelIdLogProbGradPost (ModelId modelId) = + _mkRequest "POST" ["/v1/models/",toPath modelId,"/log_prob_grad"] + +data V1ModelsModelIdLogProbGradPost + +-- | /Body Param/ "adjust_transform" - Boolean to control whether we apply a Jacobian adjust transform. +instance HasBodyParam V1ModelsModelIdLogProbGradPost AdjustTransform + +-- | @application/json@ +instance Consumes V1ModelsModelIdLogProbGradPost MimeJSON + +-- | @application/json@ +instance Produces V1ModelsModelIdLogProbGradPost MimeJSON + + +-- *** v1ModelsModelIdLogProbPost + +-- | @POST \/v1\/models\/{model_id}\/log_prob@ +-- +-- Return the log probability of the unconstrained parameters. +-- +-- Returns the output of Stan C++ ``log_prob`` model class method. +-- +v1ModelsModelIdLogProbPost + :: (Consumes V1ModelsModelIdLogProbPost MimeJSON) + => ModelId -- ^ "modelId" - ID of Stan model to use + -> HttpstanRequest V1ModelsModelIdLogProbPost MimeJSON V1ModelsModelIdLogProbPost200Response MimeJSON +v1ModelsModelIdLogProbPost (ModelId modelId) = + _mkRequest "POST" ["/v1/models/",toPath modelId,"/log_prob"] + +data V1ModelsModelIdLogProbPost + +-- | /Body Param/ "adjust_transform" - Boolean to control whether we apply a Jacobian adjust transform. +instance HasBodyParam V1ModelsModelIdLogProbPost AdjustTransform + +-- | @application/json@ +instance Consumes V1ModelsModelIdLogProbPost MimeJSON + +-- | @application/json@ +instance Produces V1ModelsModelIdLogProbPost MimeJSON + + +-- *** v1ModelsModelIdParamsPost + +-- | @POST \/v1\/models\/{model_id}\/params@ +-- +-- Get parameter names and dimensions. +-- +-- Returns the output of Stan C++ model class methods: ``constrained_param_names``, ``get_param_names`` and ``get_dims``. +-- +v1ModelsModelIdParamsPost + :: (Consumes V1ModelsModelIdParamsPost MimeJSON, MimeRender MimeJSON ParamData) + => ParamData -- ^ "_data" - Data for Stan Model. Needed to calculate param names and dimensions. + -> ModelId -- ^ "modelId" - ID of Stan model to use + -> HttpstanRequest V1ModelsModelIdParamsPost MimeJSON V1ModelsModelIdParamsPost200Response MimeJSON +v1ModelsModelIdParamsPost _data (ModelId modelId) = + _mkRequest "POST" ["/v1/models/",toPath modelId,"/params"] + `setBodyParam` _data + +data V1ModelsModelIdParamsPost + +-- | /Body Param/ "data" - Data for Stan Model. Needed to calculate param names and dimensions. +instance HasBodyParam V1ModelsModelIdParamsPost ParamData + +-- | @application/json@ +instance Consumes V1ModelsModelIdParamsPost MimeJSON + +-- | @application/json@ +instance Produces V1ModelsModelIdParamsPost MimeJSON + + +-- *** v1ModelsModelIdTransformInitsPost + +-- | @POST \/v1\/models\/{model_id}\/transform_inits@ +-- +-- Return a sequence of unconstrained parameters. +-- +-- Returns the output of Stan C++ ``transform_inits`` model class method. +-- +v1ModelsModelIdTransformInitsPost + :: (Consumes V1ModelsModelIdTransformInitsPost MimeJSON, MimeRender MimeJSON ConstrainedParameters) + => ConstrainedParameters -- ^ "constrainedParameters" - Constrained parameter values and their specified context + -> ModelId -- ^ "modelId" - ID of Stan model to use + -> HttpstanRequest V1ModelsModelIdTransformInitsPost MimeJSON V1ModelsModelIdTransformInitsPost200Response MimeJSON +v1ModelsModelIdTransformInitsPost constrainedParameters (ModelId modelId) = + _mkRequest "POST" ["/v1/models/",toPath modelId,"/transform_inits"] + `setBodyParam` constrainedParameters + +data V1ModelsModelIdTransformInitsPost + +-- | /Body Param/ "constrained_parameters" - Constrained parameter values and their specified context +instance HasBodyParam V1ModelsModelIdTransformInitsPost ConstrainedParameters + +-- | @application/json@ +instance Consumes V1ModelsModelIdTransformInitsPost MimeJSON + +-- | @application/json@ +instance Produces V1ModelsModelIdTransformInitsPost MimeJSON + + +-- *** v1ModelsModelIdWriteArrayPost + +-- | @POST \/v1\/models\/{model_id}\/write_array@ +-- +-- Return a sequence of constrained parameters. +-- +-- Returns the output of Stan C++ ``write_array`` model class method. +-- +v1ModelsModelIdWriteArrayPost + :: (Consumes V1ModelsModelIdWriteArrayPost MimeJSON, MimeRender MimeJSON IncludeGqs) + => IncludeGqs -- ^ "includeGqs" - Boolean to control whether we include generated quantities. + -> ModelId -- ^ "modelId" - ID of Stan model to use + -> HttpstanRequest V1ModelsModelIdWriteArrayPost MimeJSON V1ModelsModelIdWriteArrayPost200Response MimeJSON +v1ModelsModelIdWriteArrayPost includeGqs (ModelId modelId) = + _mkRequest "POST" ["/v1/models/",toPath modelId,"/write_array"] + `setBodyParam` includeGqs + +data V1ModelsModelIdWriteArrayPost + +-- | /Body Param/ "include_gqs" - Boolean to control whether we include generated quantities. +instance HasBodyParam V1ModelsModelIdWriteArrayPost IncludeGqs + +-- | @application/json@ +instance Consumes V1ModelsModelIdWriteArrayPost MimeJSON + +-- | @application/json@ +instance Produces V1ModelsModelIdWriteArrayPost MimeJSON + + +-- *** v1ModelsPost + +-- | @POST \/v1\/models@ +-- +-- Compile a Stan model +-- +v1ModelsPost + :: (Consumes V1ModelsPost MimeJSON, MimeRender MimeJSON CreateModelRequest) + => CreateModelRequest -- ^ "body" - Stan program code to compile + -> HttpstanRequest V1ModelsPost MimeJSON Model MimeJSON +v1ModelsPost body = + _mkRequest "POST" ["/v1/models"] + `setBodyParam` body + +data V1ModelsPost + +-- | /Body Param/ "body" - Stan program code to compile +instance HasBodyParam V1ModelsPost CreateModelRequest + +-- | @application/json@ +instance Consumes V1ModelsPost MimeJSON + +-- | @application/json@ +instance Produces V1ModelsPost MimeJSON + + +-- *** v1OperationsOperationIdGet + +-- | @GET \/v1\/operations\/{operation_id}@ +-- +-- Get Operation details. +-- +-- Return Operation details. Details about an Operation include whether or not the operation is `done` and information about the progress of sampling. +-- +v1OperationsOperationIdGet + :: OperationId -- ^ "operationId" - ID of Operation + -> HttpstanRequest V1OperationsOperationIdGet MimeNoContent Operation MimeJSON +v1OperationsOperationIdGet (OperationId operationId) = + _mkRequest "GET" ["/v1/operations/",toPath operationId] + +data V1OperationsOperationIdGet +-- | @application/json@ +instance Produces V1OperationsOperationIdGet MimeJSON + diff --git a/lib/Httpstan/Client.hs b/lib/Httpstan/Client.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/Client.hs @@ -0,0 +1,223 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.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 Httpstan.Client where + +import Httpstan.Core +import Httpstan.Logging +import Httpstan.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 as B +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 + -> HttpstanConfig -- ^ config + -> HttpstanRequest 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 (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 + -> HttpstanConfig -- ^ config + -> HttpstanRequest 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 + -> HttpstanConfig -- ^ config + -> HttpstanRequest 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 + -> HttpstanConfig -- ^ config + -> HttpstanRequest 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 + -> HttpstanConfig -- ^ 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) + => HttpstanConfig -- ^ config + -> HttpstanRequest 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 + params = rParams req2 + reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders params + reqQuery = let query = paramsQuery params + queryExtraUnreserved = configQueryExtraUnreserved config + in if B.null queryExtraUnreserved + then NH.renderQuery True query + else NH.renderQueryPartialEscape True (toPartialEscapeQuery queryExtraUnreserved query) + pReq = parsedReq { NH.method = rMethod req2 + , NH.requestHeaders = reqHeaders + , NH.queryString = reqQuery + } + outReq <- case paramsBody params 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 + => HttpstanConfig -> LogExec m a +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 -> HttpstanConfig -> LogExec m a +runConfigLogWithExceptions src config = runConfigLog config . logExceptions src diff --git a/lib/Httpstan/Core.hs b/lib/Httpstan/Core.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/Core.hs @@ -0,0 +1,581 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.Core +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module Httpstan.Core where + +import Httpstan.MimeTypes +import Httpstan.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.Kind as K (Type) +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 Text.Printf as T +import qualified Web.FormUrlEncoded as WH +import qualified Web.HttpApiData as WH + +import Control.Applicative ((<|>)) +import Control.Applicative (Alternative) +import Control.Monad.Fail (MonadFail) +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, maybe) + +-- * HttpstanConfig + +-- | +data HttpstanConfig = HttpstanConfig + { 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 + , configQueryExtraUnreserved :: B.ByteString -- ^ Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':' + } + +-- | display the config +instance P.Show HttpstanConfig where + show c = + T.printf + "{ configHost = %v, configUserAgent = %v, ..}" + (show (configHost c)) + (show (configUserAgent c)) + +-- | constructs a default HttpstanConfig +-- +-- configHost: +-- +-- @http://localhost@ +-- +-- configUserAgent: +-- +-- @"httpstan/0.1.0.0"@ +-- +newConfig :: IO HttpstanConfig +newConfig = do + logCxt <- initLogContext + return $ HttpstanConfig + { configHost = "http://localhost" + , configUserAgent = "httpstan/0.1.0.0" + , configLogExecWithContext = runDefaultLogExecWithContext + , configLogContext = logCxt + , configAuthMethods = [] + , configValidateAuthMethods = True + , configQueryExtraUnreserved = "" + } + +-- | updates config use AuthMethod on matching requests +addAuthMethod :: AuthMethod auth => HttpstanConfig -> auth -> HttpstanConfig +addAuthMethod config@HttpstanConfig {configAuthMethods = as} a = + config { configAuthMethods = AnyAuthMethod a : as} + +-- | updates the config to use stdout logging +withStdoutLogging :: HttpstanConfig -> IO HttpstanConfig +withStdoutLogging p = do + logCxt <- stdoutLoggingContext (configLogContext p) + return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt } + +-- | updates the config to use stderr logging +withStderrLogging :: HttpstanConfig -> IO HttpstanConfig +withStderrLogging p = do + logCxt <- stderrLoggingContext (configLogContext p) + return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt } + +-- | updates the config to disable logging +withNoLogging :: HttpstanConfig -> HttpstanConfig +withNoLogging p = p { configLogExecWithContext = runNullLogExec} + +-- * HttpstanRequest + +-- | Represents a request. +-- +-- Type Variables: +-- +-- * req - request operation +-- * contentType - 'MimeType' associated with request body +-- * res - response model +-- * accept - 'MimeType' associated with response body +data HttpstanRequest req contentType res accept = HttpstanRequest + { rMethod :: NH.Method -- ^ Method of HttpstanRequest + , rUrlPath :: [BCL.ByteString] -- ^ Endpoint of HttpstanRequest + , rParams :: Params -- ^ params of HttpstanRequest + , rAuthTypes :: [P.TypeRep] -- ^ types of auth methods + } + deriving (P.Show) + +-- | 'rMethod' Lens +rMethodL :: Lens_' (HttpstanRequest req contentType res accept) NH.Method +rMethodL f HttpstanRequest{..} = (\rMethod -> HttpstanRequest { rMethod, ..} ) <$> f rMethod +{-# INLINE rMethodL #-} + +-- | 'rUrlPath' Lens +rUrlPathL :: Lens_' (HttpstanRequest req contentType res accept) [BCL.ByteString] +rUrlPathL f HttpstanRequest{..} = (\rUrlPath -> HttpstanRequest { rUrlPath, ..} ) <$> f rUrlPath +{-# INLINE rUrlPathL #-} + +-- | 'rParams' Lens +rParamsL :: Lens_' (HttpstanRequest req contentType res accept) Params +rParamsL f HttpstanRequest{..} = (\rParams -> HttpstanRequest { rParams, ..} ) <$> f rParams +{-# INLINE rParamsL #-} + +-- | 'rParams' Lens +rAuthTypesL :: Lens_' (HttpstanRequest req contentType res accept) [P.TypeRep] +rAuthTypesL f HttpstanRequest{..} = (\rAuthTypes -> HttpstanRequest { 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) => HttpstanRequest req contentType res accept -> param -> HttpstanRequest 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 :: HttpstanRequest req contentType res accept -> param -> HttpstanRequest req contentType res accept + applyOptionalParam = (-&-) + {-# INLINE applyOptionalParam #-} + + -- | infix operator \/ alias for 'addOptionalParam' + (-&-) :: HttpstanRequest req contentType res accept -> param -> HttpstanRequest 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) + +-- ** HttpstanRequest Utils + +_mkRequest :: NH.Method -- ^ Method + -> [BCL.ByteString] -- ^ Endpoint + -> HttpstanRequest req contentType res accept -- ^ req: Request Type, res: Response Type +_mkRequest m u = HttpstanRequest m u _mkParams [] + +_mkParams :: Params +_mkParams = Params [] [] ParamBodyNone + +setHeader :: + HttpstanRequest req contentType res accept + -> [NH.Header] + -> HttpstanRequest req contentType res accept +setHeader req header = + req `removeHeader` P.fmap P.fst header + & (`addHeader` header) + +addHeader :: + HttpstanRequest req contentType res accept + -> [NH.Header] + -> HttpstanRequest req contentType res accept +addHeader req header = L.over (rParamsL . paramsHeadersL) (header P.++) req + +removeHeader :: HttpstanRequest req contentType res accept -> [NH.HeaderName] -> HttpstanRequest 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 => HttpstanRequest req contentType res accept -> HttpstanRequest 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 => HttpstanRequest req contentType res accept -> HttpstanRequest 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 :: + HttpstanRequest req contentType res accept + -> [NH.QueryItem] + -> HttpstanRequest req contentType res accept +setQuery req query = + req & + L.over + (rParamsL . paramsQueryL) + (P.filter (\q -> cifst q `P.notElem` P.fmap cifst query)) & + (`addQuery` query) + where + cifst = CI.mk . P.fst + +addQuery :: + HttpstanRequest req contentType res accept + -> [NH.QueryItem] + -> HttpstanRequest req contentType res accept +addQuery req query = req & L.over (rParamsL . paramsQueryL) (query P.++) + +addForm :: HttpstanRequest req contentType res accept -> WH.Form -> HttpstanRequest 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 :: HttpstanRequest req contentType res accept -> NH.Part -> HttpstanRequest 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 :: HttpstanRequest req contentType res accept -> B.ByteString -> HttpstanRequest req contentType res accept +_setBodyBS req body = + req & L.set (rParamsL . paramsBodyL) (ParamBodyB body) + +_setBodyLBS :: HttpstanRequest req contentType res accept -> BL.ByteString -> HttpstanRequest req contentType res accept +_setBodyLBS req body = + req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body) + +_hasAuthType :: AuthMethod authMethod => HttpstanRequest req contentType res accept -> P.Proxy authMethod -> HttpstanRequest 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 + +toPartialEscapeQuery :: B.ByteString -> NH.Query -> NH.PartialEscapeQuery +toPartialEscapeQuery extraUnreserved query = fmap (\(k, v) -> (k, maybe [] go v)) query + where go :: B.ByteString -> [NH.EscapeItem] + go v = v & B.groupBy (\a b -> a `B.notElem` extraUnreserved && b `B.notElem` extraUnreserved) + & fmap (\xs -> if B.null xs then NH.QN xs + else if B.head xs `B.elem` extraUnreserved + then NH.QN xs -- Not Encoded + else NH.QE xs -- Encoded + ) + +-- *** 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 + :: HttpstanConfig + -> a + -> HttpstanRequest req contentType res accept + -> IO (HttpstanRequest 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 + :: HttpstanRequest req contentType res accept + -> HttpstanConfig + -> IO (HttpstanRequest req contentType res accept) +_applyAuthMethods req config@(HttpstanConfig {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) +#if MIN_VERSION_aeson(2,0,0) +_omitNulls :: [(A.Key, A.Value)] -> A.Value +#else +_omitNulls :: [(Text, A.Value)] -> A.Value +#endif +_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) +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.maybe (P.Left "parseUrlPiece @DateTime") P.Right . _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 :: (MonadFail m, Alternative m) => String -> m DateTime +_readDateTime s = + DateTime <$> _parseISO8601 s +{-# 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, MonadFail 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) +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.maybe (P.Left "parseUrlPiece @Date") P.Right . _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 :: MonadFail m => String -> m Date +_readDate s = Date <$> TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d" s +{-# 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.maybe (P.Left "parseUrlPiece @ByteArray") P.Right . _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 :: MonadFail 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.maybe (P.Left "parseUrlPiece @Binary") P.Right . _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 :: MonadFail 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 :: K.Type -> K.Type). Functor f => (a -> f b) -> s -> f t diff --git a/lib/Httpstan/Logging.hs b/lib/Httpstan/Logging.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/Logging.hs @@ -0,0 +1,33 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.Logging +Logging functions +-} +{-# LANGUAGE CPP #-} + +#ifdef USE_KATIP + +module Httpstan.Logging + ( module Httpstan.LoggingKatip + ) where + +import Httpstan.LoggingKatip + +#else + +module Httpstan.Logging + ( module Httpstan.LoggingMonadLogger + ) where + +import Httpstan.LoggingMonadLogger + +#endif diff --git a/lib/Httpstan/LoggingKatip.hs b/lib/Httpstan/LoggingKatip.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/LoggingKatip.hs @@ -0,0 +1,117 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.LoggingKatip +Katip Logging functions +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Httpstan.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 a. P.MonadIO m => + LogContext -> LogExec m a + +-- | A Katip logging block +type LogExec m 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 "Httpstan" "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/Httpstan/LoggingMonadLogger.hs b/lib/Httpstan/LoggingMonadLogger.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/LoggingMonadLogger.hs @@ -0,0 +1,126 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.LoggingMonadLogger +monad-logger Logging functions +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Httpstan.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.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 a. P.MonadIO m => + LogContext -> LogExec m a + +-- | A monad-logger block +type LogExec m 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 ("Httpstan." <> 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/Httpstan/MimeTypes.hs b/lib/Httpstan/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/MimeTypes.hs @@ -0,0 +1,203 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.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 Httpstan.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/Httpstan/Model.hs b/lib/Httpstan/Model.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/Model.hs @@ -0,0 +1,627 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.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 Httpstan.Model where + +import Httpstan.Core +import Httpstan.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 + + +-- ** AdjustTransform +newtype AdjustTransform = AdjustTransform { unAdjustTransform :: Bool } deriving (P.Eq, P.Show, A.ToJSON) + +-- ** ConstrainedParameters +newtype ConstrainedParameters = ConstrainedParameters { unConstrainedParameters :: A.Value } deriving (P.Eq, P.Show, A.ToJSON) + +-- ** FitId +newtype FitId = FitId { unFitId :: Text } deriving (P.Eq, P.Show) + +-- ** IncludeGqs +newtype IncludeGqs = IncludeGqs { unIncludeGqs :: Bool } deriving (P.Eq, P.Show, A.ToJSON) + +-- ** ModelId +newtype ModelId = ModelId { unModelId :: Text } deriving (P.Eq, P.Show) + +-- ** OperationId +newtype OperationId = OperationId { unOperationId :: Text } deriving (P.Eq, P.Show) + +-- ** ParamData +newtype ParamData = ParamData { unParamData :: A.Value } deriving (P.Eq, P.Show, A.ToJSON) + +-- * Models + + +-- ** CreateFitRequest +-- | CreateFitRequest +data CreateFitRequest = CreateFitRequest + { createFitRequestChain :: !(Maybe Int) -- ^ "chain" + , createFitRequestData :: !(Maybe A.Value) -- ^ "data" + , createFitRequestDelta :: !(Maybe Double) -- ^ "delta" + , createFitRequestFunction :: !(E'Function) -- ^ /Required/ "function" + , createFitRequestGamma :: !(Maybe Double) -- ^ "gamma" + , createFitRequestInit :: !(Maybe A.Value) -- ^ "init" + , createFitRequestInitBuffer :: !(Maybe Int) -- ^ "init_buffer" + , createFitRequestInitRadius :: !(Maybe Double) -- ^ "init_radius" + , createFitRequestKappa :: !(Maybe Double) -- ^ "kappa" + , createFitRequestMaxDepth :: !(Maybe Int) -- ^ "max_depth" + , createFitRequestNumSamples :: !(Maybe Int) -- ^ "num_samples" + , createFitRequestNumThin :: !(Maybe Int) -- ^ "num_thin" + , createFitRequestNumWarmup :: !(Maybe Int) -- ^ "num_warmup" + , createFitRequestRandomSeed :: !(Maybe Int) -- ^ "random_seed" + , createFitRequestRefresh :: !(Maybe Int) -- ^ "refresh" + , createFitRequestSaveWarmup :: !(Maybe Bool) -- ^ "save_warmup" + , createFitRequestStepsize :: !(Maybe Double) -- ^ "stepsize" + , createFitRequestStepsizeJitter :: !(Maybe Double) -- ^ "stepsize_jitter" + , createFitRequestT0 :: !(Maybe Double) -- ^ "t0" + , createFitRequestTermBuffer :: !(Maybe Int) -- ^ "term_buffer" + , createFitRequestWindow :: !(Maybe Int) -- ^ "window" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON CreateFitRequest +instance A.FromJSON CreateFitRequest where + parseJSON = A.withObject "CreateFitRequest" $ \o -> + CreateFitRequest + <$> (o .:? "chain") + <*> (o .:? "data") + <*> (o .:? "delta") + <*> (o .: "function") + <*> (o .:? "gamma") + <*> (o .:? "init") + <*> (o .:? "init_buffer") + <*> (o .:? "init_radius") + <*> (o .:? "kappa") + <*> (o .:? "max_depth") + <*> (o .:? "num_samples") + <*> (o .:? "num_thin") + <*> (o .:? "num_warmup") + <*> (o .:? "random_seed") + <*> (o .:? "refresh") + <*> (o .:? "save_warmup") + <*> (o .:? "stepsize") + <*> (o .:? "stepsize_jitter") + <*> (o .:? "t0") + <*> (o .:? "term_buffer") + <*> (o .:? "window") + +-- | ToJSON CreateFitRequest +instance A.ToJSON CreateFitRequest where + toJSON CreateFitRequest {..} = + _omitNulls + [ "chain" .= createFitRequestChain + , "data" .= createFitRequestData + , "delta" .= createFitRequestDelta + , "function" .= createFitRequestFunction + , "gamma" .= createFitRequestGamma + , "init" .= createFitRequestInit + , "init_buffer" .= createFitRequestInitBuffer + , "init_radius" .= createFitRequestInitRadius + , "kappa" .= createFitRequestKappa + , "max_depth" .= createFitRequestMaxDepth + , "num_samples" .= createFitRequestNumSamples + , "num_thin" .= createFitRequestNumThin + , "num_warmup" .= createFitRequestNumWarmup + , "random_seed" .= createFitRequestRandomSeed + , "refresh" .= createFitRequestRefresh + , "save_warmup" .= createFitRequestSaveWarmup + , "stepsize" .= createFitRequestStepsize + , "stepsize_jitter" .= createFitRequestStepsizeJitter + , "t0" .= createFitRequestT0 + , "term_buffer" .= createFitRequestTermBuffer + , "window" .= createFitRequestWindow + ] + + +-- | Construct a value of type 'CreateFitRequest' (by applying it's required fields, if any) +mkCreateFitRequest + :: E'Function -- ^ 'createFitRequestFunction' + -> CreateFitRequest +mkCreateFitRequest createFitRequestFunction = + CreateFitRequest + { createFitRequestChain = Nothing + , createFitRequestData = Nothing + , createFitRequestDelta = Nothing + , createFitRequestFunction + , createFitRequestGamma = Nothing + , createFitRequestInit = Nothing + , createFitRequestInitBuffer = Nothing + , createFitRequestInitRadius = Nothing + , createFitRequestKappa = Nothing + , createFitRequestMaxDepth = Nothing + , createFitRequestNumSamples = Nothing + , createFitRequestNumThin = Nothing + , createFitRequestNumWarmup = Nothing + , createFitRequestRandomSeed = Nothing + , createFitRequestRefresh = Nothing + , createFitRequestSaveWarmup = Nothing + , createFitRequestStepsize = Nothing + , createFitRequestStepsizeJitter = Nothing + , createFitRequestT0 = Nothing + , createFitRequestTermBuffer = Nothing + , createFitRequestWindow = Nothing + } + +-- ** CreateModelRequest +-- | CreateModelRequest +data CreateModelRequest = CreateModelRequest + { createModelRequestProgramCode :: !(Text) -- ^ /Required/ "program_code" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON CreateModelRequest +instance A.FromJSON CreateModelRequest where + parseJSON = A.withObject "CreateModelRequest" $ \o -> + CreateModelRequest + <$> (o .: "program_code") + +-- | ToJSON CreateModelRequest +instance A.ToJSON CreateModelRequest where + toJSON CreateModelRequest {..} = + _omitNulls + [ "program_code" .= createModelRequestProgramCode + ] + + +-- | Construct a value of type 'CreateModelRequest' (by applying it's required fields, if any) +mkCreateModelRequest + :: Text -- ^ 'createModelRequestProgramCode' + -> CreateModelRequest +mkCreateModelRequest createModelRequestProgramCode = + CreateModelRequest + { createModelRequestProgramCode + } + +-- ** Fit +-- | Fit +data Fit = Fit + { fitName :: !(Text) -- ^ /Required/ "name" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON Fit +instance A.FromJSON Fit where + parseJSON = A.withObject "Fit" $ \o -> + Fit + <$> (o .: "name") + +-- | ToJSON Fit +instance A.ToJSON Fit where + toJSON Fit {..} = + _omitNulls + [ "name" .= fitName + ] + + +-- | Construct a value of type 'Fit' (by applying it's required fields, if any) +mkFit + :: Text -- ^ 'fitName' + -> Fit +mkFit fitName = + Fit + { fitName + } + +-- ** Model +-- | Model +data Model = Model + { modelCompilerOutput :: !(Text) -- ^ /Required/ "compiler_output" + , modelName :: !(Text) -- ^ /Required/ "name" + , modelStancWarnings :: !(Text) -- ^ /Required/ "stanc_warnings" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON Model +instance A.FromJSON Model where + parseJSON = A.withObject "Model" $ \o -> + Model + <$> (o .: "compiler_output") + <*> (o .: "name") + <*> (o .: "stanc_warnings") + +-- | ToJSON Model +instance A.ToJSON Model where + toJSON Model {..} = + _omitNulls + [ "compiler_output" .= modelCompilerOutput + , "name" .= modelName + , "stanc_warnings" .= modelStancWarnings + ] + + +-- | Construct a value of type 'Model' (by applying it's required fields, if any) +mkModel + :: Text -- ^ 'modelCompilerOutput' + -> Text -- ^ 'modelName' + -> Text -- ^ 'modelStancWarnings' + -> Model +mkModel modelCompilerOutput modelName modelStancWarnings = + Model + { modelCompilerOutput + , modelName + , modelStancWarnings + } + +-- ** Operation +-- | Operation +data Operation = Operation + { operationDone :: !(Bool) -- ^ /Required/ "done" + , operationMetadata :: !(Maybe A.Value) -- ^ "metadata" + , operationName :: !(Text) -- ^ /Required/ "name" + , operationResult :: !(Maybe A.Value) -- ^ "result" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON Operation +instance A.FromJSON Operation where + parseJSON = A.withObject "Operation" $ \o -> + Operation + <$> (o .: "done") + <*> (o .:? "metadata") + <*> (o .: "name") + <*> (o .:? "result") + +-- | ToJSON Operation +instance A.ToJSON Operation where + toJSON Operation {..} = + _omitNulls + [ "done" .= operationDone + , "metadata" .= operationMetadata + , "name" .= operationName + , "result" .= operationResult + ] + + +-- | Construct a value of type 'Operation' (by applying it's required fields, if any) +mkOperation + :: Bool -- ^ 'operationDone' + -> Text -- ^ 'operationName' + -> Operation +mkOperation operationDone operationName = + Operation + { operationDone + , operationMetadata = Nothing + , operationName + , operationResult = Nothing + } + +-- ** Parameter +-- | Parameter +data Parameter = Parameter + { parameterConstrainedNames :: !([Text]) -- ^ /Required/ "constrained_names" + , parameterDims :: !([Int]) -- ^ /Required/ "dims" + , parameterName :: !(Text) -- ^ /Required/ "name" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON Parameter +instance A.FromJSON Parameter where + parseJSON = A.withObject "Parameter" $ \o -> + Parameter + <$> (o .: "constrained_names") + <*> (o .: "dims") + <*> (o .: "name") + +-- | ToJSON Parameter +instance A.ToJSON Parameter where + toJSON Parameter {..} = + _omitNulls + [ "constrained_names" .= parameterConstrainedNames + , "dims" .= parameterDims + , "name" .= parameterName + ] + + +-- | Construct a value of type 'Parameter' (by applying it's required fields, if any) +mkParameter + :: [Text] -- ^ 'parameterConstrainedNames' + -> [Int] -- ^ 'parameterDims' + -> Text -- ^ 'parameterName' + -> Parameter +mkParameter parameterConstrainedNames parameterDims parameterName = + Parameter + { parameterConstrainedNames + , parameterDims + , parameterName + } + +-- ** Status +-- | Status +data Status = Status + { statusCode :: !(Int) -- ^ /Required/ "code" + , statusDetails :: !(Maybe [A.Value]) -- ^ "details" + , statusMessage :: !(Text) -- ^ /Required/ "message" + , statusStatus :: !(Text) -- ^ /Required/ "status" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON Status +instance A.FromJSON Status where + parseJSON = A.withObject "Status" $ \o -> + Status + <$> (o .: "code") + <*> (o .:? "details") + <*> (o .: "message") + <*> (o .: "status") + +-- | ToJSON Status +instance A.ToJSON Status where + toJSON Status {..} = + _omitNulls + [ "code" .= statusCode + , "details" .= statusDetails + , "message" .= statusMessage + , "status" .= statusStatus + ] + + +-- | Construct a value of type 'Status' (by applying it's required fields, if any) +mkStatus + :: Int -- ^ 'statusCode' + -> Text -- ^ 'statusMessage' + -> Text -- ^ 'statusStatus' + -> Status +mkStatus statusCode statusMessage statusStatus = + Status + { statusCode + , statusDetails = Nothing + , statusMessage + , statusStatus + } + +-- ** V1ModelsGet200Response +-- | V1ModelsGet200Response +data V1ModelsGet200Response = V1ModelsGet200Response + { v1ModelsGet200ResponseModels :: !(Maybe [Model]) -- ^ "models" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON V1ModelsGet200Response +instance A.FromJSON V1ModelsGet200Response where + parseJSON = A.withObject "V1ModelsGet200Response" $ \o -> + V1ModelsGet200Response + <$> (o .:? "models") + +-- | ToJSON V1ModelsGet200Response +instance A.ToJSON V1ModelsGet200Response where + toJSON V1ModelsGet200Response {..} = + _omitNulls + [ "models" .= v1ModelsGet200ResponseModels + ] + + +-- | Construct a value of type 'V1ModelsGet200Response' (by applying it's required fields, if any) +mkV1ModelsGet200Response + :: V1ModelsGet200Response +mkV1ModelsGet200Response = + V1ModelsGet200Response + { v1ModelsGet200ResponseModels = Nothing + } + +-- ** V1ModelsModelIdLogProbGradPost200Response +-- | V1ModelsModelIdLogProbGradPost200Response +data V1ModelsModelIdLogProbGradPost200Response = V1ModelsModelIdLogProbGradPost200Response + { v1ModelsModelIdLogProbGradPost200ResponseGradLogProb :: !(Maybe [Double]) -- ^ "grad_log_prob" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON V1ModelsModelIdLogProbGradPost200Response +instance A.FromJSON V1ModelsModelIdLogProbGradPost200Response where + parseJSON = A.withObject "V1ModelsModelIdLogProbGradPost200Response" $ \o -> + V1ModelsModelIdLogProbGradPost200Response + <$> (o .:? "grad_log_prob") + +-- | ToJSON V1ModelsModelIdLogProbGradPost200Response +instance A.ToJSON V1ModelsModelIdLogProbGradPost200Response where + toJSON V1ModelsModelIdLogProbGradPost200Response {..} = + _omitNulls + [ "grad_log_prob" .= v1ModelsModelIdLogProbGradPost200ResponseGradLogProb + ] + + +-- | Construct a value of type 'V1ModelsModelIdLogProbGradPost200Response' (by applying it's required fields, if any) +mkV1ModelsModelIdLogProbGradPost200Response + :: V1ModelsModelIdLogProbGradPost200Response +mkV1ModelsModelIdLogProbGradPost200Response = + V1ModelsModelIdLogProbGradPost200Response + { v1ModelsModelIdLogProbGradPost200ResponseGradLogProb = Nothing + } + +-- ** V1ModelsModelIdLogProbPost200Response +-- | V1ModelsModelIdLogProbPost200Response +data V1ModelsModelIdLogProbPost200Response = V1ModelsModelIdLogProbPost200Response + { v1ModelsModelIdLogProbPost200ResponseLogProb :: !(Maybe Double) -- ^ "log_prob" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON V1ModelsModelIdLogProbPost200Response +instance A.FromJSON V1ModelsModelIdLogProbPost200Response where + parseJSON = A.withObject "V1ModelsModelIdLogProbPost200Response" $ \o -> + V1ModelsModelIdLogProbPost200Response + <$> (o .:? "log_prob") + +-- | ToJSON V1ModelsModelIdLogProbPost200Response +instance A.ToJSON V1ModelsModelIdLogProbPost200Response where + toJSON V1ModelsModelIdLogProbPost200Response {..} = + _omitNulls + [ "log_prob" .= v1ModelsModelIdLogProbPost200ResponseLogProb + ] + + +-- | Construct a value of type 'V1ModelsModelIdLogProbPost200Response' (by applying it's required fields, if any) +mkV1ModelsModelIdLogProbPost200Response + :: V1ModelsModelIdLogProbPost200Response +mkV1ModelsModelIdLogProbPost200Response = + V1ModelsModelIdLogProbPost200Response + { v1ModelsModelIdLogProbPost200ResponseLogProb = Nothing + } + +-- ** V1ModelsModelIdParamsPost200Response +-- | V1ModelsModelIdParamsPost200Response +data V1ModelsModelIdParamsPost200Response = V1ModelsModelIdParamsPost200Response + { v1ModelsModelIdParamsPost200ResponseId :: !(Maybe Text) -- ^ "id" + , v1ModelsModelIdParamsPost200ResponseParams :: !(Maybe [Parameter]) -- ^ "params" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON V1ModelsModelIdParamsPost200Response +instance A.FromJSON V1ModelsModelIdParamsPost200Response where + parseJSON = A.withObject "V1ModelsModelIdParamsPost200Response" $ \o -> + V1ModelsModelIdParamsPost200Response + <$> (o .:? "id") + <*> (o .:? "params") + +-- | ToJSON V1ModelsModelIdParamsPost200Response +instance A.ToJSON V1ModelsModelIdParamsPost200Response where + toJSON V1ModelsModelIdParamsPost200Response {..} = + _omitNulls + [ "id" .= v1ModelsModelIdParamsPost200ResponseId + , "params" .= v1ModelsModelIdParamsPost200ResponseParams + ] + + +-- | Construct a value of type 'V1ModelsModelIdParamsPost200Response' (by applying it's required fields, if any) +mkV1ModelsModelIdParamsPost200Response + :: V1ModelsModelIdParamsPost200Response +mkV1ModelsModelIdParamsPost200Response = + V1ModelsModelIdParamsPost200Response + { v1ModelsModelIdParamsPost200ResponseId = Nothing + , v1ModelsModelIdParamsPost200ResponseParams = Nothing + } + +-- ** V1ModelsModelIdTransformInitsPost200Response +-- | V1ModelsModelIdTransformInitsPost200Response +data V1ModelsModelIdTransformInitsPost200Response = V1ModelsModelIdTransformInitsPost200Response + { v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained :: !(Maybe [Double]) -- ^ "params_r_unconstrained" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON V1ModelsModelIdTransformInitsPost200Response +instance A.FromJSON V1ModelsModelIdTransformInitsPost200Response where + parseJSON = A.withObject "V1ModelsModelIdTransformInitsPost200Response" $ \o -> + V1ModelsModelIdTransformInitsPost200Response + <$> (o .:? "params_r_unconstrained") + +-- | ToJSON V1ModelsModelIdTransformInitsPost200Response +instance A.ToJSON V1ModelsModelIdTransformInitsPost200Response where + toJSON V1ModelsModelIdTransformInitsPost200Response {..} = + _omitNulls + [ "params_r_unconstrained" .= v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained + ] + + +-- | Construct a value of type 'V1ModelsModelIdTransformInitsPost200Response' (by applying it's required fields, if any) +mkV1ModelsModelIdTransformInitsPost200Response + :: V1ModelsModelIdTransformInitsPost200Response +mkV1ModelsModelIdTransformInitsPost200Response = + V1ModelsModelIdTransformInitsPost200Response + { v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained = Nothing + } + +-- ** V1ModelsModelIdWriteArrayPost200Response +-- | V1ModelsModelIdWriteArrayPost200Response +data V1ModelsModelIdWriteArrayPost200Response = V1ModelsModelIdWriteArrayPost200Response + { v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained :: !(Maybe [Double]) -- ^ "params_r_constrained" + } deriving (P.Show, P.Eq, P.Typeable) + +-- | FromJSON V1ModelsModelIdWriteArrayPost200Response +instance A.FromJSON V1ModelsModelIdWriteArrayPost200Response where + parseJSON = A.withObject "V1ModelsModelIdWriteArrayPost200Response" $ \o -> + V1ModelsModelIdWriteArrayPost200Response + <$> (o .:? "params_r_constrained") + +-- | ToJSON V1ModelsModelIdWriteArrayPost200Response +instance A.ToJSON V1ModelsModelIdWriteArrayPost200Response where + toJSON V1ModelsModelIdWriteArrayPost200Response {..} = + _omitNulls + [ "params_r_constrained" .= v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained + ] + + +-- | Construct a value of type 'V1ModelsModelIdWriteArrayPost200Response' (by applying it's required fields, if any) +mkV1ModelsModelIdWriteArrayPost200Response + :: V1ModelsModelIdWriteArrayPost200Response +mkV1ModelsModelIdWriteArrayPost200Response = + V1ModelsModelIdWriteArrayPost200Response + { v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained = Nothing + } + + +-- * Enums + + +-- ** E'Function + +-- | Enum of 'Text' +data E'Function + = E'Function'Hmc_nuts_diag_e_adapt -- ^ @"stan::services::sample::hmc_nuts_diag_e_adapt"@ + | E'Function'Fixed_param -- ^ @"stan::services::sample::fixed_param"@ + deriving (P.Show, P.Eq, P.Typeable, P.Ord, P.Bounded, P.Enum) + +instance A.ToJSON E'Function where toJSON = A.toJSON . fromE'Function +instance A.FromJSON E'Function where parseJSON o = P.either P.fail (pure . P.id) . toE'Function =<< A.parseJSON o +instance WH.ToHttpApiData E'Function where toQueryParam = WH.toQueryParam . fromE'Function +instance WH.FromHttpApiData E'Function where parseQueryParam o = WH.parseQueryParam o >>= P.left T.pack . toE'Function +instance MimeRender MimeMultipartFormData E'Function where mimeRender _ = mimeRenderDefaultMultipartFormData + +-- | unwrap 'E'Function' enum +fromE'Function :: E'Function -> Text +fromE'Function = \case + E'Function'Hmc_nuts_diag_e_adapt -> "stan::services::sample::hmc_nuts_diag_e_adapt" + E'Function'Fixed_param -> "stan::services::sample::fixed_param" + +-- | parse 'E'Function' enum +toE'Function :: Text -> P.Either String E'Function +toE'Function = \case + "stan::services::sample::hmc_nuts_diag_e_adapt" -> P.Right E'Function'Hmc_nuts_diag_e_adapt + "stan::services::sample::fixed_param" -> P.Right E'Function'Fixed_param + s -> P.Left $ "toE'Function: enum parse failure: " P.++ P.show s + + + diff --git a/lib/Httpstan/ModelLens.hs b/lib/Httpstan/ModelLens.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/ModelLens.hs @@ -0,0 +1,309 @@ +{- + httpstan + + No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) + + OpenAPI Version: 3.0.1 + httpstan API version: 4.10.0 + Generated by OpenAPI Generator (https://openapi-generator.tech) +-} + +{-| +Module : Httpstan.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 Httpstan.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 Httpstan.Model +import Httpstan.Core + + +-- * CreateFitRequest + +-- | 'createFitRequestChain' Lens +createFitRequestChainL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestChainL f CreateFitRequest{..} = (\createFitRequestChain -> CreateFitRequest { createFitRequestChain, ..} ) <$> f createFitRequestChain +{-# INLINE createFitRequestChainL #-} + +-- | 'createFitRequestData' Lens +createFitRequestDataL :: Lens_' CreateFitRequest (Maybe A.Value) +createFitRequestDataL f CreateFitRequest{..} = (\createFitRequestData -> CreateFitRequest { createFitRequestData, ..} ) <$> f createFitRequestData +{-# INLINE createFitRequestDataL #-} + +-- | 'createFitRequestDelta' Lens +createFitRequestDeltaL :: Lens_' CreateFitRequest (Maybe Double) +createFitRequestDeltaL f CreateFitRequest{..} = (\createFitRequestDelta -> CreateFitRequest { createFitRequestDelta, ..} ) <$> f createFitRequestDelta +{-# INLINE createFitRequestDeltaL #-} + +-- | 'createFitRequestFunction' Lens +createFitRequestFunctionL :: Lens_' CreateFitRequest (E'Function) +createFitRequestFunctionL f CreateFitRequest{..} = (\createFitRequestFunction -> CreateFitRequest { createFitRequestFunction, ..} ) <$> f createFitRequestFunction +{-# INLINE createFitRequestFunctionL #-} + +-- | 'createFitRequestGamma' Lens +createFitRequestGammaL :: Lens_' CreateFitRequest (Maybe Double) +createFitRequestGammaL f CreateFitRequest{..} = (\createFitRequestGamma -> CreateFitRequest { createFitRequestGamma, ..} ) <$> f createFitRequestGamma +{-# INLINE createFitRequestGammaL #-} + +-- | 'createFitRequestInit' Lens +createFitRequestInitL :: Lens_' CreateFitRequest (Maybe A.Value) +createFitRequestInitL f CreateFitRequest{..} = (\createFitRequestInit -> CreateFitRequest { createFitRequestInit, ..} ) <$> f createFitRequestInit +{-# INLINE createFitRequestInitL #-} + +-- | 'createFitRequestInitBuffer' Lens +createFitRequestInitBufferL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestInitBufferL f CreateFitRequest{..} = (\createFitRequestInitBuffer -> CreateFitRequest { createFitRequestInitBuffer, ..} ) <$> f createFitRequestInitBuffer +{-# INLINE createFitRequestInitBufferL #-} + +-- | 'createFitRequestInitRadius' Lens +createFitRequestInitRadiusL :: Lens_' CreateFitRequest (Maybe Double) +createFitRequestInitRadiusL f CreateFitRequest{..} = (\createFitRequestInitRadius -> CreateFitRequest { createFitRequestInitRadius, ..} ) <$> f createFitRequestInitRadius +{-# INLINE createFitRequestInitRadiusL #-} + +-- | 'createFitRequestKappa' Lens +createFitRequestKappaL :: Lens_' CreateFitRequest (Maybe Double) +createFitRequestKappaL f CreateFitRequest{..} = (\createFitRequestKappa -> CreateFitRequest { createFitRequestKappa, ..} ) <$> f createFitRequestKappa +{-# INLINE createFitRequestKappaL #-} + +-- | 'createFitRequestMaxDepth' Lens +createFitRequestMaxDepthL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestMaxDepthL f CreateFitRequest{..} = (\createFitRequestMaxDepth -> CreateFitRequest { createFitRequestMaxDepth, ..} ) <$> f createFitRequestMaxDepth +{-# INLINE createFitRequestMaxDepthL #-} + +-- | 'createFitRequestNumSamples' Lens +createFitRequestNumSamplesL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestNumSamplesL f CreateFitRequest{..} = (\createFitRequestNumSamples -> CreateFitRequest { createFitRequestNumSamples, ..} ) <$> f createFitRequestNumSamples +{-# INLINE createFitRequestNumSamplesL #-} + +-- | 'createFitRequestNumThin' Lens +createFitRequestNumThinL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestNumThinL f CreateFitRequest{..} = (\createFitRequestNumThin -> CreateFitRequest { createFitRequestNumThin, ..} ) <$> f createFitRequestNumThin +{-# INLINE createFitRequestNumThinL #-} + +-- | 'createFitRequestNumWarmup' Lens +createFitRequestNumWarmupL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestNumWarmupL f CreateFitRequest{..} = (\createFitRequestNumWarmup -> CreateFitRequest { createFitRequestNumWarmup, ..} ) <$> f createFitRequestNumWarmup +{-# INLINE createFitRequestNumWarmupL #-} + +-- | 'createFitRequestRandomSeed' Lens +createFitRequestRandomSeedL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestRandomSeedL f CreateFitRequest{..} = (\createFitRequestRandomSeed -> CreateFitRequest { createFitRequestRandomSeed, ..} ) <$> f createFitRequestRandomSeed +{-# INLINE createFitRequestRandomSeedL #-} + +-- | 'createFitRequestRefresh' Lens +createFitRequestRefreshL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestRefreshL f CreateFitRequest{..} = (\createFitRequestRefresh -> CreateFitRequest { createFitRequestRefresh, ..} ) <$> f createFitRequestRefresh +{-# INLINE createFitRequestRefreshL #-} + +-- | 'createFitRequestSaveWarmup' Lens +createFitRequestSaveWarmupL :: Lens_' CreateFitRequest (Maybe Bool) +createFitRequestSaveWarmupL f CreateFitRequest{..} = (\createFitRequestSaveWarmup -> CreateFitRequest { createFitRequestSaveWarmup, ..} ) <$> f createFitRequestSaveWarmup +{-# INLINE createFitRequestSaveWarmupL #-} + +-- | 'createFitRequestStepsize' Lens +createFitRequestStepsizeL :: Lens_' CreateFitRequest (Maybe Double) +createFitRequestStepsizeL f CreateFitRequest{..} = (\createFitRequestStepsize -> CreateFitRequest { createFitRequestStepsize, ..} ) <$> f createFitRequestStepsize +{-# INLINE createFitRequestStepsizeL #-} + +-- | 'createFitRequestStepsizeJitter' Lens +createFitRequestStepsizeJitterL :: Lens_' CreateFitRequest (Maybe Double) +createFitRequestStepsizeJitterL f CreateFitRequest{..} = (\createFitRequestStepsizeJitter -> CreateFitRequest { createFitRequestStepsizeJitter, ..} ) <$> f createFitRequestStepsizeJitter +{-# INLINE createFitRequestStepsizeJitterL #-} + +-- | 'createFitRequestT0' Lens +createFitRequestT0L :: Lens_' CreateFitRequest (Maybe Double) +createFitRequestT0L f CreateFitRequest{..} = (\createFitRequestT0 -> CreateFitRequest { createFitRequestT0, ..} ) <$> f createFitRequestT0 +{-# INLINE createFitRequestT0L #-} + +-- | 'createFitRequestTermBuffer' Lens +createFitRequestTermBufferL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestTermBufferL f CreateFitRequest{..} = (\createFitRequestTermBuffer -> CreateFitRequest { createFitRequestTermBuffer, ..} ) <$> f createFitRequestTermBuffer +{-# INLINE createFitRequestTermBufferL #-} + +-- | 'createFitRequestWindow' Lens +createFitRequestWindowL :: Lens_' CreateFitRequest (Maybe Int) +createFitRequestWindowL f CreateFitRequest{..} = (\createFitRequestWindow -> CreateFitRequest { createFitRequestWindow, ..} ) <$> f createFitRequestWindow +{-# INLINE createFitRequestWindowL #-} + + + +-- * CreateModelRequest + +-- | 'createModelRequestProgramCode' Lens +createModelRequestProgramCodeL :: Lens_' CreateModelRequest (Text) +createModelRequestProgramCodeL f CreateModelRequest{..} = (\createModelRequestProgramCode -> CreateModelRequest { createModelRequestProgramCode, ..} ) <$> f createModelRequestProgramCode +{-# INLINE createModelRequestProgramCodeL #-} + + + +-- * Fit + +-- | 'fitName' Lens +fitNameL :: Lens_' Fit (Text) +fitNameL f Fit{..} = (\fitName -> Fit { fitName, ..} ) <$> f fitName +{-# INLINE fitNameL #-} + + + +-- * Model + +-- | 'modelCompilerOutput' Lens +modelCompilerOutputL :: Lens_' Model (Text) +modelCompilerOutputL f Model{..} = (\modelCompilerOutput -> Model { modelCompilerOutput, ..} ) <$> f modelCompilerOutput +{-# INLINE modelCompilerOutputL #-} + +-- | 'modelName' Lens +modelNameL :: Lens_' Model (Text) +modelNameL f Model{..} = (\modelName -> Model { modelName, ..} ) <$> f modelName +{-# INLINE modelNameL #-} + +-- | 'modelStancWarnings' Lens +modelStancWarningsL :: Lens_' Model (Text) +modelStancWarningsL f Model{..} = (\modelStancWarnings -> Model { modelStancWarnings, ..} ) <$> f modelStancWarnings +{-# INLINE modelStancWarningsL #-} + + + +-- * Operation + +-- | 'operationDone' Lens +operationDoneL :: Lens_' Operation (Bool) +operationDoneL f Operation{..} = (\operationDone -> Operation { operationDone, ..} ) <$> f operationDone +{-# INLINE operationDoneL #-} + +-- | 'operationMetadata' Lens +operationMetadataL :: Lens_' Operation (Maybe A.Value) +operationMetadataL f Operation{..} = (\operationMetadata -> Operation { operationMetadata, ..} ) <$> f operationMetadata +{-# INLINE operationMetadataL #-} + +-- | 'operationName' Lens +operationNameL :: Lens_' Operation (Text) +operationNameL f Operation{..} = (\operationName -> Operation { operationName, ..} ) <$> f operationName +{-# INLINE operationNameL #-} + +-- | 'operationResult' Lens +operationResultL :: Lens_' Operation (Maybe A.Value) +operationResultL f Operation{..} = (\operationResult -> Operation { operationResult, ..} ) <$> f operationResult +{-# INLINE operationResultL #-} + + + +-- * Parameter + +-- | 'parameterConstrainedNames' Lens +parameterConstrainedNamesL :: Lens_' Parameter ([Text]) +parameterConstrainedNamesL f Parameter{..} = (\parameterConstrainedNames -> Parameter { parameterConstrainedNames, ..} ) <$> f parameterConstrainedNames +{-# INLINE parameterConstrainedNamesL #-} + +-- | 'parameterDims' Lens +parameterDimsL :: Lens_' Parameter ([Int]) +parameterDimsL f Parameter{..} = (\parameterDims -> Parameter { parameterDims, ..} ) <$> f parameterDims +{-# INLINE parameterDimsL #-} + +-- | 'parameterName' Lens +parameterNameL :: Lens_' Parameter (Text) +parameterNameL f Parameter{..} = (\parameterName -> Parameter { parameterName, ..} ) <$> f parameterName +{-# INLINE parameterNameL #-} + + + +-- * Status + +-- | 'statusCode' Lens +statusCodeL :: Lens_' Status (Int) +statusCodeL f Status{..} = (\statusCode -> Status { statusCode, ..} ) <$> f statusCode +{-# INLINE statusCodeL #-} + +-- | 'statusDetails' Lens +statusDetailsL :: Lens_' Status (Maybe [A.Value]) +statusDetailsL f Status{..} = (\statusDetails -> Status { statusDetails, ..} ) <$> f statusDetails +{-# INLINE statusDetailsL #-} + +-- | 'statusMessage' Lens +statusMessageL :: Lens_' Status (Text) +statusMessageL f Status{..} = (\statusMessage -> Status { statusMessage, ..} ) <$> f statusMessage +{-# INLINE statusMessageL #-} + +-- | 'statusStatus' Lens +statusStatusL :: Lens_' Status (Text) +statusStatusL f Status{..} = (\statusStatus -> Status { statusStatus, ..} ) <$> f statusStatus +{-# INLINE statusStatusL #-} + + + +-- * V1ModelsGet200Response + +-- | 'v1ModelsGet200ResponseModels' Lens +v1ModelsGet200ResponseModelsL :: Lens_' V1ModelsGet200Response (Maybe [Model]) +v1ModelsGet200ResponseModelsL f V1ModelsGet200Response{..} = (\v1ModelsGet200ResponseModels -> V1ModelsGet200Response { v1ModelsGet200ResponseModels, ..} ) <$> f v1ModelsGet200ResponseModels +{-# INLINE v1ModelsGet200ResponseModelsL #-} + + + +-- * V1ModelsModelIdLogProbGradPost200Response + +-- | 'v1ModelsModelIdLogProbGradPost200ResponseGradLogProb' Lens +v1ModelsModelIdLogProbGradPost200ResponseGradLogProbL :: Lens_' V1ModelsModelIdLogProbGradPost200Response (Maybe [Double]) +v1ModelsModelIdLogProbGradPost200ResponseGradLogProbL f V1ModelsModelIdLogProbGradPost200Response{..} = (\v1ModelsModelIdLogProbGradPost200ResponseGradLogProb -> V1ModelsModelIdLogProbGradPost200Response { v1ModelsModelIdLogProbGradPost200ResponseGradLogProb, ..} ) <$> f v1ModelsModelIdLogProbGradPost200ResponseGradLogProb +{-# INLINE v1ModelsModelIdLogProbGradPost200ResponseGradLogProbL #-} + + + +-- * V1ModelsModelIdLogProbPost200Response + +-- | 'v1ModelsModelIdLogProbPost200ResponseLogProb' Lens +v1ModelsModelIdLogProbPost200ResponseLogProbL :: Lens_' V1ModelsModelIdLogProbPost200Response (Maybe Double) +v1ModelsModelIdLogProbPost200ResponseLogProbL f V1ModelsModelIdLogProbPost200Response{..} = (\v1ModelsModelIdLogProbPost200ResponseLogProb -> V1ModelsModelIdLogProbPost200Response { v1ModelsModelIdLogProbPost200ResponseLogProb, ..} ) <$> f v1ModelsModelIdLogProbPost200ResponseLogProb +{-# INLINE v1ModelsModelIdLogProbPost200ResponseLogProbL #-} + + + +-- * V1ModelsModelIdParamsPost200Response + +-- | 'v1ModelsModelIdParamsPost200ResponseId' Lens +v1ModelsModelIdParamsPost200ResponseIdL :: Lens_' V1ModelsModelIdParamsPost200Response (Maybe Text) +v1ModelsModelIdParamsPost200ResponseIdL f V1ModelsModelIdParamsPost200Response{..} = (\v1ModelsModelIdParamsPost200ResponseId -> V1ModelsModelIdParamsPost200Response { v1ModelsModelIdParamsPost200ResponseId, ..} ) <$> f v1ModelsModelIdParamsPost200ResponseId +{-# INLINE v1ModelsModelIdParamsPost200ResponseIdL #-} + +-- | 'v1ModelsModelIdParamsPost200ResponseParams' Lens +v1ModelsModelIdParamsPost200ResponseParamsL :: Lens_' V1ModelsModelIdParamsPost200Response (Maybe [Parameter]) +v1ModelsModelIdParamsPost200ResponseParamsL f V1ModelsModelIdParamsPost200Response{..} = (\v1ModelsModelIdParamsPost200ResponseParams -> V1ModelsModelIdParamsPost200Response { v1ModelsModelIdParamsPost200ResponseParams, ..} ) <$> f v1ModelsModelIdParamsPost200ResponseParams +{-# INLINE v1ModelsModelIdParamsPost200ResponseParamsL #-} + + + +-- * V1ModelsModelIdTransformInitsPost200Response + +-- | 'v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained' Lens +v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrainedL :: Lens_' V1ModelsModelIdTransformInitsPost200Response (Maybe [Double]) +v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrainedL f V1ModelsModelIdTransformInitsPost200Response{..} = (\v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained -> V1ModelsModelIdTransformInitsPost200Response { v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained, ..} ) <$> f v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained +{-# INLINE v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrainedL #-} + + + +-- * V1ModelsModelIdWriteArrayPost200Response + +-- | 'v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained' Lens +v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrainedL :: Lens_' V1ModelsModelIdWriteArrayPost200Response (Maybe [Double]) +v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrainedL f V1ModelsModelIdWriteArrayPost200Response{..} = (\v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained -> V1ModelsModelIdWriteArrayPost200Response { v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained, ..} ) <$> f v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained +{-# INLINE v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrainedL #-} + + diff --git a/openapi.yaml b/openapi.yaml new file mode 100644 --- /dev/null +++ b/openapi.yaml @@ -0,0 +1,656 @@ +openapi: 3.0.1 +info: + title: httpstan + version: 4.10.0 +servers: +- url: / +paths: + /v1/health: + get: + description: Check if service is running. + responses: + "200": + content: {} + description: OK + /v1/models: + get: + description: List cached models. + responses: + "200": + content: + application/json: + schema: + $ref: '#/components/schemas/_v1_models_get_200_response' + description: Identifier for compiled Stan model and compiler output. + post: + description: Compile a Stan model + requestBody: + content: + application/json: + schema: + $ref: '#/components/schemas/CreateModelRequest' + description: Stan program code to compile + required: true + responses: + "201": + content: + application/json: + schema: + $ref: '#/components/schemas/Model' + description: Identifier for compiled Stan model and compiler output. + "400": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Error associated with compile request. + x-codegen-request-body-name: body + /v1/models/{model_id}: + delete: + description: Delete a model which has been saved in the cache. + parameters: + - description: ID of Stan model + in: path + name: model_id + required: true + schema: + type: string + responses: + "200": + content: {} + description: Model successfully deleted. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Model not found. + summary: Delete a model and any associated fits. + /v1/models/{model_id}/params: + post: + description: "Returns the output of Stan C++ model class methods: ``constrained_param_names``,\ + \ ``get_param_names`` and ``get_dims``." + parameters: + - description: ID of Stan model to use + in: path + name: model_id + required: true + schema: + type: string + requestBody: + content: + application/json: + schema: + $ref: '#/components/schemas/Data' + description: Data for Stan Model. Needed to calculate param names and dimensions. + required: true + responses: + "200": + content: + application/json: + schema: + $ref: '#/components/schemas/_v1_models__model_id__params_post_200_response' + description: Parameters for Stan Model + "400": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Error associated with request. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Model not found. + summary: Get parameter names and dimensions. + x-codegen-request-body-name: data + /v1/models/{model_id}/log_prob: + post: + description: Returns the output of Stan C++ ``log_prob`` model class method. + parameters: + - description: ID of Stan model to use + in: path + name: model_id + required: true + schema: + type: string + requestBody: + content: + application/json: + schema: + type: boolean + description: Boolean to control whether we apply a Jacobian adjust transform. + required: false + responses: + "200": + content: + application/json: + schema: + $ref: '#/components/schemas/_v1_models__model_id__log_prob_post_200_response' + description: Log probability of the unconstrained parameters. + "400": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Error associated with request. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Model not found. + summary: Return the log probability of the unconstrained parameters. + x-codegen-request-body-name: adjust_transform + /v1/models/{model_id}/log_prob_grad: + post: + description: Returns the output of Stan C++ `stan::model::log_prob_grad`. + parameters: + - description: ID of Stan model to use + in: path + name: model_id + required: true + schema: + type: string + requestBody: + content: + application/json: + schema: + type: boolean + description: Boolean to control whether we apply a Jacobian adjust transform. + required: false + responses: + "200": + content: + application/json: + schema: + $ref: '#/components/schemas/_v1_models__model_id__log_prob_grad_post_200_response' + description: Gradient of the log posterior evaluated at the unconstrained + parameters. + "400": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Error associated with request. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Model not found. + summary: Return the gradient of the log posterior evaluated at the unconstrained + parameters. + x-codegen-request-body-name: adjust_transform + /v1/models/{model_id}/write_array: + post: + description: Returns the output of Stan C++ ``write_array`` model class method. + parameters: + - description: ID of Stan model to use + in: path + name: model_id + required: true + schema: + type: string + requestBody: + content: + application/json: + schema: + type: boolean + description: Boolean to control whether we include generated quantities. + required: true + responses: + "200": + content: + application/json: + schema: + $ref: '#/components/schemas/_v1_models__model_id__write_array_post_200_response' + description: "Sequence of constrained parameters, optionally including transformed\ + \ parameters and generated quantities." + "400": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Error associated with request. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Model not found. + summary: Return a sequence of constrained parameters. + x-codegen-request-body-name: include_gqs + /v1/models/{model_id}/transform_inits: + post: + description: Returns the output of Stan C++ ``transform_inits`` model class + method. + parameters: + - description: ID of Stan model to use + in: path + name: model_id + required: true + schema: + type: string + requestBody: + content: + application/json: + schema: + $ref: '#/components/schemas/Data' + description: Constrained parameter values and their specified context + required: true + responses: + "200": + content: + application/json: + schema: + $ref: '#/components/schemas/_v1_models__model_id__transform_inits_post_200_response' + description: Sequence of unconstrained parameters. + "400": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Error associated with request. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Model not found. + summary: Return a sequence of unconstrained parameters. + x-codegen-request-body-name: constrained_parameters + /v1/models/{model_id}/fits: + post: + description: |- + A request to this endpoint starts a long-running operation. Users can retrieve information about the status of the operation by making a GET request to the operations resource endpoint. + When the operation is `done`, the "fit" may be downloaded. (A "fit" collects all logger and writer messages from Stan.) + ``function`` indicates the name of the ``stan::services function`` which should be called given the Stan model associated with the id ``model_id``. For example, if sampling using ``stan::services::sample::hmc_nuts_diag_e_adapt`` then ``function`` is the full function name ``stan::services::sample::hmc_nuts_diag_e_adapt``. Sampler parameters which are not supplied will be given default values taken from CmdStan. For example, if ``stan::services::sample::hmc_nuts_diag_e_adapt`` is the function called and the parameter ``num_samples`` is not specified, the value 1000 will be used. For a full list of default values consult the CmdStan documentation. + parameters: + - description: ID of Stan model to use + in: path + name: model_id + required: true + schema: + type: string + requestBody: + content: + application/json: + schema: + $ref: '#/components/schemas/CreateFitRequest' + description: Full stan::services function name and associated arguments to + call with Stan model. + required: true + responses: + "201": + content: + application/json: + schema: + $ref: '#/components/schemas/Fit' + description: Identifier for completed Stan fit + "400": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Error associated with request. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Fit not found. + summary: Call function defined in stan::services. + x-codegen-request-body-name: body + /v1/models/{model_id}/fits/{fit_id}: + delete: + description: Delete a fit which has been saved in the cache. + parameters: + - description: ID of Stan model associated with the fit. + in: path + name: model_id + required: true + schema: + type: string + - description: ID of fit to be deleted. + in: path + name: fit_id + required: true + schema: + type: string + responses: + "200": + content: {} + description: Fit successfully deleted. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Fit not found. + summary: Delete a fit. + get: + description: "Result (draws, logger messages) from calling a function defined\ + \ in stan::services." + parameters: + - description: ID of Stan model associated with the result + in: path + name: model_id + required: true + schema: + type: string + - description: ID of Stan result ("fit") desired + in: path + name: fit_id + required: true + schema: + type: string + responses: + "200": + content: {} + description: Newline-delimited JSON-encoded messages from Stan. Includes + draws. + "404": + content: + text/plain: + schema: + $ref: '#/components/schemas/Status' + description: Fit not found. + summary: Get results returned by a function. + /v1/operations/{operation_id}: + get: + description: Return Operation details. Details about an Operation include whether + or not the operation is `done` and information about the progress of sampling. + parameters: + - description: ID of Operation + in: path + name: operation_id + required: true + schema: + type: string + responses: + "200": + content: + application/json: + schema: + $ref: '#/components/schemas/Operation' + description: Operation name and metadata. + "404": + content: + application/json: + schema: + $ref: '#/components/schemas/Status' + description: Operation not found. + summary: Get Operation details. +components: + schemas: + CreateFitRequest: + example: + random_seed: 0 + init: "{}" + chain: 0 + data: "{}" + max_depth: 0 + stepsize_jitter: 1.0246457001441578 + delta: 6.027456183070403 + refresh: 0 + term_buffer: 0 + init_buffer: 0 + init_radius: 5.637376656633329 + function: stan::services::sample::hmc_nuts_diag_e_adapt + num_thin: 0 + kappa: 2.3021358869347655 + num_warmup: 0 + window: 0 + t0: 1.4894159098541704 + save_warmup: true + gamma: 1.4658129805029452 + stepsize: 1.2315135367772556 + num_samples: 0 + properties: + chain: + minimum: 0 + type: integer + data: + allOf: + - $ref: '#/components/schemas/Data' + type: object + delta: + type: number + function: + enum: + - stan::services::sample::hmc_nuts_diag_e_adapt + - stan::services::sample::fixed_param + type: string + gamma: + type: number + init: + allOf: + - $ref: '#/components/schemas/Data' + type: object + init_buffer: + minimum: 0 + type: integer + init_radius: + type: number + kappa: + type: number + max_depth: + minimum: 0 + type: integer + num_samples: + minimum: 0 + type: integer + num_thin: + minimum: 0 + type: integer + num_warmup: + minimum: 0 + type: integer + random_seed: + minimum: 0 + type: integer + refresh: + minimum: 0 + type: integer + save_warmup: + type: boolean + stepsize: + type: number + stepsize_jitter: + type: number + t0: + type: number + term_buffer: + minimum: 0 + type: integer + window: + minimum: 0 + type: integer + required: + - function + type: object + CreateModelRequest: + example: + program_code: program_code + properties: + program_code: + type: string + required: + - program_code + type: object + Data: + type: object + Fit: + example: + name: name + properties: + name: + type: string + required: + - name + type: object + Model: + example: + stanc_warnings: stanc_warnings + compiler_output: compiler_output + name: name + properties: + compiler_output: + type: string + name: + type: string + stanc_warnings: + type: string + required: + - compiler_output + - name + - stanc_warnings + type: object + Operation: + example: + result: "{}" + metadata: "{}" + name: name + done: true + properties: + done: + type: boolean + metadata: + properties: {} + type: object + name: + type: string + result: + properties: {} + type: object + required: + - done + - name + type: object + Parameter: + example: + dims: + - 0 + - 0 + name: name + constrained_names: + - constrained_names + - constrained_names + properties: + constrained_names: + items: + type: string + type: array + dims: + items: + type: integer + type: array + name: + type: string + required: + - constrained_names + - dims + - name + type: object + Status: + properties: + code: + type: integer + details: + items: + properties: {} + type: object + type: array + message: + type: string + status: + type: string + required: + - code + - message + - status + type: object + _v1_models_get_200_response: + example: + models: + - stanc_warnings: stanc_warnings + compiler_output: compiler_output + name: name + - stanc_warnings: stanc_warnings + compiler_output: compiler_output + name: name + properties: + models: + items: + $ref: '#/components/schemas/Model' + type: array + type: object + _v1_models__model_id__params_post_200_response: + example: + id: id + params: + - dims: + - 0 + - 0 + name: name + constrained_names: + - constrained_names + - constrained_names + - dims: + - 0 + - 0 + name: name + constrained_names: + - constrained_names + - constrained_names + properties: + id: + type: string + params: + items: + $ref: '#/components/schemas/Parameter' + type: array + type: object + _v1_models__model_id__log_prob_post_200_response: + example: + log_prob: 0.8008281904610115 + properties: + log_prob: + type: number + type: object + _v1_models__model_id__log_prob_grad_post_200_response: + example: + grad_log_prob: + - 0.8008281904610115 + - 0.8008281904610115 + properties: + grad_log_prob: + items: + type: number + type: array + type: object + _v1_models__model_id__write_array_post_200_response: + example: + params_r_constrained: + - 0.8008281904610115 + - 0.8008281904610115 + properties: + params_r_constrained: + items: + type: number + type: array + type: object + _v1_models__model_id__transform_inits_post_200_response: + example: + params_r_unconstrained: + - 0.8008281904610115 + - 0.8008281904610115 + properties: + params_r_unconstrained: + items: + type: number + type: array + type: object +x-original-swagger-version: "2.0" 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,256 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} + +module Instances where + +import Httpstan.Model +import Httpstan.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 Data.String (fromString) + +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 + +#if MIN_VERSION_aeson(2,0,0) +#else +-- | A naive Arbitrary instance for A.Value: +instance Arbitrary A.Value where + arbitrary = arbitraryValue +#endif + +arbitraryValue :: Gen A.Value +arbitraryValue = + 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) = (fromString 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 CreateFitRequest where + arbitrary = sized genCreateFitRequest + +genCreateFitRequest :: Int -> Gen CreateFitRequest +genCreateFitRequest n = + CreateFitRequest + <$> arbitraryReducedMaybe n -- createFitRequestChain :: Maybe Int + <*> arbitraryReducedMaybeValue n -- createFitRequestData :: Maybe A.Value + <*> arbitraryReducedMaybe n -- createFitRequestDelta :: Maybe Double + <*> arbitrary -- createFitRequestFunction :: E'Function + <*> arbitraryReducedMaybe n -- createFitRequestGamma :: Maybe Double + <*> arbitraryReducedMaybeValue n -- createFitRequestInit :: Maybe A.Value + <*> arbitraryReducedMaybe n -- createFitRequestInitBuffer :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestInitRadius :: Maybe Double + <*> arbitraryReducedMaybe n -- createFitRequestKappa :: Maybe Double + <*> arbitraryReducedMaybe n -- createFitRequestMaxDepth :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestNumSamples :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestNumThin :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestNumWarmup :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestRandomSeed :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestRefresh :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestSaveWarmup :: Maybe Bool + <*> arbitraryReducedMaybe n -- createFitRequestStepsize :: Maybe Double + <*> arbitraryReducedMaybe n -- createFitRequestStepsizeJitter :: Maybe Double + <*> arbitraryReducedMaybe n -- createFitRequestT0 :: Maybe Double + <*> arbitraryReducedMaybe n -- createFitRequestTermBuffer :: Maybe Int + <*> arbitraryReducedMaybe n -- createFitRequestWindow :: Maybe Int + +instance Arbitrary CreateModelRequest where + arbitrary = sized genCreateModelRequest + +genCreateModelRequest :: Int -> Gen CreateModelRequest +genCreateModelRequest n = + CreateModelRequest + <$> arbitrary -- createModelRequestProgramCode :: Text + +instance Arbitrary Fit where + arbitrary = sized genFit + +genFit :: Int -> Gen Fit +genFit n = + Fit + <$> arbitrary -- fitName :: Text + +instance Arbitrary Model where + arbitrary = sized genModel + +genModel :: Int -> Gen Model +genModel n = + Model + <$> arbitrary -- modelCompilerOutput :: Text + <*> arbitrary -- modelName :: Text + <*> arbitrary -- modelStancWarnings :: Text + +instance Arbitrary Operation where + arbitrary = sized genOperation + +genOperation :: Int -> Gen Operation +genOperation n = + Operation + <$> arbitrary -- operationDone :: Bool + <*> arbitraryReducedMaybeValue n -- operationMetadata :: Maybe A.Value + <*> arbitrary -- operationName :: Text + <*> arbitraryReducedMaybeValue n -- operationResult :: Maybe A.Value + +instance Arbitrary Parameter where + arbitrary = sized genParameter + +genParameter :: Int -> Gen Parameter +genParameter n = + Parameter + <$> arbitrary -- parameterConstrainedNames :: [Text] + <*> arbitrary -- parameterDims :: [Int] + <*> arbitrary -- parameterName :: Text + +instance Arbitrary Status where + arbitrary = sized genStatus + +genStatus :: Int -> Gen Status +genStatus n = + Status + <$> arbitrary -- statusCode :: Int + <*> arbitraryReducedMaybe n -- statusDetails :: Maybe [A.Value] + <*> arbitrary -- statusMessage :: Text + <*> arbitrary -- statusStatus :: Text + +instance Arbitrary V1ModelsGet200Response where + arbitrary = sized genV1ModelsGet200Response + +genV1ModelsGet200Response :: Int -> Gen V1ModelsGet200Response +genV1ModelsGet200Response n = + V1ModelsGet200Response + <$> arbitraryReducedMaybe n -- v1ModelsGet200ResponseModels :: Maybe [Model] + +instance Arbitrary V1ModelsModelIdLogProbGradPost200Response where + arbitrary = sized genV1ModelsModelIdLogProbGradPost200Response + +genV1ModelsModelIdLogProbGradPost200Response :: Int -> Gen V1ModelsModelIdLogProbGradPost200Response +genV1ModelsModelIdLogProbGradPost200Response n = + V1ModelsModelIdLogProbGradPost200Response + <$> arbitraryReducedMaybe n -- v1ModelsModelIdLogProbGradPost200ResponseGradLogProb :: Maybe [Double] + +instance Arbitrary V1ModelsModelIdLogProbPost200Response where + arbitrary = sized genV1ModelsModelIdLogProbPost200Response + +genV1ModelsModelIdLogProbPost200Response :: Int -> Gen V1ModelsModelIdLogProbPost200Response +genV1ModelsModelIdLogProbPost200Response n = + V1ModelsModelIdLogProbPost200Response + <$> arbitraryReducedMaybe n -- v1ModelsModelIdLogProbPost200ResponseLogProb :: Maybe Double + +instance Arbitrary V1ModelsModelIdParamsPost200Response where + arbitrary = sized genV1ModelsModelIdParamsPost200Response + +genV1ModelsModelIdParamsPost200Response :: Int -> Gen V1ModelsModelIdParamsPost200Response +genV1ModelsModelIdParamsPost200Response n = + V1ModelsModelIdParamsPost200Response + <$> arbitraryReducedMaybe n -- v1ModelsModelIdParamsPost200ResponseId :: Maybe Text + <*> arbitraryReducedMaybe n -- v1ModelsModelIdParamsPost200ResponseParams :: Maybe [Parameter] + +instance Arbitrary V1ModelsModelIdTransformInitsPost200Response where + arbitrary = sized genV1ModelsModelIdTransformInitsPost200Response + +genV1ModelsModelIdTransformInitsPost200Response :: Int -> Gen V1ModelsModelIdTransformInitsPost200Response +genV1ModelsModelIdTransformInitsPost200Response n = + V1ModelsModelIdTransformInitsPost200Response + <$> arbitraryReducedMaybe n -- v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained :: Maybe [Double] + +instance Arbitrary V1ModelsModelIdWriteArrayPost200Response where + arbitrary = sized genV1ModelsModelIdWriteArrayPost200Response + +genV1ModelsModelIdWriteArrayPost200Response :: Int -> Gen V1ModelsModelIdWriteArrayPost200Response +genV1ModelsModelIdWriteArrayPost200Response n = + V1ModelsModelIdWriteArrayPost200Response + <$> arbitraryReducedMaybe n -- v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained :: Maybe [Double] + + + + +instance Arbitrary E'Function where + arbitrary = arbitraryBoundedEnum + 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 Httpstan.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,36 @@ +{-# 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 Httpstan.Model +import Httpstan.MimeTypes + +main :: IO () +main = + hspec $ modifyMaxSize (const 10) $ do + describe "JSON instances" $ do + pure () + propMimeEq MimeJSON (Proxy :: Proxy CreateFitRequest) + propMimeEq MimeJSON (Proxy :: Proxy CreateModelRequest) + propMimeEq MimeJSON (Proxy :: Proxy Fit) + propMimeEq MimeJSON (Proxy :: Proxy Model) + propMimeEq MimeJSON (Proxy :: Proxy Operation) + propMimeEq MimeJSON (Proxy :: Proxy Parameter) + propMimeEq MimeJSON (Proxy :: Proxy Status) + propMimeEq MimeJSON (Proxy :: Proxy V1ModelsGet200Response) + propMimeEq MimeJSON (Proxy :: Proxy V1ModelsModelIdLogProbGradPost200Response) + propMimeEq MimeJSON (Proxy :: Proxy V1ModelsModelIdLogProbPost200Response) + propMimeEq MimeJSON (Proxy :: Proxy V1ModelsModelIdParamsPost200Response) + propMimeEq MimeJSON (Proxy :: Proxy V1ModelsModelIdTransformInitsPost200Response) + propMimeEq MimeJSON (Proxy :: Proxy V1ModelsModelIdWriteArrayPost200Response) +