diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,203 +0,0 @@ -## OpenAPI Auto-Generated [http-client](https://www.stackage.org/lts-10.0/package/http-client-0.5.7.1) Bindings to `httpstan` - -The library in `lib` provides auto-generated-from-OpenAPI [http-client](https://www.stackage.org/lts-10.0/package/http-client-0.5.7.1) bindings to the httpstan API. - -OpenApi Version: 3.0.1 - -## Installation - -Installation follows the standard approach to installing Stack-based projects. - -1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README). -2. To build the package, and generate the documentation (recommended): -``` -stack haddock -``` -which will generate docs for this lib in the `docs` folder. - -To generate the docs in the normal location (to enable hyperlinks to external libs), remove -``` -build: - haddock-arguments: - haddock-args: - - "--odir=./docs" -``` -from the stack.yaml file and run `stack haddock` again. - -3. To run unit tests: -``` -stack test -``` - -## OpenAPI-Generator - -The code generator that produced this library, and which explains how -to obtain and use the openapi-generator cli tool lives at - -https://openapi-generator.tech - -The _generator-name_ argument (`--generator-name`) passed to the cli tool used should be - -``` -haskell-http-client -``` - -### Unsupported OpenAPI Features - -* Model Inheritance - -This is beta software; other cases may not be supported. - -### Codegen "additional properties" parameters - -These options allow some customization of the code generation process. - -**haskell-http-client additional properties:** - -| OPTION | DESCRIPTION | DEFAULT | ACTUAL | -|---------------------------------|-------------------------------------------------------------------------------------------------------------------------------|----------|---------------------------------------| -| allowFromJsonNulls | allow JSON Null during model decoding from JSON | true | true | -| allowNonUniqueOperationIds | allow *different* API modules to contain the same operationId. Each API must be imported qualified | false | false | -| allowToJsonNulls | allow emitting JSON Null during model encoding to JSON | false | false | -| baseModule | Set the base module namespace | | Httpstan | -| cabalPackage | Set the cabal package name, which consists of one or more alphanumeric words separated by hyphens | | httpstan | -| cabalVersion | Set the cabal version number, consisting of a sequence of one or more integers separated by dots | 0.1.0.0 | 0.1.0.0 | -| customTestInstanceModule | test module used to provide typeclass instances for types not known by the generator | | | -| configType | Set the name of the type used for configuration | | HttpstanConfig | -| dateFormat | format string used to parse/render a date | %Y-%m-%d | %Y-%m-%d | -| dateTimeFormat | format string used to parse/render a datetime. (Defaults to [formatISO8601Millis][1] when not provided) | | | -| dateTimeParseFormat | overrides the format string used to parse a datetime | | | -| generateEnums | Generate specific datatypes for OpenAPI enums | true | true | -| generateFormUrlEncodedInstances | Generate FromForm/ToForm instances for models used by x-www-form-urlencoded operations (model fields must be primitive types) | true | true | -| generateLenses | Generate Lens optics for Models | true | true | -| generateModelConstructors | Generate smart constructors (only supply required fields) for models | true | true | -| inlineMimeTypes | Inline (hardcode) the content-type and accept parameters on operations, when there is only 1 option | true | true | -| modelDeriving | Additional classes to include in the deriving() clause of Models | | | -| requestType | Set the name of the type used to generate requests | | HttpstanRequest | -| strictFields | Add strictness annotations to all model fields | true | true | -| useKatip | Sets the default value for the UseKatip cabal flag. If true, the katip package provides logging instead of monad-logger | true | true | -| queryExtraUnreserved | Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':' | | | - -[1]: https://www.stackage.org/haddock/lts-9.0/iso8601-time-0.1.4/Data-Time-ISO8601.html#v:formatISO8601Millis - -An example setting _dateTimeFormat_ and _strictFields_: - -``` -java -jar openapi-generator-cli.jar generate -i petstore.yaml -g haskell-http-client -o output/haskell-http-client --additional-properties=dateTimeFormat="%Y-%m-%dT%H:%M:%S%Q%z" --additional-properties=strictFields=false -``` - -View the full list of Codegen "config option" parameters with the command: - -``` -java -jar openapi-generator-cli.jar config-help -g haskell-http-client -``` - -## Usage Notes - -### Example Petstore Haddock documentation - -An example of the generated haddock documentation targeting the server http://petstore.swagger.io/ (Petstore) can be found [here][2] - -[2]: https://hackage.haskell.org/package/swagger-petstore - -### Example Petstore App - -An example application using the auto-generated haskell-http-client bindings for the server http://petstore.swagger.io/ can be found [here][3] - -[3]: https://github.com/openapitools/openapi-generator/tree/master/samples/client/petstore/haskell-http-client/example-app - -This library is intended to be imported qualified. - -### Modules - -| MODULE | NOTES | -| ------------------- | --------------------------------------------------- | -| Httpstan.Client | use the "dispatch" functions to send requests | -| Httpstan.Core | core functions, config and request types | -| Httpstan.API | construct api requests | -| Httpstan.Model | describes api models | -| Httpstan.MimeTypes | encoding/decoding MIME types (content-types/accept) | -| Httpstan.ModelLens | lenses for model fields | -| Httpstan.Logging | logging functions and utils | - - -### MimeTypes - -This library adds type safety around what OpenAPI specifies as -Produces and Consumes for each Operation (e.g. the list of MIME types an -Operation can Produce (using 'accept' headers) and Consume (using 'content-type' headers). - -For example, if there is an Operation named _addFoo_, there will be a -data type generated named _AddFoo_ (note the capitalization), which -describes additional constraints and actions on the _addFoo_ operation -via its typeclass instances. These typeclass instances can be viewed -in GHCi or via the Haddocks. - -* required parameters are included as function arguments to _addFoo_ -* optional non-body parameters are included by using `applyOptionalParam` -* optional body parameters are set by using `setBodyParam` - -Example code generated for pretend _addFoo_ operation: - -```haskell -data AddFoo -instance Consumes AddFoo MimeJSON -instance Produces AddFoo MimeJSON -instance Produces AddFoo MimeXML -instance HasBodyParam AddFoo FooModel -instance HasOptionalParam AddFoo FooName -instance HasOptionalParam AddFoo FooId -``` - -this would indicate that: - -* the _addFoo_ operation can consume JSON -* the _addFoo_ operation produces JSON or XML, depending on the argument passed to the dispatch function -* the _addFoo_ operation can set it's body param of _FooModel_ via `setBodyParam` -* the _addFoo_ operation can set 2 different optional parameters via `applyOptionalParam` - -If the OpenAPI spec doesn't declare it can accept or produce a certain -MIME type for a given Operation, you should either add a Produces or -Consumes instance for the desired MIME types (assuming the server -supports it), use `dispatchLbsUnsafe` or modify the OpenAPI spec and -run the generator again. - -New MIME type instances can be added via MimeType/MimeRender/MimeUnrender - -Only JSON instances are generated by default, and in some case -x-www-form-urlencoded instances (FromFrom, ToForm) will also be -generated if the model fields are primitive types, and there are -Operations using x-www-form-urlencoded which use those models. - -### Authentication - -A haskell data type will be generated for each OpenAPI authentication type. - -If for example the AuthMethod `AuthOAuthFoo` is generated for OAuth operations, then -`addAuthMethod` should be used to add the AuthMethod config. - -When a request is dispatched, if a matching auth method is found in -the config, it will be applied to the request. - -### Example - -```haskell -mgr <- newManager defaultManagerSettings -config0 <- withStdoutLogging =<< newConfig -let config = config0 - `addAuthMethod` AuthOAuthFoo "secret-key" - -let addFooRequest = - addFoo - (ContentType MimeJSON) - (Accept MimeXML) - (ParamBar paramBar) - (ParamQux paramQux) - modelBaz - `applyOptionalParam` FooId 1 - `applyOptionalParam` FooName "name" - `setHeader` [("qux_header","xxyy")] -addFooResult <- dispatchMime mgr config addFooRequest -``` - -See the example app and the haddocks for details. diff --git a/httpstan.cabal b/httpstan.cabal --- a/httpstan.cabal +++ b/httpstan.cabal @@ -1,117 +1,46 @@ -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 +name: httpstan +version: 0.3.0.0 +synopsis: Auto-generated API bindings for httpstan +description: Please see README.md +homepage: https://github.com/jmcarthur/httpstan-hs +author: Jake McArthur +maintainer: Jake.McArthur@email.com +copyright: 2023 - Jake McArthur +license: BSD3 +license-files: LICENSE +category: Statistics +build-type: Simple +cabal-version: >=1.10 -extra-source-files: - README.md - openapi.yaml +library + hs-source-dirs: lib + exposed-modules: Httpstan.API + , Httpstan.Types + ghc-options: -Wall + build-depends: + aeson >= 2.1.2 && < 2.2, + base >= 4.16.4 && < 4.17, + containers >= 0.6.5 && < 0.7, + mtl >= 2.2.2 && < 2.3, + transformers >= 0.5.6 && < 0.6, + text >= 1.2.5 && < 1.3, + time >= 1.11.1 && < 1.12, + exceptions >= 0.10.4 && < 0.11, + http-api-data >= 0.5 && < 0.6, + http-types >= 0.12.3 && < 0.13, + http-client >= 0.7.13 && < 0.8, + network-uri >= 2.6.4 && < 2.7, + http-client-tls >= 0.3.6 && < 0.4, + servant >= 0.19.1 && < 0.20, + servant-client >= 0.19 && < 0.20, + servant-client-core >= 0.19 && < 0.20, + servant-server >= 0.19.2 && < 0.20, + wai >= 3.2.3 && < 3.3, + warp >= 3.3.25 && < 3.4, + swagger2 >= 2.8.7 && < 2.9, + uuid >= 1.3.15 && < 1.4 + default-language: Haskell2010 source-repository head type: git location: git@github.com:jmcarthur/httpstan-hs.git - -Flag UseKatip - Description: Use the katip package to provide logging (if false, use the default monad-logger package) - Default: True - Manual: True - -library - hs-source-dirs: - lib - ghc-options: -Wall -funbox-strict-fields - build-depends: - aeson >=1.0 && <3.0 - , base >=4.7 && <5.0 - , base64-bytestring >1.0 && <2.0 - , bytestring >= 0.11.4 && < 0.12 - , case-insensitive >= 1.2.1 && < 1.3 - , containers >=0.5.0.0 && <0.8 - , deepseq >= 1.4 && <1.6 - , exceptions >= 0.10.4 && < 0.11 - , http-api-data >= 0.3.4 && <0.5 - , http-client >=0.5 && <0.8 - , http-client-tls >= 0.3.6 && < 0.4 - , http-media >= 0.4 && < 0.9 - , http-types >=0.8 && <0.13 - , iso8601-time >=0.1.3 && <0.2.0 - , microlens >= 0.4.13 && < 0.5 - , mtl >= 2.2.2 && < 2.3 - , network >=2.6.2 && <3.9 - , random >= 1.2.1 && < 1.3 - , safe-exceptions <0.2 - , text >=0.11 && <1.3 - , time >= 1.11.1 && < 1.12 - , transformers >= 0.5.6 && < 0.6 - , unordered-containers >= 0.2.19 && < 0.3 - , vector >=0.10.9 && <0.13 - - other-modules: - Paths_httpstan - exposed-modules: - Httpstan - Httpstan.API - Httpstan.API.ApiDefault - Httpstan.Client - Httpstan.Core - Httpstan.Logging - Httpstan.MimeTypes - Httpstan.Model - Httpstan.ModelLens - default-language: Haskell2010 - - if flag(UseKatip) - build-depends: katip >=0.8 && < 1.0 - other-modules: Httpstan.LoggingKatip - cpp-options: -DUSE_KATIP - else - build-depends: monad-logger >=0.3 && <0.4 - other-modules: Httpstan.LoggingMonadLogger - cpp-options: -DUSE_MONAD_LOGGER - -test-suite tests - type: exitcode-stdio-1.0 - main-is: Test.hs - hs-source-dirs: - tests - ghc-options: -Wall -fno-warn-orphans - build-depends: - httpstan - , QuickCheck - , aeson - , base >=4.7 && <5.0 - , bytestring >=0.10.0 - , containers - , hspec >=1.8 - , iso8601-time - , mtl >=2.2.1 - , semigroups - , text - , time - , transformers >=0.4.0.0 - , unordered-containers - , vector - other-modules: - ApproxEq - Instances - PropMime - default-language: Haskell2010 diff --git a/lib/Httpstan.hs b/lib/Httpstan.hs deleted file mode 100644 --- a/lib/Httpstan.hs +++ /dev/null @@ -1,31 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan --} - -module Httpstan - ( module Httpstan.API - , module Httpstan.Client - , module Httpstan.Core - , module Httpstan.Logging - , module Httpstan.MimeTypes - , module Httpstan.Model - , module Httpstan.ModelLens - ) where - -import Httpstan.API -import Httpstan.Client -import Httpstan.Core -import Httpstan.Logging -import Httpstan.MimeTypes -import Httpstan.Model -import Httpstan.ModelLens diff --git a/lib/Httpstan/API.hs b/lib/Httpstan/API.hs --- a/lib/Httpstan/API.hs +++ b/lib/Httpstan/API.hs @@ -1,19 +1,280 @@ -{- - httpstan +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC +-fno-warn-unused-binds -fno-warn-unused-imports -freduction-depth=328 #-} - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) +module Httpstan.API + ( -- * Client and Server + Config(..) + , HttpstanBackend(..) + , createHttpstanClient + , runHttpstanServer + , runHttpstanMiddlewareServer + , runHttpstanClient + , runHttpstanClientWithManager + , callHttpstan + , HttpstanClient + , HttpstanClientError(..) + -- ** Servant + , HttpstanAPI + -- ** Plain WAI Application + , serverWaiApplicationHttpstan + ) where - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} +import Httpstan.Types -{-| -Module : Httpstan.API --} +import Control.Monad.Catch (Exception, MonadThrow, throwM) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Aeson (Value) +import Data.Coerce (coerce) +import Data.Data (Data) +import Data.Function ((&)) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Data.UUID (UUID) +import GHC.Exts (IsString (..)) +import GHC.Generics (Generic) +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types.Method (methodOptions) +import Network.Wai (Middleware) +import qualified Network.Wai.Handler.Warp as Warp +import Servant (ServerError, serveWithContextT) +import Servant.API hiding (addHeader) +import Servant.API.Verbs (StdMethod (..), Verb) +import Servant.Client (ClientEnv, Scheme (Http), ClientError, client, + mkClientEnv, parseBaseUrl) +import Servant.Client.Core (baseUrlPort, baseUrlHost) +import Servant.Client.Internal.HttpClient (ClientM (..)) +import Servant.Server (Handler (..), Application, Context (EmptyContext)) +import Servant.Server.StaticFiles (serveDirectoryFileServer) +import Web.FormUrlEncoded +import Web.HttpApiData -module Httpstan.API - ( module Httpstan.API.ApiDefault - ) where -import Httpstan.API.ApiDefault + + +-- | List of elements parsed from a query. +newtype QueryList (p :: CollectionFormat) a = QueryList + { fromQueryList :: [a] + } deriving (Functor, Applicative, Monad, Foldable, Traversable) + +-- | Formats in which a list can be encoded into a HTTP path. +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`. Only for GET params. + +instance FromHttpApiData a => FromHttpApiData (QueryList 'CommaSeparated a) where + parseQueryParam = parseSeparatedQueryList ',' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'TabSeparated a) where + parseQueryParam = parseSeparatedQueryList '\t' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'SpaceSeparated a) where + parseQueryParam = parseSeparatedQueryList ' ' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'PipeSeparated a) where + parseQueryParam = parseSeparatedQueryList '|' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'MultiParamArray a) where + parseQueryParam = error "unimplemented FromHttpApiData for MultiParamArray collection format" + +parseSeparatedQueryList :: FromHttpApiData a => Char -> Text -> Either Text (QueryList p a) +parseSeparatedQueryList char = fmap QueryList . mapM parseQueryParam . T.split (== char) + +instance ToHttpApiData a => ToHttpApiData (QueryList 'CommaSeparated a) where + toQueryParam = formatSeparatedQueryList ',' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'TabSeparated a) where + toQueryParam = formatSeparatedQueryList '\t' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'SpaceSeparated a) where + toQueryParam = formatSeparatedQueryList ' ' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'PipeSeparated a) where + toQueryParam = formatSeparatedQueryList '|' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'MultiParamArray a) where + toQueryParam = error "unimplemented ToHttpApiData for MultiParamArray collection format" + +formatSeparatedQueryList :: ToHttpApiData a => Char -> QueryList p a -> Text +formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList + + +-- | Servant type-level API, generated from the OpenAPI spec for Httpstan. +type HttpstanAPI + = "v1" :> "health" :> Verb 'GET 200 '[JSON] NoContent -- 'v1HealthGet' route + :<|> "v1" :> "models" :> Verb 'GET 200 '[JSON] V1ModelsGet200Response -- 'v1ModelsGet' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> Verb 'DELETE 200 '[JSON] NoContent -- 'v1ModelsModelIdDelete' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "fits" :> Capture "fit_id" Text :> Verb 'DELETE 200 '[JSON] NoContent -- 'v1ModelsModelIdFitsFitIdDelete' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "fits" :> Capture "fit_id" Text :> Verb 'GET 200 '[JSON] NoContent -- 'v1ModelsModelIdFitsFitIdGet' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "fits" :> ReqBody '[JSON] CreateFitRequest :> Verb 'POST 201 '[JSON] Fit -- 'v1ModelsModelIdFitsPost' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "log_prob_grad" :> ReqBody '[JSON] Bool :> Verb 'POST 200 '[JSON] V1ModelsModelIdLogProbGradPost200Response -- 'v1ModelsModelIdLogProbGradPost' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "log_prob" :> ReqBody '[JSON] Bool :> Verb 'POST 200 '[JSON] V1ModelsModelIdLogProbPost200Response -- 'v1ModelsModelIdLogProbPost' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "params" :> ReqBody '[JSON] Value :> Verb 'POST 200 '[JSON] V1ModelsModelIdParamsPost200Response -- 'v1ModelsModelIdParamsPost' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "transform_inits" :> ReqBody '[JSON] Value :> Verb 'POST 200 '[JSON] V1ModelsModelIdTransformInitsPost200Response -- 'v1ModelsModelIdTransformInitsPost' route + :<|> "v1" :> "models" :> Capture "model_id" Text :> "write_array" :> ReqBody '[JSON] Bool :> Verb 'POST 200 '[JSON] V1ModelsModelIdWriteArrayPost200Response -- 'v1ModelsModelIdWriteArrayPost' route + :<|> "v1" :> "models" :> ReqBody '[JSON] CreateModelRequest :> Verb 'POST 201 '[JSON] Model -- 'v1ModelsPost' route + :<|> "v1" :> "operations" :> Capture "operation_id" Text :> Verb 'GET 200 '[JSON] Operation -- 'v1OperationsOperationIdGet' route + :<|> Raw + + +-- | Server or client configuration, specifying the host and port to query or serve on. +data Config = Config + { configUrl :: String -- ^ scheme://hostname:port/path, e.g. "http://localhost:8080/" + } deriving (Eq, Ord, Show, Read) + + +-- | Custom exception type for our errors. +newtype HttpstanClientError = HttpstanClientError ClientError + deriving (Show, Exception) +-- | Configuration, specifying the full url of the service. + + +-- | Backend for Httpstan. +-- The backend can be used both for the client and the server. The client generated from the Httpstan OpenAPI spec +-- is a backend that executes actions by sending HTTP requests (see @createHttpstanClient@). Alternatively, provided +-- a backend, the API can be served using @runHttpstanMiddlewareServer@. +data HttpstanBackend m = HttpstanBackend + { v1HealthGet :: m NoContent{- ^ Check if service is running. -} + , v1ModelsGet :: m V1ModelsGet200Response{- ^ List cached models. -} + , v1ModelsModelIdDelete :: Text -> m NoContent{- ^ Delete a model which has been saved in the cache. -} + , v1ModelsModelIdFitsFitIdDelete :: Text -> Text -> m NoContent{- ^ Delete a fit which has been saved in the cache. -} + , v1ModelsModelIdFitsFitIdGet :: Text -> Text -> m NoContent{- ^ Result (draws, logger messages) from calling a function defined in stan::services. -} + , v1ModelsModelIdFitsPost :: Text -> CreateFitRequest -> m Fit{- ^ 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. -} + , v1ModelsModelIdLogProbGradPost :: Text -> Bool -> m V1ModelsModelIdLogProbGradPost200Response{- ^ Returns the output of Stan C++ `stan::model::log_prob_grad`. -} + , v1ModelsModelIdLogProbPost :: Text -> Bool -> m V1ModelsModelIdLogProbPost200Response{- ^ Returns the output of Stan C++ ``log_prob`` model class method. -} + , v1ModelsModelIdParamsPost :: Text -> Value -> m V1ModelsModelIdParamsPost200Response{- ^ Returns the output of Stan C++ model class methods: ``constrained_param_names``, ``get_param_names`` and ``get_dims``. -} + , v1ModelsModelIdTransformInitsPost :: Text -> Value -> m V1ModelsModelIdTransformInitsPost200Response{- ^ Returns the output of Stan C++ ``transform_inits`` model class method. -} + , v1ModelsModelIdWriteArrayPost :: Text -> Bool -> m V1ModelsModelIdWriteArrayPost200Response{- ^ Returns the output of Stan C++ ``write_array`` model class method. -} + , v1ModelsPost :: CreateModelRequest -> m Model{- ^ Compile a Stan model -} + , v1OperationsOperationIdGet :: Text -> m Operation{- ^ Return Operation details. Details about an Operation include whether or not the operation is `done` and information about the progress of sampling. -} + } + + +newtype HttpstanClient a = HttpstanClient + { runClient :: ClientEnv -> ExceptT ClientError IO a + } deriving Functor + +instance Applicative HttpstanClient where + pure x = HttpstanClient (\_ -> pure x) + (HttpstanClient f) <*> (HttpstanClient x) = + HttpstanClient (\env -> f env <*> x env) + +instance Monad HttpstanClient where + (HttpstanClient a) >>= f = + HttpstanClient (\env -> do + value <- a env + runClient (f value) env) + +instance MonadIO HttpstanClient where + liftIO io = HttpstanClient (\_ -> liftIO io) + +createHttpstanClient :: HttpstanBackend HttpstanClient +createHttpstanClient = HttpstanBackend{..} + where + ((coerce -> v1HealthGet) :<|> + (coerce -> v1ModelsGet) :<|> + (coerce -> v1ModelsModelIdDelete) :<|> + (coerce -> v1ModelsModelIdFitsFitIdDelete) :<|> + (coerce -> v1ModelsModelIdFitsFitIdGet) :<|> + (coerce -> v1ModelsModelIdFitsPost) :<|> + (coerce -> v1ModelsModelIdLogProbGradPost) :<|> + (coerce -> v1ModelsModelIdLogProbPost) :<|> + (coerce -> v1ModelsModelIdParamsPost) :<|> + (coerce -> v1ModelsModelIdTransformInitsPost) :<|> + (coerce -> v1ModelsModelIdWriteArrayPost) :<|> + (coerce -> v1ModelsPost) :<|> + (coerce -> v1OperationsOperationIdGet) :<|> + _) = client (Proxy :: Proxy HttpstanAPI) + +-- | Run requests in the HttpstanClient monad. +runHttpstanClient :: Config -> HttpstanClient a -> ExceptT ClientError IO a +runHttpstanClient clientConfig cl = do + manager <- liftIO $ newManager tlsManagerSettings + runHttpstanClientWithManager manager clientConfig cl + +-- | Run requests in the HttpstanClient monad using a custom manager. +runHttpstanClientWithManager :: Manager -> Config -> HttpstanClient a -> ExceptT ClientError IO a +runHttpstanClientWithManager manager Config{..} cl = do + url <- parseBaseUrl configUrl + runClient cl $ mkClientEnv manager url + +-- | Like @runClient@, but returns the response or throws +-- a HttpstanClientError +callHttpstan + :: (MonadIO m, MonadThrow m) + => ClientEnv -> HttpstanClient a -> m a +callHttpstan env f = do + res <- liftIO $ runExceptT $ runClient f env + case res of + Left err -> throwM (HttpstanClientError err) + Right response -> pure response + + +requestMiddlewareId :: Application -> Application +requestMiddlewareId a = a + +-- | Run the Httpstan server at the provided host and port. +runHttpstanServer + :: (MonadIO m, MonadThrow m) + => Config -> HttpstanBackend (ExceptT ServerError IO) -> m () +runHttpstanServer config backend = runHttpstanMiddlewareServer config requestMiddlewareId backend + +-- | Run the Httpstan server at the provided host and port. +runHttpstanMiddlewareServer + :: (MonadIO m, MonadThrow m) + => Config -> Middleware -> HttpstanBackend (ExceptT ServerError IO) -> m () +runHttpstanMiddlewareServer Config{..} middleware backend = do + url <- parseBaseUrl configUrl + let warpSettings = Warp.defaultSettings + & Warp.setPort (baseUrlPort url) + & Warp.setHost (fromString $ baseUrlHost url) + liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplicationHttpstan backend + +-- | Plain "Network.Wai" Application for the Httpstan server. +-- +-- Can be used to implement e.g. tests that call the API without a full webserver. +serverWaiApplicationHttpstan :: HttpstanBackend (ExceptT ServerError IO) -> Application +serverWaiApplicationHttpstan backend = serveWithContextT (Proxy :: Proxy HttpstanAPI) context id (serverFromBackend backend) + where + context = serverContext + serverFromBackend HttpstanBackend{..} = + (coerce v1HealthGet :<|> + coerce v1ModelsGet :<|> + coerce v1ModelsModelIdDelete :<|> + coerce v1ModelsModelIdFitsFitIdDelete :<|> + coerce v1ModelsModelIdFitsFitIdGet :<|> + coerce v1ModelsModelIdFitsPost :<|> + coerce v1ModelsModelIdLogProbGradPost :<|> + coerce v1ModelsModelIdLogProbPost :<|> + coerce v1ModelsModelIdParamsPost :<|> + coerce v1ModelsModelIdTransformInitsPost :<|> + coerce v1ModelsModelIdWriteArrayPost :<|> + coerce v1ModelsPost :<|> + coerce v1OperationsOperationIdGet :<|> + serveDirectoryFileServer "static") + + +serverContext :: Context ('[]) +serverContext = EmptyContext diff --git a/lib/Httpstan/API/ApiDefault.hs b/lib/Httpstan/API/ApiDefault.hs deleted file mode 100644 --- a/lib/Httpstan/API/ApiDefault.hs +++ /dev/null @@ -1,360 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.API.ApiDefault --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports #-} - -module Httpstan.API.ApiDefault where - -import Httpstan.Core -import Httpstan.MimeTypes -import Httpstan.Model as M - -import qualified Data.Aeson as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Data as P (Typeable, TypeRep, typeOf, typeRep) -import qualified Data.Foldable as P -import qualified Data.Map as Map -import qualified Data.Maybe as P -import qualified Data.Proxy as P (Proxy(..)) -import qualified Data.Set as Set -import qualified Data.String as P -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Time as TI -import qualified Network.HTTP.Client.MultipartFormData as NH -import qualified Network.HTTP.Media as ME -import qualified Network.HTTP.Types as NH -import qualified Web.FormUrlEncoded as WH -import qualified Web.HttpApiData as WH - -import Data.Text (Text) -import GHC.Base ((<|>)) - -import Prelude ((==),(/=),($), (.),(<$>),(<*>),(>>=),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor) -import qualified Prelude as P - --- * Operations - - --- ** Default - --- *** v1HealthGet - --- | @GET \/v1\/health@ --- --- Check if service is running. --- -v1HealthGet - :: HttpstanRequest V1HealthGet MimeNoContent NoContent MimeNoContent -v1HealthGet = - _mkRequest "GET" ["/v1/health"] - -data V1HealthGet -instance Produces V1HealthGet MimeNoContent - - --- *** v1ModelsGet - --- | @GET \/v1\/models@ --- --- List cached models. --- -v1ModelsGet - :: HttpstanRequest V1ModelsGet MimeNoContent V1ModelsGet200Response MimeJSON -v1ModelsGet = - _mkRequest "GET" ["/v1/models"] - -data V1ModelsGet --- | @application/json@ -instance Produces V1ModelsGet MimeJSON - - --- *** v1ModelsModelIdDelete - --- | @DELETE \/v1\/models\/{model_id}@ --- --- Delete a model and any associated fits. --- --- Delete a model which has been saved in the cache. --- -v1ModelsModelIdDelete - :: ModelId -- ^ "modelId" - ID of Stan model - -> HttpstanRequest V1ModelsModelIdDelete MimeNoContent NoContent MimeNoContent -v1ModelsModelIdDelete (ModelId modelId) = - _mkRequest "DELETE" ["/v1/models/",toPath modelId] - -data V1ModelsModelIdDelete -instance Produces V1ModelsModelIdDelete MimeNoContent - - --- *** v1ModelsModelIdFitsFitIdDelete - --- | @DELETE \/v1\/models\/{model_id}\/fits\/{fit_id}@ --- --- Delete a fit. --- --- Delete a fit which has been saved in the cache. --- -v1ModelsModelIdFitsFitIdDelete - :: ModelId -- ^ "modelId" - ID of Stan model associated with the fit. - -> FitId -- ^ "fitId" - ID of fit to be deleted. - -> HttpstanRequest V1ModelsModelIdFitsFitIdDelete MimeNoContent NoContent MimeNoContent -v1ModelsModelIdFitsFitIdDelete (ModelId modelId) (FitId fitId) = - _mkRequest "DELETE" ["/v1/models/",toPath modelId,"/fits/",toPath fitId] - -data V1ModelsModelIdFitsFitIdDelete -instance Produces V1ModelsModelIdFitsFitIdDelete MimeNoContent - - --- *** v1ModelsModelIdFitsFitIdGet - --- | @GET \/v1\/models\/{model_id}\/fits\/{fit_id}@ --- --- Get results returned by a function. --- --- Result (draws, logger messages) from calling a function defined in stan::services. --- -v1ModelsModelIdFitsFitIdGet - :: ModelId -- ^ "modelId" - ID of Stan model associated with the result - -> FitId -- ^ "fitId" - ID of Stan result (\"fit\") desired - -> HttpstanRequest V1ModelsModelIdFitsFitIdGet MimeNoContent NoContent MimeNoContent -v1ModelsModelIdFitsFitIdGet (ModelId modelId) (FitId fitId) = - _mkRequest "GET" ["/v1/models/",toPath modelId,"/fits/",toPath fitId] - -data V1ModelsModelIdFitsFitIdGet -instance Produces V1ModelsModelIdFitsFitIdGet MimeNoContent - - --- *** v1ModelsModelIdFitsPost - --- | @POST \/v1\/models\/{model_id}\/fits@ --- --- Call function defined in stan::services. --- --- A request to this endpoint starts a long-running operation. Users can retrieve information about the status of the operation by making a GET request to the operations resource endpoint. When the operation is `done`, the \"fit\" may be downloaded. (A \"fit\" collects all logger and writer messages from Stan.) ``function`` indicates the name of the ``stan::services function`` which should be called given the Stan model associated with the id ``model_id``. For example, if sampling using ``stan::services::sample::hmc_nuts_diag_e_adapt`` then ``function`` is the full function name ``stan::services::sample::hmc_nuts_diag_e_adapt``. Sampler parameters which are not supplied will be given default values taken from CmdStan. For example, if ``stan::services::sample::hmc_nuts_diag_e_adapt`` is the function called and the parameter ``num_samples`` is not specified, the value 1000 will be used. For a full list of default values consult the CmdStan documentation. --- -v1ModelsModelIdFitsPost - :: (Consumes V1ModelsModelIdFitsPost MimeJSON, MimeRender MimeJSON CreateFitRequest) - => CreateFitRequest -- ^ "body" - Full stan::services function name and associated arguments to call with Stan model. - -> ModelId -- ^ "modelId" - ID of Stan model to use - -> HttpstanRequest V1ModelsModelIdFitsPost MimeJSON Fit MimeJSON -v1ModelsModelIdFitsPost body (ModelId modelId) = - _mkRequest "POST" ["/v1/models/",toPath modelId,"/fits"] - `setBodyParam` body - -data V1ModelsModelIdFitsPost - --- | /Body Param/ "body" - Full stan::services function name and associated arguments to call with Stan model. -instance HasBodyParam V1ModelsModelIdFitsPost CreateFitRequest - --- | @application/json@ -instance Consumes V1ModelsModelIdFitsPost MimeJSON - --- | @application/json@ -instance Produces V1ModelsModelIdFitsPost MimeJSON - - --- *** v1ModelsModelIdLogProbGradPost - --- | @POST \/v1\/models\/{model_id}\/log_prob_grad@ --- --- Return the gradient of the log posterior evaluated at the unconstrained parameters. --- --- Returns the output of Stan C++ `stan::model::log_prob_grad`. --- -v1ModelsModelIdLogProbGradPost - :: (Consumes V1ModelsModelIdLogProbGradPost MimeJSON) - => ModelId -- ^ "modelId" - ID of Stan model to use - -> HttpstanRequest V1ModelsModelIdLogProbGradPost MimeJSON V1ModelsModelIdLogProbGradPost200Response MimeJSON -v1ModelsModelIdLogProbGradPost (ModelId modelId) = - _mkRequest "POST" ["/v1/models/",toPath modelId,"/log_prob_grad"] - -data V1ModelsModelIdLogProbGradPost - --- | /Body Param/ "adjust_transform" - Boolean to control whether we apply a Jacobian adjust transform. -instance HasBodyParam V1ModelsModelIdLogProbGradPost AdjustTransform - --- | @application/json@ -instance Consumes V1ModelsModelIdLogProbGradPost MimeJSON - --- | @application/json@ -instance Produces V1ModelsModelIdLogProbGradPost MimeJSON - - --- *** v1ModelsModelIdLogProbPost - --- | @POST \/v1\/models\/{model_id}\/log_prob@ --- --- Return the log probability of the unconstrained parameters. --- --- Returns the output of Stan C++ ``log_prob`` model class method. --- -v1ModelsModelIdLogProbPost - :: (Consumes V1ModelsModelIdLogProbPost MimeJSON) - => ModelId -- ^ "modelId" - ID of Stan model to use - -> HttpstanRequest V1ModelsModelIdLogProbPost MimeJSON V1ModelsModelIdLogProbPost200Response MimeJSON -v1ModelsModelIdLogProbPost (ModelId modelId) = - _mkRequest "POST" ["/v1/models/",toPath modelId,"/log_prob"] - -data V1ModelsModelIdLogProbPost - --- | /Body Param/ "adjust_transform" - Boolean to control whether we apply a Jacobian adjust transform. -instance HasBodyParam V1ModelsModelIdLogProbPost AdjustTransform - --- | @application/json@ -instance Consumes V1ModelsModelIdLogProbPost MimeJSON - --- | @application/json@ -instance Produces V1ModelsModelIdLogProbPost MimeJSON - - --- *** v1ModelsModelIdParamsPost - --- | @POST \/v1\/models\/{model_id}\/params@ --- --- Get parameter names and dimensions. --- --- Returns the output of Stan C++ model class methods: ``constrained_param_names``, ``get_param_names`` and ``get_dims``. --- -v1ModelsModelIdParamsPost - :: (Consumes V1ModelsModelIdParamsPost MimeJSON, MimeRender MimeJSON ParamData) - => ParamData -- ^ "_data" - Data for Stan Model. Needed to calculate param names and dimensions. - -> ModelId -- ^ "modelId" - ID of Stan model to use - -> HttpstanRequest V1ModelsModelIdParamsPost MimeJSON V1ModelsModelIdParamsPost200Response MimeJSON -v1ModelsModelIdParamsPost _data (ModelId modelId) = - _mkRequest "POST" ["/v1/models/",toPath modelId,"/params"] - `setBodyParam` _data - -data V1ModelsModelIdParamsPost - --- | /Body Param/ "data" - Data for Stan Model. Needed to calculate param names and dimensions. -instance HasBodyParam V1ModelsModelIdParamsPost ParamData - --- | @application/json@ -instance Consumes V1ModelsModelIdParamsPost MimeJSON - --- | @application/json@ -instance Produces V1ModelsModelIdParamsPost MimeJSON - - --- *** v1ModelsModelIdTransformInitsPost - --- | @POST \/v1\/models\/{model_id}\/transform_inits@ --- --- Return a sequence of unconstrained parameters. --- --- Returns the output of Stan C++ ``transform_inits`` model class method. --- -v1ModelsModelIdTransformInitsPost - :: (Consumes V1ModelsModelIdTransformInitsPost MimeJSON, MimeRender MimeJSON ConstrainedParameters) - => ConstrainedParameters -- ^ "constrainedParameters" - Constrained parameter values and their specified context - -> ModelId -- ^ "modelId" - ID of Stan model to use - -> HttpstanRequest V1ModelsModelIdTransformInitsPost MimeJSON V1ModelsModelIdTransformInitsPost200Response MimeJSON -v1ModelsModelIdTransformInitsPost constrainedParameters (ModelId modelId) = - _mkRequest "POST" ["/v1/models/",toPath modelId,"/transform_inits"] - `setBodyParam` constrainedParameters - -data V1ModelsModelIdTransformInitsPost - --- | /Body Param/ "constrained_parameters" - Constrained parameter values and their specified context -instance HasBodyParam V1ModelsModelIdTransformInitsPost ConstrainedParameters - --- | @application/json@ -instance Consumes V1ModelsModelIdTransformInitsPost MimeJSON - --- | @application/json@ -instance Produces V1ModelsModelIdTransformInitsPost MimeJSON - - --- *** v1ModelsModelIdWriteArrayPost - --- | @POST \/v1\/models\/{model_id}\/write_array@ --- --- Return a sequence of constrained parameters. --- --- Returns the output of Stan C++ ``write_array`` model class method. --- -v1ModelsModelIdWriteArrayPost - :: (Consumes V1ModelsModelIdWriteArrayPost MimeJSON, MimeRender MimeJSON IncludeGqs) - => IncludeGqs -- ^ "includeGqs" - Boolean to control whether we include generated quantities. - -> ModelId -- ^ "modelId" - ID of Stan model to use - -> HttpstanRequest V1ModelsModelIdWriteArrayPost MimeJSON V1ModelsModelIdWriteArrayPost200Response MimeJSON -v1ModelsModelIdWriteArrayPost includeGqs (ModelId modelId) = - _mkRequest "POST" ["/v1/models/",toPath modelId,"/write_array"] - `setBodyParam` includeGqs - -data V1ModelsModelIdWriteArrayPost - --- | /Body Param/ "include_gqs" - Boolean to control whether we include generated quantities. -instance HasBodyParam V1ModelsModelIdWriteArrayPost IncludeGqs - --- | @application/json@ -instance Consumes V1ModelsModelIdWriteArrayPost MimeJSON - --- | @application/json@ -instance Produces V1ModelsModelIdWriteArrayPost MimeJSON - - --- *** v1ModelsPost - --- | @POST \/v1\/models@ --- --- Compile a Stan model --- -v1ModelsPost - :: (Consumes V1ModelsPost MimeJSON, MimeRender MimeJSON CreateModelRequest) - => CreateModelRequest -- ^ "body" - Stan program code to compile - -> HttpstanRequest V1ModelsPost MimeJSON Model MimeJSON -v1ModelsPost body = - _mkRequest "POST" ["/v1/models"] - `setBodyParam` body - -data V1ModelsPost - --- | /Body Param/ "body" - Stan program code to compile -instance HasBodyParam V1ModelsPost CreateModelRequest - --- | @application/json@ -instance Consumes V1ModelsPost MimeJSON - --- | @application/json@ -instance Produces V1ModelsPost MimeJSON - - --- *** v1OperationsOperationIdGet - --- | @GET \/v1\/operations\/{operation_id}@ --- --- Get Operation details. --- --- Return Operation details. Details about an Operation include whether or not the operation is `done` and information about the progress of sampling. --- -v1OperationsOperationIdGet - :: OperationId -- ^ "operationId" - ID of Operation - -> HttpstanRequest V1OperationsOperationIdGet MimeNoContent Operation MimeJSON -v1OperationsOperationIdGet (OperationId operationId) = - _mkRequest "GET" ["/v1/operations/",toPath operationId] - -data V1OperationsOperationIdGet --- | @application/json@ -instance Produces V1OperationsOperationIdGet MimeJSON - diff --git a/lib/Httpstan/Client.hs b/lib/Httpstan/Client.hs deleted file mode 100644 --- a/lib/Httpstan/Client.hs +++ /dev/null @@ -1,223 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.Client --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} - -module Httpstan.Client where - -import Httpstan.Core -import Httpstan.Logging -import Httpstan.MimeTypes - -import qualified Control.Exception.Safe as E -import qualified Control.Monad.IO.Class as P -import qualified Control.Monad as P -import qualified Data.Aeson.Types as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BCL -import qualified Data.Proxy as P (Proxy(..)) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Network.HTTP.Client as NH -import qualified Network.HTTP.Client.MultipartFormData as NH -import qualified Network.HTTP.Types as NH -import qualified Web.FormUrlEncoded as WH -import qualified Web.HttpApiData as WH - -import Data.Function ((&)) -import Data.Monoid ((<>)) -import Data.Text (Text) -import GHC.Exts (IsString(..)) - --- * Dispatch - --- ** Lbs - --- | send a request returning the raw http response -dispatchLbs - :: (Produces req accept, MimeType contentType) - => NH.Manager -- ^ http-client Connection manager - -> HttpstanConfig -- ^ config - -> HttpstanRequest req contentType res accept -- ^ request - -> IO (NH.Response BCL.ByteString) -- ^ response -dispatchLbs manager config request = do - initReq <- _toInitRequest config request - dispatchInitUnsafe manager config initReq - --- ** Mime - --- | pair of decoded http body and http response -data MimeResult res = - MimeResult { mimeResult :: Either MimeError res -- ^ decoded http body - , mimeResultResponse :: NH.Response BCL.ByteString -- ^ http response - } - deriving (Show, Functor, Foldable, Traversable) - --- | pair of unrender/parser error and http response -data MimeError = - MimeError { - mimeError :: String -- ^ unrender/parser error - , mimeErrorResponse :: NH.Response BCL.ByteString -- ^ http response - } deriving (Show) - --- | send a request returning the 'MimeResult' -dispatchMime - :: forall req contentType res accept. (Produces req accept, MimeUnrender accept res, MimeType contentType) - => NH.Manager -- ^ http-client Connection manager - -> HttpstanConfig -- ^ config - -> HttpstanRequest req contentType res accept -- ^ request - -> IO (MimeResult res) -- ^ response -dispatchMime manager config request = do - httpResponse <- dispatchLbs manager config request - let statusCode = NH.statusCode . NH.responseStatus $ httpResponse - parsedResult <- - runConfigLogWithExceptions "Client" config $ - do if (statusCode >= 400 && statusCode < 600) - then do - let s = "error statusCode: " ++ show statusCode - _log "Client" levelError (T.pack s) - pure (Left (MimeError s httpResponse)) - else case mimeUnrender (P.Proxy :: P.Proxy accept) (NH.responseBody httpResponse) of - Left s -> do - _log "Client" levelError (T.pack s) - pure (Left (MimeError s httpResponse)) - Right r -> pure (Right r) - return (MimeResult parsedResult httpResponse) - --- | like 'dispatchMime', but only returns the decoded http body -dispatchMime' - :: (Produces req accept, MimeUnrender accept res, MimeType contentType) - => NH.Manager -- ^ http-client Connection manager - -> HttpstanConfig -- ^ config - -> HttpstanRequest req contentType res accept -- ^ request - -> IO (Either MimeError res) -- ^ response -dispatchMime' manager config request = do - MimeResult parsedResult _ <- dispatchMime manager config request - return parsedResult - --- ** Unsafe - --- | like 'dispatchReqLbs', but does not validate the operation is a 'Producer' of the "accept" 'MimeType'. (Useful if the server's response is undocumented) -dispatchLbsUnsafe - :: (MimeType accept, MimeType contentType) - => NH.Manager -- ^ http-client Connection manager - -> HttpstanConfig -- ^ config - -> HttpstanRequest req contentType res accept -- ^ request - -> IO (NH.Response BCL.ByteString) -- ^ response -dispatchLbsUnsafe manager config request = do - initReq <- _toInitRequest config request - dispatchInitUnsafe manager config initReq - --- | dispatch an InitRequest -dispatchInitUnsafe - :: NH.Manager -- ^ http-client Connection manager - -> HttpstanConfig -- ^ config - -> InitRequest req contentType res accept -- ^ init request - -> IO (NH.Response BCL.ByteString) -- ^ response -dispatchInitUnsafe manager config (InitRequest req) = do - runConfigLogWithExceptions src config $ - do _log src levelInfo requestLogMsg - _log src levelDebug requestDbgLogMsg - res <- P.liftIO $ NH.httpLbs req manager - _log src levelInfo (responseLogMsg res) - _log src levelDebug ((T.pack . show) res) - return res - where - src = "Client" - endpoint = - T.pack $ - BC.unpack $ - NH.method req <> " " <> NH.host req <> NH.path req <> NH.queryString req - requestLogMsg = "REQ:" <> endpoint - requestDbgLogMsg = - "Headers=" <> (T.pack . show) (NH.requestHeaders req) <> " Body=" <> - (case NH.requestBody req of - NH.RequestBodyLBS xs -> T.decodeUtf8 (BL.toStrict xs) - _ -> "") - responseStatusCode = (T.pack . show) . NH.statusCode . NH.responseStatus - responseLogMsg res = - "RES:statusCode=" <> responseStatusCode res <> " (" <> endpoint <> ")" - --- * InitRequest - --- | wraps an http-client 'Request' with request/response type parameters -newtype InitRequest req contentType res accept = InitRequest - { unInitRequest :: NH.Request - } deriving (Show) - --- | Build an http-client 'Request' record from the supplied config and request -_toInitRequest - :: (MimeType accept, MimeType contentType) - => HttpstanConfig -- ^ config - -> HttpstanRequest req contentType res accept -- ^ request - -> IO (InitRequest req contentType res accept) -- ^ initialized request -_toInitRequest config req0 = - runConfigLogWithExceptions "Client" config $ do - parsedReq <- P.liftIO $ NH.parseRequest $ BCL.unpack $ BCL.append (configHost config) (BCL.concat (rUrlPath req0)) - req1 <- P.liftIO $ _applyAuthMethods req0 config - P.when - (configValidateAuthMethods config && (not . null . rAuthTypes) req1) - (E.throw $ AuthMethodException $ "AuthMethod not configured: " <> (show . head . rAuthTypes) req1) - let req2 = req1 & _setContentTypeHeader & _setAcceptHeader - params = rParams req2 - reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders params - reqQuery = let query = paramsQuery params - queryExtraUnreserved = configQueryExtraUnreserved config - in if B.null queryExtraUnreserved - then NH.renderQuery True query - else NH.renderQueryPartialEscape True (toPartialEscapeQuery queryExtraUnreserved query) - pReq = parsedReq { NH.method = rMethod req2 - , NH.requestHeaders = reqHeaders - , NH.queryString = reqQuery - } - outReq <- case paramsBody params of - ParamBodyNone -> pure (pReq { NH.requestBody = mempty }) - ParamBodyB bs -> pure (pReq { NH.requestBody = NH.RequestBodyBS bs }) - ParamBodyBL bl -> pure (pReq { NH.requestBody = NH.RequestBodyLBS bl }) - ParamBodyFormUrlEncoded form -> pure (pReq { NH.requestBody = NH.RequestBodyLBS (WH.urlEncodeForm form) }) - ParamBodyMultipartFormData parts -> NH.formDataBody parts pReq - - pure (InitRequest outReq) - --- | modify the underlying Request -modifyInitRequest :: InitRequest req contentType res accept -> (NH.Request -> NH.Request) -> InitRequest req contentType res accept -modifyInitRequest (InitRequest req) f = InitRequest (f req) - --- | modify the underlying Request (monadic) -modifyInitRequestM :: Monad m => InitRequest req contentType res accept -> (NH.Request -> m NH.Request) -> m (InitRequest req contentType res accept) -modifyInitRequestM (InitRequest req) f = fmap InitRequest (f req) - --- ** Logging - --- | Run a block using the configured logger instance -runConfigLog - :: P.MonadIO m - => HttpstanConfig -> LogExec m a -runConfigLog config = configLogExecWithContext config (configLogContext config) - --- | Run a block using the configured logger instance (logs exceptions) -runConfigLogWithExceptions - :: (E.MonadCatch m, P.MonadIO m) - => T.Text -> HttpstanConfig -> LogExec m a -runConfigLogWithExceptions src config = runConfigLog config . logExceptions src diff --git a/lib/Httpstan/Core.hs b/lib/Httpstan/Core.hs deleted file mode 100644 --- a/lib/Httpstan/Core.hs +++ /dev/null @@ -1,581 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.Core --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports #-} - -module Httpstan.Core where - -import Httpstan.MimeTypes -import Httpstan.Logging - -import qualified Control.Arrow as P (left) -import qualified Control.DeepSeq as NF -import qualified Control.Exception.Safe as E -import qualified Data.Aeson as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64.Lazy as BL64 -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BCL -import qualified Data.CaseInsensitive as CI -import qualified Data.Data as P (Data, Typeable, TypeRep, typeRep) -import qualified Data.Foldable as P -import qualified Data.Ix as P -import qualified Data.Kind as K (Type) -import qualified Data.Maybe as P -import qualified Data.Proxy as P (Proxy(..)) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Time as TI -import qualified Data.Time.ISO8601 as TI -import qualified GHC.Base as P (Alternative) -import qualified Lens.Micro as L -import qualified Network.HTTP.Client.MultipartFormData as NH -import qualified Network.HTTP.Types as NH -import qualified Prelude as P -import qualified Text.Printf as T -import qualified Web.FormUrlEncoded as WH -import qualified Web.HttpApiData as WH - -import Control.Applicative ((<|>)) -import Control.Applicative (Alternative) -import Control.Monad.Fail (MonadFail) -import Data.Function ((&)) -import Data.Foldable(foldlM) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Prelude (($), (.), (&&), (<$>), (<*>), Maybe(..), Bool(..), Char, String, fmap, mempty, pure, return, show, IO, Monad, Functor, maybe) - --- * HttpstanConfig - --- | -data HttpstanConfig = HttpstanConfig - { configHost :: BCL.ByteString -- ^ host supplied in the Request - , configUserAgent :: Text -- ^ user-agent supplied in the Request - , configLogExecWithContext :: LogExecWithContext -- ^ Run a block using a Logger instance - , configLogContext :: LogContext -- ^ Configures the logger - , configAuthMethods :: [AnyAuthMethod] -- ^ List of configured auth methods - , configValidateAuthMethods :: Bool -- ^ throw exceptions if auth methods are not configured - , configQueryExtraUnreserved :: B.ByteString -- ^ Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':' - } - --- | display the config -instance P.Show HttpstanConfig where - show c = - T.printf - "{ configHost = %v, configUserAgent = %v, ..}" - (show (configHost c)) - (show (configUserAgent c)) - --- | constructs a default HttpstanConfig --- --- configHost: --- --- @http://localhost@ --- --- configUserAgent: --- --- @"httpstan/0.1.0.0"@ --- -newConfig :: IO HttpstanConfig -newConfig = do - logCxt <- initLogContext - return $ HttpstanConfig - { configHost = "http://localhost" - , configUserAgent = "httpstan/0.1.0.0" - , configLogExecWithContext = runDefaultLogExecWithContext - , configLogContext = logCxt - , configAuthMethods = [] - , configValidateAuthMethods = True - , configQueryExtraUnreserved = "" - } - --- | updates config use AuthMethod on matching requests -addAuthMethod :: AuthMethod auth => HttpstanConfig -> auth -> HttpstanConfig -addAuthMethod config@HttpstanConfig {configAuthMethods = as} a = - config { configAuthMethods = AnyAuthMethod a : as} - --- | updates the config to use stdout logging -withStdoutLogging :: HttpstanConfig -> IO HttpstanConfig -withStdoutLogging p = do - logCxt <- stdoutLoggingContext (configLogContext p) - return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt } - --- | updates the config to use stderr logging -withStderrLogging :: HttpstanConfig -> IO HttpstanConfig -withStderrLogging p = do - logCxt <- stderrLoggingContext (configLogContext p) - return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt } - --- | updates the config to disable logging -withNoLogging :: HttpstanConfig -> HttpstanConfig -withNoLogging p = p { configLogExecWithContext = runNullLogExec} - --- * HttpstanRequest - --- | Represents a request. --- --- Type Variables: --- --- * req - request operation --- * contentType - 'MimeType' associated with request body --- * res - response model --- * accept - 'MimeType' associated with response body -data HttpstanRequest req contentType res accept = HttpstanRequest - { rMethod :: NH.Method -- ^ Method of HttpstanRequest - , rUrlPath :: [BCL.ByteString] -- ^ Endpoint of HttpstanRequest - , rParams :: Params -- ^ params of HttpstanRequest - , rAuthTypes :: [P.TypeRep] -- ^ types of auth methods - } - deriving (P.Show) - --- | 'rMethod' Lens -rMethodL :: Lens_' (HttpstanRequest req contentType res accept) NH.Method -rMethodL f HttpstanRequest{..} = (\rMethod -> HttpstanRequest { rMethod, ..} ) <$> f rMethod -{-# INLINE rMethodL #-} - --- | 'rUrlPath' Lens -rUrlPathL :: Lens_' (HttpstanRequest req contentType res accept) [BCL.ByteString] -rUrlPathL f HttpstanRequest{..} = (\rUrlPath -> HttpstanRequest { rUrlPath, ..} ) <$> f rUrlPath -{-# INLINE rUrlPathL #-} - --- | 'rParams' Lens -rParamsL :: Lens_' (HttpstanRequest req contentType res accept) Params -rParamsL f HttpstanRequest{..} = (\rParams -> HttpstanRequest { rParams, ..} ) <$> f rParams -{-# INLINE rParamsL #-} - --- | 'rParams' Lens -rAuthTypesL :: Lens_' (HttpstanRequest req contentType res accept) [P.TypeRep] -rAuthTypesL f HttpstanRequest{..} = (\rAuthTypes -> HttpstanRequest { rAuthTypes, ..} ) <$> f rAuthTypes -{-# INLINE rAuthTypesL #-} - --- * HasBodyParam - --- | Designates the body parameter of a request -class HasBodyParam req param where - setBodyParam :: forall contentType res accept. (Consumes req contentType, MimeRender contentType param) => HttpstanRequest req contentType res accept -> param -> HttpstanRequest req contentType res accept - setBodyParam req xs = - req `_setBodyLBS` mimeRender (P.Proxy :: P.Proxy contentType) xs & _setContentTypeHeader - --- * HasOptionalParam - --- | Designates the optional parameters of a request -class HasOptionalParam req param where - {-# MINIMAL applyOptionalParam | (-&-) #-} - - -- | Apply an optional parameter to a request - applyOptionalParam :: HttpstanRequest req contentType res accept -> param -> HttpstanRequest req contentType res accept - applyOptionalParam = (-&-) - {-# INLINE applyOptionalParam #-} - - -- | infix operator \/ alias for 'addOptionalParam' - (-&-) :: HttpstanRequest req contentType res accept -> param -> HttpstanRequest req contentType res accept - (-&-) = applyOptionalParam - {-# INLINE (-&-) #-} - -infixl 2 -&- - --- | Request Params -data Params = Params - { paramsQuery :: NH.Query - , paramsHeaders :: NH.RequestHeaders - , paramsBody :: ParamBody - } - deriving (P.Show) - --- | 'paramsQuery' Lens -paramsQueryL :: Lens_' Params NH.Query -paramsQueryL f Params{..} = (\paramsQuery -> Params { paramsQuery, ..} ) <$> f paramsQuery -{-# INLINE paramsQueryL #-} - --- | 'paramsHeaders' Lens -paramsHeadersL :: Lens_' Params NH.RequestHeaders -paramsHeadersL f Params{..} = (\paramsHeaders -> Params { paramsHeaders, ..} ) <$> f paramsHeaders -{-# INLINE paramsHeadersL #-} - --- | 'paramsBody' Lens -paramsBodyL :: Lens_' Params ParamBody -paramsBodyL f Params{..} = (\paramsBody -> Params { paramsBody, ..} ) <$> f paramsBody -{-# INLINE paramsBodyL #-} - --- | Request Body -data ParamBody - = ParamBodyNone - | ParamBodyB B.ByteString - | ParamBodyBL BL.ByteString - | ParamBodyFormUrlEncoded WH.Form - | ParamBodyMultipartFormData [NH.Part] - deriving (P.Show) - --- ** HttpstanRequest Utils - -_mkRequest :: NH.Method -- ^ Method - -> [BCL.ByteString] -- ^ Endpoint - -> HttpstanRequest req contentType res accept -- ^ req: Request Type, res: Response Type -_mkRequest m u = HttpstanRequest m u _mkParams [] - -_mkParams :: Params -_mkParams = Params [] [] ParamBodyNone - -setHeader :: - HttpstanRequest req contentType res accept - -> [NH.Header] - -> HttpstanRequest req contentType res accept -setHeader req header = - req `removeHeader` P.fmap P.fst header - & (`addHeader` header) - -addHeader :: - HttpstanRequest req contentType res accept - -> [NH.Header] - -> HttpstanRequest req contentType res accept -addHeader req header = L.over (rParamsL . paramsHeadersL) (header P.++) req - -removeHeader :: HttpstanRequest req contentType res accept -> [NH.HeaderName] -> HttpstanRequest req contentType res accept -removeHeader req header = - req & - L.over - (rParamsL . paramsHeadersL) - (P.filter (\h -> cifst h `P.notElem` P.fmap CI.mk header)) - where - cifst = CI.mk . P.fst - - -_setContentTypeHeader :: forall req contentType res accept. MimeType contentType => HttpstanRequest req contentType res accept -> HttpstanRequest req contentType res accept -_setContentTypeHeader req = - case mimeType (P.Proxy :: P.Proxy contentType) of - Just m -> req `setHeader` [("content-type", BC.pack $ P.show m)] - Nothing -> req `removeHeader` ["content-type"] - -_setAcceptHeader :: forall req contentType res accept. MimeType accept => HttpstanRequest req contentType res accept -> HttpstanRequest req contentType res accept -_setAcceptHeader req = - case mimeType (P.Proxy :: P.Proxy accept) of - Just m -> req `setHeader` [("accept", BC.pack $ P.show m)] - Nothing -> req `removeHeader` ["accept"] - -setQuery :: - HttpstanRequest req contentType res accept - -> [NH.QueryItem] - -> HttpstanRequest req contentType res accept -setQuery req query = - req & - L.over - (rParamsL . paramsQueryL) - (P.filter (\q -> cifst q `P.notElem` P.fmap cifst query)) & - (`addQuery` query) - where - cifst = CI.mk . P.fst - -addQuery :: - HttpstanRequest req contentType res accept - -> [NH.QueryItem] - -> HttpstanRequest req contentType res accept -addQuery req query = req & L.over (rParamsL . paramsQueryL) (query P.++) - -addForm :: HttpstanRequest req contentType res accept -> WH.Form -> HttpstanRequest req contentType res accept -addForm req newform = - let form = case paramsBody (rParams req) of - ParamBodyFormUrlEncoded _form -> _form - _ -> mempty - in req & L.set (rParamsL . paramsBodyL) (ParamBodyFormUrlEncoded (newform <> form)) - -_addMultiFormPart :: HttpstanRequest req contentType res accept -> NH.Part -> HttpstanRequest req contentType res accept -_addMultiFormPart req newpart = - let parts = case paramsBody (rParams req) of - ParamBodyMultipartFormData _parts -> _parts - _ -> [] - in req & L.set (rParamsL . paramsBodyL) (ParamBodyMultipartFormData (newpart : parts)) - -_setBodyBS :: HttpstanRequest req contentType res accept -> B.ByteString -> HttpstanRequest req contentType res accept -_setBodyBS req body = - req & L.set (rParamsL . paramsBodyL) (ParamBodyB body) - -_setBodyLBS :: HttpstanRequest req contentType res accept -> BL.ByteString -> HttpstanRequest req contentType res accept -_setBodyLBS req body = - req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body) - -_hasAuthType :: AuthMethod authMethod => HttpstanRequest req contentType res accept -> P.Proxy authMethod -> HttpstanRequest req contentType res accept -_hasAuthType req proxy = - req & L.over rAuthTypesL (P.typeRep proxy :) - --- ** Params Utils - -toPath - :: WH.ToHttpApiData a - => a -> BCL.ByteString -toPath = BB.toLazyByteString . WH.toEncodedUrlPiece - -toHeader :: WH.ToHttpApiData a => (NH.HeaderName, a) -> [NH.Header] -toHeader x = [fmap WH.toHeader x] - -toForm :: WH.ToHttpApiData v => (BC.ByteString, v) -> WH.Form -toForm (k,v) = WH.toForm [(BC.unpack k,v)] - -toQuery :: WH.ToHttpApiData a => (BC.ByteString, Maybe a) -> [NH.QueryItem] -toQuery x = [(fmap . fmap) toQueryParam x] - where toQueryParam = T.encodeUtf8 . WH.toQueryParam - -toPartialEscapeQuery :: B.ByteString -> NH.Query -> NH.PartialEscapeQuery -toPartialEscapeQuery extraUnreserved query = fmap (\(k, v) -> (k, maybe [] go v)) query - where go :: B.ByteString -> [NH.EscapeItem] - go v = v & B.groupBy (\a b -> a `B.notElem` extraUnreserved && b `B.notElem` extraUnreserved) - & fmap (\xs -> if B.null xs then NH.QN xs - else if B.head xs `B.elem` extraUnreserved - then NH.QN xs -- Not Encoded - else NH.QE xs -- Encoded - ) - --- *** OpenAPI `CollectionFormat` Utils - --- | Determines the format of the array if type array is used. -data CollectionFormat - = CommaSeparated -- ^ CSV format for multiple parameters. - | SpaceSeparated -- ^ Also called "SSV" - | TabSeparated -- ^ Also called "TSV" - | PipeSeparated -- ^ `value1|value2|value2` - | MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. This is valid only for parameters in "query" ('NH.Query') or "formData" ('WH.Form') - -toHeaderColl :: WH.ToHttpApiData a => CollectionFormat -> (NH.HeaderName, [a]) -> [NH.Header] -toHeaderColl c xs = _toColl c toHeader xs - -toFormColl :: WH.ToHttpApiData v => CollectionFormat -> (BC.ByteString, [v]) -> WH.Form -toFormColl c xs = WH.toForm $ fmap unpack $ _toColl c toHeader $ pack xs - where - pack (k,v) = (CI.mk k, v) - unpack (k,v) = (BC.unpack (CI.original k), BC.unpack v) - -toQueryColl :: WH.ToHttpApiData a => CollectionFormat -> (BC.ByteString, Maybe [a]) -> NH.Query -toQueryColl c xs = _toCollA c toQuery xs - -_toColl :: P.Traversable f => CollectionFormat -> (f a -> [(b, BC.ByteString)]) -> f [a] -> [(b, BC.ByteString)] -_toColl c encode xs = fmap (fmap P.fromJust) (_toCollA' c fencode BC.singleton (fmap Just xs)) - where fencode = fmap (fmap Just) . encode . fmap P.fromJust - {-# INLINE fencode #-} - -_toCollA :: (P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t BC.ByteString)]) -> f (t [a]) -> [(b, t BC.ByteString)] -_toCollA c encode xs = _toCollA' c encode BC.singleton xs - -_toCollA' :: (P.Monoid c, P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t c)]) -> (Char -> c) -> f (t [a]) -> [(b, t c)] -_toCollA' c encode one xs = case c of - CommaSeparated -> go (one ',') - SpaceSeparated -> go (one ' ') - TabSeparated -> go (one '\t') - PipeSeparated -> go (one '|') - MultiParamArray -> expandList - where - go sep = - [P.foldl1 (\(sk, sv) (_, v) -> (sk, (combine sep <$> sv <*> v) <|> sv <|> v)) expandList] - combine sep x y = x <> sep <> y - expandList = (P.concatMap encode . (P.traverse . P.traverse) P.toList) xs - {-# INLINE go #-} - {-# INLINE expandList #-} - {-# INLINE combine #-} - --- * AuthMethods - --- | Provides a method to apply auth methods to requests -class P.Typeable a => - AuthMethod a where - applyAuthMethod - :: HttpstanConfig - -> a - -> HttpstanRequest req contentType res accept - -> IO (HttpstanRequest req contentType res accept) - --- | An existential wrapper for any AuthMethod -data AnyAuthMethod = forall a. AuthMethod a => AnyAuthMethod a deriving (P.Typeable) - -instance AuthMethod AnyAuthMethod where applyAuthMethod config (AnyAuthMethod a) req = applyAuthMethod config a req - --- | indicates exceptions related to AuthMethods -data AuthMethodException = AuthMethodException String deriving (P.Show, P.Typeable) - -instance E.Exception AuthMethodException - --- | apply all matching AuthMethods in config to request -_applyAuthMethods - :: HttpstanRequest req contentType res accept - -> HttpstanConfig - -> IO (HttpstanRequest req contentType res accept) -_applyAuthMethods req config@(HttpstanConfig {configAuthMethods = as}) = - foldlM go req as - where - go r (AnyAuthMethod a) = applyAuthMethod config a r - --- * Utils - --- | Removes Null fields. (OpenAPI-Specification 2.0 does not allow Null in JSON) -#if MIN_VERSION_aeson(2,0,0) -_omitNulls :: [(A.Key, A.Value)] -> A.Value -#else -_omitNulls :: [(Text, A.Value)] -> A.Value -#endif -_omitNulls = A.object . P.filter notNull - where - notNull (_, A.Null) = False - notNull _ = True - --- | Encodes fields using WH.toQueryParam -_toFormItem :: (WH.ToHttpApiData a, Functor f) => t -> f a -> f (t, [Text]) -_toFormItem name x = (name,) . (:[]) . WH.toQueryParam <$> x - --- | Collapse (Just "") to Nothing -_emptyToNothing :: Maybe String -> Maybe String -_emptyToNothing (Just "") = Nothing -_emptyToNothing x = x -{-# INLINE _emptyToNothing #-} - --- | Collapse (Just mempty) to Nothing -_memptyToNothing :: (P.Monoid a, P.Eq a) => Maybe a -> Maybe a -_memptyToNothing (Just x) | x P.== P.mempty = Nothing -_memptyToNothing x = x -{-# INLINE _memptyToNothing #-} - --- * DateTime Formatting - -newtype DateTime = DateTime { unDateTime :: TI.UTCTime } - deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData) -instance A.FromJSON DateTime where - parseJSON = A.withText "DateTime" (_readDateTime . T.unpack) -instance A.ToJSON DateTime where - toJSON (DateTime t) = A.toJSON (_showDateTime t) -instance WH.FromHttpApiData DateTime where - parseUrlPiece = P.maybe (P.Left "parseUrlPiece @DateTime") P.Right . _readDateTime . T.unpack -instance WH.ToHttpApiData DateTime where - toUrlPiece (DateTime t) = T.pack (_showDateTime t) -instance P.Show DateTime where - show (DateTime t) = _showDateTime t -instance MimeRender MimeMultipartFormData DateTime where - mimeRender _ = mimeRenderDefaultMultipartFormData - --- | @_parseISO8601@ -_readDateTime :: (MonadFail m, Alternative m) => String -> m DateTime -_readDateTime s = - DateTime <$> _parseISO8601 s -{-# INLINE _readDateTime #-} - --- | @TI.formatISO8601Millis@ -_showDateTime :: (t ~ TI.UTCTime, TI.FormatTime t) => t -> String -_showDateTime = - TI.formatISO8601Millis -{-# INLINE _showDateTime #-} - --- | parse an ISO8601 date-time string -_parseISO8601 :: (TI.ParseTime t, MonadFail m, Alternative m) => String -> m t -_parseISO8601 t = - P.asum $ - P.flip (TI.parseTimeM True TI.defaultTimeLocale) t <$> - ["%FT%T%QZ", "%FT%T%Q%z", "%FT%T%Q%Z"] -{-# INLINE _parseISO8601 #-} - --- * Date Formatting - -newtype Date = Date { unDate :: TI.Day } - deriving (P.Enum,P.Eq,P.Data,P.Ord,P.Ix,NF.NFData) -instance A.FromJSON Date where - parseJSON = A.withText "Date" (_readDate . T.unpack) -instance A.ToJSON Date where - toJSON (Date t) = A.toJSON (_showDate t) -instance WH.FromHttpApiData Date where - parseUrlPiece = P.maybe (P.Left "parseUrlPiece @Date") P.Right . _readDate . T.unpack -instance WH.ToHttpApiData Date where - toUrlPiece (Date t) = T.pack (_showDate t) -instance P.Show Date where - show (Date t) = _showDate t -instance MimeRender MimeMultipartFormData Date where - mimeRender _ = mimeRenderDefaultMultipartFormData - --- | @TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d"@ -_readDate :: MonadFail m => String -> m Date -_readDate s = Date <$> TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d" s -{-# INLINE _readDate #-} - --- | @TI.formatTime TI.defaultTimeLocale "%Y-%m-%d"@ -_showDate :: TI.FormatTime t => t -> String -_showDate = - TI.formatTime TI.defaultTimeLocale "%Y-%m-%d" -{-# INLINE _showDate #-} - --- * Byte/Binary Formatting - - --- | base64 encoded characters -newtype ByteArray = ByteArray { unByteArray :: BL.ByteString } - deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData) - -instance A.FromJSON ByteArray where - parseJSON = A.withText "ByteArray" _readByteArray -instance A.ToJSON ByteArray where - toJSON = A.toJSON . _showByteArray -instance WH.FromHttpApiData ByteArray where - parseUrlPiece = P.maybe (P.Left "parseUrlPiece @ByteArray") P.Right . _readByteArray -instance WH.ToHttpApiData ByteArray where - toUrlPiece = _showByteArray -instance P.Show ByteArray where - show = T.unpack . _showByteArray -instance MimeRender MimeMultipartFormData ByteArray where - mimeRender _ = mimeRenderDefaultMultipartFormData - --- | read base64 encoded characters -_readByteArray :: MonadFail m => Text -> m ByteArray -_readByteArray = P.either P.fail (pure . ByteArray) . BL64.decode . BL.fromStrict . T.encodeUtf8 -{-# INLINE _readByteArray #-} - --- | show base64 encoded characters -_showByteArray :: ByteArray -> Text -_showByteArray = T.decodeUtf8 . BL.toStrict . BL64.encode . unByteArray -{-# INLINE _showByteArray #-} - --- | any sequence of octets -newtype Binary = Binary { unBinary :: BL.ByteString } - deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData) - -instance A.FromJSON Binary where - parseJSON = A.withText "Binary" _readBinaryBase64 -instance A.ToJSON Binary where - toJSON = A.toJSON . _showBinaryBase64 -instance WH.FromHttpApiData Binary where - parseUrlPiece = P.maybe (P.Left "parseUrlPiece @Binary") P.Right . _readBinaryBase64 -instance WH.ToHttpApiData Binary where - toUrlPiece = _showBinaryBase64 -instance P.Show Binary where - show = T.unpack . _showBinaryBase64 -instance MimeRender MimeMultipartFormData Binary where - mimeRender _ = unBinary - -_readBinaryBase64 :: MonadFail m => Text -> m Binary -_readBinaryBase64 = P.either P.fail (pure . Binary) . BL64.decode . BL.fromStrict . T.encodeUtf8 -{-# INLINE _readBinaryBase64 #-} - -_showBinaryBase64 :: Binary -> Text -_showBinaryBase64 = T.decodeUtf8 . BL.toStrict . BL64.encode . unBinary -{-# INLINE _showBinaryBase64 #-} - --- * Lens Type Aliases - -type Lens_' s a = Lens_ s s a a -type Lens_ s t a b = forall (f :: K.Type -> K.Type). Functor f => (a -> f b) -> s -> f t diff --git a/lib/Httpstan/Logging.hs b/lib/Httpstan/Logging.hs deleted file mode 100644 --- a/lib/Httpstan/Logging.hs +++ /dev/null @@ -1,33 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.Logging -Logging functions --} -{-# LANGUAGE CPP #-} - -#ifdef USE_KATIP - -module Httpstan.Logging - ( module Httpstan.LoggingKatip - ) where - -import Httpstan.LoggingKatip - -#else - -module Httpstan.Logging - ( module Httpstan.LoggingMonadLogger - ) where - -import Httpstan.LoggingMonadLogger - -#endif diff --git a/lib/Httpstan/LoggingKatip.hs b/lib/Httpstan/LoggingKatip.hs deleted file mode 100644 --- a/lib/Httpstan/LoggingKatip.hs +++ /dev/null @@ -1,117 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.LoggingKatip -Katip Logging functions --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Httpstan.LoggingKatip where - -import qualified Control.Exception.Safe as E -import qualified Control.Monad.IO.Class as P -import qualified Control.Monad.Trans.Reader as P -import qualified Data.Text as T -import qualified Lens.Micro as L -import qualified System.IO as IO - -import Data.Text (Text) -import GHC.Exts (IsString(..)) - -import qualified Katip as LG - --- * Type Aliases (for compatibility) - --- | Runs a Katip logging block with the Log environment -type LogExecWithContext = forall m a. P.MonadIO m => - LogContext -> LogExec m a - --- | A Katip logging block -type LogExec m a = LG.KatipT m a -> m a - --- | A Katip Log environment -type LogContext = LG.LogEnv - --- | A Katip Log severity -type LogLevel = LG.Severity - --- * default logger - --- | the default log environment -initLogContext :: IO LogContext -initLogContext = LG.initLogEnv "Httpstan" "dev" - --- | Runs a Katip logging block with the Log environment -runDefaultLogExecWithContext :: LogExecWithContext -runDefaultLogExecWithContext = LG.runKatipT - --- * stdout logger - --- | Runs a Katip logging block with the Log environment -stdoutLoggingExec :: LogExecWithContext -stdoutLoggingExec = runDefaultLogExecWithContext - --- | A Katip Log environment which targets stdout -stdoutLoggingContext :: LogContext -> IO LogContext -stdoutLoggingContext cxt = do - handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stdout (LG.permitItem LG.InfoS) LG.V2 - LG.registerScribe "stdout" handleScribe LG.defaultScribeSettings cxt - --- * stderr logger - --- | Runs a Katip logging block with the Log environment -stderrLoggingExec :: LogExecWithContext -stderrLoggingExec = runDefaultLogExecWithContext - --- | A Katip Log environment which targets stderr -stderrLoggingContext :: LogContext -> IO LogContext -stderrLoggingContext cxt = do - handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stderr (LG.permitItem LG.InfoS) LG.V2 - LG.registerScribe "stderr" handleScribe LG.defaultScribeSettings cxt - --- * Null logger - --- | Disables Katip logging -runNullLogExec :: LogExecWithContext -runNullLogExec le (LG.KatipT f) = P.runReaderT f (L.set LG.logEnvScribes mempty le) - --- * Log Msg - --- | Log a katip message -_log :: (Applicative m, LG.Katip m) => Text -> LogLevel -> Text -> m () -_log src level msg = do - LG.logMsg (fromString $ T.unpack src) level (LG.logStr msg) - --- * Log Exceptions - --- | re-throws exceptions after logging them -logExceptions - :: (LG.Katip m, E.MonadCatch m, Applicative m) - => Text -> m a -> m a -logExceptions src = - E.handle - (\(e :: E.SomeException) -> do - _log src LG.ErrorS ((T.pack . show) e) - E.throw e) - --- * Log Level - -levelInfo :: LogLevel -levelInfo = LG.InfoS - -levelError :: LogLevel -levelError = LG.ErrorS - -levelDebug :: LogLevel -levelDebug = LG.DebugS diff --git a/lib/Httpstan/LoggingMonadLogger.hs b/lib/Httpstan/LoggingMonadLogger.hs deleted file mode 100644 --- a/lib/Httpstan/LoggingMonadLogger.hs +++ /dev/null @@ -1,126 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.LoggingMonadLogger -monad-logger Logging functions --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Httpstan.LoggingMonadLogger where - -import qualified Control.Exception.Safe as E -import qualified Control.Monad.IO.Class as P -import qualified Data.Text as T -import qualified Data.Time as TI - -import Data.Text (Text) - -import qualified Control.Monad.Logger as LG - --- * Type Aliases (for compatibility) - --- | Runs a monad-logger block with the filter predicate -type LogExecWithContext = forall m a. P.MonadIO m => - LogContext -> LogExec m a - --- | A monad-logger block -type LogExec m a = LG.LoggingT m a -> m a - --- | A monad-logger filter predicate -type LogContext = LG.LogSource -> LG.LogLevel -> Bool - --- | A monad-logger log level -type LogLevel = LG.LogLevel - --- * default logger - --- | the default log environment -initLogContext :: IO LogContext -initLogContext = pure infoLevelFilter - --- | Runs a monad-logger block with the filter predicate -runDefaultLogExecWithContext :: LogExecWithContext -runDefaultLogExecWithContext = runNullLogExec - --- * stdout logger - --- | Runs a monad-logger block targeting stdout, with the filter predicate -stdoutLoggingExec :: LogExecWithContext -stdoutLoggingExec cxt = LG.runStdoutLoggingT . LG.filterLogger cxt - --- | @pure@ -stdoutLoggingContext :: LogContext -> IO LogContext -stdoutLoggingContext = pure - --- * stderr logger - --- | Runs a monad-logger block targeting stderr, with the filter predicate -stderrLoggingExec :: LogExecWithContext -stderrLoggingExec cxt = LG.runStderrLoggingT . LG.filterLogger cxt - --- | @pure@ -stderrLoggingContext :: LogContext -> IO LogContext -stderrLoggingContext = pure - --- * Null logger - --- | Disables monad-logger logging -runNullLogExec :: LogExecWithContext -runNullLogExec = const (`LG.runLoggingT` nullLogger) - --- | monad-logger which does nothing -nullLogger :: LG.Loc -> LG.LogSource -> LG.LogLevel -> LG.LogStr -> IO () -nullLogger _ _ _ _ = return () - --- * Log Msg - --- | Log a message using the current time -_log :: (P.MonadIO m, LG.MonadLogger m) => Text -> LG.LogLevel -> Text -> m () -_log src level msg = do - now <- P.liftIO (formatTimeLog <$> TI.getCurrentTime) - LG.logOtherNS ("Httpstan." <> src) level ("[" <> now <> "] " <> msg) - where - formatTimeLog = - T.pack . TI.formatTime TI.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Z" - --- * Log Exceptions - --- | re-throws exceptions after logging them -logExceptions - :: (LG.MonadLogger m, E.MonadCatch m, P.MonadIO m) - => Text -> m a -> m a -logExceptions src = - E.handle - (\(e :: E.SomeException) -> do - _log src LG.LevelError ((T.pack . show) e) - E.throw e) - --- * Log Level - -levelInfo :: LogLevel -levelInfo = LG.LevelInfo - -levelError :: LogLevel -levelError = LG.LevelError - -levelDebug :: LogLevel -levelDebug = LG.LevelDebug - --- * Level Filter - -minLevelFilter :: LG.LogLevel -> LG.LogSource -> LG.LogLevel -> Bool -minLevelFilter l _ l' = l' >= l - -infoLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool -infoLevelFilter = minLevelFilter LG.LevelInfo diff --git a/lib/Httpstan/MimeTypes.hs b/lib/Httpstan/MimeTypes.hs deleted file mode 100644 --- a/lib/Httpstan/MimeTypes.hs +++ /dev/null @@ -1,203 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.MimeTypes --} - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} - -module Httpstan.MimeTypes where - -import qualified Control.Arrow as P (left) -import qualified Data.Aeson as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BCL -import qualified Data.Data as P (Typeable) -import qualified Data.Proxy as P (Proxy(..)) -import qualified Data.String as P -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Network.HTTP.Media as ME -import qualified Web.FormUrlEncoded as WH -import qualified Web.HttpApiData as WH - -import Prelude (($), (.),(<$>),(<*>),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty) -import qualified Prelude as P - --- * ContentType MimeType - -data ContentType a = MimeType a => ContentType { unContentType :: a } - --- * Accept MimeType - -data Accept a = MimeType a => Accept { unAccept :: a } - --- * Consumes Class - -class MimeType mtype => Consumes req mtype where - --- * Produces Class - -class MimeType mtype => Produces req mtype where - --- * Default Mime Types - -data MimeJSON = MimeJSON deriving (P.Typeable) -data MimeXML = MimeXML deriving (P.Typeable) -data MimePlainText = MimePlainText deriving (P.Typeable) -data MimeFormUrlEncoded = MimeFormUrlEncoded deriving (P.Typeable) -data MimeMultipartFormData = MimeMultipartFormData deriving (P.Typeable) -data MimeOctetStream = MimeOctetStream deriving (P.Typeable) -data MimeNoContent = MimeNoContent deriving (P.Typeable) -data MimeAny = MimeAny deriving (P.Typeable) - --- | A type for responses without content-body. -data NoContent = NoContent - deriving (P.Show, P.Eq, P.Typeable) - - --- * MimeType Class - -class P.Typeable mtype => MimeType mtype where - {-# MINIMAL mimeType | mimeTypes #-} - - mimeTypes :: P.Proxy mtype -> [ME.MediaType] - mimeTypes p = - case mimeType p of - Just x -> [x] - Nothing -> [] - - mimeType :: P.Proxy mtype -> Maybe ME.MediaType - mimeType p = - case mimeTypes p of - [] -> Nothing - (x:_) -> Just x - - mimeType' :: mtype -> Maybe ME.MediaType - mimeType' _ = mimeType (P.Proxy :: P.Proxy mtype) - mimeTypes' :: mtype -> [ME.MediaType] - mimeTypes' _ = mimeTypes (P.Proxy :: P.Proxy mtype) - --- Default MimeType Instances - --- | @application/json; charset=utf-8@ -instance MimeType MimeJSON where - mimeType _ = Just $ P.fromString "application/json" --- | @application/xml; charset=utf-8@ -instance MimeType MimeXML where - mimeType _ = Just $ P.fromString "application/xml" --- | @application/x-www-form-urlencoded@ -instance MimeType MimeFormUrlEncoded where - mimeType _ = Just $ P.fromString "application/x-www-form-urlencoded" --- | @multipart/form-data@ -instance MimeType MimeMultipartFormData where - mimeType _ = Just $ P.fromString "multipart/form-data" --- | @text/plain; charset=utf-8@ -instance MimeType MimePlainText where - mimeType _ = Just $ P.fromString "text/plain" --- | @application/octet-stream@ -instance MimeType MimeOctetStream where - mimeType _ = Just $ P.fromString "application/octet-stream" --- | @"*/*"@ -instance MimeType MimeAny where - mimeType _ = Just $ P.fromString "*/*" -instance MimeType MimeNoContent where - mimeType _ = Nothing - --- * MimeRender Class - -class MimeType mtype => MimeRender mtype x where - mimeRender :: P.Proxy mtype -> x -> BL.ByteString - mimeRender' :: mtype -> x -> BL.ByteString - mimeRender' _ x = mimeRender (P.Proxy :: P.Proxy mtype) x - - -mimeRenderDefaultMultipartFormData :: WH.ToHttpApiData a => a -> BL.ByteString -mimeRenderDefaultMultipartFormData = BL.fromStrict . T.encodeUtf8 . WH.toQueryParam - --- Default MimeRender Instances - --- | `A.encode` -instance A.ToJSON a => MimeRender MimeJSON a where mimeRender _ = A.encode --- | @WH.urlEncodeAsForm@ -instance WH.ToForm a => MimeRender MimeFormUrlEncoded a where mimeRender _ = WH.urlEncodeAsForm - --- | @P.id@ -instance MimeRender MimePlainText BL.ByteString where mimeRender _ = P.id --- | @BL.fromStrict . T.encodeUtf8@ -instance MimeRender MimePlainText T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8 --- | @BCL.pack@ -instance MimeRender MimePlainText String where mimeRender _ = BCL.pack - --- | @P.id@ -instance MimeRender MimeOctetStream BL.ByteString where mimeRender _ = P.id --- | @BL.fromStrict . T.encodeUtf8@ -instance MimeRender MimeOctetStream T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8 --- | @BCL.pack@ -instance MimeRender MimeOctetStream String where mimeRender _ = BCL.pack - -instance MimeRender MimeMultipartFormData BL.ByteString where mimeRender _ = P.id - -instance MimeRender MimeMultipartFormData Bool where mimeRender _ = mimeRenderDefaultMultipartFormData -instance MimeRender MimeMultipartFormData Char where mimeRender _ = mimeRenderDefaultMultipartFormData -instance MimeRender MimeMultipartFormData Double where mimeRender _ = mimeRenderDefaultMultipartFormData -instance MimeRender MimeMultipartFormData Float where mimeRender _ = mimeRenderDefaultMultipartFormData -instance MimeRender MimeMultipartFormData Int where mimeRender _ = mimeRenderDefaultMultipartFormData -instance MimeRender MimeMultipartFormData Integer where mimeRender _ = mimeRenderDefaultMultipartFormData -instance MimeRender MimeMultipartFormData String where mimeRender _ = mimeRenderDefaultMultipartFormData -instance MimeRender MimeMultipartFormData T.Text where mimeRender _ = mimeRenderDefaultMultipartFormData - --- | @P.Right . P.const NoContent@ -instance MimeRender MimeNoContent NoContent where mimeRender _ = P.const BCL.empty - - --- * MimeUnrender Class - -class MimeType mtype => MimeUnrender mtype o where - mimeUnrender :: P.Proxy mtype -> BL.ByteString -> P.Either String o - mimeUnrender' :: mtype -> BL.ByteString -> P.Either String o - mimeUnrender' _ x = mimeUnrender (P.Proxy :: P.Proxy mtype) x - --- Default MimeUnrender Instances - --- | @A.eitherDecode@ -instance A.FromJSON a => MimeUnrender MimeJSON a where mimeUnrender _ = A.eitherDecode --- | @P.left T.unpack . WH.urlDecodeAsForm@ -instance WH.FromForm a => MimeUnrender MimeFormUrlEncoded a where mimeUnrender _ = P.left T.unpack . WH.urlDecodeAsForm --- | @P.Right . P.id@ - -instance MimeUnrender MimePlainText BL.ByteString where mimeUnrender _ = P.Right . P.id --- | @P.left P.show . TL.decodeUtf8'@ -instance MimeUnrender MimePlainText T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict --- | @P.Right . BCL.unpack@ -instance MimeUnrender MimePlainText String where mimeUnrender _ = P.Right . BCL.unpack - --- | @P.Right . P.id@ -instance MimeUnrender MimeOctetStream BL.ByteString where mimeUnrender _ = P.Right . P.id --- | @P.left P.show . T.decodeUtf8' . BL.toStrict@ -instance MimeUnrender MimeOctetStream T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict --- | @P.Right . BCL.unpack@ -instance MimeUnrender MimeOctetStream String where mimeUnrender _ = P.Right . BCL.unpack - --- | @P.Right . P.const NoContent@ -instance MimeUnrender MimeNoContent NoContent where mimeUnrender _ = P.Right . P.const NoContent - - diff --git a/lib/Httpstan/Model.hs b/lib/Httpstan/Model.hs deleted file mode 100644 --- a/lib/Httpstan/Model.hs +++ /dev/null @@ -1,627 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.Model --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-} - -module Httpstan.Model where - -import Httpstan.Core -import Httpstan.MimeTypes - -import Data.Aeson ((.:),(.:!),(.:?),(.=)) - -import qualified Control.Arrow as P (left) -import qualified Data.Aeson as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.Data as P (Typeable, TypeRep, typeOf, typeRep) -import qualified Data.Foldable as P -import qualified Data.HashMap.Lazy as HM -import qualified Data.Map as Map -import qualified Data.Maybe as P -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Time as TI -import qualified Lens.Micro as L -import qualified Web.FormUrlEncoded as WH -import qualified Web.HttpApiData as WH - -import Control.Applicative ((<|>)) -import Control.Applicative (Alternative) -import Data.Function ((&)) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Prelude (($),(/=),(.),(<$>),(<*>),(>>=),(=<<),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor) - -import qualified Prelude as P - - - --- * Parameter newtypes - - --- ** AdjustTransform -newtype AdjustTransform = AdjustTransform { unAdjustTransform :: Bool } deriving (P.Eq, P.Show, A.ToJSON) - --- ** ConstrainedParameters -newtype ConstrainedParameters = ConstrainedParameters { unConstrainedParameters :: A.Value } deriving (P.Eq, P.Show, A.ToJSON) - --- ** FitId -newtype FitId = FitId { unFitId :: Text } deriving (P.Eq, P.Show) - --- ** IncludeGqs -newtype IncludeGqs = IncludeGqs { unIncludeGqs :: Bool } deriving (P.Eq, P.Show, A.ToJSON) - --- ** ModelId -newtype ModelId = ModelId { unModelId :: Text } deriving (P.Eq, P.Show) - --- ** OperationId -newtype OperationId = OperationId { unOperationId :: Text } deriving (P.Eq, P.Show) - --- ** ParamData -newtype ParamData = ParamData { unParamData :: A.Value } deriving (P.Eq, P.Show, A.ToJSON) - --- * Models - - --- ** CreateFitRequest --- | CreateFitRequest -data CreateFitRequest = CreateFitRequest - { createFitRequestChain :: !(Maybe Int) -- ^ "chain" - , createFitRequestData :: !(Maybe A.Value) -- ^ "data" - , createFitRequestDelta :: !(Maybe Double) -- ^ "delta" - , createFitRequestFunction :: !(E'Function) -- ^ /Required/ "function" - , createFitRequestGamma :: !(Maybe Double) -- ^ "gamma" - , createFitRequestInit :: !(Maybe A.Value) -- ^ "init" - , createFitRequestInitBuffer :: !(Maybe Int) -- ^ "init_buffer" - , createFitRequestInitRadius :: !(Maybe Double) -- ^ "init_radius" - , createFitRequestKappa :: !(Maybe Double) -- ^ "kappa" - , createFitRequestMaxDepth :: !(Maybe Int) -- ^ "max_depth" - , createFitRequestNumSamples :: !(Maybe Int) -- ^ "num_samples" - , createFitRequestNumThin :: !(Maybe Int) -- ^ "num_thin" - , createFitRequestNumWarmup :: !(Maybe Int) -- ^ "num_warmup" - , createFitRequestRandomSeed :: !(Maybe Int) -- ^ "random_seed" - , createFitRequestRefresh :: !(Maybe Int) -- ^ "refresh" - , createFitRequestSaveWarmup :: !(Maybe Bool) -- ^ "save_warmup" - , createFitRequestStepsize :: !(Maybe Double) -- ^ "stepsize" - , createFitRequestStepsizeJitter :: !(Maybe Double) -- ^ "stepsize_jitter" - , createFitRequestT0 :: !(Maybe Double) -- ^ "t0" - , createFitRequestTermBuffer :: !(Maybe Int) -- ^ "term_buffer" - , createFitRequestWindow :: !(Maybe Int) -- ^ "window" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON CreateFitRequest -instance A.FromJSON CreateFitRequest where - parseJSON = A.withObject "CreateFitRequest" $ \o -> - CreateFitRequest - <$> (o .:? "chain") - <*> (o .:? "data") - <*> (o .:? "delta") - <*> (o .: "function") - <*> (o .:? "gamma") - <*> (o .:? "init") - <*> (o .:? "init_buffer") - <*> (o .:? "init_radius") - <*> (o .:? "kappa") - <*> (o .:? "max_depth") - <*> (o .:? "num_samples") - <*> (o .:? "num_thin") - <*> (o .:? "num_warmup") - <*> (o .:? "random_seed") - <*> (o .:? "refresh") - <*> (o .:? "save_warmup") - <*> (o .:? "stepsize") - <*> (o .:? "stepsize_jitter") - <*> (o .:? "t0") - <*> (o .:? "term_buffer") - <*> (o .:? "window") - --- | ToJSON CreateFitRequest -instance A.ToJSON CreateFitRequest where - toJSON CreateFitRequest {..} = - _omitNulls - [ "chain" .= createFitRequestChain - , "data" .= createFitRequestData - , "delta" .= createFitRequestDelta - , "function" .= createFitRequestFunction - , "gamma" .= createFitRequestGamma - , "init" .= createFitRequestInit - , "init_buffer" .= createFitRequestInitBuffer - , "init_radius" .= createFitRequestInitRadius - , "kappa" .= createFitRequestKappa - , "max_depth" .= createFitRequestMaxDepth - , "num_samples" .= createFitRequestNumSamples - , "num_thin" .= createFitRequestNumThin - , "num_warmup" .= createFitRequestNumWarmup - , "random_seed" .= createFitRequestRandomSeed - , "refresh" .= createFitRequestRefresh - , "save_warmup" .= createFitRequestSaveWarmup - , "stepsize" .= createFitRequestStepsize - , "stepsize_jitter" .= createFitRequestStepsizeJitter - , "t0" .= createFitRequestT0 - , "term_buffer" .= createFitRequestTermBuffer - , "window" .= createFitRequestWindow - ] - - --- | Construct a value of type 'CreateFitRequest' (by applying it's required fields, if any) -mkCreateFitRequest - :: E'Function -- ^ 'createFitRequestFunction' - -> CreateFitRequest -mkCreateFitRequest createFitRequestFunction = - CreateFitRequest - { createFitRequestChain = Nothing - , createFitRequestData = Nothing - , createFitRequestDelta = Nothing - , createFitRequestFunction - , createFitRequestGamma = Nothing - , createFitRequestInit = Nothing - , createFitRequestInitBuffer = Nothing - , createFitRequestInitRadius = Nothing - , createFitRequestKappa = Nothing - , createFitRequestMaxDepth = Nothing - , createFitRequestNumSamples = Nothing - , createFitRequestNumThin = Nothing - , createFitRequestNumWarmup = Nothing - , createFitRequestRandomSeed = Nothing - , createFitRequestRefresh = Nothing - , createFitRequestSaveWarmup = Nothing - , createFitRequestStepsize = Nothing - , createFitRequestStepsizeJitter = Nothing - , createFitRequestT0 = Nothing - , createFitRequestTermBuffer = Nothing - , createFitRequestWindow = Nothing - } - --- ** CreateModelRequest --- | CreateModelRequest -data CreateModelRequest = CreateModelRequest - { createModelRequestProgramCode :: !(Text) -- ^ /Required/ "program_code" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON CreateModelRequest -instance A.FromJSON CreateModelRequest where - parseJSON = A.withObject "CreateModelRequest" $ \o -> - CreateModelRequest - <$> (o .: "program_code") - --- | ToJSON CreateModelRequest -instance A.ToJSON CreateModelRequest where - toJSON CreateModelRequest {..} = - _omitNulls - [ "program_code" .= createModelRequestProgramCode - ] - - --- | Construct a value of type 'CreateModelRequest' (by applying it's required fields, if any) -mkCreateModelRequest - :: Text -- ^ 'createModelRequestProgramCode' - -> CreateModelRequest -mkCreateModelRequest createModelRequestProgramCode = - CreateModelRequest - { createModelRequestProgramCode - } - --- ** Fit --- | Fit -data Fit = Fit - { fitName :: !(Text) -- ^ /Required/ "name" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON Fit -instance A.FromJSON Fit where - parseJSON = A.withObject "Fit" $ \o -> - Fit - <$> (o .: "name") - --- | ToJSON Fit -instance A.ToJSON Fit where - toJSON Fit {..} = - _omitNulls - [ "name" .= fitName - ] - - --- | Construct a value of type 'Fit' (by applying it's required fields, if any) -mkFit - :: Text -- ^ 'fitName' - -> Fit -mkFit fitName = - Fit - { fitName - } - --- ** Model --- | Model -data Model = Model - { modelCompilerOutput :: !(Text) -- ^ /Required/ "compiler_output" - , modelName :: !(Text) -- ^ /Required/ "name" - , modelStancWarnings :: !(Text) -- ^ /Required/ "stanc_warnings" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON Model -instance A.FromJSON Model where - parseJSON = A.withObject "Model" $ \o -> - Model - <$> (o .: "compiler_output") - <*> (o .: "name") - <*> (o .: "stanc_warnings") - --- | ToJSON Model -instance A.ToJSON Model where - toJSON Model {..} = - _omitNulls - [ "compiler_output" .= modelCompilerOutput - , "name" .= modelName - , "stanc_warnings" .= modelStancWarnings - ] - - --- | Construct a value of type 'Model' (by applying it's required fields, if any) -mkModel - :: Text -- ^ 'modelCompilerOutput' - -> Text -- ^ 'modelName' - -> Text -- ^ 'modelStancWarnings' - -> Model -mkModel modelCompilerOutput modelName modelStancWarnings = - Model - { modelCompilerOutput - , modelName - , modelStancWarnings - } - --- ** Operation --- | Operation -data Operation = Operation - { operationDone :: !(Bool) -- ^ /Required/ "done" - , operationMetadata :: !(Maybe A.Value) -- ^ "metadata" - , operationName :: !(Text) -- ^ /Required/ "name" - , operationResult :: !(Maybe A.Value) -- ^ "result" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON Operation -instance A.FromJSON Operation where - parseJSON = A.withObject "Operation" $ \o -> - Operation - <$> (o .: "done") - <*> (o .:? "metadata") - <*> (o .: "name") - <*> (o .:? "result") - --- | ToJSON Operation -instance A.ToJSON Operation where - toJSON Operation {..} = - _omitNulls - [ "done" .= operationDone - , "metadata" .= operationMetadata - , "name" .= operationName - , "result" .= operationResult - ] - - --- | Construct a value of type 'Operation' (by applying it's required fields, if any) -mkOperation - :: Bool -- ^ 'operationDone' - -> Text -- ^ 'operationName' - -> Operation -mkOperation operationDone operationName = - Operation - { operationDone - , operationMetadata = Nothing - , operationName - , operationResult = Nothing - } - --- ** Parameter --- | Parameter -data Parameter = Parameter - { parameterConstrainedNames :: !([Text]) -- ^ /Required/ "constrained_names" - , parameterDims :: !([Int]) -- ^ /Required/ "dims" - , parameterName :: !(Text) -- ^ /Required/ "name" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON Parameter -instance A.FromJSON Parameter where - parseJSON = A.withObject "Parameter" $ \o -> - Parameter - <$> (o .: "constrained_names") - <*> (o .: "dims") - <*> (o .: "name") - --- | ToJSON Parameter -instance A.ToJSON Parameter where - toJSON Parameter {..} = - _omitNulls - [ "constrained_names" .= parameterConstrainedNames - , "dims" .= parameterDims - , "name" .= parameterName - ] - - --- | Construct a value of type 'Parameter' (by applying it's required fields, if any) -mkParameter - :: [Text] -- ^ 'parameterConstrainedNames' - -> [Int] -- ^ 'parameterDims' - -> Text -- ^ 'parameterName' - -> Parameter -mkParameter parameterConstrainedNames parameterDims parameterName = - Parameter - { parameterConstrainedNames - , parameterDims - , parameterName - } - --- ** Status --- | Status -data Status = Status - { statusCode :: !(Int) -- ^ /Required/ "code" - , statusDetails :: !(Maybe [A.Value]) -- ^ "details" - , statusMessage :: !(Text) -- ^ /Required/ "message" - , statusStatus :: !(Text) -- ^ /Required/ "status" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON Status -instance A.FromJSON Status where - parseJSON = A.withObject "Status" $ \o -> - Status - <$> (o .: "code") - <*> (o .:? "details") - <*> (o .: "message") - <*> (o .: "status") - --- | ToJSON Status -instance A.ToJSON Status where - toJSON Status {..} = - _omitNulls - [ "code" .= statusCode - , "details" .= statusDetails - , "message" .= statusMessage - , "status" .= statusStatus - ] - - --- | Construct a value of type 'Status' (by applying it's required fields, if any) -mkStatus - :: Int -- ^ 'statusCode' - -> Text -- ^ 'statusMessage' - -> Text -- ^ 'statusStatus' - -> Status -mkStatus statusCode statusMessage statusStatus = - Status - { statusCode - , statusDetails = Nothing - , statusMessage - , statusStatus - } - --- ** V1ModelsGet200Response --- | V1ModelsGet200Response -data V1ModelsGet200Response = V1ModelsGet200Response - { v1ModelsGet200ResponseModels :: !(Maybe [Model]) -- ^ "models" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON V1ModelsGet200Response -instance A.FromJSON V1ModelsGet200Response where - parseJSON = A.withObject "V1ModelsGet200Response" $ \o -> - V1ModelsGet200Response - <$> (o .:? "models") - --- | ToJSON V1ModelsGet200Response -instance A.ToJSON V1ModelsGet200Response where - toJSON V1ModelsGet200Response {..} = - _omitNulls - [ "models" .= v1ModelsGet200ResponseModels - ] - - --- | Construct a value of type 'V1ModelsGet200Response' (by applying it's required fields, if any) -mkV1ModelsGet200Response - :: V1ModelsGet200Response -mkV1ModelsGet200Response = - V1ModelsGet200Response - { v1ModelsGet200ResponseModels = Nothing - } - --- ** V1ModelsModelIdLogProbGradPost200Response --- | V1ModelsModelIdLogProbGradPost200Response -data V1ModelsModelIdLogProbGradPost200Response = V1ModelsModelIdLogProbGradPost200Response - { v1ModelsModelIdLogProbGradPost200ResponseGradLogProb :: !(Maybe [Double]) -- ^ "grad_log_prob" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON V1ModelsModelIdLogProbGradPost200Response -instance A.FromJSON V1ModelsModelIdLogProbGradPost200Response where - parseJSON = A.withObject "V1ModelsModelIdLogProbGradPost200Response" $ \o -> - V1ModelsModelIdLogProbGradPost200Response - <$> (o .:? "grad_log_prob") - --- | ToJSON V1ModelsModelIdLogProbGradPost200Response -instance A.ToJSON V1ModelsModelIdLogProbGradPost200Response where - toJSON V1ModelsModelIdLogProbGradPost200Response {..} = - _omitNulls - [ "grad_log_prob" .= v1ModelsModelIdLogProbGradPost200ResponseGradLogProb - ] - - --- | Construct a value of type 'V1ModelsModelIdLogProbGradPost200Response' (by applying it's required fields, if any) -mkV1ModelsModelIdLogProbGradPost200Response - :: V1ModelsModelIdLogProbGradPost200Response -mkV1ModelsModelIdLogProbGradPost200Response = - V1ModelsModelIdLogProbGradPost200Response - { v1ModelsModelIdLogProbGradPost200ResponseGradLogProb = Nothing - } - --- ** V1ModelsModelIdLogProbPost200Response --- | V1ModelsModelIdLogProbPost200Response -data V1ModelsModelIdLogProbPost200Response = V1ModelsModelIdLogProbPost200Response - { v1ModelsModelIdLogProbPost200ResponseLogProb :: !(Maybe Double) -- ^ "log_prob" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON V1ModelsModelIdLogProbPost200Response -instance A.FromJSON V1ModelsModelIdLogProbPost200Response where - parseJSON = A.withObject "V1ModelsModelIdLogProbPost200Response" $ \o -> - V1ModelsModelIdLogProbPost200Response - <$> (o .:? "log_prob") - --- | ToJSON V1ModelsModelIdLogProbPost200Response -instance A.ToJSON V1ModelsModelIdLogProbPost200Response where - toJSON V1ModelsModelIdLogProbPost200Response {..} = - _omitNulls - [ "log_prob" .= v1ModelsModelIdLogProbPost200ResponseLogProb - ] - - --- | Construct a value of type 'V1ModelsModelIdLogProbPost200Response' (by applying it's required fields, if any) -mkV1ModelsModelIdLogProbPost200Response - :: V1ModelsModelIdLogProbPost200Response -mkV1ModelsModelIdLogProbPost200Response = - V1ModelsModelIdLogProbPost200Response - { v1ModelsModelIdLogProbPost200ResponseLogProb = Nothing - } - --- ** V1ModelsModelIdParamsPost200Response --- | V1ModelsModelIdParamsPost200Response -data V1ModelsModelIdParamsPost200Response = V1ModelsModelIdParamsPost200Response - { v1ModelsModelIdParamsPost200ResponseId :: !(Maybe Text) -- ^ "id" - , v1ModelsModelIdParamsPost200ResponseParams :: !(Maybe [Parameter]) -- ^ "params" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON V1ModelsModelIdParamsPost200Response -instance A.FromJSON V1ModelsModelIdParamsPost200Response where - parseJSON = A.withObject "V1ModelsModelIdParamsPost200Response" $ \o -> - V1ModelsModelIdParamsPost200Response - <$> (o .:? "id") - <*> (o .:? "params") - --- | ToJSON V1ModelsModelIdParamsPost200Response -instance A.ToJSON V1ModelsModelIdParamsPost200Response where - toJSON V1ModelsModelIdParamsPost200Response {..} = - _omitNulls - [ "id" .= v1ModelsModelIdParamsPost200ResponseId - , "params" .= v1ModelsModelIdParamsPost200ResponseParams - ] - - --- | Construct a value of type 'V1ModelsModelIdParamsPost200Response' (by applying it's required fields, if any) -mkV1ModelsModelIdParamsPost200Response - :: V1ModelsModelIdParamsPost200Response -mkV1ModelsModelIdParamsPost200Response = - V1ModelsModelIdParamsPost200Response - { v1ModelsModelIdParamsPost200ResponseId = Nothing - , v1ModelsModelIdParamsPost200ResponseParams = Nothing - } - --- ** V1ModelsModelIdTransformInitsPost200Response --- | V1ModelsModelIdTransformInitsPost200Response -data V1ModelsModelIdTransformInitsPost200Response = V1ModelsModelIdTransformInitsPost200Response - { v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained :: !(Maybe [Double]) -- ^ "params_r_unconstrained" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON V1ModelsModelIdTransformInitsPost200Response -instance A.FromJSON V1ModelsModelIdTransformInitsPost200Response where - parseJSON = A.withObject "V1ModelsModelIdTransformInitsPost200Response" $ \o -> - V1ModelsModelIdTransformInitsPost200Response - <$> (o .:? "params_r_unconstrained") - --- | ToJSON V1ModelsModelIdTransformInitsPost200Response -instance A.ToJSON V1ModelsModelIdTransformInitsPost200Response where - toJSON V1ModelsModelIdTransformInitsPost200Response {..} = - _omitNulls - [ "params_r_unconstrained" .= v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained - ] - - --- | Construct a value of type 'V1ModelsModelIdTransformInitsPost200Response' (by applying it's required fields, if any) -mkV1ModelsModelIdTransformInitsPost200Response - :: V1ModelsModelIdTransformInitsPost200Response -mkV1ModelsModelIdTransformInitsPost200Response = - V1ModelsModelIdTransformInitsPost200Response - { v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained = Nothing - } - --- ** V1ModelsModelIdWriteArrayPost200Response --- | V1ModelsModelIdWriteArrayPost200Response -data V1ModelsModelIdWriteArrayPost200Response = V1ModelsModelIdWriteArrayPost200Response - { v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained :: !(Maybe [Double]) -- ^ "params_r_constrained" - } deriving (P.Show, P.Eq, P.Typeable) - --- | FromJSON V1ModelsModelIdWriteArrayPost200Response -instance A.FromJSON V1ModelsModelIdWriteArrayPost200Response where - parseJSON = A.withObject "V1ModelsModelIdWriteArrayPost200Response" $ \o -> - V1ModelsModelIdWriteArrayPost200Response - <$> (o .:? "params_r_constrained") - --- | ToJSON V1ModelsModelIdWriteArrayPost200Response -instance A.ToJSON V1ModelsModelIdWriteArrayPost200Response where - toJSON V1ModelsModelIdWriteArrayPost200Response {..} = - _omitNulls - [ "params_r_constrained" .= v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained - ] - - --- | Construct a value of type 'V1ModelsModelIdWriteArrayPost200Response' (by applying it's required fields, if any) -mkV1ModelsModelIdWriteArrayPost200Response - :: V1ModelsModelIdWriteArrayPost200Response -mkV1ModelsModelIdWriteArrayPost200Response = - V1ModelsModelIdWriteArrayPost200Response - { v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained = Nothing - } - - --- * Enums - - --- ** E'Function - --- | Enum of 'Text' -data E'Function - = E'Function'Hmc_nuts_diag_e_adapt -- ^ @"stan::services::sample::hmc_nuts_diag_e_adapt"@ - | E'Function'Fixed_param -- ^ @"stan::services::sample::fixed_param"@ - deriving (P.Show, P.Eq, P.Typeable, P.Ord, P.Bounded, P.Enum) - -instance A.ToJSON E'Function where toJSON = A.toJSON . fromE'Function -instance A.FromJSON E'Function where parseJSON o = P.either P.fail (pure . P.id) . toE'Function =<< A.parseJSON o -instance WH.ToHttpApiData E'Function where toQueryParam = WH.toQueryParam . fromE'Function -instance WH.FromHttpApiData E'Function where parseQueryParam o = WH.parseQueryParam o >>= P.left T.pack . toE'Function -instance MimeRender MimeMultipartFormData E'Function where mimeRender _ = mimeRenderDefaultMultipartFormData - --- | unwrap 'E'Function' enum -fromE'Function :: E'Function -> Text -fromE'Function = \case - E'Function'Hmc_nuts_diag_e_adapt -> "stan::services::sample::hmc_nuts_diag_e_adapt" - E'Function'Fixed_param -> "stan::services::sample::fixed_param" - --- | parse 'E'Function' enum -toE'Function :: Text -> P.Either String E'Function -toE'Function = \case - "stan::services::sample::hmc_nuts_diag_e_adapt" -> P.Right E'Function'Hmc_nuts_diag_e_adapt - "stan::services::sample::fixed_param" -> P.Right E'Function'Fixed_param - s -> P.Left $ "toE'Function: enum parse failure: " P.++ P.show s - - - diff --git a/lib/Httpstan/ModelLens.hs b/lib/Httpstan/ModelLens.hs deleted file mode 100644 --- a/lib/Httpstan/ModelLens.hs +++ /dev/null @@ -1,309 +0,0 @@ -{- - httpstan - - No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator) - - OpenAPI Version: 3.0.1 - httpstan API version: 4.10.0 - Generated by OpenAPI Generator (https://openapi-generator.tech) --} - -{-| -Module : Httpstan.Lens --} - -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-} - -module Httpstan.ModelLens where - -import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy as BL -import qualified Data.Data as P (Data, Typeable) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Time as TI - -import Data.Text (Text) - -import Prelude (($), (.),(<$>),(<*>),(=<<),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor) -import qualified Prelude as P - -import Httpstan.Model -import Httpstan.Core - - --- * CreateFitRequest - --- | 'createFitRequestChain' Lens -createFitRequestChainL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestChainL f CreateFitRequest{..} = (\createFitRequestChain -> CreateFitRequest { createFitRequestChain, ..} ) <$> f createFitRequestChain -{-# INLINE createFitRequestChainL #-} - --- | 'createFitRequestData' Lens -createFitRequestDataL :: Lens_' CreateFitRequest (Maybe A.Value) -createFitRequestDataL f CreateFitRequest{..} = (\createFitRequestData -> CreateFitRequest { createFitRequestData, ..} ) <$> f createFitRequestData -{-# INLINE createFitRequestDataL #-} - --- | 'createFitRequestDelta' Lens -createFitRequestDeltaL :: Lens_' CreateFitRequest (Maybe Double) -createFitRequestDeltaL f CreateFitRequest{..} = (\createFitRequestDelta -> CreateFitRequest { createFitRequestDelta, ..} ) <$> f createFitRequestDelta -{-# INLINE createFitRequestDeltaL #-} - --- | 'createFitRequestFunction' Lens -createFitRequestFunctionL :: Lens_' CreateFitRequest (E'Function) -createFitRequestFunctionL f CreateFitRequest{..} = (\createFitRequestFunction -> CreateFitRequest { createFitRequestFunction, ..} ) <$> f createFitRequestFunction -{-# INLINE createFitRequestFunctionL #-} - --- | 'createFitRequestGamma' Lens -createFitRequestGammaL :: Lens_' CreateFitRequest (Maybe Double) -createFitRequestGammaL f CreateFitRequest{..} = (\createFitRequestGamma -> CreateFitRequest { createFitRequestGamma, ..} ) <$> f createFitRequestGamma -{-# INLINE createFitRequestGammaL #-} - --- | 'createFitRequestInit' Lens -createFitRequestInitL :: Lens_' CreateFitRequest (Maybe A.Value) -createFitRequestInitL f CreateFitRequest{..} = (\createFitRequestInit -> CreateFitRequest { createFitRequestInit, ..} ) <$> f createFitRequestInit -{-# INLINE createFitRequestInitL #-} - --- | 'createFitRequestInitBuffer' Lens -createFitRequestInitBufferL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestInitBufferL f CreateFitRequest{..} = (\createFitRequestInitBuffer -> CreateFitRequest { createFitRequestInitBuffer, ..} ) <$> f createFitRequestInitBuffer -{-# INLINE createFitRequestInitBufferL #-} - --- | 'createFitRequestInitRadius' Lens -createFitRequestInitRadiusL :: Lens_' CreateFitRequest (Maybe Double) -createFitRequestInitRadiusL f CreateFitRequest{..} = (\createFitRequestInitRadius -> CreateFitRequest { createFitRequestInitRadius, ..} ) <$> f createFitRequestInitRadius -{-# INLINE createFitRequestInitRadiusL #-} - --- | 'createFitRequestKappa' Lens -createFitRequestKappaL :: Lens_' CreateFitRequest (Maybe Double) -createFitRequestKappaL f CreateFitRequest{..} = (\createFitRequestKappa -> CreateFitRequest { createFitRequestKappa, ..} ) <$> f createFitRequestKappa -{-# INLINE createFitRequestKappaL #-} - --- | 'createFitRequestMaxDepth' Lens -createFitRequestMaxDepthL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestMaxDepthL f CreateFitRequest{..} = (\createFitRequestMaxDepth -> CreateFitRequest { createFitRequestMaxDepth, ..} ) <$> f createFitRequestMaxDepth -{-# INLINE createFitRequestMaxDepthL #-} - --- | 'createFitRequestNumSamples' Lens -createFitRequestNumSamplesL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestNumSamplesL f CreateFitRequest{..} = (\createFitRequestNumSamples -> CreateFitRequest { createFitRequestNumSamples, ..} ) <$> f createFitRequestNumSamples -{-# INLINE createFitRequestNumSamplesL #-} - --- | 'createFitRequestNumThin' Lens -createFitRequestNumThinL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestNumThinL f CreateFitRequest{..} = (\createFitRequestNumThin -> CreateFitRequest { createFitRequestNumThin, ..} ) <$> f createFitRequestNumThin -{-# INLINE createFitRequestNumThinL #-} - --- | 'createFitRequestNumWarmup' Lens -createFitRequestNumWarmupL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestNumWarmupL f CreateFitRequest{..} = (\createFitRequestNumWarmup -> CreateFitRequest { createFitRequestNumWarmup, ..} ) <$> f createFitRequestNumWarmup -{-# INLINE createFitRequestNumWarmupL #-} - --- | 'createFitRequestRandomSeed' Lens -createFitRequestRandomSeedL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestRandomSeedL f CreateFitRequest{..} = (\createFitRequestRandomSeed -> CreateFitRequest { createFitRequestRandomSeed, ..} ) <$> f createFitRequestRandomSeed -{-# INLINE createFitRequestRandomSeedL #-} - --- | 'createFitRequestRefresh' Lens -createFitRequestRefreshL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestRefreshL f CreateFitRequest{..} = (\createFitRequestRefresh -> CreateFitRequest { createFitRequestRefresh, ..} ) <$> f createFitRequestRefresh -{-# INLINE createFitRequestRefreshL #-} - --- | 'createFitRequestSaveWarmup' Lens -createFitRequestSaveWarmupL :: Lens_' CreateFitRequest (Maybe Bool) -createFitRequestSaveWarmupL f CreateFitRequest{..} = (\createFitRequestSaveWarmup -> CreateFitRequest { createFitRequestSaveWarmup, ..} ) <$> f createFitRequestSaveWarmup -{-# INLINE createFitRequestSaveWarmupL #-} - --- | 'createFitRequestStepsize' Lens -createFitRequestStepsizeL :: Lens_' CreateFitRequest (Maybe Double) -createFitRequestStepsizeL f CreateFitRequest{..} = (\createFitRequestStepsize -> CreateFitRequest { createFitRequestStepsize, ..} ) <$> f createFitRequestStepsize -{-# INLINE createFitRequestStepsizeL #-} - --- | 'createFitRequestStepsizeJitter' Lens -createFitRequestStepsizeJitterL :: Lens_' CreateFitRequest (Maybe Double) -createFitRequestStepsizeJitterL f CreateFitRequest{..} = (\createFitRequestStepsizeJitter -> CreateFitRequest { createFitRequestStepsizeJitter, ..} ) <$> f createFitRequestStepsizeJitter -{-# INLINE createFitRequestStepsizeJitterL #-} - --- | 'createFitRequestT0' Lens -createFitRequestT0L :: Lens_' CreateFitRequest (Maybe Double) -createFitRequestT0L f CreateFitRequest{..} = (\createFitRequestT0 -> CreateFitRequest { createFitRequestT0, ..} ) <$> f createFitRequestT0 -{-# INLINE createFitRequestT0L #-} - --- | 'createFitRequestTermBuffer' Lens -createFitRequestTermBufferL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestTermBufferL f CreateFitRequest{..} = (\createFitRequestTermBuffer -> CreateFitRequest { createFitRequestTermBuffer, ..} ) <$> f createFitRequestTermBuffer -{-# INLINE createFitRequestTermBufferL #-} - --- | 'createFitRequestWindow' Lens -createFitRequestWindowL :: Lens_' CreateFitRequest (Maybe Int) -createFitRequestWindowL f CreateFitRequest{..} = (\createFitRequestWindow -> CreateFitRequest { createFitRequestWindow, ..} ) <$> f createFitRequestWindow -{-# INLINE createFitRequestWindowL #-} - - - --- * CreateModelRequest - --- | 'createModelRequestProgramCode' Lens -createModelRequestProgramCodeL :: Lens_' CreateModelRequest (Text) -createModelRequestProgramCodeL f CreateModelRequest{..} = (\createModelRequestProgramCode -> CreateModelRequest { createModelRequestProgramCode, ..} ) <$> f createModelRequestProgramCode -{-# INLINE createModelRequestProgramCodeL #-} - - - --- * Fit - --- | 'fitName' Lens -fitNameL :: Lens_' Fit (Text) -fitNameL f Fit{..} = (\fitName -> Fit { fitName, ..} ) <$> f fitName -{-# INLINE fitNameL #-} - - - --- * Model - --- | 'modelCompilerOutput' Lens -modelCompilerOutputL :: Lens_' Model (Text) -modelCompilerOutputL f Model{..} = (\modelCompilerOutput -> Model { modelCompilerOutput, ..} ) <$> f modelCompilerOutput -{-# INLINE modelCompilerOutputL #-} - --- | 'modelName' Lens -modelNameL :: Lens_' Model (Text) -modelNameL f Model{..} = (\modelName -> Model { modelName, ..} ) <$> f modelName -{-# INLINE modelNameL #-} - --- | 'modelStancWarnings' Lens -modelStancWarningsL :: Lens_' Model (Text) -modelStancWarningsL f Model{..} = (\modelStancWarnings -> Model { modelStancWarnings, ..} ) <$> f modelStancWarnings -{-# INLINE modelStancWarningsL #-} - - - --- * Operation - --- | 'operationDone' Lens -operationDoneL :: Lens_' Operation (Bool) -operationDoneL f Operation{..} = (\operationDone -> Operation { operationDone, ..} ) <$> f operationDone -{-# INLINE operationDoneL #-} - --- | 'operationMetadata' Lens -operationMetadataL :: Lens_' Operation (Maybe A.Value) -operationMetadataL f Operation{..} = (\operationMetadata -> Operation { operationMetadata, ..} ) <$> f operationMetadata -{-# INLINE operationMetadataL #-} - --- | 'operationName' Lens -operationNameL :: Lens_' Operation (Text) -operationNameL f Operation{..} = (\operationName -> Operation { operationName, ..} ) <$> f operationName -{-# INLINE operationNameL #-} - --- | 'operationResult' Lens -operationResultL :: Lens_' Operation (Maybe A.Value) -operationResultL f Operation{..} = (\operationResult -> Operation { operationResult, ..} ) <$> f operationResult -{-# INLINE operationResultL #-} - - - --- * Parameter - --- | 'parameterConstrainedNames' Lens -parameterConstrainedNamesL :: Lens_' Parameter ([Text]) -parameterConstrainedNamesL f Parameter{..} = (\parameterConstrainedNames -> Parameter { parameterConstrainedNames, ..} ) <$> f parameterConstrainedNames -{-# INLINE parameterConstrainedNamesL #-} - --- | 'parameterDims' Lens -parameterDimsL :: Lens_' Parameter ([Int]) -parameterDimsL f Parameter{..} = (\parameterDims -> Parameter { parameterDims, ..} ) <$> f parameterDims -{-# INLINE parameterDimsL #-} - --- | 'parameterName' Lens -parameterNameL :: Lens_' Parameter (Text) -parameterNameL f Parameter{..} = (\parameterName -> Parameter { parameterName, ..} ) <$> f parameterName -{-# INLINE parameterNameL #-} - - - --- * Status - --- | 'statusCode' Lens -statusCodeL :: Lens_' Status (Int) -statusCodeL f Status{..} = (\statusCode -> Status { statusCode, ..} ) <$> f statusCode -{-# INLINE statusCodeL #-} - --- | 'statusDetails' Lens -statusDetailsL :: Lens_' Status (Maybe [A.Value]) -statusDetailsL f Status{..} = (\statusDetails -> Status { statusDetails, ..} ) <$> f statusDetails -{-# INLINE statusDetailsL #-} - --- | 'statusMessage' Lens -statusMessageL :: Lens_' Status (Text) -statusMessageL f Status{..} = (\statusMessage -> Status { statusMessage, ..} ) <$> f statusMessage -{-# INLINE statusMessageL #-} - --- | 'statusStatus' Lens -statusStatusL :: Lens_' Status (Text) -statusStatusL f Status{..} = (\statusStatus -> Status { statusStatus, ..} ) <$> f statusStatus -{-# INLINE statusStatusL #-} - - - --- * V1ModelsGet200Response - --- | 'v1ModelsGet200ResponseModels' Lens -v1ModelsGet200ResponseModelsL :: Lens_' V1ModelsGet200Response (Maybe [Model]) -v1ModelsGet200ResponseModelsL f V1ModelsGet200Response{..} = (\v1ModelsGet200ResponseModels -> V1ModelsGet200Response { v1ModelsGet200ResponseModels, ..} ) <$> f v1ModelsGet200ResponseModels -{-# INLINE v1ModelsGet200ResponseModelsL #-} - - - --- * V1ModelsModelIdLogProbGradPost200Response - --- | 'v1ModelsModelIdLogProbGradPost200ResponseGradLogProb' Lens -v1ModelsModelIdLogProbGradPost200ResponseGradLogProbL :: Lens_' V1ModelsModelIdLogProbGradPost200Response (Maybe [Double]) -v1ModelsModelIdLogProbGradPost200ResponseGradLogProbL f V1ModelsModelIdLogProbGradPost200Response{..} = (\v1ModelsModelIdLogProbGradPost200ResponseGradLogProb -> V1ModelsModelIdLogProbGradPost200Response { v1ModelsModelIdLogProbGradPost200ResponseGradLogProb, ..} ) <$> f v1ModelsModelIdLogProbGradPost200ResponseGradLogProb -{-# INLINE v1ModelsModelIdLogProbGradPost200ResponseGradLogProbL #-} - - - --- * V1ModelsModelIdLogProbPost200Response - --- | 'v1ModelsModelIdLogProbPost200ResponseLogProb' Lens -v1ModelsModelIdLogProbPost200ResponseLogProbL :: Lens_' V1ModelsModelIdLogProbPost200Response (Maybe Double) -v1ModelsModelIdLogProbPost200ResponseLogProbL f V1ModelsModelIdLogProbPost200Response{..} = (\v1ModelsModelIdLogProbPost200ResponseLogProb -> V1ModelsModelIdLogProbPost200Response { v1ModelsModelIdLogProbPost200ResponseLogProb, ..} ) <$> f v1ModelsModelIdLogProbPost200ResponseLogProb -{-# INLINE v1ModelsModelIdLogProbPost200ResponseLogProbL #-} - - - --- * V1ModelsModelIdParamsPost200Response - --- | 'v1ModelsModelIdParamsPost200ResponseId' Lens -v1ModelsModelIdParamsPost200ResponseIdL :: Lens_' V1ModelsModelIdParamsPost200Response (Maybe Text) -v1ModelsModelIdParamsPost200ResponseIdL f V1ModelsModelIdParamsPost200Response{..} = (\v1ModelsModelIdParamsPost200ResponseId -> V1ModelsModelIdParamsPost200Response { v1ModelsModelIdParamsPost200ResponseId, ..} ) <$> f v1ModelsModelIdParamsPost200ResponseId -{-# INLINE v1ModelsModelIdParamsPost200ResponseIdL #-} - --- | 'v1ModelsModelIdParamsPost200ResponseParams' Lens -v1ModelsModelIdParamsPost200ResponseParamsL :: Lens_' V1ModelsModelIdParamsPost200Response (Maybe [Parameter]) -v1ModelsModelIdParamsPost200ResponseParamsL f V1ModelsModelIdParamsPost200Response{..} = (\v1ModelsModelIdParamsPost200ResponseParams -> V1ModelsModelIdParamsPost200Response { v1ModelsModelIdParamsPost200ResponseParams, ..} ) <$> f v1ModelsModelIdParamsPost200ResponseParams -{-# INLINE v1ModelsModelIdParamsPost200ResponseParamsL #-} - - - --- * V1ModelsModelIdTransformInitsPost200Response - --- | 'v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained' Lens -v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrainedL :: Lens_' V1ModelsModelIdTransformInitsPost200Response (Maybe [Double]) -v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrainedL f V1ModelsModelIdTransformInitsPost200Response{..} = (\v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained -> V1ModelsModelIdTransformInitsPost200Response { v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained, ..} ) <$> f v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained -{-# INLINE v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrainedL #-} - - - --- * V1ModelsModelIdWriteArrayPost200Response - --- | 'v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained' Lens -v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrainedL :: Lens_' V1ModelsModelIdWriteArrayPost200Response (Maybe [Double]) -v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrainedL f V1ModelsModelIdWriteArrayPost200Response{..} = (\v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained -> V1ModelsModelIdWriteArrayPost200Response { v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained, ..} ) <$> f v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained -{-# INLINE v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrainedL #-} - - diff --git a/lib/Httpstan/Types.hs b/lib/Httpstan/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Httpstan/Types.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module Httpstan.Types ( + CreateFitRequest (..), + CreateModelRequest (..), + Fit (..), + Model (..), + Operation (..), + Parameter (..), + Status (..), + V1ModelsGet200Response (..), + V1ModelsModelIdLogProbGradPost200Response (..), + V1ModelsModelIdLogProbPost200Response (..), + V1ModelsModelIdParamsPost200Response (..), + V1ModelsModelIdTransformInitsPost200Response (..), + V1ModelsModelIdWriteArrayPost200Response (..), + ) where + +import Data.Data (Data) +import Data.UUID (UUID) +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) +import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON) +import Data.Aeson.Types (Options(..), defaultOptions) +import Data.Set (Set) +import Data.Text (Text) +import Data.Time +import Data.Swagger (ToSchema, declareNamedSchema) +import qualified Data.Swagger as Swagger +import qualified Data.Char as Char +import qualified Data.Text as T +import qualified Data.Map as Map +import GHC.Generics (Generic) +import Data.Function ((&)) + + +-- | +data CreateFitRequest = CreateFitRequest + { createFitRequestChain :: Maybe Int -- ^ + , createFitRequestData :: Maybe Value -- ^ + , createFitRequestDelta :: Maybe Double -- ^ + , createFitRequestFunction :: Text -- ^ + , createFitRequestGamma :: Maybe Double -- ^ + , createFitRequestInit :: Maybe Value -- ^ + , createFitRequestInitUnderscorebuffer :: Maybe Int -- ^ + , createFitRequestInitUnderscoreradius :: Maybe Double -- ^ + , createFitRequestKappa :: Maybe Double -- ^ + , createFitRequestMaxUnderscoredepth :: Maybe Int -- ^ + , createFitRequestNumUnderscoresamples :: Maybe Int -- ^ + , createFitRequestNumUnderscorethin :: Maybe Int -- ^ + , createFitRequestNumUnderscorewarmup :: Maybe Int -- ^ + , createFitRequestRandomUnderscoreseed :: Maybe Int -- ^ + , createFitRequestRefresh :: Maybe Int -- ^ + , createFitRequestSaveUnderscorewarmup :: Maybe Bool -- ^ + , createFitRequestStepsize :: Maybe Double -- ^ + , createFitRequestStepsizeUnderscorejitter :: Maybe Double -- ^ + , createFitRequestT0 :: Maybe Double -- ^ + , createFitRequestTermUnderscorebuffer :: Maybe Int -- ^ + , createFitRequestWindow :: Maybe Int -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON CreateFitRequest where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "createFitRequest") +instance ToJSON CreateFitRequest where + toJSON = genericToJSON (removeFieldLabelPrefix False "createFitRequest") + + +-- | +data CreateModelRequest = CreateModelRequest + { createModelRequestProgramUnderscorecode :: Text -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON CreateModelRequest where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "createModelRequest") +instance ToJSON CreateModelRequest where + toJSON = genericToJSON (removeFieldLabelPrefix False "createModelRequest") + + +-- | +data Fit = Fit + { fitName :: Text -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON Fit where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "fit") +instance ToJSON Fit where + toJSON = genericToJSON (removeFieldLabelPrefix False "fit") + + +-- | +data Model = Model + { modelCompilerUnderscoreoutput :: Text -- ^ + , modelName :: Text -- ^ + , modelStancUnderscorewarnings :: Text -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON Model where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "model") +instance ToJSON Model where + toJSON = genericToJSON (removeFieldLabelPrefix False "model") + + +-- | +data Operation = Operation + { operationDone :: Bool -- ^ + , operationMetadata :: Maybe Value -- ^ + , operationName :: Text -- ^ + , operationResult :: Maybe Value -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON Operation where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "operation") +instance ToJSON Operation where + toJSON = genericToJSON (removeFieldLabelPrefix False "operation") + + +-- | +data Parameter = Parameter + { parameterConstrainedUnderscorenames :: [Text] -- ^ + , parameterDims :: [Int] -- ^ + , parameterName :: Text -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON Parameter where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "parameter") +instance ToJSON Parameter where + toJSON = genericToJSON (removeFieldLabelPrefix False "parameter") + + +-- | +data Status = Status + { statusCode :: Int -- ^ + , statusDetails :: Maybe [Value] -- ^ + , statusMessage :: Text -- ^ + , statusStatus :: Text -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON Status where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "status") +instance ToJSON Status where + toJSON = genericToJSON (removeFieldLabelPrefix False "status") + + +-- | +data V1ModelsGet200Response = V1ModelsGet200Response + { v1ModelsGet200ResponseModels :: Maybe [Model] -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON V1ModelsGet200Response where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "v1ModelsGet200Response") +instance ToJSON V1ModelsGet200Response where + toJSON = genericToJSON (removeFieldLabelPrefix False "v1ModelsGet200Response") + + +-- | +data V1ModelsModelIdLogProbGradPost200Response = V1ModelsModelIdLogProbGradPost200Response + { v1ModelsModelIdLogProbGradPost200ResponseGradUnderscorelogUnderscoreprob :: Maybe [Double] -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON V1ModelsModelIdLogProbGradPost200Response where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "v1ModelsModelIdLogProbGradPost200Response") +instance ToJSON V1ModelsModelIdLogProbGradPost200Response where + toJSON = genericToJSON (removeFieldLabelPrefix False "v1ModelsModelIdLogProbGradPost200Response") + + +-- | +data V1ModelsModelIdLogProbPost200Response = V1ModelsModelIdLogProbPost200Response + { v1ModelsModelIdLogProbPost200ResponseLogUnderscoreprob :: Maybe Double -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON V1ModelsModelIdLogProbPost200Response where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "v1ModelsModelIdLogProbPost200Response") +instance ToJSON V1ModelsModelIdLogProbPost200Response where + toJSON = genericToJSON (removeFieldLabelPrefix False "v1ModelsModelIdLogProbPost200Response") + + +-- | +data V1ModelsModelIdParamsPost200Response = V1ModelsModelIdParamsPost200Response + { v1ModelsModelIdParamsPost200ResponseId :: Maybe Text -- ^ + , v1ModelsModelIdParamsPost200ResponseParams :: Maybe [Parameter] -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON V1ModelsModelIdParamsPost200Response where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "v1ModelsModelIdParamsPost200Response") +instance ToJSON V1ModelsModelIdParamsPost200Response where + toJSON = genericToJSON (removeFieldLabelPrefix False "v1ModelsModelIdParamsPost200Response") + + +-- | +data V1ModelsModelIdTransformInitsPost200Response = V1ModelsModelIdTransformInitsPost200Response + { v1ModelsModelIdTransformInitsPost200ResponseParamsUnderscorerUnderscoreunconstrained :: Maybe [Double] -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON V1ModelsModelIdTransformInitsPost200Response where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "v1ModelsModelIdTransformInitsPost200Response") +instance ToJSON V1ModelsModelIdTransformInitsPost200Response where + toJSON = genericToJSON (removeFieldLabelPrefix False "v1ModelsModelIdTransformInitsPost200Response") + + +-- | +data V1ModelsModelIdWriteArrayPost200Response = V1ModelsModelIdWriteArrayPost200Response + { v1ModelsModelIdWriteArrayPost200ResponseParamsUnderscorerUnderscoreconstrained :: Maybe [Double] -- ^ + } deriving (Show, Eq, Generic, Data) + +instance FromJSON V1ModelsModelIdWriteArrayPost200Response where + parseJSON = genericParseJSON (removeFieldLabelPrefix True "v1ModelsModelIdWriteArrayPost200Response") +instance ToJSON V1ModelsModelIdWriteArrayPost200Response where + toJSON = genericToJSON (removeFieldLabelPrefix False "v1ModelsModelIdWriteArrayPost200Response") + + +uncapitalize :: String -> String +uncapitalize (first:rest) = Char.toLower first : rest +uncapitalize [] = [] + +-- | Remove a field label prefix during JSON parsing. +-- Also perform any replacements for special characters. +-- The @forParsing@ parameter is to distinguish between the cases in which we're using this +-- to power a @FromJSON@ or a @ToJSON@ instance. In the first case we're parsing, and we want +-- to replace special characters with their quoted equivalents (because we cannot have special +-- chars in identifier names), while we want to do vice versa when sending data instead. +removeFieldLabelPrefix :: Bool -> String -> Options +removeFieldLabelPrefix forParsing prefix = + defaultOptions + { omitNothingFields = True + , fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars + } + where + replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars) + specialChars = + [ ("$", "'Dollar") + , ("^", "'Caret") + , ("|", "'Pipe") + , ("=", "'Equal") + , ("*", "'Star") + , ("-", "'Dash") + , ("&", "'Ampersand") + , ("%", "'Percent") + , ("#", "'Hash") + , ("@", "'At") + , ("!", "'Exclamation") + , ("+", "'Plus") + , (":", "'Colon") + , (";", "'Semicolon") + , (">", "'GreaterThan") + , ("<", "'LessThan") + , (".", "'Period") + , ("_", "'Underscore") + , ("?", "'Question_Mark") + , (",", "'Comma") + , ("'", "'Quote") + , ("/", "'Slash") + , ("(", "'Left_Parenthesis") + , (")", "'Right_Parenthesis") + , ("{", "'Left_Curly_Bracket") + , ("}", "'Right_Curly_Bracket") + , ("[", "'Left_Square_Bracket") + , ("]", "'Right_Square_Bracket") + , ("~", "'Tilde") + , ("`", "'Backtick") + , ("<=", "'Less_Than_Or_Equal_To") + , (">=", "'Greater_Than_Or_Equal_To") + , ("!=", "'Not_Equal") + , ("<>", "'Not_Equal") + , ("~=", "'Tilde_Equal") + , ("\\", "'Back_Slash") + , ("\"", "'Double_Quote") + ] + mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack + replacer = + if forParsing + then flip T.replace + else T.replace diff --git a/openapi.yaml b/openapi.yaml deleted file mode 100644 --- a/openapi.yaml +++ /dev/null @@ -1,656 +0,0 @@ -openapi: 3.0.1 -info: - title: httpstan - version: 4.10.0 -servers: -- url: / -paths: - /v1/health: - get: - description: Check if service is running. - responses: - "200": - content: {} - description: OK - /v1/models: - get: - description: List cached models. - responses: - "200": - content: - application/json: - schema: - $ref: '#/components/schemas/_v1_models_get_200_response' - description: Identifier for compiled Stan model and compiler output. - post: - description: Compile a Stan model - requestBody: - content: - application/json: - schema: - $ref: '#/components/schemas/CreateModelRequest' - description: Stan program code to compile - required: true - responses: - "201": - content: - application/json: - schema: - $ref: '#/components/schemas/Model' - description: Identifier for compiled Stan model and compiler output. - "400": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Error associated with compile request. - x-codegen-request-body-name: body - /v1/models/{model_id}: - delete: - description: Delete a model which has been saved in the cache. - parameters: - - description: ID of Stan model - in: path - name: model_id - required: true - schema: - type: string - responses: - "200": - content: {} - description: Model successfully deleted. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Model not found. - summary: Delete a model and any associated fits. - /v1/models/{model_id}/params: - post: - description: "Returns the output of Stan C++ model class methods: ``constrained_param_names``,\ - \ ``get_param_names`` and ``get_dims``." - parameters: - - description: ID of Stan model to use - in: path - name: model_id - required: true - schema: - type: string - requestBody: - content: - application/json: - schema: - $ref: '#/components/schemas/Data' - description: Data for Stan Model. Needed to calculate param names and dimensions. - required: true - responses: - "200": - content: - application/json: - schema: - $ref: '#/components/schemas/_v1_models__model_id__params_post_200_response' - description: Parameters for Stan Model - "400": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Error associated with request. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Model not found. - summary: Get parameter names and dimensions. - x-codegen-request-body-name: data - /v1/models/{model_id}/log_prob: - post: - description: Returns the output of Stan C++ ``log_prob`` model class method. - parameters: - - description: ID of Stan model to use - in: path - name: model_id - required: true - schema: - type: string - requestBody: - content: - application/json: - schema: - type: boolean - description: Boolean to control whether we apply a Jacobian adjust transform. - required: false - responses: - "200": - content: - application/json: - schema: - $ref: '#/components/schemas/_v1_models__model_id__log_prob_post_200_response' - description: Log probability of the unconstrained parameters. - "400": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Error associated with request. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Model not found. - summary: Return the log probability of the unconstrained parameters. - x-codegen-request-body-name: adjust_transform - /v1/models/{model_id}/log_prob_grad: - post: - description: Returns the output of Stan C++ `stan::model::log_prob_grad`. - parameters: - - description: ID of Stan model to use - in: path - name: model_id - required: true - schema: - type: string - requestBody: - content: - application/json: - schema: - type: boolean - description: Boolean to control whether we apply a Jacobian adjust transform. - required: false - responses: - "200": - content: - application/json: - schema: - $ref: '#/components/schemas/_v1_models__model_id__log_prob_grad_post_200_response' - description: Gradient of the log posterior evaluated at the unconstrained - parameters. - "400": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Error associated with request. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Model not found. - summary: Return the gradient of the log posterior evaluated at the unconstrained - parameters. - x-codegen-request-body-name: adjust_transform - /v1/models/{model_id}/write_array: - post: - description: Returns the output of Stan C++ ``write_array`` model class method. - parameters: - - description: ID of Stan model to use - in: path - name: model_id - required: true - schema: - type: string - requestBody: - content: - application/json: - schema: - type: boolean - description: Boolean to control whether we include generated quantities. - required: true - responses: - "200": - content: - application/json: - schema: - $ref: '#/components/schemas/_v1_models__model_id__write_array_post_200_response' - description: "Sequence of constrained parameters, optionally including transformed\ - \ parameters and generated quantities." - "400": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Error associated with request. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Model not found. - summary: Return a sequence of constrained parameters. - x-codegen-request-body-name: include_gqs - /v1/models/{model_id}/transform_inits: - post: - description: Returns the output of Stan C++ ``transform_inits`` model class - method. - parameters: - - description: ID of Stan model to use - in: path - name: model_id - required: true - schema: - type: string - requestBody: - content: - application/json: - schema: - $ref: '#/components/schemas/Data' - description: Constrained parameter values and their specified context - required: true - responses: - "200": - content: - application/json: - schema: - $ref: '#/components/schemas/_v1_models__model_id__transform_inits_post_200_response' - description: Sequence of unconstrained parameters. - "400": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Error associated with request. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Model not found. - summary: Return a sequence of unconstrained parameters. - x-codegen-request-body-name: constrained_parameters - /v1/models/{model_id}/fits: - post: - description: |- - A request to this endpoint starts a long-running operation. Users can retrieve information about the status of the operation by making a GET request to the operations resource endpoint. - When the operation is `done`, the "fit" may be downloaded. (A "fit" collects all logger and writer messages from Stan.) - ``function`` indicates the name of the ``stan::services function`` which should be called given the Stan model associated with the id ``model_id``. For example, if sampling using ``stan::services::sample::hmc_nuts_diag_e_adapt`` then ``function`` is the full function name ``stan::services::sample::hmc_nuts_diag_e_adapt``. Sampler parameters which are not supplied will be given default values taken from CmdStan. For example, if ``stan::services::sample::hmc_nuts_diag_e_adapt`` is the function called and the parameter ``num_samples`` is not specified, the value 1000 will be used. For a full list of default values consult the CmdStan documentation. - parameters: - - description: ID of Stan model to use - in: path - name: model_id - required: true - schema: - type: string - requestBody: - content: - application/json: - schema: - $ref: '#/components/schemas/CreateFitRequest' - description: Full stan::services function name and associated arguments to - call with Stan model. - required: true - responses: - "201": - content: - application/json: - schema: - $ref: '#/components/schemas/Fit' - description: Identifier for completed Stan fit - "400": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Error associated with request. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Fit not found. - summary: Call function defined in stan::services. - x-codegen-request-body-name: body - /v1/models/{model_id}/fits/{fit_id}: - delete: - description: Delete a fit which has been saved in the cache. - parameters: - - description: ID of Stan model associated with the fit. - in: path - name: model_id - required: true - schema: - type: string - - description: ID of fit to be deleted. - in: path - name: fit_id - required: true - schema: - type: string - responses: - "200": - content: {} - description: Fit successfully deleted. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Fit not found. - summary: Delete a fit. - get: - description: "Result (draws, logger messages) from calling a function defined\ - \ in stan::services." - parameters: - - description: ID of Stan model associated with the result - in: path - name: model_id - required: true - schema: - type: string - - description: ID of Stan result ("fit") desired - in: path - name: fit_id - required: true - schema: - type: string - responses: - "200": - content: {} - description: Newline-delimited JSON-encoded messages from Stan. Includes - draws. - "404": - content: - text/plain: - schema: - $ref: '#/components/schemas/Status' - description: Fit not found. - summary: Get results returned by a function. - /v1/operations/{operation_id}: - get: - description: Return Operation details. Details about an Operation include whether - or not the operation is `done` and information about the progress of sampling. - parameters: - - description: ID of Operation - in: path - name: operation_id - required: true - schema: - type: string - responses: - "200": - content: - application/json: - schema: - $ref: '#/components/schemas/Operation' - description: Operation name and metadata. - "404": - content: - application/json: - schema: - $ref: '#/components/schemas/Status' - description: Operation not found. - summary: Get Operation details. -components: - schemas: - CreateFitRequest: - example: - random_seed: 0 - init: "{}" - chain: 0 - data: "{}" - max_depth: 0 - stepsize_jitter: 1.0246457001441578 - delta: 6.027456183070403 - refresh: 0 - term_buffer: 0 - init_buffer: 0 - init_radius: 5.637376656633329 - function: stan::services::sample::hmc_nuts_diag_e_adapt - num_thin: 0 - kappa: 2.3021358869347655 - num_warmup: 0 - window: 0 - t0: 1.4894159098541704 - save_warmup: true - gamma: 1.4658129805029452 - stepsize: 1.2315135367772556 - num_samples: 0 - properties: - chain: - minimum: 0 - type: integer - data: - allOf: - - $ref: '#/components/schemas/Data' - type: object - delta: - type: number - function: - enum: - - stan::services::sample::hmc_nuts_diag_e_adapt - - stan::services::sample::fixed_param - type: string - gamma: - type: number - init: - allOf: - - $ref: '#/components/schemas/Data' - type: object - init_buffer: - minimum: 0 - type: integer - init_radius: - type: number - kappa: - type: number - max_depth: - minimum: 0 - type: integer - num_samples: - minimum: 0 - type: integer - num_thin: - minimum: 0 - type: integer - num_warmup: - minimum: 0 - type: integer - random_seed: - minimum: 0 - type: integer - refresh: - minimum: 0 - type: integer - save_warmup: - type: boolean - stepsize: - type: number - stepsize_jitter: - type: number - t0: - type: number - term_buffer: - minimum: 0 - type: integer - window: - minimum: 0 - type: integer - required: - - function - type: object - CreateModelRequest: - example: - program_code: program_code - properties: - program_code: - type: string - required: - - program_code - type: object - Data: - type: object - Fit: - example: - name: name - properties: - name: - type: string - required: - - name - type: object - Model: - example: - stanc_warnings: stanc_warnings - compiler_output: compiler_output - name: name - properties: - compiler_output: - type: string - name: - type: string - stanc_warnings: - type: string - required: - - compiler_output - - name - - stanc_warnings - type: object - Operation: - example: - result: "{}" - metadata: "{}" - name: name - done: true - properties: - done: - type: boolean - metadata: - properties: {} - type: object - name: - type: string - result: - properties: {} - type: object - required: - - done - - name - type: object - Parameter: - example: - dims: - - 0 - - 0 - name: name - constrained_names: - - constrained_names - - constrained_names - properties: - constrained_names: - items: - type: string - type: array - dims: - items: - type: integer - type: array - name: - type: string - required: - - constrained_names - - dims - - name - type: object - Status: - properties: - code: - type: integer - details: - items: - properties: {} - type: object - type: array - message: - type: string - status: - type: string - required: - - code - - message - - status - type: object - _v1_models_get_200_response: - example: - models: - - stanc_warnings: stanc_warnings - compiler_output: compiler_output - name: name - - stanc_warnings: stanc_warnings - compiler_output: compiler_output - name: name - properties: - models: - items: - $ref: '#/components/schemas/Model' - type: array - type: object - _v1_models__model_id__params_post_200_response: - example: - id: id - params: - - dims: - - 0 - - 0 - name: name - constrained_names: - - constrained_names - - constrained_names - - dims: - - 0 - - 0 - name: name - constrained_names: - - constrained_names - - constrained_names - properties: - id: - type: string - params: - items: - $ref: '#/components/schemas/Parameter' - type: array - type: object - _v1_models__model_id__log_prob_post_200_response: - example: - log_prob: 0.8008281904610115 - properties: - log_prob: - type: number - type: object - _v1_models__model_id__log_prob_grad_post_200_response: - example: - grad_log_prob: - - 0.8008281904610115 - - 0.8008281904610115 - properties: - grad_log_prob: - items: - type: number - type: array - type: object - _v1_models__model_id__write_array_post_200_response: - example: - params_r_constrained: - - 0.8008281904610115 - - 0.8008281904610115 - properties: - params_r_constrained: - items: - type: number - type: array - type: object - _v1_models__model_id__transform_inits_post_200_response: - example: - params_r_unconstrained: - - 0.8008281904610115 - - 0.8008281904610115 - properties: - params_r_unconstrained: - items: - type: number - type: array - type: object -x-original-swagger-version: "2.0" diff --git a/tests/ApproxEq.hs b/tests/ApproxEq.hs deleted file mode 100644 --- a/tests/ApproxEq.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ApproxEq where - -import Data.Text (Text) -import Data.Time.Clock -import Test.QuickCheck -import GHC.Generics as G - -(==~) - :: (ApproxEq a, Show a) - => a -> a -> Property -a ==~ b = counterexample (show a ++ " !=~ " ++ show b) (a =~ b) - -class GApproxEq f where - gApproxEq :: f a -> f a -> Bool - -instance GApproxEq U1 where - gApproxEq U1 U1 = True - -instance (GApproxEq a, GApproxEq b) => - GApproxEq (a :+: b) where - gApproxEq (L1 a) (L1 b) = gApproxEq a b - gApproxEq (R1 a) (R1 b) = gApproxEq a b - gApproxEq _ _ = False - -instance (GApproxEq a, GApproxEq b) => - GApproxEq (a :*: b) where - gApproxEq (a1 :*: b1) (a2 :*: b2) = gApproxEq a1 a2 && gApproxEq b1 b2 - -instance (ApproxEq a) => - GApproxEq (K1 i a) where - gApproxEq (K1 a) (K1 b) = a =~ b - -instance (GApproxEq f) => - GApproxEq (M1 i t f) where - gApproxEq (M1 a) (M1 b) = gApproxEq a b - -class ApproxEq a where - (=~) :: a -> a -> Bool - default (=~) :: (Generic a, GApproxEq (Rep a)) => a -> a -> Bool - a =~ b = gApproxEq (G.from a) (G.from b) - -instance ApproxEq Text where - (=~) = (==) - -instance ApproxEq Char where - (=~) = (==) - -instance ApproxEq Bool where - (=~) = (==) - -instance ApproxEq Int where - (=~) = (==) - -instance ApproxEq Double where - (=~) = (==) - -instance ApproxEq a => - ApproxEq (Maybe a) - -instance ApproxEq UTCTime where - (=~) = (==) - -instance ApproxEq a => - ApproxEq [a] where - as =~ bs = and (zipWith (=~) as bs) - -instance (ApproxEq l, ApproxEq r) => - ApproxEq (Either l r) where - Left a =~ Left b = a =~ b - Right a =~ Right b = a =~ b - _ =~ _ = False - -instance (ApproxEq l, ApproxEq r) => - ApproxEq (l, r) where - (=~) (l1, r1) (l2, r2) = l1 =~ l2 && r1 =~ r2 diff --git a/tests/Instances.hs b/tests/Instances.hs deleted file mode 100644 --- a/tests/Instances.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-matches #-} - -module Instances where - -import Httpstan.Model -import Httpstan.Core - -import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HM -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Time as TI -import qualified Data.Vector as V -import Data.String (fromString) - -import Control.Monad -import Data.Char (isSpace) -import Data.List (sort) -import Test.QuickCheck - -import ApproxEq - -instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary TI.Day where - arbitrary = TI.ModifiedJulianDay . (2000 +) <$> arbitrary - shrink = (TI.ModifiedJulianDay <$>) . shrink . TI.toModifiedJulianDay - -instance Arbitrary TI.UTCTime where - arbitrary = - TI.UTCTime <$> arbitrary <*> (TI.secondsToDiffTime <$> choose (0, 86401)) - -instance Arbitrary BL.ByteString where - arbitrary = BL.pack <$> arbitrary - shrink xs = BL.pack <$> shrink (BL.unpack xs) - -instance Arbitrary ByteArray where - arbitrary = ByteArray <$> arbitrary - shrink (ByteArray xs) = ByteArray <$> shrink xs - -instance Arbitrary Binary where - arbitrary = Binary <$> arbitrary - shrink (Binary xs) = Binary <$> shrink xs - -instance Arbitrary DateTime where - arbitrary = DateTime <$> arbitrary - shrink (DateTime xs) = DateTime <$> shrink xs - -instance Arbitrary Date where - arbitrary = Date <$> arbitrary - shrink (Date xs) = Date <$> shrink xs - -#if MIN_VERSION_aeson(2,0,0) -#else --- | A naive Arbitrary instance for A.Value: -instance Arbitrary A.Value where - arbitrary = arbitraryValue -#endif - -arbitraryValue :: Gen A.Value -arbitraryValue = - frequency [(3, simpleTypes), (1, arrayTypes), (1, objectTypes)] - where - simpleTypes :: Gen A.Value - simpleTypes = - frequency - [ (1, return A.Null) - , (2, liftM A.Bool (arbitrary :: Gen Bool)) - , (2, liftM (A.Number . fromIntegral) (arbitrary :: Gen Int)) - , (2, liftM (A.String . T.pack) (arbitrary :: Gen String)) - ] - mapF (k, v) = (fromString k, v) - simpleAndArrays = frequency [(1, sized sizedArray), (4, simpleTypes)] - arrayTypes = sized sizedArray - objectTypes = sized sizedObject - sizedArray n = liftM (A.Array . V.fromList) $ replicateM n simpleTypes - sizedObject n = - liftM (A.object . map mapF) $ - replicateM n $ (,) <$> (arbitrary :: Gen String) <*> simpleAndArrays - --- | Checks if a given list has no duplicates in _O(n log n)_. -hasNoDups - :: (Ord a) - => [a] -> Bool -hasNoDups = go Set.empty - where - go _ [] = True - go s (x:xs) - | s' <- Set.insert x s - , Set.size s' > Set.size s = go s' xs - | otherwise = False - -instance ApproxEq TI.Day where - (=~) = (==) - -arbitraryReduced :: Arbitrary a => Int -> Gen a -arbitraryReduced n = resize (n `div` 2) arbitrary - -arbitraryReducedMaybe :: Arbitrary a => Int -> Gen (Maybe a) -arbitraryReducedMaybe 0 = elements [Nothing] -arbitraryReducedMaybe n = arbitraryReduced n - -arbitraryReducedMaybeValue :: Int -> Gen (Maybe A.Value) -arbitraryReducedMaybeValue 0 = elements [Nothing] -arbitraryReducedMaybeValue n = do - generated <- arbitraryReduced n - if generated == Just A.Null - then return Nothing - else return generated - --- * Models - -instance Arbitrary CreateFitRequest where - arbitrary = sized genCreateFitRequest - -genCreateFitRequest :: Int -> Gen CreateFitRequest -genCreateFitRequest n = - CreateFitRequest - <$> arbitraryReducedMaybe n -- createFitRequestChain :: Maybe Int - <*> arbitraryReducedMaybeValue n -- createFitRequestData :: Maybe A.Value - <*> arbitraryReducedMaybe n -- createFitRequestDelta :: Maybe Double - <*> arbitrary -- createFitRequestFunction :: E'Function - <*> arbitraryReducedMaybe n -- createFitRequestGamma :: Maybe Double - <*> arbitraryReducedMaybeValue n -- createFitRequestInit :: Maybe A.Value - <*> arbitraryReducedMaybe n -- createFitRequestInitBuffer :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestInitRadius :: Maybe Double - <*> arbitraryReducedMaybe n -- createFitRequestKappa :: Maybe Double - <*> arbitraryReducedMaybe n -- createFitRequestMaxDepth :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestNumSamples :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestNumThin :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestNumWarmup :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestRandomSeed :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestRefresh :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestSaveWarmup :: Maybe Bool - <*> arbitraryReducedMaybe n -- createFitRequestStepsize :: Maybe Double - <*> arbitraryReducedMaybe n -- createFitRequestStepsizeJitter :: Maybe Double - <*> arbitraryReducedMaybe n -- createFitRequestT0 :: Maybe Double - <*> arbitraryReducedMaybe n -- createFitRequestTermBuffer :: Maybe Int - <*> arbitraryReducedMaybe n -- createFitRequestWindow :: Maybe Int - -instance Arbitrary CreateModelRequest where - arbitrary = sized genCreateModelRequest - -genCreateModelRequest :: Int -> Gen CreateModelRequest -genCreateModelRequest n = - CreateModelRequest - <$> arbitrary -- createModelRequestProgramCode :: Text - -instance Arbitrary Fit where - arbitrary = sized genFit - -genFit :: Int -> Gen Fit -genFit n = - Fit - <$> arbitrary -- fitName :: Text - -instance Arbitrary Model where - arbitrary = sized genModel - -genModel :: Int -> Gen Model -genModel n = - Model - <$> arbitrary -- modelCompilerOutput :: Text - <*> arbitrary -- modelName :: Text - <*> arbitrary -- modelStancWarnings :: Text - -instance Arbitrary Operation where - arbitrary = sized genOperation - -genOperation :: Int -> Gen Operation -genOperation n = - Operation - <$> arbitrary -- operationDone :: Bool - <*> arbitraryReducedMaybeValue n -- operationMetadata :: Maybe A.Value - <*> arbitrary -- operationName :: Text - <*> arbitraryReducedMaybeValue n -- operationResult :: Maybe A.Value - -instance Arbitrary Parameter where - arbitrary = sized genParameter - -genParameter :: Int -> Gen Parameter -genParameter n = - Parameter - <$> arbitrary -- parameterConstrainedNames :: [Text] - <*> arbitrary -- parameterDims :: [Int] - <*> arbitrary -- parameterName :: Text - -instance Arbitrary Status where - arbitrary = sized genStatus - -genStatus :: Int -> Gen Status -genStatus n = - Status - <$> arbitrary -- statusCode :: Int - <*> arbitraryReducedMaybe n -- statusDetails :: Maybe [A.Value] - <*> arbitrary -- statusMessage :: Text - <*> arbitrary -- statusStatus :: Text - -instance Arbitrary V1ModelsGet200Response where - arbitrary = sized genV1ModelsGet200Response - -genV1ModelsGet200Response :: Int -> Gen V1ModelsGet200Response -genV1ModelsGet200Response n = - V1ModelsGet200Response - <$> arbitraryReducedMaybe n -- v1ModelsGet200ResponseModels :: Maybe [Model] - -instance Arbitrary V1ModelsModelIdLogProbGradPost200Response where - arbitrary = sized genV1ModelsModelIdLogProbGradPost200Response - -genV1ModelsModelIdLogProbGradPost200Response :: Int -> Gen V1ModelsModelIdLogProbGradPost200Response -genV1ModelsModelIdLogProbGradPost200Response n = - V1ModelsModelIdLogProbGradPost200Response - <$> arbitraryReducedMaybe n -- v1ModelsModelIdLogProbGradPost200ResponseGradLogProb :: Maybe [Double] - -instance Arbitrary V1ModelsModelIdLogProbPost200Response where - arbitrary = sized genV1ModelsModelIdLogProbPost200Response - -genV1ModelsModelIdLogProbPost200Response :: Int -> Gen V1ModelsModelIdLogProbPost200Response -genV1ModelsModelIdLogProbPost200Response n = - V1ModelsModelIdLogProbPost200Response - <$> arbitraryReducedMaybe n -- v1ModelsModelIdLogProbPost200ResponseLogProb :: Maybe Double - -instance Arbitrary V1ModelsModelIdParamsPost200Response where - arbitrary = sized genV1ModelsModelIdParamsPost200Response - -genV1ModelsModelIdParamsPost200Response :: Int -> Gen V1ModelsModelIdParamsPost200Response -genV1ModelsModelIdParamsPost200Response n = - V1ModelsModelIdParamsPost200Response - <$> arbitraryReducedMaybe n -- v1ModelsModelIdParamsPost200ResponseId :: Maybe Text - <*> arbitraryReducedMaybe n -- v1ModelsModelIdParamsPost200ResponseParams :: Maybe [Parameter] - -instance Arbitrary V1ModelsModelIdTransformInitsPost200Response where - arbitrary = sized genV1ModelsModelIdTransformInitsPost200Response - -genV1ModelsModelIdTransformInitsPost200Response :: Int -> Gen V1ModelsModelIdTransformInitsPost200Response -genV1ModelsModelIdTransformInitsPost200Response n = - V1ModelsModelIdTransformInitsPost200Response - <$> arbitraryReducedMaybe n -- v1ModelsModelIdTransformInitsPost200ResponseParamsRUnconstrained :: Maybe [Double] - -instance Arbitrary V1ModelsModelIdWriteArrayPost200Response where - arbitrary = sized genV1ModelsModelIdWriteArrayPost200Response - -genV1ModelsModelIdWriteArrayPost200Response :: Int -> Gen V1ModelsModelIdWriteArrayPost200Response -genV1ModelsModelIdWriteArrayPost200Response n = - V1ModelsModelIdWriteArrayPost200Response - <$> arbitraryReducedMaybe n -- v1ModelsModelIdWriteArrayPost200ResponseParamsRConstrained :: Maybe [Double] - - - - -instance Arbitrary E'Function where - arbitrary = arbitraryBoundedEnum - diff --git a/tests/PropMime.hs b/tests/PropMime.hs deleted file mode 100644 --- a/tests/PropMime.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module PropMime where - -import Data.Aeson -import Data.Aeson.Types (parseEither) -import Data.Monoid ((<>)) -import Data.Typeable (Proxy(..), typeOf, Typeable) -import qualified Data.ByteString.Lazy.Char8 as BL8 -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Property -import Test.Hspec.QuickCheck (prop) - -import Httpstan.MimeTypes - -import ApproxEq - --- * Type Aliases - -type ArbitraryMime mime a = ArbitraryRoundtrip (MimeUnrender mime) (MimeRender mime) a - -type ArbitraryRoundtrip from to a = (from a, to a, Arbitrary' a) - -type Arbitrary' a = (Arbitrary a, Show a, Typeable a) - --- * Mime - -propMime - :: forall a b mime. - (ArbitraryMime mime a, Testable b) - => String -> (a -> a -> b) -> mime -> Proxy a -> Spec -propMime eqDescr eq m _ = - prop - (show (typeOf (undefined :: a)) <> " " <> show (typeOf (undefined :: mime)) <> " roundtrip " <> eqDescr) $ - \(x :: a) -> - let rendered = mimeRender' m x - actual = mimeUnrender' m rendered - expected = Right x - failMsg = - "ACTUAL: " <> show actual <> "\nRENDERED: " <> BL8.unpack rendered - in counterexample failMsg $ - either reject property (eq <$> actual <*> expected) - where - reject = property . const rejected - -propMimeEq :: (ArbitraryMime mime a, Eq a) => mime -> Proxy a -> Spec -propMimeEq = propMime "(EQ)" (==) diff --git a/tests/Test.hs b/tests/Test.hs deleted file mode 100644 --- a/tests/Test.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# 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) -