httpstan (empty) → 0.2.0.0
raw patch · 20 files changed
+4057/−0 lines, 20 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, base64-bytestring, bytestring, case-insensitive, containers, deepseq, exceptions, hspec, http-api-data, http-client, http-client-tls, http-media, http-types, httpstan, iso8601-time, katip, microlens, monad-logger, mtl, network, random, safe-exceptions, semigroups, text, time, transformers, unordered-containers, vector
Files
- LICENSE +26/−0
- README.md +203/−0
- Setup.hs +2/−0
- httpstan.cabal +117/−0
- lib/Httpstan.hs +31/−0
- lib/Httpstan/API.hs +19/−0
- lib/Httpstan/API/ApiDefault.hs +360/−0
- lib/Httpstan/Client.hs +223/−0
- lib/Httpstan/Core.hs +581/−0
- lib/Httpstan/Logging.hs +33/−0
- lib/Httpstan/LoggingKatip.hs +117/−0
- lib/Httpstan/LoggingMonadLogger.hs +126/−0
- lib/Httpstan/MimeTypes.hs +203/−0
- lib/Httpstan/Model.hs +627/−0
- lib/Httpstan/ModelLens.hs +309/−0
- openapi.yaml +656/−0
- tests/ApproxEq.hs +81/−0
- tests/Instances.hs +256/−0
- tests/PropMime.hs +51/−0
- tests/Test.hs +36/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ httpstan.cabal view
@@ -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
+ lib/Httpstan.hs view
@@ -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
+ lib/Httpstan/API.hs view
@@ -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
+ lib/Httpstan/API/ApiDefault.hs view
@@ -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+
+ lib/Httpstan/Client.hs view
@@ -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)+ _ -> "<RequestBody>")+ 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
+ lib/Httpstan/Core.hs view
@@ -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
+ lib/Httpstan/Logging.hs view
@@ -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
+ lib/Httpstan/LoggingKatip.hs view
@@ -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
+ lib/Httpstan/LoggingMonadLogger.hs view
@@ -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
+ lib/Httpstan/MimeTypes.hs view
@@ -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++
+ lib/Httpstan/Model.hs view
@@ -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+++
+ lib/Httpstan/ModelLens.hs view
@@ -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 #-}++
+ openapi.yaml view
@@ -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"
+ tests/ApproxEq.hs view
@@ -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
+ tests/Instances.hs view
@@ -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+
+ tests/PropMime.hs view
@@ -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)" (==)
+ tests/Test.hs view
@@ -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)+