openapi3-code-generator 0.1.0.6 → 0.1.0.7
raw patch · 34 files changed
+2999/−1893 lines, 34 filesdep +autodocodecdep +autodocodec-yamldep +optparse-applicativedep −optionssetup-changednew-uploader
Dependencies added: autodocodec, autodocodec-yaml, optparse-applicative, path, path-io
Dependencies removed: options
Files
- ChangeLog.md +0/−3
- README.md +0/−73
- Setup.hs +0/−3
- app/Embed.hs +0/−10
- app/Main.hs +1/−166
- openapi3-code-generator.cabal +152/−132
- src/OpenAPI/Common.hs +121/−71
- src/OpenAPI/Generate.hs +29/−72
- src/OpenAPI/Generate/Doc.hs +58/−31
- src/OpenAPI/Generate/Flags.hs +0/−118
- src/OpenAPI/Generate/IO.hs +271/−0
- src/OpenAPI/Generate/Internal/Embed.hs +10/−0
- src/OpenAPI/Generate/Internal/Operation.hs +283/−137
- src/OpenAPI/Generate/Internal/Unknown.hs +67/−0
- src/OpenAPI/Generate/Internal/Util.hs +31/−30
- src/OpenAPI/Generate/Log.hs +64/−0
- src/OpenAPI/Generate/Main.hs +92/−0
- src/OpenAPI/Generate/Model.hs +395/−268
- src/OpenAPI/Generate/ModelDependencies.hs +67/−47
- src/OpenAPI/Generate/Monad.hs +42/−62
- src/OpenAPI/Generate/Operation.hs +120/−101
- src/OpenAPI/Generate/OptParse.hs +175/−0
- src/OpenAPI/Generate/OptParse/Configuration.hs +89/−0
- src/OpenAPI/Generate/OptParse/Flags.hs +353/−0
- src/OpenAPI/Generate/Response.hs +33/−35
- src/OpenAPI/Generate/SecurityScheme.hs +89/−90
- src/OpenAPI/Generate/Types.hs +188/−200
- src/OpenAPI/Generate/Types/ExternalDocumentation.hs +4/−5
- src/OpenAPI/Generate/Types/Schema.hs +111/−82
- test/OpenAPI/Generate/DocSpec.hs +61/−64
- test/OpenAPI/Generate/Internal/UtilSpec.hs +16/−24
- test/OpenAPI/Generate/ModelDependenciesSpec.hs +19/−18
- test/OpenAPI/Generate/MonadSpec.hs +36/−29
- test/OpenAPI/Generate/OperationTHSpec.hs +22/−22
− ChangeLog.md
@@ -1,3 +0,0 @@-# Changelog for openapi3-code-generator--## Unreleased changes
− README.md
@@ -1,73 +0,0 @@-# openapi3-code-generator-[](https://circleci.com/gh/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator)--## How to use?-1. install [cabal](https://www.haskell.org/cabal/)-1. `cabal update`-1. `cabal install openapi3-code-generator`-1. `openapi3-code-generator-exe my_specification.yml`--An `out` directory is created with the generated code. Hint you can use `--output-dir` to specify another output directory.-You can use `openapi3-code-generator --help` to list all CLI options.--If `openapi3-code-generator-exe` is not found, you may not have added the cabal bin to your `PATH`. Execute `~/.local/bin/openapi3-code-generator-exe` instead.--## How to run from source-1. install [stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/)-1. `stack run -- --help`--## Example package-In the folder `example` is a package that uses the generated code from `specifications/petstore.yml`.-You can run `stack test` inside the `example` directory to run the code, it calls the server "https://petstore.swagger.io/v2" with some sample data.--https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library uses this code generator to generate-a Stripe API client.--## Documentation-The documentation for the code can be found at https://hackage.haskell.org/package/openapi3-code-generator-This package was created as part of a bachelor thesis. This thesis can be found here TODO.--## Large specifications-For large specifications some modules (CyclicTypes.hs for example) can get pretty big. It may be necessary to use `--fast` with `stack build --fast` to build the code.--## Module structure of the generated code.-All symbols are globally unique and are reexported in the module `OpenAPI` (Module name can be changed with `--module-name`).-To reduce compile time, the code is split up into multiple modules.-Mainly for every operation and for every schema.-Schemas with cyclic dependencies are are in the module `OpenAPI.CyclicTypes`.--## Troubleshooting naming conflicts-Naming conflicts can happen, sometimes a little manual adjustment is needed.-With the following options naming conflicts can be resolved.-It can happen, that the names get so long, that they are longer than the file system supports.--- `property-type-suffix`-- `response-type-suffix`-- `response-body-type-suffix`-- `request-body-type-suffix`-- `use-numbered-variant-constructors`-- `convert-to-camel-case`--## Limitations-The following features are not supported-- links-- callbacks-- Only references to `components` are supported-- Only JSON is supported for both sending and receiving data. `application/x-www-form-urlencoded` can only be used to send data.-- Some circular references in the schemas. For example if an `allOf` contains itself-- Parameters not in `path` or `query`-- `additionalProperties`-- `not` schemas-- `writeOnly` and `readOnly`-- `multipleOf`-- `maximum`-- `exclusiveMaximum`-- `minimum`-- `exclusiveMinimum`-- `minLength`-- `maxItems`-- `minItems`-- `uniqueItems`-- `maxProperties`-- `minProperties`-- `xml`
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
− app/Embed.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Embed where--import Language.Haskell.TH-import Language.Haskell.TH.Syntax--embedFile :: FilePath -> Q Exp-embedFile fp =- [|$(LitE . StringL <$> (qAddDependentFile fp >> runIO (readFile fp)))|]
app/Main.hs view
@@ -1,171 +1,6 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE TemplateHaskell #-}- module Main where -import Control.Monad-import qualified Data.Bifunctor as BF-import qualified Data.Text as T-import Embed-import Language.Haskell.TH import OpenAPI.Generate-import qualified OpenAPI.Generate.Doc as Doc-import qualified OpenAPI.Generate.Flags as OAF-import OpenAPI.Generate.Internal.Util-import qualified OpenAPI.Generate.Monad as OAM-import qualified OpenAPI.Generate.Reference as Ref-import Options-import System.Directory-import System.Exit-import System.FilePath-import System.IO.Error -srcDirectory :: FilePath-srcDirectory = "src"---- | Creates files from mostly static data-stackProjectFiles ::- -- | Name of the cabal project- String ->- -- | Name of the module- String ->- -- | Modules to export- [String] ->- [(FilePath, String)]-stackProjectFiles packageName moduleName modulesToExport =- [ ( packageName ++ ".cabal",- unlines $- [ "cabal-version: 1.12",- "",- "name: " ++ packageName,- "version: 0.1.0.0",- "build-type: Simple",- "",- "library",- " exposed-modules:",- " " ++ moduleName- ]- <> fmap (" " <>) modulesToExport- <> [ " hs-source-dirs:",- " src",- " build-depends:",- " base >=4.7 && <5",- " , text",- " , ghc-prim",- " , http-conduit",- " , http-client",- " , http-types",- " , bytestring",- " , aeson",- " , unordered-containers",- " , vector",- " , scientific",- " , time",- " , mtl",- " , transformers",- " default-language: Haskell2010"- ]- ),- ( "stack.yaml",- unlines- [ "resolver: lts-15.3",- "packages:",- "- ."- ]- )- ]--replaceOpenAPI :: String -> String -> String-replaceOpenAPI moduleName contents =- T.unpack- $ T.replace (T.pack "OpenAPI.Common") (T.pack $ moduleName ++ ".Common")- $ T.replace (T.pack "OpenAPI.Configuration") (T.pack $ moduleName ++ ".Configuration")- $ T.pack contents--permitProceed :: FilePath -> Bool -> IO Bool-permitProceed outputDirectory force = do- outputDirectoryExists <- doesPathExist outputDirectory- if outputDirectoryExists- then- if force- then do- putStrLn "output directory already exists and will be overwritten"- pure True- else do- putStrLn "The output directory "- putStrLn ""- putStrLn $ " " ++ show outputDirectory- putStrLn ""- putStrLn "already exists. overwrite? Y/N"- putStrLn ""- answer <- getLine- pure $ (answer == "Y") || (answer == "y")- else do- putStrLn "output directory will be created"- pure True- main :: IO ()-main = runCommand $ \opts args -> case args of- [path] -> do- spec <- decodeOpenApi path- let env = OAM.createEnvironment opts $ Ref.buildReferenceMap spec- logMessages = mapM_ (putStrLn . T.unpack) . OAM.transformGeneratorLogs- moduleName = OAF.optModuleName opts- (operationsQ, logs) = OAM.runGenerator env $ defineOperations (OAF.optModuleName opts) spec- logMessages logs- operationModules <- runQ operationsQ- configurationInfo <- runQ $ defineConfigurationInformation moduleName spec- let (modelsQ, logsModels) = OAM.runGenerator env $ defineModels moduleName spec- logMessages logsModels- modelModules <- runQ modelsQ- let (securitySchemesQ, logs') = OAM.runGenerator env $ defineSecuritySchemes moduleName spec- logMessages logs'- securitySchemes' <- runQ securitySchemesQ- let outputDirectory = OAF.optOutputDir opts- showAndReplace = replaceOpenAPI moduleName . show- modules =- fmap (BF.bimap ("Operations" :) showAndReplace) operationModules- <> fmap (BF.second showAndReplace) modelModules- <> [ (["Configuration"], showAndReplace configurationInfo),- (["SecuritySchemes"], showAndReplace securitySchemes'),- (["Common"], replaceOpenAPI moduleName $(embedFile "src/OpenAPI/Common.hs"))- ]- modulesToExport =- fmap- ( (moduleName <>) . ("." <>)- . joinWithPoint- . fst- )- modules- mainFile = outputDirectory </> srcDirectory </> (moduleName ++ ".hs")- mainModuleContent = show $ Doc.createModuleHeaderWithReexports moduleName modulesToExport "The main module which exports all functionality."- filesToCreate = (mainFile, mainModuleContent) : (BF.first ((outputDirectory </>) . (srcDirectory </>) . (moduleName </>) . (<> ".hs") . foldr1 (</>)) <$> modules)- if OAF.optDryRun opts- then- mapM_- ( \(file, content) -> do- putStrLn $ "File: " <> file- putStrLn "---"- putStrLn content- putStrLn "---\n\n"- )- filesToCreate- else do- proceed <- permitProceed outputDirectory (OAF.optForce opts)- if proceed- then do- _ <- tryIOError (removeDirectoryRecursive outputDirectory)- createDirectoryIfMissing True (outputDirectory </> srcDirectory)- createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleName)- createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleName </> "Operations")- createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleName </> "Types")- mapM_ (uncurry writeFile) filesToCreate- when (OAF.optGenerateStackProject opts) $- mapM_- ( uncurry writeFile- . BF.first (outputDirectory </>)- )- (stackProjectFiles (OAF.optPackageName opts) moduleName modulesToExport)- putStrLn "finished"- else putStrLn "aborted"- _ -> die "Failed to generate code because no OpenAPI specification was provided. Pass the location of the OpenAPI specification as CLI argument. Run the CLI with --help to see further options."+main = runGenerator
openapi3-code-generator.cabal view
@@ -1,153 +1,173 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 5c9f55e3cb67b6324959a3a09c91ecb0c5172a5430099f91fc163132052c7a57+-- hash: 32506648aaf0bd947f7c5eab0209f3426a5e70f31645b6045ab0a9c326ea3167 name: openapi3-code-generator-version: 0.1.0.6-license: MIT-license-file: LICENSE-copyright: 2020 Remo Dörig & Joel Fisch-maintainer: Joel Fisch <joel.fisch96@gmail.com> & Remo Dörig <remo.doerig@gmail.com>-author: Remo Dörig & Joel Fisch-homepage: https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator#readme-bug-reports: https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator/issues+version: 0.1.0.7 synopsis: OpenAPI3 Haskell Client Code Generator description: Please see the README on GitHub at <https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator#readme> category: Code-Generator+homepage: https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator#readme+bug-reports: https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator/issues+author: Remo Dörig & Joel Fisch+maintainer: Joel Fisch <joel.fisch96@gmail.com> & Remo Dörig <remo.doerig@gmail.com>+copyright: 2020 Remo Dörig & Joel Fisch+license: MIT+license-file: LICENSE build-type: Simple extra-source-files:- README.md- ChangeLog.md LICENSE source-repository head- type: git- location: https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator+ type: git+ location: https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator library- exposed-modules:- OpenAPI.Common- OpenAPI.Generate- OpenAPI.Generate.Doc- OpenAPI.Generate.Flags- OpenAPI.Generate.Internal.Operation- OpenAPI.Generate.Internal.Util- OpenAPI.Generate.Model- OpenAPI.Generate.ModelDependencies- OpenAPI.Generate.Monad- OpenAPI.Generate.Operation- OpenAPI.Generate.Reference- OpenAPI.Generate.Response- OpenAPI.Generate.SecurityScheme- OpenAPI.Generate.Types- OpenAPI.Generate.Types.ExternalDocumentation- OpenAPI.Generate.Types.Referencable- OpenAPI.Generate.Types.Schema- hs-source-dirs:- src- other-modules:- Paths_openapi3_code_generator- default-language: Haskell2010- ghc-options: -Wall- build-depends:- aeson,- base >=4.7 && <5,- bytestring,- containers,- hashmap,- http-client,- http-conduit,- http-types,- mtl,- options,- scientific,- split,- template-haskell,- text,- time,- transformers,- unordered-containers,- vector,- yaml+ exposed-modules:+ OpenAPI.Common+ OpenAPI.Generate+ OpenAPI.Generate.Doc+ OpenAPI.Generate.Internal.Embed+ OpenAPI.Generate.Internal.Operation+ OpenAPI.Generate.Internal.Unknown+ OpenAPI.Generate.Internal.Util+ OpenAPI.Generate.IO+ OpenAPI.Generate.Log+ OpenAPI.Generate.Main+ OpenAPI.Generate.Model+ OpenAPI.Generate.ModelDependencies+ OpenAPI.Generate.Monad+ OpenAPI.Generate.Operation+ OpenAPI.Generate.OptParse+ OpenAPI.Generate.OptParse.Configuration+ OpenAPI.Generate.OptParse.Flags+ OpenAPI.Generate.Reference+ OpenAPI.Generate.Response+ OpenAPI.Generate.SecurityScheme+ OpenAPI.Generate.Types+ OpenAPI.Generate.Types.ExternalDocumentation+ OpenAPI.Generate.Types.Referencable+ OpenAPI.Generate.Types.Schema+ other-modules:+ Paths_openapi3_code_generator+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Widentities -Wcpp-undef+ build-depends:+ aeson+ , autodocodec+ , autodocodec-yaml+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , filepath+ , hashmap+ , http-client+ , http-conduit+ , http-types+ , mtl+ , optparse-applicative+ , path+ , path-io+ , scientific+ , split+ , template-haskell+ , text+ , time+ , transformers+ , unordered-containers+ , vector+ , yaml+ default-language: Haskell2010 executable openapi3-code-generator-exe- main-is: Main.hs- hs-source-dirs:- app- other-modules:- Embed- Paths_openapi3_code_generator- default-language: Haskell2010- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall- build-depends:- aeson,- base >=4.7 && <5,- bytestring,- containers,- directory,- filepath,- hashmap,- http-client,- http-conduit,- http-types,- mtl,- openapi3-code-generator,- options,- scientific,- split,- template-haskell,- text,- time,- transformers,- unordered-containers,- vector,- yaml+ main-is: Main.hs+ other-modules:+ Paths_openapi3_code_generator+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ aeson+ , autodocodec+ , autodocodec-yaml+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , filepath+ , hashmap+ , http-client+ , http-conduit+ , http-types+ , mtl+ , openapi3-code-generator+ , optparse-applicative+ , path+ , path-io+ , scientific+ , split+ , template-haskell+ , text+ , time+ , transformers+ , unordered-containers+ , vector+ , yaml+ default-language: Haskell2010 test-suite openapi3-code-generator-test- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs:- test- other-modules:- OpenAPI.Generate.DocSpec- OpenAPI.Generate.Internal.UtilSpec- OpenAPI.Generate.ModelDependenciesSpec- OpenAPI.Generate.MonadSpec- OpenAPI.Generate.OperationGetOperationDescriptionSpec- OpenAPI.Generate.OperationTHSpec- OpenAPI.Generate.ReferenceSpec- Paths_openapi3_code_generator- default-language: Haskell2010- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall- build-depends:- QuickCheck,- aeson,- base >=4.7 && <5,- bytestring,- containers,- genvalidity,- genvalidity-hspec,- genvalidity-text,- hashmap,- hspec,- http-client,- http-conduit,- http-types,- mtl,- openapi3-code-generator,- options,- scientific,- split,- template-haskell,- text,- time,- transformers,- unordered-containers,- validity,- validity-text,- vector,- yaml+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ OpenAPI.Generate.DocSpec+ OpenAPI.Generate.Internal.UtilSpec+ OpenAPI.Generate.ModelDependenciesSpec+ OpenAPI.Generate.MonadSpec+ OpenAPI.Generate.OperationGetOperationDescriptionSpec+ OpenAPI.Generate.OperationTHSpec+ OpenAPI.Generate.ReferenceSpec+ Paths_openapi3_code_generator+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ QuickCheck+ , aeson+ , autodocodec+ , autodocodec-yaml+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , filepath+ , genvalidity+ , genvalidity-hspec+ , genvalidity-text+ , hashmap+ , hspec+ , http-client+ , http-conduit+ , http-types+ , mtl+ , openapi3-code-generator+ , optparse-applicative+ , path+ , path-io+ , scientific+ , split+ , template-haskell+ , text+ , time+ , transformers+ , unordered-containers+ , validity+ , validity-text+ , vector+ , yaml+ default-language: Haskell2010
src/OpenAPI/Common.hs view
@@ -1,59 +1,86 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -- | This module serves the purpose of defining common functionality which remains the same across all OpenAPI specifications. module OpenAPI.Common- ( Configuration (..),- doCallWithConfiguration,+ ( doCallWithConfiguration, doCallWithConfigurationM, doBodyCallWithConfiguration, doBodyCallWithConfigurationM, runWithConfiguration,- MonadHTTP (..),+ textToByte, stringifyModel,+ anonymousSecurityScheme,+ Configuration (..),+ SecurityScheme,+ MonadHTTP (..), StringifyModel,- SecurityScheme (..),- AnonymousSecurityScheme (..),- textToByte, JsonByteString (..), JsonDateTime (..), RequestBodyEncoding (..),+ QueryParameter (..),+ ClientT (..),+ ClientM, ) where -import qualified Control.Exception as Exception+import qualified Control.Monad.IO.Class as MIO import qualified Control.Monad.Reader as MR import qualified Control.Monad.Trans.Class as MT import qualified Data.Aeson as Aeson import qualified Data.Bifunctor as BF import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as LB8 import qualified Data.HashMap.Strict as HMap import qualified Data.Maybe as Maybe import qualified Data.Scientific as Scientific-import qualified Data.Text as T import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import qualified Data.Time.LocalTime as Time import qualified Data.Vector as Vector-import GHC.Generics import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Simple as HS -- | Abstracts the usage of 'Network.HTTP.Simple.httpBS' away, -- so that it can be used for testing class Monad m => MonadHTTP m where- httpBS :: HS.Request -> m (Either HS.HttpException (HS.Response B8.ByteString))+ httpBS :: HS.Request -> m (HS.Response B8.ByteString) -- | This instance is the default instance used for production code instance MonadHTTP IO where- httpBS request =- BF.first (\e -> e :: HS.HttpException)- <$> Exception.try (HS.httpBS request)+ httpBS = HS.httpBS instance MonadHTTP m => MonadHTTP (MR.ReaderT r m) where httpBS = MT.lift . httpBS +instance MonadHTTP m => MonadHTTP (ClientT m) where+ httpBS = MT.lift . httpBS++-- | The monad in which the operations can be run.+-- Contains the 'Configuration' to run the requests with.+--+-- Run it with 'runWithConfiguration'+newtype ClientT m a = ClientT (MR.ReaderT Configuration m a)+ deriving (Functor, Applicative, Monad, MR.MonadReader Configuration)++instance MT.MonadTrans ClientT where+ lift = ClientT . MT.lift++instance MIO.MonadIO m => MIO.MonadIO (ClientT m) where+ liftIO = ClientT . MIO.liftIO++-- | Utility type which uses 'IO' as underlying monad+type ClientM a = ClientT IO a++-- | Run a 'ClientT' monad transformer in another monad with a specified configuration+runWithConfiguration :: Configuration -> ClientT m a -> m a+runWithConfiguration c (ClientT r) = MR.runReaderT r c+ -- | An operation can and must be configured with data, which may be common -- for many operations. --@@ -67,16 +94,14 @@ -- -- To get started, the 'OpenAPI.Configuration.defaultConfiguration' can be used and changed accordingly. ----- Note that it is possible that @BearerAuthenticationSecurityScheme@ is not available because it is not a security scheme in the OpenAPI specification.+-- Note that it is possible that @bearerAuthenticationSecurityScheme@ is not available because it is not a security scheme in the OpenAPI specification. -- -- > defaultConfiguration--- > { configSecurityScheme = BearerAuthenticationSecurityScheme "token" }-data Configuration s- = Configuration- { configBaseURL :: Text,- configSecurityScheme :: s- }- deriving (Show, Ord, Eq, Generic)+-- > { configSecurityScheme = bearerAuthenticationSecurityScheme "token" }+data Configuration = Configuration+ { configBaseURL :: Text,+ configSecurityScheme :: SecurityScheme+ } -- | Defines how a request body is encoded data RequestBodyEncoding@@ -85,51 +110,48 @@ | -- | Encode the body as form data RequestBodyEncodingFormData --- | Allows to specify an authentication scheme for requests done with 'doCallWithConfiguration'------ This can be used to define custom schemes as well-class SecurityScheme s where- authenticateRequest :: s -> HS.Request -> HS.Request---- | The default authentication scheme which does not add any authentication information-data AnonymousSecurityScheme = AnonymousSecurityScheme+-- | Defines a query parameter with the information necessary for serialization+data QueryParameter = QueryParameter+ { queryParamName :: Text,+ queryParamValue :: Maybe Aeson.Value,+ queryParamStyle :: Text,+ queryParamExplode :: Bool+ }+ deriving (Show, Eq) --- | Instance for the anonymous scheme which does not alter the request in any way-instance SecurityScheme AnonymousSecurityScheme where- authenticateRequest = const id+-- | This type specifies a security scheme which can modify a request according to the scheme (e. g. add an Authorization header)+type SecurityScheme = HS.Request -> HS.Request --- | Run the 'MR.ReaderT' monad with a specified configuration------ Note: This is just @'flip' 'MR.runReaderT'@.-runWithConfiguration :: SecurityScheme s => Configuration s -> MR.ReaderT (Configuration s) m a -> m a-runWithConfiguration = flip MR.runReaderT+-- | Anonymous security scheme which does not alter the request in any way+anonymousSecurityScheme :: SecurityScheme+anonymousSecurityScheme = id -- | This is the main functionality of this module -- -- It makes a concrete Call to a Server without a body doCallWithConfiguration ::- (MonadHTTP m, SecurityScheme s) =>+ MonadHTTP m => -- | Configuration options like base URL and security scheme- Configuration s ->+ Configuration -> -- | HTTP method (GET, POST, etc.) Text -> -- | Path to append to the base URL (path parameters should already be replaced) Text -> -- | Query parameters- [(Text, Maybe String)] ->+ [QueryParameter] -> -- | The raw response from the server- m (Either HS.HttpException (HS.Response B8.ByteString))+ m (HS.Response B8.ByteString) doCallWithConfiguration config method path queryParams = httpBS $ createBaseRequest config method path queryParams -- | Same as 'doCallWithConfiguration' but run in a 'MR.ReaderT' environment which contains the configuration. -- This is useful if multiple calls have to be executed with the same configuration. doCallWithConfigurationM ::- (MonadHTTP m, SecurityScheme s) =>+ MonadHTTP m => Text -> Text ->- [(Text, Maybe String)] ->- MR.ReaderT (Configuration s) m (Either HS.HttpException (HS.Response B8.ByteString))+ [QueryParameter] ->+ ClientT m (HS.Response B8.ByteString) doCallWithConfigurationM method path queryParams = do config <- MR.ask MT.lift $ doCallWithConfiguration config method path queryParams@@ -138,21 +160,21 @@ -- -- It makes a concrete Call to a Server with a body doBodyCallWithConfiguration ::- (MonadHTTP m, SecurityScheme s, Aeson.ToJSON body) =>+ (MonadHTTP m, Aeson.ToJSON body) => -- | Configuration options like base URL and security scheme- Configuration s ->+ Configuration -> -- | HTTP method (GET, POST, etc.) Text -> -- | Path to append to the base URL (path parameters should already be replaced) Text -> -- | Query parameters- [(Text, Maybe String)] ->+ [QueryParameter] -> -- | Request body Maybe body -> -- | JSON or form data deepobjects RequestBodyEncoding -> -- | The raw response from the server- m (Either HS.HttpException (HS.Response B8.ByteString))+ m (HS.Response B8.ByteString) doBodyCallWithConfiguration config method path queryParams Nothing _ = doCallWithConfiguration config method path queryParams doBodyCallWithConfiguration config method path queryParams (Just body) RequestBodyEncodingJSON = httpBS $ HS.setRequestMethod (textToByte method) $ HS.setRequestBodyJSON body baseRequest@@ -167,37 +189,36 @@ -- | Same as 'doBodyCallWithConfiguration' but run in a 'MR.ReaderT' environment which contains the configuration. -- This is useful if multiple calls have to be executed with the same configuration. doBodyCallWithConfigurationM ::- (MonadHTTP m, SecurityScheme s, Aeson.ToJSON body) =>+ (MonadHTTP m, Aeson.ToJSON body) => Text -> Text ->- [(Text, Maybe String)] ->+ [QueryParameter] -> Maybe body -> RequestBodyEncoding ->- MR.ReaderT (Configuration s) m (Either HS.HttpException (HS.Response B8.ByteString))+ ClientT m (HS.Response B8.ByteString) doBodyCallWithConfigurationM method path queryParams body encoding = do config <- MR.ask MT.lift $ doBodyCallWithConfiguration config method path queryParams body encoding -- | Creates a Base Request createBaseRequest ::- SecurityScheme s =>- -- | Common configuration Options- Configuration s ->- -- | HTTP Method (GET,POST,etc.)+ -- | Configuration options like base URL and security scheme+ Configuration ->+ -- | HTTP method (GET, POST, etc.) Text -> -- | The path for which the placeholders have already been replaced Text -> -- | Query Parameters- [(Text, Maybe String)] ->+ [QueryParameter] -> -- | The Response from the server HS.Request createBaseRequest config method path queryParams =- authenticateRequest (configSecurityScheme config)- $ HS.setRequestMethod (textToByte method)- $ HS.setRequestQueryString query- $ HS.setRequestPath- (B8.pack (T.unpack $ byteToText basePathModifier <> path))- baseRequest+ configSecurityScheme config $+ HS.setRequestMethod (textToByte method) $+ HS.setRequestQueryString query $+ HS.setRequestPath+ (B8.pack (T.unpack $ byteToText basePathModifier <> path))+ baseRequest where baseRequest = parseURL $ configBaseURL config basePath = HC.path baseRequest@@ -206,8 +227,37 @@ then "" else basePath -- filters all maybe- query = [(textToByte a, Just $ B8.pack b) | (a, Just b) <- queryParams]+ query = BF.second pure <$> serializeQueryParams queryParams +serializeQueryParams :: [QueryParameter] -> [(B8.ByteString, B8.ByteString)]+serializeQueryParams = (>>= serializeQueryParam)++serializeQueryParam :: QueryParameter -> [(B8.ByteString, B8.ByteString)]+serializeQueryParam QueryParameter {..} =+ let concatValues joinWith = if queryParamExplode then pure . (queryParamName,) . B8.intercalate joinWith . fmap snd else id+ in BF.first textToByte <$> case queryParamValue of+ Nothing -> []+ Just value ->+ ( case queryParamStyle of+ "form" -> concatValues ","+ "spaceDelimited" -> concatValues " "+ "pipeDelimited" -> concatValues "|"+ "deepObject" -> const $ BF.second textToByte <$> jsonToFormDataPrefixed queryParamName value+ _ -> const []+ )+ $ jsonToFormDataFlat queryParamName value++encodeStrict :: Aeson.ToJSON a => a -> B8.ByteString+encodeStrict = LB8.toStrict . Aeson.encode++jsonToFormDataFlat :: Text -> Aeson.Value -> [(Text, B8.ByteString)]+jsonToFormDataFlat _ Aeson.Null = []+jsonToFormDataFlat name (Aeson.Number a) = [(name, encodeStrict a)]+jsonToFormDataFlat name (Aeson.String a) = [(name, textToByte a)]+jsonToFormDataFlat name (Aeson.Bool a) = [(name, encodeStrict a)]+jsonToFormDataFlat _ (Aeson.Object object) = HMap.toList object >>= uncurry jsonToFormDataFlat+jsonToFormDataFlat name (Aeson.Array vector) = Vector.toList vector >>= jsonToFormDataFlat name+ -- | creates form data bytestring array createFormData :: (Aeson.ToJSON a) => a -> [(B8.ByteString, B8.ByteString)] createFormData body =@@ -216,17 +266,17 @@ -- | Convert a 'B8.ByteString' to 'Text' byteToText :: B8.ByteString -> Text-byteToText = T.pack . B8.unpack+byteToText = TE.decodeUtf8 -- | Convert 'Text' a to 'B8.ByteString' textToByte :: Text -> B8.ByteString-textToByte = B8.pack . T.unpack+textToByte = TE.encodeUtf8 parseURL :: Text -> HS.Request parseURL url =- Maybe.fromMaybe HS.defaultRequest- $ HS.parseRequest- $ T.unpack url+ Maybe.fromMaybe HS.defaultRequest $+ HS.parseRequest $+ T.unpack url jsonToFormData :: Aeson.Value -> [(Text, Text)] jsonToFormData = jsonToFormDataPrefixed ""@@ -235,8 +285,8 @@ jsonToFormDataPrefixed prefix (Aeson.Number a) = case Scientific.toBoundedInteger a :: Maybe Int of Just myInt -> [(prefix, T.pack $ show myInt)] Nothing -> [(prefix, T.pack $ show a)]-jsonToFormDataPrefixed prefix (Aeson.Bool True) = [(prefix, T.pack "true")]-jsonToFormDataPrefixed prefix (Aeson.Bool False) = [(prefix, T.pack "false")]+jsonToFormDataPrefixed prefix (Aeson.Bool True) = [(prefix, "true")]+jsonToFormDataPrefixed prefix (Aeson.Bool False) = [(prefix, "false")] jsonToFormDataPrefixed _ Aeson.Null = [] jsonToFormDataPrefixed prefix (Aeson.String a) = [(prefix, a)] jsonToFormDataPrefixed "" (Aeson.Object object) =
src/OpenAPI/Generate.hs view
@@ -1,89 +1,46 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-} -- | Functionality to Generate Haskell Code out of an OpenAPI definition File module OpenAPI.Generate where -import qualified Data.Map as Map-import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Yaml-import Language.Haskell.TH-import Language.Haskell.TH.PprLib hiding ((<>))-import qualified OpenAPI.Common as OC-import qualified OpenAPI.Generate.Doc as Doc-import qualified OpenAPI.Generate.Model as Model-import qualified OpenAPI.Generate.ModelDependencies as Dep-import qualified OpenAPI.Generate.Monad as OAM-import qualified OpenAPI.Generate.Operation as Operation-import qualified OpenAPI.Generate.SecurityScheme as SecurityScheme+import qualified OpenAPI.Generate.IO as OAI+import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Types as OAT import System.Exit -- | Decodes an OpenAPI File-decodeOpenApi :: String -> IO OAT.OpenApiSpecification+decodeOpenApi :: Text -> IO OAT.OpenApiSpecification decodeOpenApi fileName = do- res <- decodeFileEither fileName+ res <- decodeFileEither $ T.unpack fileName case res of- Left exc -> die $ "Could not parse OpenAPI specification '" <> fileName <> "': " <> show exc+ Left exc -> die $ "Could not parse OpenAPI specification '" <> T.unpack fileName <> "': " <> show exc Right o -> pure o --- | Defines all the operations as functions and the common imports-defineOperations :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q [Dep.ModuleDefinition])-defineOperations moduleName =- OAM.nested "paths"- . fmap- ( fmap- concat- . sequence- )- . mapM (uncurry $ Operation.defineOperationsForPath moduleName)- . Map.toList- . OAT.paths---- | Defines the @defaultURL@ and the @defaultConfiguration@ containing this URL.-defineConfigurationInformation :: String -> OAT.OpenApiSpecification -> Q Doc-defineConfigurationInformation moduleName spec =- let servers' = (OAT.servers :: OAT.OpenApiSpecification -> [OAT.ServerObject]) spec- defaultURL = getServerURL servers'- defaultURLName = mkName "defaultURL"- getServerURL = maybe "/" (OAT.url :: OAT.ServerObject -> Text) . Maybe.listToMaybe- in Doc.addConfigurationModuleHeader moduleName- . vcat- <$> sequence- [ pure $- Doc.generateHaddockComment- [ "The default url specified by the OpenAPI specification",- "",- "@" <> defaultURL <> "@"- ],- ppr- <$> [d|$(varP defaultURLName) = T.pack $(litE $ stringL $ T.unpack defaultURL)|],- pure $ Doc.generateHaddockComment ["The default configuration containing the 'defaultURL' and no authorization"],- ppr <$> [d|$(varP $ mkName "defaultConfiguration") = OC.Configuration $(varE defaultURLName) OC.AnonymousSecurityScheme|]- ]---- | Defines all models in the components.schemas section of the 'OAT.OpenApiSpecification'-defineModels :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q [Dep.ModuleDefinition])-defineModels moduleName spec =- let schemaDefinitions = Map.toList $ OAT.schemas $ OAT.components spec- in OAM.nested "schemas" $ do- models <- mapM (uncurry Model.defineModelForSchema) schemaDefinitions- pure $ Dep.getModelModulesFromModelsWithDependencies moduleName models---- | Defines all supported security schemes from the 'OAT.OpenApiSpecification'.-defineSecuritySchemes :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q Doc)-defineSecuritySchemes moduleName =- OAM.nested "components"- . fmap (fmap $ Doc.addSecuritySchemesModuleHeader moduleName)- . SecurityScheme.defineSupportedSecuritySchemes (T.pack moduleName)- . Maybe.mapMaybe- ( \(name', scheme') -> case scheme' of- OAT.Concrete s -> Just (name', s)- OAT.Reference _ -> Nothing- )- . Map.toList- . OAT.securitySchemes- . OAT.components+-- | Run the generator as CLI+runGenerator :: IO ()+runGenerator = do+ settings <- OAO.getSettings+ spec <- decodeOpenApi $ OAO.settingOpenApiSpecification settings+ outFiles@OAI.OutputFiles {..} <- OAI.generateFilesToCreate spec settings+ if OAO.settingDryRun settings+ then+ mapM_+ ( \(file, content) -> do+ putStrLn $ "File: " <> file+ putStrLn "---"+ putStrLn content+ putStrLn "---\n\n"+ )+ moduleFiles+ else do+ proceed <- OAI.permitProceed settings+ if proceed+ then do+ OAI.writeFiles settings outFiles+ putStrLn "finished"+ else putStrLn "aborted"
src/OpenAPI/Generate/Doc.hs view
@@ -3,12 +3,14 @@ -- | Utility functions for 'Language.Haskell.TH.PprLib.Doc' manipulation module OpenAPI.Generate.Doc- ( emptyDoc,+ ( typeAliasModule,+ emptyDoc, appendDoc, generateHaddockComment, escapeText, breakOnTokens,- breakOnTokensWithReplacement,+ reformatRecord,+ reformatADT, sideComments, zipCodeAndComments, sideBySide,@@ -24,8 +26,11 @@ import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH.PprLib hiding ((<>))-import OpenAPI.Generate.Internal.Util +-- | The name of the module which contains all type aliases which would be in their own module otherwise+typeAliasModule :: String+typeAliasModule = "TypeAlias"+ -- | Empty document inside an 'Applicative' (typically 'Language.Haskell.TH.Q') emptyDoc :: Applicative f => f Doc emptyDoc = pure empty@@ -108,8 +113,34 @@ breakOnTokensWithReplacement :: (Text -> Text) -> [Text] -> Doc -> Doc breakOnTokensWithReplacement replaceFn tokens = let addLineBreaks = foldr (\token f -> T.replace token (replaceFn token) . f) id tokens- in text . T.unpack . addLineBreaks . T.replace "\n" "" . removeDuplicateSpaces . T.pack . show+ in text . T.unpack+ . T.unlines+ . fmap T.stripEnd+ . T.lines+ . addLineBreaks+ . T.replace "\n" ""+ . removeDuplicateSpaces+ . T.pack+ . show +reformatRecord :: Doc -> Doc+reformatRecord =+ breakOnTokensWithReplacement+ ( \case+ "{" -> "{\n "+ token -> "\n " <> token+ )+ [",", "{", "}"]++reformatADT :: Doc -> Doc+reformatADT =+ breakOnTokensWithReplacement+ ( \case+ "=" -> "=\n "+ token -> "\n " <> token+ )+ ["=", "deriving", "|"]+ removeDuplicateSpaces :: Text -> Text removeDuplicateSpaces t = let t' = T.replace " " " " t@@ -131,27 +162,20 @@ -- | Place two documents side-by-side, aligned at the top line -- -- If one of the documents is longer than the other, the shorter one is extended with empty lines.--- The lines of the right document are aligned in the same column, no matter if the left document is shorter or longer -- -- Example usage: -- -- >>> show $ sideBySide (text "a") (text "b" $$ text "c") -- a b--- c+-- c sideBySide :: Doc -> Doc -> Doc sideBySide leftDoc rightDoc =- let splitDoc = splitOn '\n' . show- leftDocLines = splitDoc leftDoc- leftDoc' = map text leftDocLines- maxLength = foldr max 0 (fmap length leftDocLines) + 1- rightDoc' = map (nest maxLength . text) . splitDoc $ rightDoc- isLeftLonger = length leftDoc' > length rightDoc'- isRightLonger = length leftDoc' < length rightDoc'+ let splitDoc = fmap (\l -> if null l then empty else text l) . lines . show+ (leftDoc', rightDoc') = case (splitDoc leftDoc, splitDoc rightDoc) of+ (l, r) | length l < length r -> (l <> repeat empty, r)+ (l, r) -> (l, r <> repeat empty) in foldl ($$) empty $- zipWith- ($$)- (if isRightLonger then leftDoc' <> repeat empty else leftDoc')- (if isLeftLonger then rightDoc' <> repeat empty else rightDoc')+ zipWith (\l r -> if null (show l) && null (show r) then text "" else l <+> r) leftDoc' rightDoc' -- | Add the module header to a module of an operation addOperationsModuleHeader :: String -> String -> String -> Doc -> Doc@@ -160,15 +184,16 @@ . languageExtension "OverloadedStrings" . languageExtension "ExplicitForAll" . languageExtension "MultiWayIf"- . languageExtension "DeriveGeneric" . emptyLine . moduleDescription ("Contains the different functions to run the operation " <> operationId) . moduleDeclaration (mainModuleName <> ".Operations") moduleName . emptyLine . importQualified "Prelude as GHC.Integer.Type" . importQualified "Prelude as GHC.Maybe"+ . importQualified "Control.Monad.Fail" . importQualified "Control.Monad.Trans.Reader" . importQualified "Data.Aeson"+ . importQualified "Data.Aeson as Data.Aeson.Encoding.Internal" . importQualified "Data.Aeson as Data.Aeson.Types" . importQualified "Data.Aeson as Data.Aeson.Types.FromJSON" . importQualified "Data.Aeson as Data.Aeson.Types.ToJSON"@@ -185,7 +210,6 @@ . importQualified "Data.Vector" . importQualified "GHC.Base" . importQualified "GHC.Classes"- . importQualified "GHC.Generics" . importQualified "GHC.Int" . importQualified "GHC.Show" . importQualified "GHC.Types"@@ -205,14 +229,16 @@ addModelModuleHeader mainModuleName moduleName modelModulesToImport description = generatorNote . languageExtension "OverloadedStrings"- . languageExtension "DeriveGeneric"+ . languageExtension "MultiWayIf" . emptyLine . moduleDescription description . moduleDeclaration mainModuleName moduleName . emptyLine . importQualified "Prelude as GHC.Integer.Type" . importQualified "Prelude as GHC.Maybe"+ . importQualified "Control.Monad.Fail" . importQualified "Data.Aeson"+ . importQualified "Data.Aeson as Data.Aeson.Encoding.Internal" . importQualified "Data.Aeson as Data.Aeson.Types" . importQualified "Data.Aeson as Data.Aeson.Types.FromJSON" . importQualified "Data.Aeson as Data.Aeson.Types.ToJSON"@@ -227,12 +253,12 @@ . importQualified "Data.Time.LocalTime as Data.Time.LocalTime.Internal.ZonedTime" . importQualified "GHC.Base" . importQualified "GHC.Classes"- . importQualified "GHC.Generics" . importQualified "GHC.Int" . importQualified "GHC.Show" . importQualified "GHC.Types" . importQualified (mainModuleName <> ".Common")- . (vcat (fmap (text . ("import " <>) . ((mainModuleName <> ".") <>)) modelModulesToImport) $$)+ . (if moduleName == typeAliasModule then id else importUnqualified (mainModuleName <> "." <> typeAliasModule))+ . (vcat (fmap (text . ("import {-# SOURCE #-} " <>) . ((mainModuleName <> ".") <>)) modelModulesToImport) $$) . emptyLine -- | Add the module header to the security scheme module@@ -271,12 +297,13 @@ createModuleHeaderWithReexports moduleName modulesToExport description = let exports = vcat $ fmap (text . ("module " <>) . (<> ",")) modulesToExport imports = vcat $ fmap (text . ("import " <>)) modulesToExport- in generatorNote $ moduleDescription description $- text ("module " <> moduleName <> " (")- $$ nest- 2- ( exports- $$ text ") where"- )- $$ text ""- $$ imports+ in generatorNote $+ moduleDescription description $+ text ("module " <> moduleName <> " (")+ $$ nest+ 2+ ( exports+ $$ text ") where"+ )+ $$ text ""+ $$ imports
− src/OpenAPI/Generate/Flags.hs
@@ -1,118 +0,0 @@--- | This module defines the available command line flags and their default values.-module OpenAPI.Generate.Flags where--import Options---- | The options passed to the generator via CLI-data Flags- = Flags- { -- | The directory where the generated output is stored.- optOutputDir :: String,- -- | Generate a stack project alongside the raw Haskell files- optGenerateStackProject :: Bool,- -- | Do not generate the output files but only print the generated code- optDryRun :: Bool,- -- | Overwrite output directory without question- optForce :: Bool,- -- | Name of the stack project- optPackageName :: String,- -- | Name of the module- optModuleName :: String,- -- | Use Data.Scientific instead of Double to support arbitary number precision- optUseFloatWithArbitraryPrecision :: Bool,- -- | Convert strings formatted as date / date-time to date types- optUseDateTypesAsString :: Bool,- -- | Convert names to CamelCase instead of using names which are as close as possible to the names provided in the specification- optConvertToCamelCase :: Bool,- -- | Add a suffix to property types to prevent naming conflicts- optPropertyTypeSuffix :: String,- -- | The suffix which is added to the response data types- optResponseTypeSuffix :: String,- -- | The suffix which is added to the response body data types- optResponseBodyTypeSuffix :: String,- -- | The suffix which is added to the request body data types- optRequestBodyTypeSuffix :: String,- -- | Use numbered data constructors (e. g. Variant1, Variant 2, etc.) for one-of types- optUseNumberedVariantConstructors :: Bool- }- deriving (Show, Eq)--instance Options Flags where- defineOptions =- Flags- <$> simpleOption- "output-dir"- (optOutputDir defaultFlags)- "The directory where the generated output is stored."- <*> simpleOption- "generate-stack-project"- (optGenerateStackProject defaultFlags)- "Generate a stack project alongside the raw Haskell files"- <*> simpleOption- "dry-run"- (optDryRun defaultFlags)- "Do not generate the output files but only print the generated code"- <*> simpleOption- "force"- (optForce defaultFlags)- "Overwrite output directory without question"- <*> simpleOption- "package-name"- (optPackageName defaultFlags)- "Name of the stack project"- <*> simpleOption- "module-name"- (optModuleName defaultFlags)- "Name of the module"- <*> simpleOption- "use-float-with-arbitrary-precision"- (optUseFloatWithArbitraryPrecision defaultFlags)- "Use Data.Scientific instead of Double to support arbitary number precision"- <*> simpleOption- "use-date-types-as-string"- (optUseDateTypesAsString defaultFlags)- "Convert strings formatted as date / date-time to date types"- <*> simpleOption- "convert-to-camel-case"- (optConvertToCamelCase defaultFlags)- "Convert names to CamelCase instead of using names which are as close as possible to the names provided in the specification"- <*> simpleOption- "property-type-suffix"- (optPropertyTypeSuffix defaultFlags)- "Add a suffix to property types to prevent naming conflicts"- <*> simpleOption- "response-type-suffix"- (optResponseTypeSuffix defaultFlags)- "The suffix which is added to the response data types"- <*> simpleOption- "response-body-type-suffix"- (optResponseBodyTypeSuffix defaultFlags)- "The suffix which is added to the response body data types"- <*> simpleOption- "request-body-type-suffix"- (optRequestBodyTypeSuffix defaultFlags)- "The suffix which is added to the request body data types"- <*> simpleOption- "use-numbered-variant-constructors"- (optUseNumberedVariantConstructors defaultFlags)- "Use numbered data constructors (e. g. Variant1, Variant 2, etc.) for one-of types"---- | Default flags which can be used for tests and as a reference which values actually are used-defaultFlags :: Flags-defaultFlags =- Flags- { optOutputDir = "out",- optGenerateStackProject = True,- optDryRun = False,- optForce = False,- optPackageName = "openapi",- optModuleName = "OpenAPI",- optUseFloatWithArbitraryPrecision = False,- optUseDateTypesAsString = False,- optConvertToCamelCase = False,- optPropertyTypeSuffix = "",- optResponseTypeSuffix = "Response",- optResponseBodyTypeSuffix = "ResponseBody",- optRequestBodyTypeSuffix = "RequestBody",- optUseNumberedVariantConstructors = False- }
+ src/OpenAPI/Generate/IO.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module OpenAPI.Generate.IO where++import Control.Exception+import Control.Monad+import qualified Data.Bifunctor as BF+import qualified Data.Text as T+import Language.Haskell.TH+import qualified OpenAPI.Generate.Doc as Doc+import OpenAPI.Generate.Internal.Embed+import OpenAPI.Generate.Internal.Util+import qualified OpenAPI.Generate.Log as OAL+import OpenAPI.Generate.Main+import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.OptParse as OAO+import qualified OpenAPI.Generate.Reference as Ref+import qualified OpenAPI.Generate.Types as OAT+import System.Directory+import System.FilePath+import System.IO.Error++type FileWithContent = (FilePath, String)++type FilesWithContent = [FileWithContent]++srcDirectory :: FilePath+srcDirectory = "src"++-- | Creates files from mostly static data+cabalProjectFiles ::+ -- | Name of the cabal project+ String ->+ -- | Name of the module+ String ->+ -- | Modules to export+ [String] ->+ FilesWithContent+cabalProjectFiles packageName moduleName modulesToExport =+ [ ( packageName ++ ".cabal",+ unlines $+ [ "cabal-version: 1.12",+ "",+ "name: " ++ packageName,+ "version: 0.1.0.0",+ "build-type: Simple",+ "",+ "library",+ " exposed-modules:",+ " " ++ moduleName+ ]+ <> fmap (" " <>) modulesToExport+ <> [ " hs-source-dirs:",+ " src",+ " build-depends:",+ " base >=4.7 && <5",+ " , text",+ " , ghc-prim",+ " , http-conduit",+ " , http-client",+ " , http-types",+ " , bytestring",+ " , aeson",+ " , unordered-containers",+ " , vector",+ " , scientific",+ " , time",+ " , mtl",+ " , transformers",+ " default-language: Haskell2010"+ ]+ )+ ]++-- | Creates stack support files+stackProjectFiles ::+ FilesWithContent+stackProjectFiles =+ [ ( "stack.yaml",+ unlines+ [ "resolver: lts-18.16",+ "packages:",+ "- ."+ ]+ )+ ]++-- | Creates nix support files+nixProjectFiles ::+ -- | Name of the cabal project+ String ->+ FilesWithContent+nixProjectFiles packageName =+ [ ( "default.nix",+ unlines+ [ "{ pkgs ? import <nixpkgs> {} }:",+ "let",+ " src = pkgs.nix-gitignore.gitignoreSource [ ] ./.;",+ "in",+ " pkgs.haskellPackages.callCabal2nix \"" ++ packageName ++ "\" ./. { }"+ ]+ ),+ ( "shell.nix",+ unlines+ [ "{ pkgs ? import <nixpkgs> {} }:",+ "(import ./default.nix { inherit pkgs; }).env"+ ]+ )+ ]++replaceOpenAPI :: String -> String -> String+replaceOpenAPI moduleName contents =+ T.unpack $+ T.replace (T.pack "OpenAPI.Common") (T.pack $ moduleName ++ ".Common") $+ T.replace (T.pack "OpenAPI.Configuration") (T.pack $ moduleName ++ ".Configuration") $+ T.pack contents++permitProceed :: OAO.Settings -> IO Bool+permitProceed settings = do+ let outputDirectory = T.unpack $ OAO.settingOutputDir settings+ outputDirectoryExists <- doesPathExist outputDirectory+ if outputDirectoryExists+ then+ if OAO.settingForce settings || OAO.settingIncremental settings+ then do+ putStrLn "Output directory already exists and will be overwritten"+ pure True+ else do+ putStrLn "The output directory "+ putStrLn ""+ putStrLn $ " " ++ show outputDirectory+ putStrLn ""+ putStrLn "already exists. overwrite? Y/N"+ putStrLn ""+ answer <- getLine+ pure $ (answer == "Y") || (answer == "y")+ else do+ putStrLn "Output directory will be created"+ pure True++getHsBootFiles :: OAO.Settings -> [([String], String)] -> FilesWithContent+getHsBootFiles settings modelModules =+ let outputDirectory = T.unpack $ OAO.settingOutputDir settings+ moduleName = T.unpack $ OAO.settingModuleName settings+ in BF.bimap+ ((outputDirectory </>) . (srcDirectory </>) . (moduleName </>) . (<> ".hs-boot") . foldr1 (</>))+ ( T.unpack+ . T.unlines+ . ( \xs -> case xs of+ x : xs' -> x : "import Data.Aeson" : "import qualified Data.Aeson as Data.Aeson.Types.Internal" : xs'+ _ -> xs+ )+ . ( ( \l ->+ maybe+ [l]+ ( \suffix ->+ [ l,+ "instance Show" <> suffix,+ "instance Eq" <> suffix,+ "instance FromJSON" <> suffix,+ "instance ToJSON" <> suffix+ ]+ )+ $ T.stripPrefix "data" l+ )+ <=< ( fmap (\l -> if T.isPrefixOf "type" l then l else T.strip (T.takeWhile (/= '=') l))+ . filter (\line -> T.isPrefixOf "data" line || T.isPrefixOf "module" line || T.isPrefixOf "type" line)+ . T.lines+ . T.pack+ )+ )+ )+ <$> filter+ ( \(p, _) -> case p of+ "Types" : _ : _ -> True+ _ -> False+ )+ modelModules++data OutputFiles = OutputFiles+ { moduleFiles :: FilesWithContent,+ cabalFiles :: FilesWithContent,+ stackFiles :: FilesWithContent,+ nixFiles :: FilesWithContent+ }++generateFilesToCreate :: OAT.OpenApiSpecification -> OAO.Settings -> IO OutputFiles+generateFilesToCreate spec settings = do+ let outputDirectory = T.unpack $ OAO.settingOutputDir settings+ moduleName = T.unpack $ OAO.settingModuleName settings+ packageName = T.unpack $ OAO.settingPackageName settings+ env = OAM.createEnvironment settings $ Ref.buildReferenceMap spec+ logMessages = mapM_ (putStrLn . T.unpack) . OAL.filterAndTransformLogs (OAO.settingLogLevel settings)+ showAndReplace = replaceOpenAPI moduleName . show+ ((operationsQ, operationDependencies), logs) = OAM.runGenerator env $ defineOperations moduleName spec+ logMessages logs+ operationModules <- runQ operationsQ+ configurationInfo <- runQ $ defineConfigurationInformation moduleName spec+ let (modelsQ, logsModels) = OAM.runGenerator env $ defineModels moduleName spec operationDependencies+ logMessages logsModels+ modelModules <- fmap (BF.second showAndReplace) <$> runQ modelsQ+ let (securitySchemesQ, logs') = OAM.runGenerator env $ defineSecuritySchemes moduleName spec+ logMessages logs'+ securitySchemes' <- runQ securitySchemesQ+ let modules =+ fmap (BF.bimap ("Operations" :) showAndReplace) operationModules+ <> modelModules+ <> [ (["Configuration"], showAndReplace configurationInfo),+ (["SecuritySchemes"], showAndReplace securitySchemes'),+ (["Common"], replaceOpenAPI moduleName $(embedFile "src/OpenAPI/Common.hs"))+ ]+ modulesToExport =+ fmap+ ( (moduleName <>) . ("." <>)+ . joinWithPoint+ . fst+ )+ modules+ mainFile = outputDirectory </> srcDirectory </> (moduleName ++ ".hs")+ mainModuleContent = show $ Doc.createModuleHeaderWithReexports moduleName modulesToExport "The main module which exports all functionality."+ hsBootFiles = getHsBootFiles settings modelModules+ pure $+ OutputFiles+ ( BF.second (unlines . lines)+ <$> (mainFile, mainModuleContent) :+ (BF.first ((outputDirectory </>) . (srcDirectory </>) . (moduleName </>) . (<> ".hs") . foldr1 (</>)) <$> modules)+ <> hsBootFiles+ )+ (BF.first (outputDirectory </>) <$> cabalProjectFiles packageName moduleName modulesToExport)+ (BF.first (outputDirectory </>) <$> stackProjectFiles)+ (BF.first (outputDirectory </>) <$> nixProjectFiles packageName)++writeFiles :: OAO.Settings -> OutputFiles -> IO ()+writeFiles settings OutputFiles {..} = do+ let outputDirectory = T.unpack $ OAO.settingOutputDir settings+ moduleName = T.unpack $ OAO.settingModuleName settings+ incremental = OAO.settingIncremental settings+ write = mapM_ $ if incremental then writeFileIncremental else writeFileWithLog+ putStrLn "Remove old output directory"+ unless incremental $+ tryIOError (removeDirectoryRecursive outputDirectory) >> pure ()+ putStrLn "Output directory removed, create missing directories"+ createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleName </> "Operations")+ createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleName </> "Types")+ putStrLn "Directories created"+ write moduleFiles+ write cabalFiles+ unless (OAO.settingDoNotGenerateStackProject settings) $+ write stackFiles+ when (OAO.settingGenerateNixFiles settings) $+ write nixFiles++writeFileWithLog :: FileWithContent -> IO ()+writeFileWithLog (filePath, content) = do+ putStrLn $ "Write file to path: " <> filePath+ writeFile filePath content++writeFileIncremental :: FileWithContent -> IO ()+writeFileIncremental (filePath, content) = do+ oldContent <-+ (Just <$> readFile filePath)+ `catch` ( \(_ :: IOException) -> do+ writeFile filePath content+ pure Nothing+ )+ when (maybe 0 length oldContent > 0 && oldContent /= Just content) $+ writeFile filePath content
+ src/OpenAPI/Generate/Internal/Embed.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}++module OpenAPI.Generate.Internal.Embed where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++embedFile :: FilePath -> Q Exp+embedFile fp =+ [|$(LitE . StringL <$> (qAddDependentFile fp >> runIO (readFile fp)))|]
src/OpenAPI/Generate/Internal/Operation.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} -- | Helpers for the generation of the operation functions module OpenAPI.Generate.Internal.Operation@@ -10,26 +11,30 @@ getResponseSchema, defineOperationFunction, getParameterDescription,- getParameterType,+ generateParameterTypeFromOperation, getParametersTypeForSignature, getParametersTypeForSignatureWithMonadTransformer, getOperationName, getOperationDescription,- getParametersFromOperationConcrete, getBodySchemaFromOperation, generateParameterizedRequestPath, generateQueryParams,+ shouldGenerateRequestBody, RequestBodyDefinition (..),+ ParameterTypeDefinition (..),+ ParameterCardinality (..), ) where import Control.Monad-import qualified Control.Monad.Reader as MR+import qualified Data.Aeson as Aeson+import qualified Data.Bifunctor as BF import qualified Data.ByteString.Char8 as B8 import qualified Data.Char as Char import qualified Data.List.Split as Split import qualified Data.Map as Map import qualified Data.Maybe as Maybe+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH@@ -40,18 +45,38 @@ import qualified OpenAPI.Generate.Doc as Doc import OpenAPI.Generate.Internal.Util import qualified OpenAPI.Generate.Model as Model+import qualified OpenAPI.Generate.ModelDependencies as Dep import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Types as OAT import qualified OpenAPI.Generate.Types.Schema as OAS -- | Extracted request body information which can be used for code generation-data RequestBodyDefinition- = RequestBodyDefinition- { schema :: OAT.Schema,- encoding :: OC.RequestBodyEncoding,- required :: Bool- }+data RequestBodyDefinition = RequestBodyDefinition+ { schema :: OAT.Schema,+ encoding :: OC.RequestBodyEncoding,+ required :: Bool+ } +-- | Defines the type of a parameter bundle including the information to access the specific parameters+data ParameterTypeDefinition = ParameterTypeDefinition+ { parameterTypeDefinitionType :: Q Type,+ parameterTypeDefinitionDoc :: Q Doc,+ parameterTypeDefinitionDependencies :: Dep.Models,+ parameterTypeDefinitionQueryParams :: [(Name, OAT.ParameterObject)],+ parameterTypeDefinitionPathParams :: [(Name, OAT.ParameterObject)]+ }++-- | Represents the number of (supported) parameters and the generated types which result of it+--+-- * No type is generated when no parameters are present+-- * Only the type of the parameter is generated if a single parameter is present+-- * A combined parameter type is generated for multiple parameters+data ParameterCardinality+ = NoParameters+ | SingleParameter (Q Type) Dep.ModelContentWithDependencies OAT.ParameterObject+ | MultipleParameters ParameterTypeDefinition+ -- | wrapper for ambigious usage getParametersFromOperationReference :: OAT.OperationObject -> [OAT.Referencable OAT.ParameterObject] getParametersFromOperationReference = OAT.parameters@@ -64,42 +89,107 @@ getInFromParameterObject :: OAT.ParameterObject -> OAT.ParameterObjectLocation getInFromParameterObject = OAT.in' +-- | Generates the parameter type for an operation. See 'ParameterCardinality' for further information.+generateParameterTypeFromOperation :: Text -> OAT.OperationObject -> OAM.Generator ParameterCardinality+generateParameterTypeFromOperation operationName = getParametersFromOperationConcrete >=> generateParameterType operationName++generateParameterType :: Text -> [(OAT.ParameterObject, [Text])] -> OAM.Generator ParameterCardinality+generateParameterType operationName parameters = OAM.nested "parameters" $ do+ maybeSchemas <- mapM (\(p, path) -> OAM.resetPath path $ getSchemaFromParameter p) parameters+ parametersSuffix <- OAM.getSetting OAO.settingParametersTypeSuffix+ let parametersWithSchemas =+ [ ((parameter, path), mergeDescriptionOfParameterWithSchema parameter schema)+ | ((parameter, path), Just schema) <-+ zip parameters maybeSchemas,+ getInFromParameterObject parameter `elem` [OAT.QueryParameterObjectLocation, OAT.PathParameterObjectLocation]+ ]+ schemaName = operationName <> parametersSuffix+ when (length parameters > length parametersWithSchemas) $ OAM.logWarning "Parameters are only supported in query and path (skipping parameters in cookie and header)."+ case parametersWithSchemas of+ [] -> pure NoParameters+ [((parameter, path), schema)] -> do+ (paramType, model) <- OAM.resetPath (path <> ["schema"]) $ Model.defineModelForSchemaNamed (schemaName <> uppercaseFirstText (getNameFromParameter parameter)) schema+ pure $+ SingleParameter+ ( if getRequiredFromParameter parameter+ then paramType+ else [t|Maybe $(paramType)|]+ )+ model+ parameter+ _ -> do+ properties <-+ mapM+ ( \((parameter, _), schema) -> do+ prefix <- getParameterLocationPrefix parameter+ pure (prefix <> uppercaseFirstText (getNameFromParameter parameter), schema)+ )+ parametersWithSchemas+ let parametersWithNames = zip (fst <$> properties) (fst <$> parametersWithSchemas)+ requiredProperties =+ Set.fromList $+ fst <$> filter ((OAT.required :: OAT.ParameterObject -> Bool) . fst . snd) parametersWithNames+ (parameterTypeDefinitionType, (parameterTypeDefinitionDoc, parameterTypeDefinitionDependencies)) <-+ Model.defineModelForSchemaNamed schemaName $+ OAT.Concrete $+ OAS.defaultSchema {OAS.properties = Map.fromList properties, OAS.required = requiredProperties}+ convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase+ let parametersWithPropertyNames = BF.bimap (haskellifyName convertToCamelCase False . (schemaName <>) . uppercaseFirstText) fst <$> parametersWithNames+ filterByType t = filter ((== t) . getInFromParameterObject . snd) parametersWithPropertyNames+ parameterTypeDefinitionQueryParams = filterByType OAT.QueryParameterObjectLocation+ parameterTypeDefinitionPathParams = filterByType OAT.PathParameterObjectLocation+ pure $ MultipleParameters ParameterTypeDefinition {..}++mergeDescriptionOfParameterWithSchema :: OAT.ParameterObject -> OAS.Schema -> OAS.Schema+mergeDescriptionOfParameterWithSchema parameter (OAT.Concrete schema) =+ let parameterName = OAT.name (parameter :: OAT.ParameterObject)+ descriptionParameter = Maybe.maybeToList $ OAT.description (parameter :: OAT.ParameterObject)+ descriptionSchema = Maybe.maybeToList $ OAS.description schema+ mergedDescription = T.intercalate "\n\n" (("Represents the parameter named '" <> parameterName <> "'") : descriptionParameter <> descriptionSchema)+ in OAT.Concrete $ schema {OAS.description = Just mergedDescription}+mergeDescriptionOfParameterWithSchema _ schema = schema++getParameterLocationPrefix :: OAT.ParameterObject -> OAM.Generator Text+getParameterLocationPrefix =+ ( \case+ OAT.QueryParameterObjectLocation -> OAM.getSetting OAO.settingParameterQueryPrefix+ OAT.PathParameterObjectLocation -> OAM.getSetting OAO.settingParameterPathPrefix+ OAT.CookieParameterObjectLocation -> OAM.getSetting OAO.settingParameterCookiePrefix+ OAT.HeaderParameterObjectLocation -> OAM.getSetting OAO.settingParameterHeaderPrefix+ )+ . getInFromParameterObject+ -- | Extracts all parameters of an operation -- -- Concrete objects are always added. References try to get resolved to a concrete object. -- If this fails, the parameter is skipped and a warning gets produced.-getParametersFromOperationConcrete :: OAT.OperationObject -> OAM.Generator [OAT.ParameterObject]+getParametersFromOperationConcrete :: OAT.OperationObject -> OAM.Generator [(OAT.ParameterObject, [Text])] getParametersFromOperationConcrete = OAM.nested "parameters" . fmap Maybe.catMaybes . mapM ( \case- OAT.Concrete p -> pure $ Just p- OAT.Reference ref -> do+ (i, OAT.Concrete p) -> do+ path <- OAM.appendToPath ["[" <> T.pack (show i) <> "]"]+ pure $ Just (p, path)+ (i, OAT.Reference ref) -> OAM.nested ("[" <> T.pack (show i) <> "]") $ do p <- OAM.getParameterReferenceM ref- if Maybe.isJust p- then pure p- else do- OAM.logWarning $ "Reference " <> ref <> " to ParameterObject could not be found and therefore will be skipped."- pure p+ when (Maybe.isNothing p) $ OAM.logWarning $ "Reference " <> ref <> " to parameter could not be found and therefore will be skipped."+ let name = T.replace "#/components/parameters/" "" ref+ pure $ (,["components", "parameters", name]) <$> p )+ . zip ([0 ..] :: [Int]) . getParametersFromOperationReference -getSchemaFromParameterObjectSchema :: OAT.ParameterObjectSchema -> OAM.Generator (Maybe OAS.SchemaObject)-getSchemaFromParameterObjectSchema OAT.SimpleParameterObjectSchema {..} = case schema of- OAT.Concrete e -> pure $ Just e- OAT.Reference ref -> do- p <- OAM.getSchemaReferenceM ref- when (Maybe.isNothing p) $ OAM.logWarning $- "Reference " <> ref <> " to SchemaObject could not be found and therefore will be skipped."- pure p-getSchemaFromParameterObjectSchema (OAT.ComplexParameterObjectSchema _) = do+getSchemaFromParameterObjectSchema :: OAT.ParameterObjectSchema -> OAM.Generator (Maybe OAS.Schema)+getSchemaFromParameterObjectSchema (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) = pure $ Just schema+getSchemaFromParameterObjectSchema (OAT.ComplexParameterObjectSchema _) = OAM.nested "content" $ do OAM.logWarning "Complex parameter schemas are not supported and therefore will be skipped." pure Nothing -- | Reads the schema from the parameter-getSchemaFromParameter :: OAT.ParameterObject -> OAM.Generator (Maybe OAS.SchemaObject)-getSchemaFromParameter OAT.ParameterObject {..} = OAM.nested name $ getSchemaFromParameterObjectSchema schema+getSchemaFromParameter :: OAT.ParameterObject -> OAM.Generator (Maybe OAS.Schema)+getSchemaFromParameter OAT.ParameterObject {..} = getSchemaFromParameterObjectSchema schema getNameFromParameter :: OAT.ParameterObject -> Text getNameFromParameter = OAT.name@@ -112,20 +202,20 @@ -- [t|OC.Configuration -> Int -> $(varT monadName) ($(responseType) $(responseInnerType))|] -- = getParametersTypeForSignature [conT ''Int] (monadName) -- @-getParametersTypeForSignature :: [Q Type] -> Name -> Name -> Name -> Q Type-getParametersTypeForSignature types responseTypeName monadName securitySchemeName =+getParametersTypeForSignature :: [Q Type] -> Name -> Name -> Q Type+getParametersTypeForSignature types responseTypeName monadName = createFunctionType- ( [t|OC.Configuration $(varT securitySchemeName)|]- : types- <> [[t|$(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]]+ ( [t|OC.Configuration|] :+ types+ <> [[t|$(varT monadName) (HS.Response $(varT responseTypeName))|]] ) -- | Same as 'getParametersTypeForSignature' but with the configuration in 'MR.ReaderT' instead of a parameter-getParametersTypeForSignatureWithMonadTransformer :: [Q Type] -> Name -> Name -> Name -> Q Type-getParametersTypeForSignatureWithMonadTransformer types responseTypeName monadName securitySchemeName =+getParametersTypeForSignatureWithMonadTransformer :: [Q Type] -> Name -> Name -> Q Type+getParametersTypeForSignatureWithMonadTransformer types responseTypeName monadName = createFunctionType ( types- <> [[t|MR.ReaderT (OC.Configuration $(varT securitySchemeName)) $(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]]+ <> [[t|OC.ClientT $(varT monadName) (HS.Response $(varT responseTypeName))|]] ) createFunctionType :: [Q Type] -> Q Type@@ -136,28 +226,22 @@ getParameterName :: OAT.ParameterObject -> OAM.Generator Name getParameterName parameter = haskellifyNameM False $ getNameFromParameter parameter --- | Get the type of a parameter depending on its schema type and the configuration options ('OAF.Flags').--- If the parameter is not required, a 'Maybe' type is produced.-getParameterType :: OAT.ParameterObject -> OAM.Generator (Q Type)-getParameterType parameter = do- flags <- OAM.getFlags- schema <- getSchemaFromParameter parameter- let paramType = varT $ maybe ''Text (Model.getSchemaType flags) schema- pure- ( if getRequiredFromParameter parameter- then paramType- else [t|Maybe $(paramType)|]- )- -- | Get a description of a parameter object (the name and if available the description from the specification) getParameterDescription :: OAT.ParameterObject -> OAM.Generator Text getParameterDescription parameter = do- schema <- Model.resolveSchemaReferenceWithoutWarning $ OAT.schema (OAT.schema (parameter :: OAT.ParameterObject) :: OAT.ParameterObjectSchema)+ schema <- case getSchemaOfParameterObject parameter of+ Just schema -> Model.resolveSchemaReferenceWithoutWarning schema+ Nothing -> pure Nothing let name = OAT.name (parameter :: OAT.ParameterObject) description = maybe "" (": " <>) $ OAT.description (parameter :: OAT.ParameterObject) constraints = joinWith ", " $ Model.getConstraintDescriptionsOfSchema schema pure $ Doc.escapeText $ name <> description <> (if T.null constraints then "" else " | Constraints: " <> constraints) +getSchemaOfParameterObject :: OAT.ParameterObject -> Maybe OAS.Schema+getSchemaOfParameterObject parameterObject = case OAT.schema (parameterObject :: OAT.ParameterObject) of+ (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) -> Just schema+ OAT.ComplexParameterObjectSchema _ -> Nothing+ -- | Defines the body of an Operation function -- The Operation function calls an generall HTTP function -- all Parameters are arguments to the function@@ -167,7 +251,7 @@ -- | How the function should be called Name -> -- | The parameters- [OAT.ParameterObject] ->+ ParameterCardinality -> -- | The request path. It may contain placeholders in the form /my/{var}/path/ Text -> -- | HTTP Method (POST,GET,etc.)@@ -179,61 +263,91 @@ Q Exp -> -- | Function body definition in TH OAM.Generator (Q Doc)-defineOperationFunction useExplicitConfiguration fnName params requestPath method bodySchema responseTransformerExp = do- paramVarNames <- mapM getParameterName params- let configArg = mkName "config"- paraPattern = varP <$> paramVarNames- fnPatterns = if useExplicitConfiguration then varP configArg : paraPattern else paraPattern- namedParameters = zip paramVarNames params- namedPathParameters = filter ((== OAT.PathParameterObjectLocation) . getInFromParameterObject . snd) namedParameters- request = generateParameterizedRequestPath namedPathParameters requestPath- namedQueryParameters = filter ((== OAT.QueryParameterObjectLocation) . getInFromParameterObject . snd) namedParameters- queryParameters = generateQueryParams namedQueryParameters+defineOperationFunction useExplicitConfiguration fnName parameterCardinality requestPath method bodySchema responseTransformerExp = do+ let configName = mkName "config"+ paramName = mkName "parameters" bodyName = mkName "body"- methodLit = litE $ stringL $ T.unpack method+ paraPattern <- case parameterCardinality of+ NoParameters -> pure []+ SingleParameter _ _ parameter -> do+ paramName' <- getParameterName parameter+ pure [varP paramName']+ MultipleParameters _ -> pure [varP paramName]+ (pathParameters, queryParameters) <- case parameterCardinality of+ NoParameters -> pure ([], [])+ SingleParameter _ _ parameter -> do+ paramName' <- getParameterName parameter+ let paramExpr = (varE paramName', parameter)+ pure $+ if getInFromParameterObject parameter == OAT.PathParameterObjectLocation+ then ([paramExpr], [])+ else ([], [paramExpr])+ MultipleParameters paramDefinition ->+ let toParamExpr f = BF.first (\name -> [|$(varE name) $(varE paramName)|]) <$> f paramDefinition+ in pure (toParamExpr parameterTypeDefinitionPathParams, toParamExpr parameterTypeDefinitionQueryParams)+ let queryParameters' = generateQueryParams queryParameters+ request = generateParameterizedRequestPath pathParameters requestPath+ methodLit = stringE $ T.unpack method+ fnPatterns = if useExplicitConfiguration then varP configName : paraPattern else paraPattern+ generateBody <- shouldGenerateRequestBody bodySchema pure $ ppr <$> case bodySchema of- Just RequestBodyDefinition {..} ->- let encodeExpr =- varE $- case encoding of- OC.RequestBodyEncodingFormData -> 'OC.RequestBodyEncodingFormData- OC.RequestBodyEncodingJSON -> 'OC.RequestBodyEncodingJSON- in [d|- $(conP fnName $ fnPatterns <> [varP bodyName]) =- $responseTransformerExp- ( $( if useExplicitConfiguration- then [|OC.doBodyCallWithConfiguration $(varE configArg)|]- else [|OC.doBodyCallWithConfigurationM|]- )- (T.toUpper $ T.pack $methodLit)- (T.pack $(request))- $(queryParameters)- $(if required then [|Just $(varE bodyName)|] else varE bodyName)- $(encodeExpr)- )- |]- Nothing ->+ Just RequestBodyDefinition {..}+ | generateBody ->+ let encodeExpr =+ varE $+ case encoding of+ OC.RequestBodyEncodingFormData -> 'OC.RequestBodyEncodingFormData+ OC.RequestBodyEncodingJSON -> 'OC.RequestBodyEncodingJSON+ in [d|+ $(conP fnName $ fnPatterns <> [varP bodyName]) =+ $responseTransformerExp+ ( $( if useExplicitConfiguration+ then [|OC.doBodyCallWithConfiguration $(varE configName)|]+ else [|OC.doBodyCallWithConfigurationM|]+ )+ (T.toUpper $ T.pack $methodLit)+ (T.pack $(request))+ $(queryParameters')+ $(if required then [|Just $(varE bodyName)|] else varE bodyName)+ $(encodeExpr)+ )+ |]+ _ -> [d| $(conP fnName fnPatterns) = $responseTransformerExp ( $( if useExplicitConfiguration- then [|OC.doCallWithConfiguration $(varE configArg)|]+ then [|OC.doCallWithConfiguration $(varE configName)|] else [|OC.doCallWithConfigurationM|] ) (T.toUpper $ T.pack $methodLit) (T.pack $(request))- $(queryParameters)+ $(queryParameters') ) |] +-- | Checks if a request body should be generated based on the CLI options and if the body type is an empty object+shouldGenerateRequestBody :: Maybe RequestBodyDefinition -> OAM.Generator Bool+shouldGenerateRequestBody Nothing = pure False+shouldGenerateRequestBody (Just RequestBodyDefinition {..}) = do+ maybeSchema <- Model.resolveSchemaReferenceWithoutWarning schema+ generateEmptyRequestBody <- OAM.getSetting OAO.settingGenerateOptionalEmptyRequestBody+ case maybeSchema of+ Just s+ | not generateEmptyRequestBody+ && not required+ && OAS.isSchemaEmpty s ->+ pure False+ _ -> pure True+ -- | Extracts the request body schema from an operation and the encoding which should be used on the body data.-getBodySchemaFromOperation :: OAT.OperationObject -> OAM.Generator (Maybe RequestBodyDefinition)-getBodySchemaFromOperation operation = do+getBodySchemaFromOperation :: OAT.OperationObject -> OAM.Generator (Maybe RequestBodyDefinition, [Text])+getBodySchemaFromOperation operation = OAM.nested "requestBody" $ do requestBody <- getRequestBodyObject operation case requestBody of- Just body -> getRequestBodySchema body- Nothing -> pure Nothing+ Just (body, path) -> OAM.resetPath path $ getRequestBodySchema body+ Nothing -> pure (Nothing, []) getRequestBodyContent :: OAT.RequestBodyObject -> Map.Map Text OAT.MediaTypeObject getRequestBodyContent = OAT.content@@ -241,8 +355,8 @@ getSchemaFromMedia :: OAT.MediaTypeObject -> Maybe OAT.Schema getSchemaFromMedia = OAT.schema -getRequestBodySchema :: OAT.RequestBodyObject -> OAM.Generator (Maybe RequestBodyDefinition)-getRequestBodySchema body =+getRequestBodySchema :: OAT.RequestBodyObject -> OAM.Generator (Maybe RequestBodyDefinition, [Text])+getRequestBodySchema body = OAM.nested "content" $ do let content = Map.lookup "application/json" $ getRequestBodyContent body createRequestBodyDefinition encoding schema = Just $@@ -251,90 +365,122 @@ encoding = encoding, required = OAT.required (body :: OAT.RequestBodyObject) }- in case content of- Nothing ->- let formContent = Map.lookup "application/x-www-form-urlencoded" $ getRequestBodyContent body- in case formContent of- Nothing -> do- OAM.logWarning "Only content type application/json and application/x-www-form-urlencoded is supported"- pure Nothing- Just media ->- pure $- getSchemaFromMedia media- >>= createRequestBodyDefinition OC.RequestBodyEncodingFormData- Just media ->- pure $- getSchemaFromMedia media- >>= createRequestBodyDefinition OC.RequestBodyEncodingJSON+ case content of+ Nothing ->+ let formContent = Map.lookup "application/x-www-form-urlencoded" $ getRequestBodyContent body+ in case formContent of+ Nothing -> do+ OAM.logWarning "Only content type application/json and application/x-www-form-urlencoded is supported"+ pure (Nothing, [])+ Just media -> do+ path <- OAM.appendToPath ["application/x-www-form-urlencoded", "schema"]+ pure+ ( getSchemaFromMedia media+ >>= createRequestBodyDefinition OC.RequestBodyEncodingFormData,+ path+ )+ Just media -> do+ path <- OAM.appendToPath ["application/json", "schema"]+ pure+ ( getSchemaFromMedia media+ >>= createRequestBodyDefinition OC.RequestBodyEncodingJSON,+ path+ ) -getRequestBodyObject :: OAT.OperationObject -> OAM.Generator (Maybe OAT.RequestBodyObject)+getRequestBodyObject :: OAT.OperationObject -> OAM.Generator (Maybe (OAT.RequestBodyObject, [Text])) getRequestBodyObject operation = case OAT.requestBody operation of Nothing -> pure Nothing- Just (OAT.Concrete p) -> pure $ Just p+ Just (OAT.Concrete p) -> do+ path <- OAM.getCurrentPath+ pure $ Just (p, path) Just (OAT.Reference ref) -> do p <- OAM.getRequestBodyReferenceM ref- when (Maybe.isNothing p) $ OAM.logWarning $ "Reference " <> ref <> " to RequestBody could not be found and therefore will be skipped."- pure p+ when (Maybe.isNothing p) $ OAM.logWarning $ "Reference '" <> ref <> "' to request body could not be found and therefore will be skipped."+ let name = T.replace "#/components/requestBodies/" "" ref+ pure $ (,["components", "requestBodies", name]) <$> p -- | Extracts the response 'OAT.Schema' from a 'OAT.ResponseObject'. -- -- A warning is logged if the response does not contain one of the supported media types.-getResponseSchema :: OAT.ResponseObject -> OAM.Generator (Maybe OAT.Schema)-getResponseSchema response = do+getResponseSchema :: OAT.ResponseObject -> OAM.Generator (Maybe OAT.Schema, [Text])+getResponseSchema response = OAM.nested "content" $ do let contentMap = OAT.content (response :: OAT.ResponseObject) schema = Map.lookup "application/json" contentMap >>= getSchemaFromMedia when (Maybe.isNothing schema && not (Map.null contentMap)) $ OAM.logWarning "Only content type application/json is supported for response bodies."- pure schema+ path <- OAM.appendToPath ["application/json", "schema"]+ pure (schema, path) -- | Resolve a possibly referenced response to a concrete value. -- -- A warning is logged if the reference is not found.-getResponseObject :: OAT.Referencable OAT.ResponseObject -> OAM.Generator (Maybe OAT.ResponseObject)-getResponseObject (OAT.Concrete p) = pure $ Just p+getResponseObject :: OAT.Referencable OAT.ResponseObject -> OAM.Generator (Maybe (OAT.ResponseObject, [Text]))+getResponseObject (OAT.Concrete p) = do+ path <- OAM.getCurrentPath+ pure $ Just (p, path) getResponseObject (OAT.Reference ref) = do p <- OAM.getResponseReferenceM ref- when (Maybe.isNothing p) $ OAM.logWarning $ "Reference " <> ref <> " to response could not be found and therefore will be skipped."- pure p+ when (Maybe.isNothing p) $ OAM.logWarning $ "Reference '" <> ref <> "' to response could not be found and therefore will be skipped."+ let name = T.replace "#/components/responses/" "" ref+ pure $ (,["components", "responses", name]) <$> p -- | Generates query params in the form of [(Text,ByteString)]-generateQueryParams :: [(Name, OAT.ParameterObject)] -> Q Exp-generateQueryParams ((name, param) : xs) =- infixE (Just [|(T.pack $(litE $ stringL queryName), $expr)|]) (varE $ mkName ":") (Just $ generateQueryParams xs)- where- queryName = T.unpack $ getNameFromParameter param- required = getRequiredFromParameter param- expr =- if required- then [|Just $ OC.stringifyModel $(varE name)|]- else [|OC.stringifyModel <$> $(varE name)|]-generateQueryParams _ = [|[]|]+generateQueryParams :: [(Q Exp, OAT.ParameterObject)] -> Q Exp+generateQueryParams [] = [|mempty|]+generateQueryParams x =+ listE+ . fmap+ ( \(var, param) ->+ let queryName = stringE $ T.unpack $ getNameFromParameter param+ required = getRequiredFromParameter param+ (maybeStyle, explode') = case OAT.schema (param :: OAT.ParameterObject) of+ (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) -> (style, explode)+ OAT.ComplexParameterObjectSchema _ -> (Just "form", True)+ style' =+ stringE $+ T.unpack $+ Maybe.fromMaybe+ ( case OAT.in' (param :: OAT.ParameterObject) of+ OAT.QueryParameterObjectLocation -> "form"+ OAT.HeaderParameterObjectLocation -> "simple"+ OAT.PathParameterObjectLocation -> "simple"+ OAT.CookieParameterObjectLocation -> "form"+ )+ maybeStyle+ expr =+ if required+ then [|Just $ Aeson.toJSON $var|]+ else [|Aeson.toJSON <$> $var|]+ in [|OC.QueryParameter (T.pack $queryName) $expr (T.pack $style') explode'|]+ )+ $ x -- | Resolves placeholders in paths with dynamic expressions -- -- "my/{var}/path" -> "my" ++ myVar ++ "/path" -- -- If the placeholder is at the end or at the beginning an empty string gets appended-generateParameterizedRequestPath :: [(Name, OAT.ParameterObject)] -> Text -> Q Exp+generateParameterizedRequestPath :: [(Q Exp, OAT.ParameterObject)] -> Text -> Q Exp generateParameterizedRequestPath ((paramName, param) : xs) path = foldr1 (foldingFn paramName) partExpressiones where parts = Split.splitOn ("{" <> T.unpack (getNameFromParameter param) <> "}") (T.unpack path) partExpressiones = generateParameterizedRequestPath xs . T.pack <$> parts- foldingFn :: Name -> Q Exp -> Q Exp -> Q Exp- foldingFn var a b = [|$(a) ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE var)) ++ $(b)|]-generateParameterizedRequestPath _ path = litE (stringL $ T.unpack path)+ foldingFn :: Q Exp -> Q Exp -> Q Exp -> Q Exp+ foldingFn var a b = [|$(a) ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $var) ++ $(b)|]+generateParameterizedRequestPath _ path = stringE $ T.unpack path -- | Extracts a description from an 'OAT.OperationObject'. -- If available, the description is used, the summary otherwise. -- If neither is available, an empty description is used. getOperationDescription :: OAT.OperationObject -> Text getOperationDescription operation =- Maybe.fromMaybe "" $ Maybe.listToMaybe $- Maybe.catMaybes- [ OAT.description (operation :: OAT.OperationObject),- OAT.summary (operation :: OAT.OperationObject)- ]+ Maybe.fromMaybe "" $+ Maybe.listToMaybe $+ Maybe.catMaybes+ [ OAT.description (operation :: OAT.OperationObject),+ OAT.summary (operation :: OAT.OperationObject)+ ] -- | Constructs the name of an operation. -- If an 'OAT.operationId' is available, this is the primary choice.
+ src/OpenAPI/Generate/Internal/Unknown.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.Internal.Unknown+ ( warnAboutUnknownWhiteListedOrOpaqueSchemas,+ warnAboutUnknownOperations,+ )+where++import Control.Monad+import qualified Data.List as L+import qualified Data.Maybe as Maybe+import qualified Data.Ord as Ord+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.OptParse as OAO+import qualified OpenAPI.Generate.Types as OAT+import qualified OpenAPI.Generate.Types.Schema as OAS++-- | Warn about operations listed as CLI options which do not appear in the provided OpenAPI specification+warnAboutUnknownOperations :: [(Text, OAT.PathItemObject)] -> OAM.Generator ()+warnAboutUnknownOperations operationDefinitions = do+ let getAllOperationObjectsFromPathItemObject = ([OAT.get, OAT.put, OAT.post, OAT.delete, OAT.options, OAT.head, OAT.patch, OAT.trace] <*>) . pure+ operationIds =+ Maybe.mapMaybe OAT.operationId $+ Maybe.catMaybes $+ operationDefinitions >>= getAllOperationObjectsFromPathItemObject . snd+ operationsToGenerate <- OAM.getSetting OAO.settingOperationsToGenerate+ printWarningIfUnknown (\operationId proposedOptions -> "The operation '" <> operationId <> "' which is listed for generation does not appear in the provided OpenAPI specification. " <> proposedOptions) operationIds operationsToGenerate++-- | Warn about schemas listed as CLI options (white list or opaque schemas) which do not appear in the provided OpenAPI specification+warnAboutUnknownWhiteListedOrOpaqueSchemas :: [(Text, OAS.Schema)] -> OAM.Generator ()+warnAboutUnknownWhiteListedOrOpaqueSchemas schemaDefinitions = do+ let schemaNames = fst <$> schemaDefinitions+ printWarningIfUnknownWithTypeName typeName = printWarningIfUnknown (\name proposedOptions -> "The " <> typeName <> " '" <> name <> "' does not appear in the provided OpenAPI specification. " <> proposedOptions) schemaNames+ whiteListedSchemas <- OAM.getSetting OAO.settingWhiteListedSchemas+ opaqueSchemas <- OAM.getSetting OAO.settingOpaqueSchemas+ printWarningIfUnknownWithTypeName "white-listed schema" whiteListedSchemas+ printWarningIfUnknownWithTypeName "schema listed as opaque" opaqueSchemas++printWarningIfUnknown :: (Text -> Text -> Text) -> [Text] -> [Text] -> OAM.Generator ()+printWarningIfUnknown generateMessage namesFromSpecification =+ mapM_+ ( \name ->+ unless (name `elem` namesFromSpecification) $+ OAM.logWarning $ generateMessage name $ getProposedOptionsFromNameAndAvailableSchemas name namesFromSpecification+ )++getProposedOptionsFromNameAndAvailableSchemas :: Text -> [Text] -> Text+getProposedOptionsFromNameAndAvailableSchemas name = getProposedOptions . sortByLongestCommonSubstring name++sortByLongestCommonSubstring :: Text -> [Text] -> [Text]+sortByLongestCommonSubstring needle = fmap fst . L.sortOn snd . fmap (\x -> (x, - (longestCommonSubstringCount needle x)))++getProposedOptions :: [Text] -> Text+getProposedOptions [] = "Specification does not contain any."+getProposedOptions (x1 : x2 : x3 : _ : _) = getProposedOptions [x1, x2, x3]+getProposedOptions xs =+ let separator = "\n "+ in "Did you mean one of following options?" <> separator <> T.intercalate separator xs++longestCommonSubstringCount :: Text -> Text -> Int+longestCommonSubstringCount x y =+ let getSetWithAllSubstrings = Set.fromList . (T.inits <=< T.tails) . T.toLower+ intersection = Set.intersection (getSetWithAllSubstrings x) (getSetWithAllSubstrings y)+ in if Set.null intersection then 0 else T.length (L.maximumBy (Ord.comparing T.length) intersection)
src/OpenAPI/Generate/Internal/Util.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Utility functions for the OpenAPI code generator@@ -9,7 +10,6 @@ uppercaseFirstText, mapMaybeM, liftedAppend,- splitOn, joinWithPoint, joinWith, )@@ -20,8 +20,8 @@ import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH-import qualified OpenAPI.Generate.Flags as OAF import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.OptParse as OAO -- | Checks if the casing of a character can be changed. -- This is required to ensure the functions 'Char.toUpper' and 'Char.toLower' actually do something.@@ -94,14 +94,14 @@ replacePlus ('+' : rest) = "Plus" <> replacePlus rest replacePlus (x : xs) = x : replacePlus xs replacePlus a = a- in replaceReservedWord- $ caseFirstCharCorrectly- $ generateNameForEmptyIdentifier name- $ removeIllegalLeadingCharacters- $ (if convertToCamelCase then toCamelCase else id)- $ nameWithoutSpecialChars- $ replacePlus- $ T.unpack name+ in replaceReservedWord $+ caseFirstCharCorrectly $+ generateNameForEmptyIdentifier name $+ removeIllegalLeadingCharacters $+ (if convertToCamelCase then toCamelCase else id) $+ nameWithoutSpecialChars $+ replacePlus $+ T.unpack name -- | The same as 'haskellifyText' but transform the result to a 'Name' haskellifyName :: Bool -> Bool -> Text -> Name@@ -110,22 +110,34 @@ -- | 'OAM.Generator' version of 'haskellifyName' haskellifyNameM :: Bool -> Text -> OAM.Generator Name haskellifyNameM startWithUppercase name = do- flags <- OAM.getFlags- pure $ haskellifyName (OAF.optConvertToCamelCase flags) startWithUppercase name+ convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase+ pure $ haskellifyName convertToCamelCase startWithUppercase name -- | Transform a module name to ensure it is valid for file names transformToModuleName :: Text -> Text transformToModuleName name = let toCamelCase (x : y : xs) | not (isValidCharaterInSuffixExceptUnderscore x) && isCasableAlpha y = Char.toUpper y : toCamelCase xs+ toCamelCase ('\'' : y : xs) | isCasableAlpha y = '\'' : Char.toUpper y : toCamelCase xs toCamelCase (x : xs) = x : toCamelCase xs toCamelCase xs = xs- in T.pack- $ uppercaseFirst- $ generateNameForEmptyIdentifier name- $ removeIllegalLeadingCharacters- $ toCamelCase- $ T.unpack- $ T.map (\c -> if isValidCharaterInSuffixExceptUnderscore c then c else '_') name+ in T.pack $+ uppercaseFirst $+ generateNameForEmptyIdentifier name $+ removeIllegalLeadingCharacters $+ fmap+ ( \case+ '\'' -> '_'+ c -> c+ )+ $ toCamelCase $+ T.unpack $+ T.map+ ( \case+ '.' -> '\''+ c | isValidCharaterInSuffixExceptUnderscore c -> c+ _ -> '_'+ )+ name uppercaseFirst :: String -> String uppercaseFirst (x : xs) = Char.toUpper x : xs@@ -150,17 +162,6 @@ ( \part1 part2 -> part1 <> separator <> part2 ) xs---- | Split a list on on a given element-splitOn :: Eq a => a -> [a] -> [[a]]-splitOn x =- foldr- ( \element (currentAcc : acc) ->- if element == x- then [] : currentAcc : acc- else (element : currentAcc) : acc- )- [[]] -- | A version of 'Data.Maybe.mapMaybe' that works with a monadic predicate. -- from https://hackage.haskell.org/package/extra-1.7.1/docs/src/Control.Monad.Extra.html#mapMaybeM copied
+ src/OpenAPI/Generate/Log.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module OpenAPI.Generate.Log where++import Autodocodec+import Data.List (intersperse)+import Data.Text (Text)+import qualified Data.Text as T++-- | Data type representing the log severities+data LogSeverity+ = TraceSeverity+ | InfoSeverity+ | WarningSeverity+ | ErrorSeverity+ deriving (Eq, Ord, Bounded, Enum)++instance Show LogSeverity where+ show ErrorSeverity = "ERROR"+ show WarningSeverity = "WARN"+ show InfoSeverity = "INFO"+ show TraceSeverity = "TRACE"++instance Read LogSeverity where+ readsPrec _ ('E' : 'R' : 'R' : 'O' : 'R' : rest) = [(ErrorSeverity, rest)]+ readsPrec _ ('W' : 'A' : 'R' : 'N' : rest) = [(WarningSeverity, rest)]+ readsPrec _ ('I' : 'N' : 'F' : 'O' : rest) = [(InfoSeverity, rest)]+ readsPrec _ ('T' : 'R' : 'A' : 'C' : 'E' : rest) = [(TraceSeverity, rest)]+ readsPrec _ _ = []++instance HasCodec LogSeverity where+ codec = shownBoundedEnumCodec++-- | A log entry containing the location within the OpenAPI specification where the message was produced, a severity and the actual message.+data LogEntry = LogEntry+ { logEntryPath :: [Text],+ logEntrySeverity :: LogSeverity,+ logEntryMessage :: Text+ }+ deriving (Show, Eq)++-- | The type contained in the writer of the 'OpenAPI.Generate.Monad.Generator' used to collect log entries+type LogEntries = [LogEntry]++-- | Filters and transforms log entries for printing+filterAndTransformLogs :: LogSeverity -> LogEntries -> [Text]+filterAndTransformLogs minimumLogLevel = transformLogs . filterLogs minimumLogLevel++-- | Filters log entries which have a lower log level than provided+filterLogs :: LogSeverity -> LogEntries -> LogEntries+filterLogs minimumLogLevel = filter $ (>= minimumLogLevel) . logEntrySeverity++-- | Transforms 'LogEntries' to a list of 'Text' values for easier printing.+transformLogs :: LogEntries -> [Text]+transformLogs =+ fmap+ ( \LogEntry {..} ->+ T.justifyLeft 5 ' ' (T.pack $ show logEntrySeverity) <> " (" <> transformPath logEntryPath <> "): " <> logEntryMessage+ )++-- | Transforms the path to a 'Text' representation (parts are seperated with a dot)+transformPath :: [Text] -> Text+transformPath = mconcat . intersperse "."
+ src/OpenAPI/Generate/Main.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Functionality to Generate Haskell Code out of an OpenAPI definition File+module OpenAPI.Generate.Main where++import Control.Monad+import qualified Data.Bifunctor as BF+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH+import Language.Haskell.TH.PprLib hiding ((<>))+import qualified OpenAPI.Common as OC+import qualified OpenAPI.Generate.Doc as Doc+import OpenAPI.Generate.Internal.Unknown+import OpenAPI.Generate.Internal.Util+import qualified OpenAPI.Generate.Model as Model+import qualified OpenAPI.Generate.ModelDependencies as Dep+import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.Operation as Operation+import qualified OpenAPI.Generate.OptParse as OAO+import qualified OpenAPI.Generate.SecurityScheme as SecurityScheme+import qualified OpenAPI.Generate.Types as OAT++-- | Defines all the operations as functions and the common imports+defineOperations :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q [Dep.ModuleDefinition], Dep.Models)+defineOperations moduleName specification =+ let paths = Map.toList $ OAT.paths specification+ in OAM.nested "paths" $ do+ warnAboutUnknownOperations paths+ fmap+ ( BF.bimap+ ( fmap concat+ . sequence+ )+ Set.unions+ )+ . mapAndUnzipM (uncurry $ Operation.defineOperationsForPath moduleName)+ $ paths++-- | Defines the @defaultURL@ and the @defaultConfiguration@ containing this URL.+defineConfigurationInformation :: String -> OAT.OpenApiSpecification -> Q Doc+defineConfigurationInformation moduleName spec =+ let servers' = (OAT.servers :: OAT.OpenApiSpecification -> [OAT.ServerObject]) spec+ defaultURL = getServerURL servers'+ defaultURLName = mkName "defaultURL"+ getServerURL = maybe "/" (OAT.url :: OAT.ServerObject -> Text) . Maybe.listToMaybe+ in Doc.addConfigurationModuleHeader moduleName+ . vcat+ <$> sequence+ [ pure $+ Doc.generateHaddockComment+ [ "The default url specified by the OpenAPI specification",+ "",+ "@" <> defaultURL <> "@"+ ],+ ppr+ <$> [d|$(varP defaultURLName) = T.pack $(stringE $ T.unpack defaultURL)|],+ pure $ Doc.generateHaddockComment ["The default configuration containing the 'defaultURL' and no authorization"],+ ppr <$> [d|$(varP $ mkName "defaultConfiguration") = OC.Configuration $(varE defaultURLName) OC.anonymousSecurityScheme|]+ ]++-- | Defines all models in the components.schemas section of the 'OAT.OpenApiSpecification'+defineModels :: String -> OAT.OpenApiSpecification -> Dep.Models -> OAM.Generator (Q [Dep.ModuleDefinition])+defineModels moduleName spec operationDependencies =+ let schemaDefinitions = Map.toList $ OAT.schemas $ OAT.components spec+ in OAM.nested "components" $+ OAM.nested "schemas" $ do+ warnAboutUnknownWhiteListedOrOpaqueSchemas schemaDefinitions+ models <- mapM (uncurry Model.defineModelForSchema) schemaDefinitions+ whiteListedSchemas <- OAM.getSetting OAO.settingWhiteListedSchemas+ let dependencies = Set.union operationDependencies $ Set.fromList $ fmap transformToModuleName whiteListedSchemas+ pure $ Dep.getModelModulesFromModelsWithDependencies moduleName dependencies models++-- | Defines all supported security schemes from the 'OAT.OpenApiSpecification'.+defineSecuritySchemes :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q Doc)+defineSecuritySchemes moduleName =+ OAM.nested "components"+ . fmap (fmap $ Doc.addSecuritySchemesModuleHeader moduleName)+ . SecurityScheme.defineSupportedSecuritySchemes (T.pack moduleName)+ . Maybe.mapMaybe+ ( \(name', scheme') -> case scheme' of+ OAT.Concrete s -> Just (name', s)+ OAT.Reference _ -> Nothing+ )+ . Map.toList+ . OAT.securitySchemes+ . OAT.components
src/OpenAPI/Generate/Model.hs view
@@ -16,27 +16,31 @@ ) where +import Control.Applicative import Control.Monad import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Text as Aeson+import qualified Data.Bifunctor as BF+import qualified Data.Either as E import qualified Data.Int as Int import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Scientific as Scientific import qualified Data.Set as Set-import qualified Data.Text as T import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT import Data.Time.Calendar-import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.PprLib hiding ((<>)) import Language.Haskell.TH.Syntax import qualified OpenAPI.Common as OC import OpenAPI.Generate.Doc (appendDoc, emptyDoc) import qualified OpenAPI.Generate.Doc as Doc-import qualified OpenAPI.Generate.Flags as OAF import OpenAPI.Generate.Internal.Util import qualified OpenAPI.Generate.ModelDependencies as Dep import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Types as OAT import qualified OpenAPI.Generate.Types.Schema as OAS import Prelude hiding (maximum, minimum, not)@@ -61,15 +65,48 @@ Nothing [ conT ''Show, conT ''Eq- -- makes the programm compilation unusable slow- -- conT ''Generic ] ] +liftAesonValueWithOverloadedStrings :: Bool -> Aeson.Value -> Q Exp+liftAesonValueWithOverloadedStrings useOverloadedStrings (Aeson.String a) =+ let s = stringE $ T.unpack a+ in if useOverloadedStrings+ then [|$s|]+ else [|Aeson.String $s|]+liftAesonValueWithOverloadedStrings _ a = [|a|]++liftAesonValue :: Aeson.Value -> Q Exp+liftAesonValue = liftAesonValueWithOverloadedStrings True++aesonValueToName :: Aeson.Value -> Text+aesonValueToName =+ ( \case+ "" -> "EmptyString"+ x -> x+ )+ . uppercaseFirstText+ . T.replace "\"" ""+ . showAesonValue++showAesonValue :: Aeson.Value -> Text+showAesonValue = LT.toStrict . Aeson.encodeToLazyText+ -- | Defines all the models for a schema defineModelForSchema :: Text -> OAS.Schema -> OAM.Generator Dep.ModelWithDependencies defineModelForSchema schemaName schema = do- namedSchema <- defineModelForSchemaNamedWithTypeAliasStrategy CreateTypeAlias schemaName schema+ let aliasWithText description =+ createAlias schemaName description CreateTypeAlias $+ pure ([t|Aeson.Value|], (emptyDoc, Set.empty))+ blackListAlias = aliasWithText "This alias is created because of the generator configuration and possibly could have a more precise type."+ whiteListAlias = aliasWithText $ "This is just a type synonym and possibly could have a more precise type because the schema name @" <> schemaName <> "@ is not whitelisted."+ settingOpaqueSchemas <- OAM.getSetting OAO.settingOpaqueSchemas+ whiteListedSchemas <- OAM.getSetting OAO.settingWhiteListedSchemas+ namedSchema <-+ OAM.nested schemaName $+ if schemaName `elem` settingOpaqueSchemas+ then blackListAlias+ else if null whiteListedSchemas || schemaName `elem` whiteListedSchemas then defineModelForSchemaNamedWithTypeAliasStrategy CreateTypeAlias schemaName schema else whiteListAlias pure (transformToModuleName schemaName, snd namedSchema) -- | Defines all the models for a schema and returns the declarations with the type of the root model@@ -78,15 +115,20 @@ -- | defines the definitions for a schema and returns a type to the "entrypoint" of the schema defineModelForSchemaNamedWithTypeAliasStrategy :: TypeAliasStrategy -> Text -> OAS.Schema -> OAM.Generator TypeWithDeclaration-defineModelForSchemaNamedWithTypeAliasStrategy strategy schemaName schema = OAM.nested schemaName $+defineModelForSchemaNamedWithTypeAliasStrategy strategy schemaName schema = case schema of OAT.Concrete concrete -> defineModelForSchemaConcrete strategy schemaName concrete OAT.Reference reference -> do- let originalName = T.replace "#/components/schemas/" "" reference- refName <- haskellifyNameM True originalName- OAM.logInfo $ "Reference " <> reference <> " to " <> T.pack (nameBase refName)- pure (varT refName, (emptyDoc, Set.singleton $ transformToModuleName originalName))+ refName <- haskellifyNameM True $ getSchemaNameFromReference reference+ OAM.logTrace $ "Encountered reference '" <> reference <> "' which references the type '" <> T.pack (nameBase refName) <> "'"+ pure (varT refName, (emptyDoc, transformReferenceToDependency reference)) +getSchemaNameFromReference :: Text -> Text+getSchemaNameFromReference = T.replace "#/components/schemas/" ""++transformReferenceToDependency :: Text -> Set.Set Text+transformReferenceToDependency = Set.singleton . transformToModuleName . getSchemaNameFromReference+ -- | Transforms a 'OAS.Schema' (either a reference or a concrete object) to @'Maybe' 'OAS.SchemaObject'@ -- If a reference is found it is resolved. If it is not found, no log message is generated. resolveSchemaReferenceWithoutWarning :: OAS.Schema -> OAM.Generator (Maybe OAS.SchemaObject)@@ -97,34 +139,36 @@ resolveSchemaReference :: Text -> OAS.Schema -> OAM.Generator (Maybe (OAS.SchemaObject, Dep.Models)) resolveSchemaReference schemaName schema =- OAM.nested schemaName $- case schema of- OAT.Concrete concrete -> pure $ Just (concrete, Set.empty)- OAT.Reference ref -> do- p <- OAM.getSchemaReferenceM ref- when (Maybe.isNothing p) $ OAM.logWarning $- "Reference " <> ref <> " to SchemaObject from "+ case schema of+ OAT.Concrete concrete -> pure $ Just (concrete, Set.empty)+ OAT.Reference ref -> do+ p <- OAM.getSchemaReferenceM ref+ when (Maybe.isNothing p) $+ OAM.logWarning $+ "Reference '" <> ref <> "' to schema from '" <> schemaName- <> " could not be found and therefore will be skipped."- pure $ (,Set.singleton $ transformToModuleName ref) <$> p+ <> "' could not be found and therefore will be skipped."+ pure $ (,transformReferenceToDependency ref) <$> p -- | creates an alias depending on the strategy createAlias :: Text -> Text -> TypeAliasStrategy -> OAM.Generator TypeWithDeclaration -> OAM.Generator TypeWithDeclaration createAlias schemaName description strategy res = do schemaName' <- haskellifyNameM True schemaName (type', (content, dependencies)) <- res+ path <- getCurrentPathEscaped pure $ case strategy of CreateTypeAlias -> ( type', ( content `appendDoc` ( ( Doc.generateHaddockComment- [ "Defines an alias for the schema " <> Doc.escapeText schemaName,+ [ "Defines an alias for the schema located at @" <> path <> "@ in the specification.", "", description ] $$ )- . ppr <$> tySynD schemaName' [] type'+ . ppr+ <$> tySynD schemaName' [] type' ), dependencies )@@ -137,99 +181,110 @@ let enumValues = OAS.enum schema in if null enumValues then defineModelForSchemaConcreteIgnoreEnum strategy schemaName schema- else defineEnumModel strategy schemaName schema enumValues+ else defineEnumModel schemaName schema enumValues -- | Creates a Model, ignores enum values defineModelForSchemaConcreteIgnoreEnum :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration defineModelForSchemaConcreteIgnoreEnum strategy schemaName schema = do- flags <- OAM.getFlags+ settings <- OAM.getSettings let schemaDescription = getDescriptionOfSchema schema typeAliasing = createAlias schemaName schemaDescription strategy case schema of- OAS.SchemaObject {type' = OAS.SchemaTypeArray, ..} -> defineArrayModelForSchema strategy schemaName schema- OAS.SchemaObject {type' = OAS.SchemaTypeObject, ..} ->- let allOfNull = Set.null $ OAS.allOf schema- oneOfNull = Set.null $ OAS.oneOf schema- anyOfNull = Set.null $ OAS.anyOf schema+ OAS.SchemaObject {type' = OAS.SchemaTypeArray} -> defineArrayModelForSchema strategy schemaName schema+ OAS.SchemaObject {type' = OAS.SchemaTypeObject} ->+ let allOfNull = null $ OAS.allOf schema+ oneOfNull = null $ OAS.oneOf schema+ anyOfNull = null $ OAS.anyOf schema in case (allOfNull, oneOfNull, anyOfNull) of- (False, _, _) -> defineAllOfSchema schemaName schemaDescription $ Set.toList $ OAS.allOf schema- (_, False, _) -> typeAliasing $ defineOneOfSchema schemaName schemaDescription $ Set.toList $ OAS.oneOf schema- (_, _, False) -> defineAnyOfSchema strategy schemaName schemaDescription $ Set.toList $ OAS.anyOf schema- _ -> defineObjectModelForSchema schemaName schema+ (False, _, _) -> OAM.nested "allOf" $ defineAllOfSchema schemaName schemaDescription $ OAS.allOf schema+ (_, False, _) -> OAM.nested "oneOf" $ typeAliasing $ defineOneOfSchema schemaName schemaDescription $ OAS.oneOf schema+ (_, _, False) -> OAM.nested "anyOf" $ defineAnyOfSchema strategy schemaName schemaDescription $ OAS.anyOf schema+ _ -> defineObjectModelForSchema strategy schemaName schema _ ->- typeAliasing $ pure (varT $ getSchemaType flags schema, (emptyDoc, Set.empty))+ typeAliasing $ pure (varT $ getSchemaType settings schema, (emptyDoc, Set.empty)) -defineEnumModel :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> Set.Set Aeson.Value -> OAM.Generator TypeWithDeclaration-defineEnumModel strategy schemaName schema enumValuesSet = do- OAM.logInfo (T.pack "Generate Enum " <> schemaName)- let enumValues = Set.toList enumValuesSet+defineEnumModel :: Text -> OAS.SchemaObject -> [Aeson.Value] -> OAM.Generator TypeWithDeclaration+defineEnumModel schemaName schema enumValues = do+ name <- haskellifyNameM True schemaName+ OAM.logInfo $ "Define as enum named '" <> T.pack (nameBase name) <> "'" let getConstructor (a, _, _) = a- let getValueInfo value = do- cname <- haskellifyNameM True (schemaName <> T.pack "Enum" <> T.replace "\"" "" (T.pack (show value)))+ getValueInfo value = do+ cname <- haskellifyNameM True (schemaName <> T.pack "Enum" <> aesonValueToName value) pure (normalC cname [], cname, value)- name <- haskellifyNameM True schemaName- (typ, (content, dependencies)) <- defineModelForSchemaConcreteIgnoreEnum strategy (schemaName <> T.pack "EnumValue") schema+ (typ, (_, dependencies)) <- defineModelForSchemaConcreteIgnoreEnum DontCreateTypeAlias (schemaName <> "EnumValue") schema constructorsInfo <- mapM getValueInfo enumValues- otherName <- haskellifyNameM True (schemaName <> T.pack "EnumOther")- typedName <- haskellifyNameM True (schemaName <> T.pack "EnumTyped")+ fallbackName <- haskellifyNameM True $ schemaName <> "Other"+ typedName <- haskellifyNameM True $ schemaName <> "Typed"+ path <- getCurrentPathEscaped let nameValuePairs = fmap (\(_, a, b) -> (a, b)) constructorsInfo- let toBangType t = do+ toBangType t = do ban <- bang noSourceUnpackedness noSourceStrictness banT <- t pure (ban, banT)- let otherC = normalC otherName [toBangType (varT ''Aeson.Value)]- let typedC = normalC typedName [toBangType typ]- let jsonImplementation = defineJsonImplementationForEnum name otherName [otherName, typedName] nameValuePairs- let newType =+ fallbackC = normalC fallbackName [toBangType (varT ''Aeson.Value)]+ typedC = normalC typedName [toBangType typ]+ jsonImplementation = defineJsonImplementationForEnum name fallbackName typedName nameValuePairs+ comments = fmap (("Represents the JSON value @" <>) . (<> "@") . showAesonValue) enumValues+ newType = ( Doc.generateHaddockComment- [ "Defines the enum schema " <> Doc.escapeText schemaName,+ [ "Defines the enum schema located at @" <> path <> "@ in the specification.", "", getDescriptionOfSchema schema ] $$ )+ . ( `Doc.sideBySide`+ ( text ""+ $$ Doc.sideComments+ ( "This case is used if the value encountered during decoding does not match any of the provided cases in the specification." :+ "This constructor can be used to send values to the server which are not present in the specification yet." :+ comments+ )+ )+ )+ . Doc.reformatADT . ppr <$> dataD (pure []) name [] Nothing- (otherC : typedC : (getConstructor <$> constructorsInfo))+ (fallbackC : typedC : (getConstructor <$> constructorsInfo)) objectDeriveClause- pure (varT name, (content `appendDoc` newType `appendDoc` jsonImplementation, dependencies))+ pure (varT name, (newType `appendDoc` jsonImplementation, dependencies)) -defineJsonImplementationForEnum :: Name -> Name -> [Name] -> [(Name, Aeson.Value)] -> Q Doc-defineJsonImplementationForEnum name fallbackName specialCons nameValues =+defineJsonImplementationForEnum :: Name -> Name -> Name -> [(Name, Aeson.Value)] -> Q Doc+defineJsonImplementationForEnum name fallbackName typedName nameValues = -- without this function, a N long string takes up N lines, as every -- new character starts on a new line- let nicifyValue (Aeson.String a) = [|Aeson.String $ T.pack $(litE $ stringL $ T.unpack a)|]- nicifyValue a = [|a|]- fnArgName = mkName "val"- getName = fst- getValue = snd- fromJsonCns (x : xs) =- let vl = getValue x- name' = getName x- in [|if $(varE fnArgName) == $(nicifyValue vl) then $(varE name') else $(fromJsonCns xs)|]- fromJsonCns [] = appE (varE fallbackName) (varE fnArgName)+ let (e, p) = (\n -> (varE n, varP n)) $ mkName "val"+ fromJsonCases =+ multiIfE $+ fmap+ ( \(name', value) -> normalGE [|$e == $(liftAesonValue value)|] (varE name')+ )+ nameValues+ <> [normalGE [|otherwise|] [|$(varE fallbackName) $e|]] fromJsonFn = funD (mkName "parseJSON")- [clause [varP fnArgName] (normalB [|pure $(fromJsonCns nameValues)|]) []]- fromJson = instanceD (pure []) (appT (varT $ mkName "Data.Aeson.FromJSON") $ varT name) [fromJsonFn]- toJsonClause (name', value) =- let jsonValue = Aeson.toJSON value- in clause [conP name' []] (normalB $ nicifyValue jsonValue) []- toSpecialCons name' =- clause- [conP name' [varP $ mkName "patternName"]]- (normalB [|Aeson.toJSON $(varE (mkName "patternName"))|])- []+ [clause [p] (normalB [|pure $fromJsonCases|]) []]+ fromJson = instanceD (cxt []) [t|Aeson.FromJSON $(varT name)|] [fromJsonFn]+ toJsonClause (name', value) = clause [conP name' []] (normalB $ liftAesonValue $ Aeson.toJSON value) [] toJsonFn = funD (mkName "toJSON")- ((toSpecialCons <$> specialCons) <> (toJsonClause <$> nameValues))- toJson = instanceD (pure []) (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT name) [toJsonFn]+ ( clause+ [conP fallbackName [p]]+ (normalB e)+ [] :+ clause+ [conP typedName [p]]+ (normalB [|Aeson.toJSON $e|])+ [] :+ (toJsonClause <$> nameValues)+ )+ toJson = instanceD (cxt []) [t|Aeson.ToJSON $(varT name)|] [toJsonFn] in fmap ppr toJson `appendDoc` fmap ppr fromJson -- | defines anyOf types@@ -238,15 +293,18 @@ -- If there are differen subschema types, per schematype a oneOf is generated defineAnyOfSchema :: TypeAliasStrategy -> Text -> Text -> [OAS.Schema] -> OAM.Generator TypeWithDeclaration defineAnyOfSchema strategy schemaName description schemas = do- OAM.logInfo $ T.pack "defineAnyOfSchema " <> schemaName schemasWithDependencies <- mapMaybeM (resolveSchemaReference schemaName) schemas let concreteSchemas = fmap fst schemasWithDependencies schemasWithoutRequired = fmap (\o -> o {OAS.required = Set.empty}) concreteSchemas notObjectSchemas = filter (\o -> OAS.type' o /= OAS.SchemaTypeObject) concreteSchemas newDependencies = Set.unions $ fmap snd schemasWithDependencies if null notObjectSchemas- then addDependencies newDependencies $ defineAllOfSchema schemaName description (fmap OAT.Concrete schemasWithoutRequired)- else createAlias schemaName description strategy $ defineOneOfSchema schemaName description schemas+ then do+ OAM.logTrace "anyOf does not contain any schemas which are not of type object and will therefore be defined as allOf"+ addDependencies newDependencies $ defineAllOfSchema schemaName description (fmap OAT.Concrete schemasWithoutRequired)+ else do+ OAM.logTrace "anyOf does contain at least one schema which is not of type object and will therefore be defined as oneOf"+ createAlias schemaName description strategy $ defineOneOfSchema schemaName description schemas -- this would be the correct implementation -- but it generates endless loop because some implementations use anyOf as a oneOf@@ -267,74 +325,124 @@ -- subschemas. Constructors are numbered defineOneOfSchema :: Text -> Text -> [OAS.Schema] -> OAM.Generator TypeWithDeclaration defineOneOfSchema schemaName description schemas = do- if null schemas- then OAM.logWarning "schemas are empty, can not create OneOfSchemas"- else OAM.logInfo $ "define oneOf Model " <> schemaName- flags <- OAM.getFlags- let indexedSchemas = zip schemas ([1 ..] :: [Integer])+ when (null schemas) $ OAM.logWarning "oneOf does not contain any sub-schemas and will therefore be defined as a void type"+ settings <- OAM.getSettings+ let name = haskellifyName (OAO.settingConvertToCamelCase settings) True $ schemaName <> "Variants"+ (schemas', schemasWithFixedValues) = extractSchemasWithFixedValues schemas+ indexedSchemas = zip schemas' ([1 ..] :: [Integer]) defineIndexed schema index = defineModelForSchemaNamed (schemaName <> "OneOf" <> T.pack (show index)) schema+ OAM.logInfo $ "Define as oneOf named '" <> T.pack (nameBase name) <> "'" variants <- mapM (uncurry defineIndexed) indexedSchemas+ path <- getCurrentPathEscaped let variantDefinitions = vcat <$> mapM (fst . snd) variants dependencies = Set.unions $ fmap (snd . snd) variants types = fmap fst variants indexedTypes = zip types ([1 ..] :: [Integer])+ haskellifyConstructor = haskellifyName (OAO.settingConvertToCamelCase settings) True+ getConstructorName (typ, n) = do+ t <- typ+ let suffix = if OAO.settingUseNumberedVariantConstructors settings then "Variant" <> T.pack (show n) else typeToSuffix t+ pure $ haskellifyConstructor $ schemaName <> suffix+ constructorNames = fmap getConstructorName indexedTypes createTypeConstruct (typ, n) = do t <- typ bang' <- bang noSourceUnpackedness noSourceStrictness- let suffix = if OAF.optUseNumberedVariantConstructors flags then "Variant" <> T.pack (show n) else typeToSuffix t- haskellifiedName = haskellifyName (OAF.optConvertToCamelCase flags) True $ schemaName <> suffix+ haskellifiedName <- getConstructorName (typ, n) normalC haskellifiedName [pure (bang', t)]+ createConstructorNameForSchemaWithFixedValue =+ haskellifyConstructor+ . (schemaName <>)+ . aesonValueToName+ createConstructorForSchemaWithFixedValue =+ (`normalC` [])+ . createConstructorNameForSchemaWithFixedValue+ fixedValueComments = fmap (("Represents the JSON value @" <>) . (<> "@") . showAesonValue) schemasWithFixedValues emptyCtx = pure []- name = haskellifyName (OAF.optConvertToCamelCase flags) True $ schemaName <> "Variants"+ patternName = mkName "a"+ p = varP patternName+ e = varE patternName fromJsonFn =- funD- (mkName "parseJSON")- [ clause- []- ( normalB- [|- Aeson.genericParseJSON Aeson.defaultOptions {Aeson.sumEncoding = Aeson.UntaggedValue}- |]- )- []- ]+ let paramName = mkName "val"+ body = do+ constructorNames' <- sequence constructorNames+ let resultExpr =+ foldr+ ( \constructorName expr ->+ [|($(varE constructorName) <$> Aeson.fromJSON $(varE paramName)) <|> $expr|]+ )+ [|Aeson.Error "No variant matched"|]+ constructorNames'+ parserExpr =+ [|+ case $resultExpr of+ Aeson.Success $p -> pure $e+ Aeson.Error $p -> fail $e+ |]+ case schemasWithFixedValues of+ [] -> parserExpr+ _ ->+ multiIfE $+ fmap+ ( \value ->+ let constructorName = createConstructorNameForSchemaWithFixedValue value+ in normalGE [|$(varE paramName) == $(liftAesonValue value)|] [|pure $(varE constructorName)|]+ )+ schemasWithFixedValues+ <> [normalGE [|otherwise|] parserExpr]+ in funD+ (mkName "parseJSON")+ [ clause+ [varP paramName]+ (normalB body)+ []+ ] toJsonFn = funD (mkName "toJSON")- [ clause- []- ( normalB- [|- Aeson.genericToJSON Aeson.defaultOptions {Aeson.sumEncoding = Aeson.UntaggedValue}- |]+ ( fmap+ ( \constructorName -> do+ n <- constructorName+ clause+ [conP n [p]]+ (normalB [|Aeson.toJSON $e|])+ [] )- []- ]+ constructorNames+ <> fmap+ ( \value ->+ let constructorName = createConstructorNameForSchemaWithFixedValue value+ in clause+ [conP constructorName []]+ (normalB $ liftAesonValue value)+ []+ )+ schemasWithFixedValues+ ) dataDefinition = ( Doc.generateHaddockComment- [ "Define the one-of schema " <> Doc.escapeText schemaName,+ [ "Defines the oneOf schema located at @" <> path <> "@ in the specification.", "", description ] $$ )+ . (`Doc.sideBySide` (text "" $$ Doc.sideComments fixedValueComments))+ . Doc.reformatADT . ppr <$> dataD emptyCtx name [] Nothing- (createTypeConstruct <$> indexedTypes)+ (fmap createConstructorForSchemaWithFixedValue schemasWithFixedValues <> fmap createTypeConstruct indexedTypes) [ derivClause Nothing [ conT ''Show,- conT ''Eq,- -- makes the programm slow, but oneOf is not used that often- conT ''Generic+ conT ''Eq ] ]- toJson = ppr <$> instanceD emptyCtx (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT name) [toJsonFn]- fromJson = ppr <$> instanceD emptyCtx (appT (varT $ mkName "Data.Aeson.FromJSON") $ varT name) [fromJsonFn]+ toJson = ppr <$> instanceD emptyCtx [t|Aeson.ToJSON $(varT name)|] [toJsonFn]+ fromJson = ppr <$> instanceD emptyCtx [t|Aeson.FromJSON $(varT name)|] [fromJsonFn] innerRes = (varT name, (variantDefinitions `appendDoc` dataDefinition `appendDoc` toJson `appendDoc` fromJson, dependencies)) pure innerRes @@ -362,12 +470,12 @@ getPropertiesForAllOf schemaName schema = let allOf = OAS.allOf schema anyOf = OAS.anyOf schema- relevantSubschemas = Set.union allOf anyOf+ relevantSubschemas = allOf <> anyOf in if null relevantSubschemas then pure (OAS.properties schema, OAS.required schema) else do- (allOfProps, allOfRequired) <- fuseSchemasAllOf schemaName $ Set.toList allOf- (anyOfProps, _) <- fuseSchemasAllOf schemaName $ Set.toList anyOf+ (allOfProps, allOfRequired) <- fuseSchemasAllOf schemaName allOf+ (anyOfProps, _) <- fuseSchemasAllOf schemaName anyOf pure (Map.unionWith const allOfProps anyOfProps, allOfRequired) -- | defines a allOf subschema@@ -378,43 +486,48 @@ case newDefs of Just (newSchema, newDependencies) -> addDependencies newDependencies $ defineModelForSchemaConcrete DontCreateTypeAlias schemaName newSchema- Nothing -> pure (varT ''Text, (emptyDoc, Set.empty))+ Nothing -> pure ([t|Aeson.Object|], (emptyDoc, Set.empty)) -- | defines a new Schema, which properties are fused defineNewSchemaForAllOf :: Text -> Text -> [OAS.Schema] -> OAM.Generator (Maybe (OAS.SchemaObject, Dep.Models)) defineNewSchemaForAllOf schemaName description schemas = do- OAM.logInfo $ "define allOf Model " <> schemaName schemasWithDependencies <- mapMaybeM (resolveSchemaReference schemaName) schemas let concreteSchemas = fmap fst schemasWithDependencies newDependencies = Set.unions $ fmap snd schemasWithDependencies (propertiesCombined, requiredCombined) <- fuseSchemasAllOf schemaName schemas if Map.null propertiesCombined then do- OAM.logWarning "allOf schemas is empty"+ OAM.logWarning "allOf does not contain any schemas with properties." pure Nothing- else+ else do let schemaPrototype = head concreteSchemas newSchema = schemaPrototype {OAS.properties = propertiesCombined, OAS.required = requiredCombined, OAS.description = Just description}- in pure $ Just (newSchema, newDependencies)+ OAM.logTrace $ "Define allOf as record named '" <> schemaName <> "'"+ pure $ Just (newSchema, newDependencies) -- | defines an array defineArrayModelForSchema :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration defineArrayModelForSchema strategy schemaName schema = do+ arrayItemTypeSuffix <- case strategy of+ CreateTypeAlias -> OAM.getSetting OAO.settingArrayItemTypeSuffix+ DontCreateTypeAlias -> pure "" -- The suffix is only relevant for top level declarations because only there a named type of the array even exists (type', (content, dependencies)) <- case OAS.items schema of- Just itemSchema -> defineModelForSchemaNamed schemaName itemSchema+ Just itemSchema -> OAM.nested "items" $ defineModelForSchemaNamed (schemaName <> arrayItemTypeSuffix) itemSchema -- not allowed by the spec Nothing -> do- OAM.logWarning $ T.pack "items is empty for an array (assume string) " <> schemaName- pure (varT ''Text, (emptyDoc, Set.empty))- let arrayType = appT (varT $ mkName "[]") type'+ OAM.logWarning "Array type was defined without a items schema and therefore cannot be defined correctly"+ pure ([t|Aeson.Object|], (emptyDoc, Set.empty))+ let arrayType = appT listT type' schemaName' <- haskellifyNameM True schemaName+ OAM.logTrace $ "Define as list named '" <> T.pack (nameBase schemaName') <> "'"+ path <- getCurrentPathEscaped pure ( arrayType, ( content `appendDoc` case strategy of CreateTypeAlias -> ( Doc.generateHaddockComment- [ "Defines an alias for the schema " <> Doc.escapeText schemaName,+ [ "Defines an alias for the schema located at @" <> path <> "@ in the specification.", "", getDescriptionOfSchema schema ]@@ -427,126 +540,139 @@ ) ) --- | Defines a Record-defineObjectModelForSchema :: Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration-defineObjectModelForSchema schemaName schema = do- flags <- OAM.getFlags- let convertToCamelCase = OAF.optConvertToCamelCase flags- name = haskellifyName convertToCamelCase True schemaName- props = Map.toList $ OAS.properties schema- propsWithNames = zip (fmap fst props) $ fmap (haskellifyName convertToCamelCase False . (schemaName <>) . uppercaseFirstText . fst) props- emptyCtx = pure []- required = OAS.required schema- OAM.logInfo $ "define object model " <> T.pack (nameBase name)- (bangTypes, propertyContent, propertyDependencies) <- propertiesToBangTypes schemaName props required- propertyDescriptions <- getDescriptionOfProperties props- let dataDefinition :: Q Doc- dataDefinition = do- bangs <- bangTypes- let record = recC name (pure <$> bangs)- flip Doc.zipCodeAndComments propertyDescriptions- . T.lines- . T.pack- . show- . Doc.breakOnTokensWithReplacement- ( \case- "{" -> "{\n "- token -> "\n " <> token- )- [",", "{", "}"]- . ppr <$> dataD emptyCtx name [] Nothing [record] objectDeriveClause- toJsonInstance = createToJSONImplementation name propsWithNames- fromJsonInstance = createFromJSONImplementation name propsWithNames required- pure- ( varT name,- ( pure- ( Doc.generateHaddockComment- [ "Defines the data type for the schema " <> Doc.escapeText schemaName,- "",- getDescriptionOfSchema schema- ]+-- | Defines a record+defineObjectModelForSchema :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration+defineObjectModelForSchema strategy schemaName schema =+ if OAS.isSchemaEmpty schema+ then createAlias schemaName (getDescriptionOfSchema schema) strategy $ pure ([t|Aeson.Object|], (emptyDoc, Set.empty))+ else do+ settings <- OAM.getSettings+ path <- getCurrentPathEscaped+ let convertToCamelCase = OAO.settingConvertToCamelCase settings+ name = haskellifyName convertToCamelCase True schemaName+ required = OAS.required schema+ (props, propsWithFixedValues) = extractPropertiesWithFixedValues required $ Map.toList $ OAS.properties schema+ propsWithNames = zip (fmap fst props) $ fmap (haskellifyName convertToCamelCase False . (schemaName <>) . uppercaseFirstText . fst) props+ emptyCtx = pure []+ OAM.logInfo $ "Define as record named '" <> T.pack (nameBase name) <> "'"+ (bangTypes, propertyContent, propertyDependencies) <- propertiesToBangTypes schemaName props required+ propertyDescriptions <- getDescriptionOfProperties props+ let dataDefinition = do+ bangs <- bangTypes+ let record = recC name (pure <$> bangs)+ flip Doc.zipCodeAndComments propertyDescriptions+ . T.lines+ . T.pack+ . show+ . Doc.reformatRecord+ . ppr+ <$> dataD emptyCtx name [] Nothing [record] objectDeriveClause+ toJsonInstance = createToJSONImplementation name propsWithNames propsWithFixedValues+ fromJsonInstance = createFromJSONImplementation name propsWithNames required+ mkFunction = createMkFunction name propsWithNames required bangTypes+ pure+ ( varT name,+ ( pure+ ( Doc.generateHaddockComment+ [ "Defines the object schema located at @" <> path <> "@ in the specification.",+ "",+ getDescriptionOfSchema schema+ ]+ )+ `appendDoc` dataDefinition+ `appendDoc` toJsonInstance+ `appendDoc` fromJsonInstance+ `appendDoc` mkFunction+ `appendDoc` propertyContent,+ propertyDependencies )- `appendDoc` dataDefinition- `appendDoc` toJsonInstance- `appendDoc` fromJsonInstance- `appendDoc` propertyContent,- propertyDependencies+ )++extractPropertiesWithFixedValues :: Set.Set Text -> [(Text, OAS.Schema)] -> ([(Text, OAS.Schema)], [(Text, Aeson.Value)])+extractPropertiesWithFixedValues required =+ E.partitionEithers+ . fmap+ ( \(name, schema) ->+ BF.bimap (name,) (name,) $+ if name `Set.member` required+ then extractSchemaWithFixedValue schema+ else Left schema )++extractSchemasWithFixedValues :: [OAS.Schema] -> ([OAS.Schema], [Aeson.Value])+extractSchemasWithFixedValues = E.partitionEithers . fmap extractSchemaWithFixedValue++extractSchemaWithFixedValue :: OAS.Schema -> Either OAS.Schema Aeson.Value+extractSchemaWithFixedValue schema@(OAT.Concrete OAS.SchemaObject {..}) = case enum of+ [value] -> Right value+ _ -> Left schema+extractSchemaWithFixedValue schema = Left schema++createMkFunction :: Name -> [(Text, Name)] -> Set.Set Text -> Q [VarBangType] -> Q Doc+createMkFunction name propsWithNames required bangTypes = do+ bangs <- bangTypes+ let fnName = mkName $ "mk" <> nameBase name+ propsWithTypes =+ ( \((originalName, propertyName), (_, _, propertyType)) ->+ (propertyName, propertyType, originalName `Set.member` required)+ )+ <$> zip propsWithNames bangs+ requiredPropsWithTypes = filter (\(_, _, isRequired) -> isRequired) propsWithTypes+ parameterPatterns = (\(propertyName, _, _) -> varP propertyName) <$> requiredPropsWithTypes+ parameterDescriptions = (\(propertyName, _, _) -> "'" <> T.pack (nameBase propertyName) <> "'") <$> requiredPropsWithTypes+ recordExpr = (\(propertyName, _, isRequired) -> fieldExp propertyName (if isRequired then varE propertyName else [|Nothing|])) <$> propsWithTypes+ expr = recConE name recordExpr+ fnType = foldr (\(_, propertyType, _) t -> [t|$(pure propertyType) -> $t|]) (conT name) requiredPropsWithTypes+ pure+ ( Doc.generateHaddockComment+ [ "Create a new '" <> T.pack (nameBase name) <> "' with all required fields."+ ] )+ `appendDoc` fmap+ ( ( `Doc.sideBySide`+ Doc.sideComments parameterDescriptions+ )+ . Doc.breakOnTokens ["->"]+ . ppr+ )+ (sigD fnName fnType)+ `appendDoc` fmap ppr (funD fnName [clause parameterPatterns (normalB expr) []]) -- | create toJSON implementation for an object-createToJSONImplementation :: Name -> [(Text, Name)] -> Q Doc-createToJSONImplementation objectName recordNames =+createToJSONImplementation :: Name -> [(Text, Name)] -> [(Text, Aeson.Value)] -> Q Doc+createToJSONImplementation objectName recordNames propsWithFixedValues = let emptyDefs = pure [] fnArgName = mkName "obj" toAssertion (jsonName, hsName) =- [|- $(varE $ mkName "Data.Aeson..=")- $(litE $ stringL $ T.unpack jsonName)- ($(varE hsName) $(varE fnArgName))- |]- toExprList :: [Q Exp] -> Q Exp- toExprList [] = [|[]|]- toExprList (x : xs) = uInfixE x (varE $ mkName ":") (toExprList xs)- toExprCombination :: [Q Exp] -> Q Exp+ [|$(stringE $ T.unpack jsonName) Aeson..= $(varE hsName) $(varE fnArgName)|]+ toFixedAssertion (jsonName, value) =+ [|$(stringE $ T.unpack jsonName) Aeson..= $(liftAesonValueWithOverloadedStrings False value)|]+ assertions = fmap toAssertion recordNames <> fmap toFixedAssertion propsWithFixedValues+ toExprList = foldr (\x expr -> uInfixE x (varE $ mkName ":") expr) [|mempty|] toExprCombination [] = [|[]|] toExprCombination [x] = x toExprCombination (x : xs) = [|$(x) <> $(toExprCombination xs)|]- defaultJsonImplementation :: [DecQ] defaultJsonImplementation =- if null recordNames- then- [ funD- (mkName "toJSON")- [ clause- [varP fnArgName]- ( normalB- [|- $(varE $ mkName "Data.Aeson.object") []- |]- )- []- ],- funD- (mkName "toEncoding")- [ clause- [varP fnArgName]- ( normalB- [|- $(varE $ mkName "Data.Aeson.pairs")- ($(varE $ mkName "Data.Aeson..=") "string" ("string" :: String))- |]- )- []- ]- ]- else- [ funD- (mkName "toJSON")- [ clause- [varP fnArgName]- ( normalB- [|- $(varE $ mkName "Data.Aeson.object")- $(toExprList $ toAssertion <$> recordNames)- |]- )- []- ],- funD- (mkName "toEncoding")- [ clause- [varP fnArgName]- ( normalB- [|- $(varE $ mkName "Data.Aeson.pairs")- $(toExprCombination $ toAssertion <$> recordNames)- |]- )- []- ]+ [ funD+ (mkName "toJSON")+ [ clause+ [varP fnArgName]+ ( normalB+ [|Aeson.object $(toExprList assertions)|]+ )+ []+ ],+ funD+ (mkName "toEncoding")+ [ clause+ [varP fnArgName]+ ( normalB+ [|Aeson.pairs $(toExprCombination assertions)|]+ )+ [] ]- in ppr <$> instanceD emptyDefs (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT objectName) defaultJsonImplementation+ ]+ in ppr <$> instanceD emptyDefs [t|Aeson.ToJSON $(varT objectName)|] defaultJsonImplementation -- | create FromJSON implementation for an object createFromJSONImplementation :: Name -> [(Text, Name)] -> Set.Set Text -> Q Doc@@ -555,10 +681,10 @@ withObjectLamda = foldl ( \prev (propName, _) ->- let propName' = litE $ stringL $ T.unpack propName+ let propName' = stringE $ T.unpack propName arg = varE fnArgName readPropE =- if propName `elem` required+ if propName `Set.member` required then [|$arg Aeson..: $propName'|] else [|$arg Aeson..:? $propName'|] in [|$prev <*> $readPropE|]@@ -574,7 +700,7 @@ [ clause [] ( normalB- [|Aeson.withObject $(litE $ stringL $ show objectName) $(lam1E (varP fnArgName) withObjectLamda)|]+ [|Aeson.withObject $(stringE $ show objectName) $(lam1E (varP fnArgName) withObjectLamda)|] ) [] ]@@ -583,25 +709,22 @@ -- | create "bangs" record fields for properties propertiesToBangTypes :: Text -> [(Text, OAS.Schema)] -> Set.Set Text -> OAM.Generator BangTypesSelfDefined propertiesToBangTypes _ [] _ = pure (pure [], emptyDoc, Set.empty)-propertiesToBangTypes schemaName props required = do- flags <- OAM.getFlags- let propertySuffix = T.pack $ OAF.optPropertyTypeSuffix flags- let createBang :: Text -> Text -> Q Type -> OAM.Generator (Q VarBangType)- createBang recordName propName myType =- let qVar :: Q VarBangType- qVar = do- bang' <- bang noSourceUnpackedness noSourceStrictness- type' <-- if recordName `elem` required- then myType- else appT (varT ''Maybe) myType- pure (haskellifyName (OAF.optConvertToCamelCase flags) False propName, bang', type')- in pure qVar+propertiesToBangTypes schemaName props required = OAM.nested "properties" $ do+ propertySuffix <- OAM.getSetting OAO.settingPropertyTypeSuffix+ convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase+ let createBang :: Text -> Text -> Q Type -> Q VarBangType+ createBang recordName propName myType = do+ bang' <- bang noSourceUnpackedness noSourceStrictness+ type' <-+ if recordName `Set.member` required+ then myType+ else appT (varT ''Maybe) myType+ pure (haskellifyName convertToCamelCase False propName, bang', type') propToBangType :: (Text, OAS.Schema) -> OAM.Generator (Q VarBangType, Q Doc, Dep.Models) propToBangType (recordName, schema) = do let propName = schemaName <> uppercaseFirstText recordName- (myType, (content, depenencies)) <- defineModelForSchemaNamed (propName <> propertySuffix) schema- myBang <- createBang recordName propName myType+ (myType, (content, depenencies)) <- OAM.nested recordName $ defineModelForSchemaNamed (propName <> propertySuffix) schema+ let myBang = createBang recordName propName myType pure (myBang, content, depenencies) foldFn :: OAM.Generator BangTypesSelfDefined -> (Text, OAS.Schema) -> OAM.Generator BangTypesSelfDefined foldFn accHolder next = do@@ -648,24 +771,28 @@ True -> Just "Must have unique items" False -> Nothing )- . OAS.uniqueItems,+ . OAS.uniqueItems, showConstraintSurrounding "Must have a maximum of " " properties" $ schema >>= OAS.maxProperties, showConstraintSurrounding "Must have a minimum of " " properties" $ schema >>= OAS.minProperties ] -- | Extracts the 'Name' of a 'OAS.SchemaObject' which should be used for primitive types-getSchemaType :: OAF.Flags -> OAS.SchemaObject -> Name-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int32", ..} = ''Int.Int32-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int64", ..} = ''Int.Int64-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, ..} = ''Integer-getSchemaType OAF.Flags {optUseFloatWithArbitraryPrecision = True, ..} OAS.SchemaObject {type' = OAS.SchemaTypeNumber, ..} = ''Scientific.Scientific-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "float", ..} = ''Float-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "double", ..} = ''Double-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, ..} = ''Double-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "byte", ..} = ''OC.JsonByteString-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "binary", ..} = ''OC.JsonByteString-getSchemaType OAF.Flags {optUseDateTypesAsString = True, ..} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date", ..} = ''Day-getSchemaType OAF.Flags {optUseDateTypesAsString = True, ..} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date-time", ..} = ''OC.JsonDateTime-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, ..} = ''Text-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeBool, ..} = ''Bool-getSchemaType _ OAS.SchemaObject {..} = ''Text+getSchemaType :: OAO.Settings -> OAS.SchemaObject -> Name+getSchemaType OAO.Settings {settingUseIntWithArbitraryPrecision = True} OAS.SchemaObject {type' = OAS.SchemaTypeInteger} = ''Integer+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int32"} = ''Int.Int32+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int64"} = ''Int.Int64+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger} = ''Int+getSchemaType OAO.Settings {settingUseFloatWithArbitraryPrecision = True} OAS.SchemaObject {type' = OAS.SchemaTypeNumber} = ''Scientific.Scientific+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "float"} = ''Float+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "double"} = ''Double+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber} = ''Double+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "byte"} = ''OC.JsonByteString+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "binary"} = ''OC.JsonByteString+getSchemaType OAO.Settings {settingUseDateTypesAsString = True} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date"} = ''Day+getSchemaType OAO.Settings {settingUseDateTypesAsString = True} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date-time"} = ''OC.JsonDateTime+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString} = ''Text+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeBool} = ''Bool+getSchemaType _ OAS.SchemaObject {} = ''Text++getCurrentPathEscaped :: OAM.Generator Text+getCurrentPathEscaped = Doc.escapeText . T.intercalate "." <$> OAM.getCurrentPath
src/OpenAPI/Generate/ModelDependencies.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-} -- | Functionality to split models into multiple modules according to their dependencies module OpenAPI.Generate.ModelDependencies@@ -11,10 +10,11 @@ ) where -import Data.List+import Data.List (find, isPrefixOf, partition)+import qualified Data.Maybe as Maybe import qualified Data.Set as Set-import qualified Data.Text as T import Data.Text (Text)+import qualified Data.Text as T import Language.Haskell.TH import Language.Haskell.TH.PprLib hiding ((<>)) import qualified OpenAPI.Generate.Doc as Doc@@ -36,58 +36,78 @@ typesModule :: String typesModule = "Types" -cyclicTypesModule :: String-cyclicTypesModule = "CyclicTypes"- -- | Analyzes the dependencies of the provided models and splits them into modules.--- All models with cyclic dependencies (between each other or to itself) are put in a module named by @cyclicTypesModule@.-getModelModulesFromModelsWithDependencies :: String -> [ModelWithDependencies] -> Q [ModuleDefinition]-getModelModulesFromModelsWithDependencies mainModuleName = createModelModules mainModuleName . extractCyclicModuleDependentModels--createModelModules :: String -> ([ModelWithDependencies], Q Doc) -> Q [ModuleDefinition]-createModelModules mainModuleName (models, cyclicModuleContentQ) = do- let prependTypesModule = ((typesModule <> ".") <>) . T.unpack- let prependMainModule = ((mainModuleName <> ".") <>)- cyclicModuleContent <- cyclicModuleContentQ- modules <-+-- All models which would form an own module but only consist of a type alias are put in a module named by 'Doc.typeAliasModule'.+getModelModulesFromModelsWithDependencies :: String -> Models -> [ModelWithDependencies] -> Q [ModuleDefinition]+getModelModulesFromModelsWithDependencies mainModuleName operationAndWhiteListDependencies models = do+ let modelsToGenerate = filterRequiredModels operationAndWhiteListDependencies models+ prependTypesModule = ((typesModule <> ".") <>) . T.unpack+ prependMainModule = ((mainModuleName <> ".") <>)+ modelsWithResolvedContent <- mapM- ( \(modelName, (doc, dependencies)) ->- ([typesModule, T.unpack modelName],)- . Doc.addModelModuleHeader- mainModuleName- (prependTypesModule modelName)- (prependTypesModule <$> Set.toList dependencies)- ("Contains the types generated from the schema " <> T.unpack modelName)- <$> doc+ ( \(name, (contentQ, dependencies)) -> do+ content <- contentQ+ pure (name, (content, dependencies)) )- models- let modelModuleNames = fmap (joinWithPoint . fst) modules+ modelsToGenerate+ let (typeAliasModels, modelsWithContent) = partition (\(_, (content, _)) -> isTypeAliasModule content) modelsWithResolvedContent+ (typeAliasModuleNames, typeAliasContent, typeAliasDependencies) =+ foldr+ ( \(name, (content, dependencies)) (names, allContent, allDependencies) ->+ (Set.insert name names, allContent $$ text "" $$ content, Set.union dependencies allDependencies)+ )+ (Set.empty, empty, Set.empty)+ typeAliasModels+ modules =+ fmap+ ( \(modelName, (doc, dependencies)) ->+ ( [typesModule, T.unpack modelName],+ Doc.addModelModuleHeader+ mainModuleName+ (prependTypesModule modelName)+ (prependTypesModule <$> Set.toList (Set.difference dependencies $ Set.insert modelName typeAliasModuleNames))+ ("Contains the types generated from the schema " <> T.unpack modelName)+ doc+ )+ )+ modelsWithContent+ modelModuleNames = fmap (joinWithPoint . fst) modules pure $ ( [typesModule], Doc.createModuleHeaderWithReexports (prependMainModule typesModule)- (fmap prependMainModule (cyclicTypesModule : modelModuleNames))+ (fmap prependMainModule (Doc.typeAliasModule : modelModuleNames)) "Rexports all type modules (used in the operation modules)."+ ) :+ ( [Doc.typeAliasModule],+ Doc.addModelModuleHeader+ mainModuleName+ Doc.typeAliasModule+ (prependTypesModule <$> Set.toList (Set.difference typeAliasDependencies typeAliasModuleNames))+ "Contains all types with cyclic dependencies (between each other or to itself)"+ typeAliasContent+ ) :+ modules++isTypeAliasModule :: Doc -> Bool+isTypeAliasModule =+ all+ ( \l ->+ isPrefixOf "--" l+ || isPrefixOf "type" l+ || null l )- : ( [cyclicTypesModule],- Doc.addModelModuleHeader- mainModuleName- cyclicTypesModule- modelModuleNames- "Contains all types with cyclic dependencies (between each other or to itself)"- cyclicModuleContent- )- : modules+ . lines+ . show -extractCyclicModuleDependentModels :: [ModelWithDependencies] -> ([ModelWithDependencies], Q Doc)-extractCyclicModuleDependentModels models =- let (cyclicModels, extractedModels) = extractUnidirectionallyDependentModels (models, [])- in (extractedModels, vcat <$> mapM (fst . snd) cyclicModels)+filterRequiredModels :: Models -> [ModelWithDependencies] -> [ModelWithDependencies]+filterRequiredModels deps models =+ let namesOfRequiredModels = resolveRequiredModels deps models+ in filter ((`Set.member` namesOfRequiredModels) . fst) models -extractUnidirectionallyDependentModels :: ([ModelWithDependencies], [ModelWithDependencies]) -> ([ModelWithDependencies], [ModelWithDependencies])-extractUnidirectionallyDependentModels (rest, extractedModels) =- let extractedModelNames = Set.fromList $ fmap fst extractedModels- (newExtractedModels, notExtractedModels) = partition ((`Set.isSubsetOf` extractedModelNames) . snd . snd) rest- in if null newExtractedModels- then (rest, extractedModels)- else extractUnidirectionallyDependentModels (notExtractedModels, extractedModels <> newExtractedModels)+resolveRequiredModels :: Models -> [ModelWithDependencies] -> Models+resolveRequiredModels deps models =+ let newDeps = Set.unions $ snd . snd <$> Maybe.mapMaybe (\dep -> find ((== dep) . fst) models) (Set.toList deps)+ in if newDeps `Set.isSubsetOf` deps+ then deps+ else resolveRequiredModels (Set.union deps newDeps) models
src/OpenAPI/Generate/Monad.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | This module contains the 'Generator' monad and functions which deal with this monad.@@ -10,9 +9,9 @@ import qualified Control.Monad.Reader as MR import qualified Control.Monad.Writer as MW-import Data.List import Data.Text (Text)-import qualified OpenAPI.Generate.Flags as OAF+import qualified OpenAPI.Generate.Log as OAL+import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Reference as Ref import qualified OpenAPI.Generate.Types as OAT import qualified OpenAPI.Generate.Types.Schema as OAS@@ -22,88 +21,69 @@ -- The 'currentPath' is updated using the 'nested' function to track the current position within the specification. -- This is used to produce tracable log messages. -- The 'references' map is a lookup table for references within the OpenAPI specification.-data GeneratorEnvironment- = GeneratorEnvironment- { currentPath :: [Text],- references :: Ref.ReferenceMap,- flags :: OAF.Flags- }- deriving (Show, Eq)---- | Data type representing the log severities-data GeneratorLogSeverity = ErrorSeverity | WarningSeverity | InfoSeverity- deriving (Show, Eq)---- | A log entry containing the location within the OpenAPI specification where the message was produced, a severity and the actual message.-data GeneratorLogEntry- = GeneratorLogEntry- { path :: [Text],- severity :: GeneratorLogSeverity,- message :: Text- }+data GeneratorEnvironment = GeneratorEnvironment+ { currentPath :: [Text],+ references :: Ref.ReferenceMap,+ settings :: OAO.Settings+ } deriving (Show, Eq) --- | The type contained in the writer of the 'Generator' used to collect log entries-type GeneratorLogs = [GeneratorLogEntry]- -- | The 'Generator' monad is used to pass a 'MR.Reader' environment to functions in need of resolving references -- and collects log messages.-newtype Generator a = Generator {unGenerator :: MW.WriterT GeneratorLogs (MR.Reader GeneratorEnvironment) a}- deriving (Functor, Applicative, Monad, MR.MonadReader GeneratorEnvironment, MW.MonadWriter GeneratorLogs)+newtype Generator a = Generator {unGenerator :: MW.WriterT OAL.LogEntries (MR.Reader GeneratorEnvironment) a}+ deriving (Functor, Applicative, Monad, MR.MonadReader GeneratorEnvironment, MW.MonadWriter OAL.LogEntries) -- | Runs the generator monad within a provided environment.-runGenerator :: GeneratorEnvironment -> Generator a -> (a, GeneratorLogs)+runGenerator :: GeneratorEnvironment -> Generator a -> (a, OAL.LogEntries) runGenerator e (Generator g) = MR.runReader (MW.runWriterT g) e --- | Create an environment based on a 'Ref.ReferenceMap' and 'OAF.Flags'-createEnvironment :: OAF.Flags -> Ref.ReferenceMap -> GeneratorEnvironment-createEnvironment flags references =+-- | Create an environment based on a 'Ref.ReferenceMap' and 'OAO.Settings'+createEnvironment :: OAO.Settings -> Ref.ReferenceMap -> GeneratorEnvironment+createEnvironment settings references = GeneratorEnvironment { currentPath = [], references = references,- flags = flags+ settings = settings } -- | Writes a log message to a 'Generator' monad-logMessage :: GeneratorLogSeverity -> Text -> Generator ()-logMessage severity message = do- path' <- MR.asks currentPath- MW.tell [GeneratorLogEntry {path = path', severity = severity, message = message}]+logMessage :: OAL.LogSeverity -> Text -> Generator ()+logMessage logEntrySeverity logEntryMessage = do+ logEntryPath <- getCurrentPath+ MW.tell [OAL.LogEntry {..}] -- | Writes an error to a 'Generator' monad logError :: Text -> Generator ()-logError = logMessage ErrorSeverity+logError = logMessage OAL.ErrorSeverity -- | Writes a warning to a 'Generator' monad logWarning :: Text -> Generator ()-logWarning = logMessage WarningSeverity+logWarning = logMessage OAL.WarningSeverity -- | Writes an info to a 'Generator' monad logInfo :: Text -> Generator ()-logInfo = logMessage InfoSeverity---- | Transforms a log returned from 'runGenerator' to a list of 'Text' values for easier printing.-transformGeneratorLogs :: GeneratorLogs -> [Text]-transformGeneratorLogs =- fmap- ( \GeneratorLogEntry {..} ->- transformSeverity severity <> " (" <> transformPath path <> "): " <> message- )---- | Transforms the severity to a 'Text' representation-transformSeverity :: GeneratorLogSeverity -> Text-transformSeverity ErrorSeverity = "ERROR"-transformSeverity WarningSeverity = "WARN"-transformSeverity InfoSeverity = "INFO"+logInfo = logMessage OAL.InfoSeverity --- | Transforms the path to a 'Text' representation (parts are seperated with a dot)-transformPath :: [Text] -> Text-transformPath = mconcat . intersperse "."+-- | Writes a trace to a 'Generator' monad+logTrace :: Text -> Generator ()+logTrace = logMessage OAL.TraceSeverity -- | This function can be used to tell the 'Generator' monad where in the OpenAPI specification the generator currently is nested :: Text -> Generator a -> Generator a nested pathItem = MR.local $ \g -> g {currentPath = currentPath g <> [pathItem]} +-- | This function can be used to tell the 'Generator' monad where in the OpenAPI specification the generator currently is (ignoring any previous path changes)+resetPath :: [Text] -> Generator a -> Generator a+resetPath path = MR.local $ \g -> g {currentPath = path}++getCurrentPath :: Generator [Text]+getCurrentPath = MR.asks currentPath++appendToPath :: [Text] -> Generator [Text]+appendToPath path = do+ p <- getCurrentPath+ pure $ p <> path+ -- | Helper function to create a lookup function for a specific type createReferenceLookupM :: (Text -> Ref.ReferenceMap -> Maybe a) -> Text -> Generator (Maybe a) createReferenceLookupM fn key = MR.asks $ fn key . references@@ -136,10 +116,10 @@ getSecuritySchemeReferenceM :: Text -> Generator (Maybe OAT.SecuritySchemeObject) getSecuritySchemeReferenceM = createReferenceLookupM Ref.getSecuritySchemeReference --- | Get all flags passed to the program-getFlags :: Generator OAF.Flags-getFlags = MR.asks flags+-- | Get all settings passed to the program+getSettings :: Generator OAO.Settings+getSettings = MR.asks settings --- | Get a specific flag selected by @f@-getFlag :: (OAF.Flags -> a) -> Generator a-getFlag f = MR.asks $ f . flags+-- | Get a specific setting selected by @f@+getSetting :: (OAO.Settings -> a) -> Generator a+getSetting f = MR.asks $ f . settings
src/OpenAPI/Generate/Operation.hs view
@@ -10,47 +10,52 @@ ) where +import qualified Control.Applicative as Applicative+import Control.Monad import qualified Data.Bifunctor as BF import qualified Data.ByteString.Char8 as B8+import qualified Data.Maybe as Maybe+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH import Language.Haskell.TH.PprLib hiding ((<>)) import qualified OpenAPI.Common as OC import qualified OpenAPI.Generate.Doc as Doc-import qualified OpenAPI.Generate.Flags as OAF import OpenAPI.Generate.Internal.Operation import OpenAPI.Generate.Internal.Util import qualified OpenAPI.Generate.Model as Model import qualified OpenAPI.Generate.ModelDependencies as Dep import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Response as OAR import qualified OpenAPI.Generate.Types as OAT -- | Defines the operations for all paths and their methods-defineOperationsForPath :: String -> Text -> OAT.PathItemObject -> OAM.Generator (Q [Dep.ModuleDefinition])-defineOperationsForPath mainModuleName requestPath =- OAM.nested requestPath- . fmap sequence- . mapM+defineOperationsForPath :: String -> Text -> OAT.PathItemObject -> OAM.Generator (Q [Dep.ModuleDefinition], Dep.Models)+defineOperationsForPath mainModuleName requestPath pathItemObject = OAM.nested requestPath $ do+ operationsToGenerate <- OAM.getSetting OAO.settingOperationsToGenerate+ fmap (BF.bimap sequence Set.unions)+ . mapAndUnzipM (uncurry (defineModuleForOperation mainModuleName requestPath))- . ( \pathItemObject ->- filterEmptyOperations- [ ("GET", OAT.get pathItemObject),- ("PUT", OAT.put pathItemObject),- ("POST", OAT.post pathItemObject),- ("DELETE", OAT.delete pathItemObject),- ("OPTIONS", OAT.options pathItemObject),- ("HEAD", OAT.head pathItemObject),- ("PATCH", OAT.patch pathItemObject),- ("TRACE", OAT.trace pathItemObject)- ]- )+ $ filterEmptyAndOmittedOperations+ operationsToGenerate+ [ ("GET", OAT.get pathItemObject),+ ("PUT", OAT.put pathItemObject),+ ("POST", OAT.post pathItemObject),+ ("DELETE", OAT.delete pathItemObject),+ ("OPTIONS", OAT.options pathItemObject),+ ("HEAD", OAT.head pathItemObject),+ ("PATCH", OAT.patch pathItemObject),+ ("TRACE", OAT.trace pathItemObject)+ ] --- | A path may define n methods--- This function filters out the empy not defined methods-filterEmptyOperations :: [(Text, Maybe OAT.OperationObject)] -> [(Text, OAT.OperationObject)]-filterEmptyOperations xs = [(method, operation) | (method, Just operation) <- xs]+filterEmptyAndOmittedOperations :: [Text] -> [(Text, Maybe OAT.OperationObject)] -> [(Text, OAT.OperationObject)]+filterEmptyAndOmittedOperations operationsToGenerate xs =+ [ (method, operation)+ | (method, Just operation) <- xs,+ null operationsToGenerate || OAT.operationId operation `elem` fmap Just operationsToGenerate+ ] -- | -- Defines an Operation for a Method and a Path@@ -68,96 +73,110 @@ -- | The Operation Object OAT.OperationObject -> -- | commented function definition and implementation- OAM.Generator (Q Dep.ModuleDefinition)+ OAM.Generator (Q Dep.ModuleDefinition, Dep.Models) defineModuleForOperation mainModuleName requestPath method operation = OAM.nested method $ do operationIdName <- getOperationName requestPath method operation- flags <- OAM.getFlags- let operationIdNameRaw = mkName $ nameBase operationIdName <> "Raw"- operationIdNameWithMonadTransformer = mkName $ nameBase operationIdName <> "M"- operationIdNameRawWithMonadTransformer = mkName $ nameBase operationIdNameRaw <> "M"- moduleName = haskellifyText (OAF.optConvertToCamelCase flags) True (T.pack $ show operationIdName)- description = Doc.escapeText $ getOperationDescription operation- monadName = mkName "m"- securitySchemeName = mkName "s"+ convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase+ let operationIdAsText = T.pack $ show operationIdName appendToOperationName = ((T.pack $ nameBase operationIdName) <>)- rawTransformation = [|id|]- OAM.logInfo $ "Generating operation with name: " <> T.pack (show operationIdName)- params <- getParametersFromOperationConcrete operation- bodySchema <- getBodySchemaFromOperation operation- (responseTypeName, responseTransformerExp, responseBodyDefinitions) <- OAR.getResponseDefinitions operation appendToOperationName- functionBody <- defineOperationFunction True operationIdName params requestPath method bodySchema responseTransformerExp- functionBodyRaw <- defineOperationFunction True operationIdNameRaw params requestPath method bodySchema rawTransformation- functionBodyWithMonadTransformer <- defineOperationFunction False operationIdNameWithMonadTransformer params requestPath method bodySchema responseTransformerExp- functionBodyRawWithMonadTransformer <- defineOperationFunction False operationIdNameRawWithMonadTransformer params requestPath method bodySchema rawTransformation- (bodyType, bodyDefinition) <- getBodyType bodySchema appendToOperationName- paramDescriptions <- (<> ["The request body to send" | not $ null bodyType]) <$> mapM getParameterDescription params- paramTypes <- mapM getParameterType params- let types = paramTypes <> bodyType- fnType = getParametersTypeForSignature types responseTypeName monadName securitySchemeName- fnTypeRaw = getParametersTypeForSignature types ''B8.ByteString monadName securitySchemeName- fnTypeWithMonadTransformer = getParametersTypeForSignatureWithMonadTransformer types responseTypeName monadName securitySchemeName- fnTypeRawWithMonadTransformer = getParametersTypeForSignatureWithMonadTransformer types ''B8.ByteString monadName securitySchemeName+ moduleName = haskellifyText convertToCamelCase True operationIdAsText+ OAM.logInfo $ "Generating operation with name '" <> operationIdAsText <> "'"+ (bodySchema, bodyPath) <- getBodySchemaFromOperation operation+ (responseTypeName, responseTransformerExp, responseBodyDefinitions, responseBodyDependencies) <- OAR.getResponseDefinitions operation appendToOperationName+ (bodyType, (bodyDefinition, bodyDependencies)) <- OAM.resetPath bodyPath $ getBodyType bodySchema appendToOperationName+ parameterCardinality <- generateParameterTypeFromOperation operationIdAsText operation+ paramDescriptions <-+ (<> ["The request body to send" | not $ null bodyType])+ <$> ( case parameterCardinality of+ NoParameters -> pure []+ SingleParameter _ _ parameter -> pure <$> getParameterDescription parameter+ MultipleParameters _ -> pure ["Contains all available parameters of this operation (query and path parameters)"]+ )+ let (paramType, paramDoc, paramDependencies) = case parameterCardinality of+ NoParameters -> ([], Doc.emptyDoc, Set.empty)+ SingleParameter paramType' (doc, deps) _ -> ([paramType'], doc, deps)+ MultipleParameters paramDefinition ->+ ( [parameterTypeDefinitionType paramDefinition],+ parameterTypeDefinitionDoc paramDefinition,+ parameterTypeDefinitionDependencies paramDefinition+ )+ types = paramType <> bodyType+ monadName = mkName "m" createFunSignature operationName fnType' = ppr <$> sigD operationName ( forallT- [plainTV monadName, plainTV securitySchemeName]- (cxt [appT (conT ''OC.MonadHTTP) (varT monadName), appT (conT ''OC.SecurityScheme) (varT securitySchemeName)])+ [plainTV monadName]+ (cxt [appT (conT ''OC.MonadHTTP) (varT monadName)]) fnType' )- fnSignature =- createFunSignature- operationIdName- fnType- fnSignatureRaw =- createFunSignature- operationIdNameRaw- fnTypeRaw- fnSignatureWithMonadTransformer =- createFunSignature- operationIdNameWithMonadTransformer- fnTypeWithMonadTransformer- fnSignatureRawWithMonadTransformer =- createFunSignature- operationIdNameRawWithMonadTransformer- fnTypeRawWithMonadTransformer methodAndPath = T.toUpper method <> " " <> requestPath operationNameAsString = nameBase operationIdName operationDescription = pure . Doc.generateHaddockComment . ("> " <> methodAndPath :) . ("" :)- pure $- ([moduleName],)- . Doc.addOperationsModuleHeader mainModuleName moduleName operationNameAsString- . ($$ text "")- <$> ( ($$)- <$> ( vcat- <$> sequence- [ operationDescription [description],- ( `Doc.sideBySide`- Doc.sideComments- ("The configuration to use in the request" : paramDescriptions <> ["Monad containing the result of the operation"])- )- . Doc.breakOnTokens ["->"]- <$> fnSignature,- functionBody,- operationDescription ["The same as '" <> T.pack operationNameAsString <> "' but returns the raw 'Data.ByteString.Char8.ByteString'"],- fnSignatureRaw,- functionBodyRaw,- operationDescription ["Monadic version of '" <> T.pack operationNameAsString <> "' (use with 'OpenAPI.Common.runWithConfiguration')"],- fnSignatureWithMonadTransformer,- functionBodyWithMonadTransformer,- operationDescription ["Monadic version of '" <> T.pack (nameBase operationIdNameRaw) <> "' (use with 'OpenAPI.Common.runWithConfiguration')"],- fnSignatureRawWithMonadTransformer,- functionBodyRawWithMonadTransformer,- bodyDefinition- ]- )- <*> responseBodyDefinitions- )+ cartesianProduct = Applicative.liftA2 (,)+ addToName suffix = mkName . (<> suffix) . nameBase+ availableOperationCombinations =+ cartesianProduct+ [ (id, responseTransformerExp, responseTypeName),+ (addToName "Raw", [|id|], ''B8.ByteString)+ ]+ [ (id, False, getParametersTypeForSignatureWithMonadTransformer),+ (addToName "WithConfiguration", True, getParametersTypeForSignature)+ ]+ description = Doc.escapeText $ getOperationDescription operation+ comments =+ [ [operationDescription [description]],+ [paramDoc, bodyDefinition, responseBodyDefinitions, operationDescription ["The same as '" <> operationIdAsText <> "' but accepts an explicit configuration."]],+ [operationDescription ["The same as '" <> operationIdAsText <> "' but returns the raw 'Data.ByteString.Char8.ByteString'."]],+ [operationDescription ["The same as '" <> operationIdAsText <> "' but accepts an explicit configuration and returns the raw 'Data.ByteString.Char8.ByteString'."]]+ ]+ functionDefinitions <-+ mapM+ ( \((f1, transformExp, responseType), (f2, explicitConfiguration, getParameterType)) -> do+ let fnName = f1 . f2 $ operationIdName+ fnSignature = createFunSignature fnName $ getParameterType types responseType monadName+ addCommentsToFnSignature =+ ( `Doc.sideBySide`+ Doc.sideComments+ ((if explicitConfiguration then ("The configuration to use in the request" :) else id) $ paramDescriptions <> ["Monadic computation which returns the result of the operation"])+ )+ . Doc.breakOnTokens ["->"]+ functionBody <- defineOperationFunction explicitConfiguration fnName parameterCardinality requestPath method bodySchema transformExp+ pure [fmap addCommentsToFnSignature fnSignature `Doc.appendDoc` functionBody]+ )+ availableOperationCombinations+ omitAdditionalFunctions <- OAM.getSetting OAO.settingOmitAdditionalOperationFunctions+ let content =+ concat $+ if omitAdditionalFunctions+ then+ zipWith+ (<>)+ [ [operationDescription [description]],+ [paramDoc, bodyDefinition, responseBodyDefinitions]+ ]+ $ (<> [[Doc.emptyDoc]]) $+ maybe [] pure $+ Maybe.listToMaybe functionDefinitions+ else zipWith (<>) comments functionDefinitions+ OAM.logTrace $ T.intercalate ", " $ Set.toList $ Set.unions [paramDependencies, bodyDependencies, responseBodyDependencies]+ pure+ ( ([moduleName],)+ . Doc.addOperationsModuleHeader mainModuleName moduleName operationNameAsString+ . ($$ text "")+ <$> ( vcat+ <$> sequence content+ ),+ Set.unions [paramDependencies, bodyDependencies, responseBodyDependencies]+ ) -getBodyType :: Maybe RequestBodyDefinition -> (Text -> Text) -> OAM.Generator ([Q Type], Q Doc)-getBodyType Nothing _ = pure ([], Doc.emptyDoc)-getBodyType (Just RequestBodyDefinition {..}) appendToOperationName = do- let transformType = pure . (if required then id else appT $ varT ''Maybe)- requestBodySuffix <- OAM.getFlag $ T.pack . OAF.optRequestBodyTypeSuffix- BF.bimap transformType fst <$> Model.defineModelForSchemaNamed (appendToOperationName requestBodySuffix) schema+getBodyType :: Maybe RequestBodyDefinition -> (Text -> Text) -> OAM.Generator ([Q Type], Dep.ModelContentWithDependencies)+getBodyType requestBody appendToOperationName = do+ generateBody <- shouldGenerateRequestBody requestBody+ case requestBody of+ Just RequestBodyDefinition {..} | generateBody -> do+ let transformType = pure . (if required then id else appT $ varT ''Maybe)+ requestBodySuffix <- OAM.getSetting OAO.settingRequestBodyTypeSuffix+ BF.first transformType <$> Model.defineModelForSchemaNamed (appendToOperationName requestBodySuffix) schema+ _ -> pure ([], (Doc.emptyDoc, Set.empty))
+ src/OpenAPI/Generate/OptParse.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++-- | This module defines the settings and their default values.+module OpenAPI.Generate.OptParse+ ( Settings (..),+ getSettings,+ )+where++import Autodocodec.Yaml+import Control.Applicative+import Control.Monad+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified OpenAPI.Generate.Log as OAL+import OpenAPI.Generate.OptParse.Configuration+import OpenAPI.Generate.OptParse.Flags+import Options.Applicative+import Options.Applicative.Help (string)+import Path.IO+import Path.Posix+import System.Exit++getSettings :: IO Settings+getSettings = do+ flags <- getFlags+ let configurationFilePath = fromMaybe "openapi-configuration.yml" $ flagConfiguration flags+ config <- getConfiguration configurationFilePath+ unless (isJust config || isNothing (flagConfiguration flags)) $ die $ "Could not read configuration file: " <> T.unpack configurationFilePath+ combineToSettings flags config configurationFilePath++data Settings = Settings+ { -- | The OpenAPI 3 specification file which code should be generated for.+ settingOpenApiSpecification :: !Text,+ -- | The directory where the generated output is stored.+ settingOutputDir :: !Text,+ -- | Name of the stack project+ settingPackageName :: !Text,+ -- | Name of the module+ settingModuleName :: !Text,+ -- | The minimum log level to output+ settingLogLevel :: !OAL.LogSeverity,+ -- | Overwrite output directory without question+ settingForce :: !Bool,+ -- | Only write new/changed files+ settingIncremental :: !Bool,+ -- | Do not generate the output files but only print the generated code+ settingDryRun :: !Bool,+ -- | Do not generate a stack project alongside the raw Haskell files+ settingDoNotGenerateStackProject :: !Bool,+ -- | Generate Nix files (default.nix and shell.nix)+ settingGenerateNixFiles :: !Bool,+ -- | Omit the additional operation functions, which are: with explicit configuration and raw variants (returning the plain ByteString) for both with and without explicit configuration+ settingOmitAdditionalOperationFunctions :: !Bool,+ -- | Force the generator to create types for empty request bodies which are optional (e. g. no properties and required equals false)+ settingGenerateOptionalEmptyRequestBody :: !Bool,+ -- | Use numbered data constructors (e. g. Variant1, Variant 2, etc.) for one-of types+ settingUseNumberedVariantConstructors :: !Bool,+ -- | Use Data.Scientific instead of Double to support arbitrary number precision+ settingUseFloatWithArbitraryPrecision :: !Bool,+ -- | Use 'Integer' instead of 'Int' to support arbitrary number precision+ settingUseIntWithArbitraryPrecision :: !Bool,+ -- | Convert strings formatted as date / date-time to date types+ settingUseDateTypesAsString :: !Bool,+ -- | Convert names to CamelCase instead of using names which are as close as possible to the names provided in the specification+ settingConvertToCamelCase :: !Bool,+ -- | Add a suffix to property types to prevent naming conflicts+ settingPropertyTypeSuffix :: !Text,+ -- | The suffix which is added to the response data types+ settingResponseTypeSuffix :: !Text,+ -- | The suffix which is added to the response body data types+ settingResponseBodyTypeSuffix :: !Text,+ -- | The suffix which is added to the request body data types+ settingRequestBodyTypeSuffix :: !Text,+ -- | The suffix which is added to the item type of an array. This is only applied to item types of top level array types which an alias is generated for.+ settingArrayItemTypeSuffix :: !Text,+ -- | The suffix which is added to the parameters type of operations+ settingParametersTypeSuffix :: !Text,+ -- | The prefix which is added to query parameters+ settingParameterQueryPrefix :: !Text,+ -- | The prefix which is added to path parameters+ settingParameterPathPrefix :: !Text,+ -- | The prefix which is added to cookie parameters+ settingParameterCookiePrefix :: !Text,+ -- | The prefix which is added to header parameters+ settingParameterHeaderPrefix :: !Text,+ -- | The operations to generate (if empty all operations are generated)+ settingOperationsToGenerate :: ![Text],+ -- | A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification)+ -- which are not further investigated while generating code from the specification.+ -- Only a type alias to 'Aeson.Value' is created for these schemas.+ settingOpaqueSchemas :: ![Text],+ -- | A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification)+ -- which need to be generated.+ -- For all other schemas only a type alias to 'Aeson.Value' is created.+ settingWhiteListedSchemas :: ![Text]+ }+ deriving (Show, Eq)++combineToSettings :: Flags -> Maybe Configuration -> Text -> IO Settings+combineToSettings Flags {..} mConf configurationFilePath = do+ let resolveRelativeToConfiguration = \case+ Just filePath -> do+ configurationDirectory <- resolveFile' $ T.unpack configurationFilePath+ file <- resolveFile (parent configurationDirectory) $ T.unpack filePath+ pure $ Just $ T.pack $ toFilePath file+ _ -> pure Nothing+ mConfigOpenApiSpecification <- resolveRelativeToConfiguration $ mc configOpenApiSpecification+ mConfigOutputDir <- resolveRelativeToConfiguration $ mc configOutputDir+ let settingOpenApiSpecification = fromMaybe "openapi-specification.yml" $ flagOpenApiSpecification <|> mConfigOpenApiSpecification+ settingOutputDir = fromMaybe "out" $ flagOutputDir <|> mConfigOutputDir+ settingPackageName = fromMaybe "openapi" $ flagPackageName <|> mc configPackageName+ settingModuleName = fromMaybe "OpenAPI" $ flagModuleName <|> mc configModuleName+ settingLogLevel = fromMaybe OAL.InfoSeverity $ flagLogLevel <|> mc configLogLevel+ settingForce = fromMaybe False $ flagForce <|> mc configForce+ settingIncremental = fromMaybe False $ flagIncremental <|> mc configIncremental+ settingDryRun = fromMaybe False $ flagDryRun <|> mc configDryRun+ settingDoNotGenerateStackProject = fromMaybe False $ flagDoNotGenerateStackProject <|> mc configDoNotGenerateStackProject+ settingGenerateNixFiles = fromMaybe False $ flagGenerateNixFiles <|> mc configGenerateNixFiles+ settingOmitAdditionalOperationFunctions = fromMaybe False $ flagOmitAdditionalOperationFunctions <|> mc configOmitAdditionalOperationFunctions+ settingGenerateOptionalEmptyRequestBody = fromMaybe False $ flagGenerateOptionalEmptyRequestBody <|> mc configGenerateOptionalEmptyRequestBody+ settingUseNumberedVariantConstructors = fromMaybe False $ flagUseNumberedVariantConstructors <|> mc configUseNumberedVariantConstructors+ settingUseFloatWithArbitraryPrecision = fromMaybe False $ flagUseFloatWithArbitraryPrecision <|> mc configUseFloatWithArbitraryPrecision+ settingUseIntWithArbitraryPrecision = fromMaybe False $ flagUseIntWithArbitraryPrecision <|> mc configUseIntWithArbitraryPrecision+ settingUseDateTypesAsString = fromMaybe False $ flagUseDateTypesAsString <|> mc configUseDateTypesAsString+ settingConvertToCamelCase = fromMaybe False $ flagConvertToCamelCase <|> mc configConvertToCamelCase+ settingPropertyTypeSuffix = fromMaybe "" $ flagPropertyTypeSuffix <|> mc configPropertyTypeSuffix+ settingResponseTypeSuffix = fromMaybe "Response" $ flagResponseTypeSuffix <|> mc configResponseTypeSuffix+ settingResponseBodyTypeSuffix = fromMaybe "ResponseBody" $ flagResponseBodyTypeSuffix <|> mc configResponseBodyTypeSuffix+ settingRequestBodyTypeSuffix = fromMaybe "RequestBody" $ flagRequestBodyTypeSuffix <|> mc configRequestBodyTypeSuffix+ settingArrayItemTypeSuffix = fromMaybe "Item" $ flagArrayItemTypeSuffix <|> mc configArrayItemTypeSuffix+ settingParametersTypeSuffix = fromMaybe "Parameters" $ flagParametersTypeSuffix <|> mc configParametersTypeSuffix+ settingParameterQueryPrefix = fromMaybe "query" $ flagParameterQueryPrefix <|> mc configParameterQueryPrefix+ settingParameterPathPrefix = fromMaybe "path" $ flagParameterPathPrefix <|> mc configParameterPathPrefix+ settingParameterCookiePrefix = fromMaybe "cookie" $ flagParameterCookiePrefix <|> mc configParameterCookiePrefix+ settingParameterHeaderPrefix = fromMaybe "header" $ flagParameterHeaderPrefix <|> mc configParameterHeaderPrefix+ settingOperationsToGenerate = fromMaybe [] $ flagOperationsToGenerate <|> mc configOperationsToGenerate+ settingOpaqueSchemas = fromMaybe [] $ flagOpaqueSchemas <|> mc configOpaqueSchemas+ settingWhiteListedSchemas = fromMaybe [] $ flagWhiteListedSchemas <|> mc configWhiteListedSchemas++ pure Settings {..}+ where+ mc :: (Configuration -> Maybe a) -> Maybe a+ mc f = mConf >>= f++getFlags :: IO Flags+getFlags = customExecParser prefs_ flagsParser++prefs_ :: ParserPrefs+prefs_ =+ defaultPrefs+ { prefShowHelpOnError = True,+ prefShowHelpOnEmpty = True+ }++flagsParser :: ParserInfo Flags+flagsParser =+ info+ (helper <*> parseFlags)+ ( fullDesc <> footerDoc (Just $ string footerStr)+ <> progDesc "This tool can be used to generate Haskell code from OpenAPI 3 specifications. For more information see https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator."+ <> header "Generate Haskell code from OpenAPI 3 specifications"+ )+ where+ footerStr =+ unlines+ [ "Configuration file format:",+ "",+ T.unpack $ TE.decodeUtf8 $ renderColouredSchemaViaCodec @Configuration+ ]
+ src/OpenAPI/Generate/OptParse/Configuration.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.OptParse.Configuration+ ( Configuration (..),+ getConfiguration,+ )+where++import Autodocodec+import Autodocodec.Yaml (readYamlConfigFile)+import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import qualified Data.Text as T+import qualified OpenAPI.Generate.Log as OAL+import Path.IO++data Configuration = Configuration+ { configOpenApiSpecification :: !(Maybe Text),+ configOutputDir :: !(Maybe Text),+ configPackageName :: !(Maybe Text),+ configModuleName :: !(Maybe Text),+ configLogLevel :: !(Maybe OAL.LogSeverity),+ configForce :: !(Maybe Bool),+ configIncremental :: !(Maybe Bool),+ configDryRun :: !(Maybe Bool),+ configDoNotGenerateStackProject :: !(Maybe Bool),+ configGenerateNixFiles :: !(Maybe Bool),+ configOmitAdditionalOperationFunctions :: !(Maybe Bool),+ configGenerateOptionalEmptyRequestBody :: !(Maybe Bool),+ configUseNumberedVariantConstructors :: !(Maybe Bool),+ configUseFloatWithArbitraryPrecision :: !(Maybe Bool),+ configUseIntWithArbitraryPrecision :: !(Maybe Bool),+ configUseDateTypesAsString :: !(Maybe Bool),+ configConvertToCamelCase :: !(Maybe Bool),+ configPropertyTypeSuffix :: !(Maybe Text),+ configResponseTypeSuffix :: !(Maybe Text),+ configResponseBodyTypeSuffix :: !(Maybe Text),+ configRequestBodyTypeSuffix :: !(Maybe Text),+ configArrayItemTypeSuffix :: !(Maybe Text),+ configParametersTypeSuffix :: !(Maybe Text),+ configParameterQueryPrefix :: !(Maybe Text),+ configParameterPathPrefix :: !(Maybe Text),+ configParameterCookiePrefix :: !(Maybe Text),+ configParameterHeaderPrefix :: !(Maybe Text),+ configOperationsToGenerate :: !(Maybe [Text]),+ configOpaqueSchemas :: !(Maybe [Text]),+ configWhiteListedSchemas :: !(Maybe [Text])+ }+ deriving stock (Show, Eq)+ deriving (FromJSON, ToJSON) via (Autodocodec Configuration)++instance HasCodec Configuration where+ codec =+ object "Configuration" $+ Configuration+ <$> optionalField "specification" "The OpenAPI 3 specification file which code should be generated for." .= configOpenApiSpecification+ <*> optionalField "outputDir" "The directory where the generated output is stored." .= configOutputDir+ <*> optionalField "packageName" "Name of the stack project" .= configPackageName+ <*> optionalField "moduleName" "Name of the module" .= configModuleName+ <*> optionalField "logLevel" "Set the minium log level (e. g. WARN to only print warnings and errors). Possible values: TRACE, INFO, WARN, ERROR" .= configLogLevel+ <*> optionalField "force" "Overwrite output directory without question" .= configForce+ <*> optionalField "incremental" "Only write new/changed files. Does not need --force flag to overwrite files." .= configIncremental+ <*> optionalField "dryRun" "Do not generate the output files but only print the generated code" .= configDryRun+ <*> optionalField "doNotGenerateStackProject" "Do not generate a stack project alongside the raw Haskell files" .= configDoNotGenerateStackProject+ <*> optionalField "generateNixFiles" "Generate Nix files alongside the raw Haskell files" .= configGenerateNixFiles+ <*> optionalField "omitAdditionalOperationFunctions" "Omit the additional operation functions, which are: with explicit configuration and raw variants (returning the plain ByteString) for both with and without explicit configuration" .= configOmitAdditionalOperationFunctions+ <*> optionalField "generateOptionalEmptyRequestBody" "Force the generator to create types for empty request bodies which are optional (e. g. no properties and required equals false)" .= configGenerateOptionalEmptyRequestBody+ <*> optionalField "useNumberedVariantConstructors" "Use numbered data constructors (e. g. Variant1, Variant 2, etc.) for one-of types" .= configUseNumberedVariantConstructors+ <*> optionalField "useFloatWithArbitraryPrecision" "Use Data.Scientific instead of Double to support arbitary number precision" .= configUseFloatWithArbitraryPrecision+ <*> optionalField "useIntWithArbitraryPrecision" "Use 'Integer' instead of 'Int' to support arbitrary number precision" .= configUseIntWithArbitraryPrecision+ <*> optionalField "useDateTypesAsString" "Convert strings formatted as date / date-time to date types" .= configUseDateTypesAsString+ <*> optionalField "convertToCamelCase" "Convert names to CamelCase instead of using names which are as close as possible to the names provided in the specification" .= configConvertToCamelCase+ <*> optionalField "propertyTypeSuffix" "Add a suffix to property types to prevent naming conflicts" .= configPropertyTypeSuffix+ <*> optionalField "responseTypeSuffix" "The suffix which is added to the response data types" .= configResponseTypeSuffix+ <*> optionalField "responseBodyTypeSuffix" "The suffix which is added to the response body data types" .= configResponseBodyTypeSuffix+ <*> optionalField "requestBodyTypeSuffix" "The suffix which is added to the request body data types" .= configRequestBodyTypeSuffix+ <*> optionalField "arrayItemTypeSuffix" "The suffix which is added to the item type of an array. This is only applied to item types of top level array types which an alias is generated for." .= configArrayItemTypeSuffix+ <*> optionalField "parametersTypeSuffix" "The suffix which is added to the parameters type of operations" .= configParametersTypeSuffix+ <*> optionalField "parameterQueryPrefix" "The prefix which is added to query parameters" .= configParameterQueryPrefix+ <*> optionalField "parameterPathPrefix" "The prefix which is added to path parameters" .= configParameterPathPrefix+ <*> optionalField "parameterCookiePrefix" "The prefix which is added to cookie parameters" .= configParameterCookiePrefix+ <*> optionalField "parameterHeaderPrefix" "The prefix which is added to header parameters" .= configParameterHeaderPrefix+ <*> optionalField "operationsToGenerate" "If not all operations should be generated, this option can be used to specify all of them which should be generated. The value has to correspond to the value in the 'operationId' field in the OpenAPI 3 specification." .= configOperationsToGenerate+ <*> optionalField "opaqueSchemas" "A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) which are not further investigated while generating code from the specification. Only a type alias to 'Aeson.Value' is created for these schemas." .= configOpaqueSchemas+ <*> optionalField "whiteListedSchemas" "A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) which need to be generated. For all other schemas only a type alias to 'Aeson.Value' is created." .= configWhiteListedSchemas++getConfiguration :: Text -> IO (Maybe Configuration)+getConfiguration path = resolveFile' (T.unpack path) >>= readYamlConfigFile
+ src/OpenAPI/Generate/OptParse/Flags.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.OptParse.Flags+ ( Flags (..),+ parseFlags,+ )+where++import Data.Text (Text)+import qualified OpenAPI.Generate.Log as OAL+import Options.Applicative++data Flags = Flags+ { flagConfiguration :: !(Maybe Text),+ flagOpenApiSpecification :: !(Maybe Text),+ flagOutputDir :: !(Maybe Text),+ flagPackageName :: !(Maybe Text),+ flagModuleName :: !(Maybe Text),+ flagLogLevel :: !(Maybe OAL.LogSeverity),+ flagForce :: !(Maybe Bool),+ flagIncremental :: !(Maybe Bool),+ flagDryRun :: !(Maybe Bool),+ flagDoNotGenerateStackProject :: !(Maybe Bool),+ flagGenerateNixFiles :: !(Maybe Bool),+ flagOmitAdditionalOperationFunctions :: !(Maybe Bool),+ flagGenerateOptionalEmptyRequestBody :: !(Maybe Bool),+ flagUseNumberedVariantConstructors :: !(Maybe Bool),+ flagUseFloatWithArbitraryPrecision :: !(Maybe Bool),+ flagUseIntWithArbitraryPrecision :: !(Maybe Bool),+ flagUseDateTypesAsString :: !(Maybe Bool),+ flagConvertToCamelCase :: !(Maybe Bool),+ flagPropertyTypeSuffix :: !(Maybe Text),+ flagResponseTypeSuffix :: !(Maybe Text),+ flagResponseBodyTypeSuffix :: !(Maybe Text),+ flagRequestBodyTypeSuffix :: !(Maybe Text),+ flagArrayItemTypeSuffix :: !(Maybe Text),+ flagParametersTypeSuffix :: !(Maybe Text),+ flagParameterQueryPrefix :: !(Maybe Text),+ flagParameterPathPrefix :: !(Maybe Text),+ flagParameterCookiePrefix :: !(Maybe Text),+ flagParameterHeaderPrefix :: !(Maybe Text),+ flagOperationsToGenerate :: !(Maybe [Text]),+ flagOpaqueSchemas :: !(Maybe [Text]),+ flagWhiteListedSchemas :: !(Maybe [Text])+ }+ deriving (Show, Eq)++parseFlags :: Parser Flags+parseFlags =+ Flags+ <$> parseFlagConfiguration+ <*> parseFlagOpenApiSpecification+ <*> parseFlagOutputDir+ <*> parseFlagPackageName+ <*> parseFlagModuleName+ <*> parseFlagLogLevel+ <*> parseFlagForce+ <*> parseFlagIncremental+ <*> parseFlagDryRun+ <*> parseFlagDoNotGenerateStackProject+ <*> parseFlagGenerateNixFiles+ <*> parseFlagOmitAdditionalOperationFunctions+ <*> parseFlagGenerateOptionalEmptyRequestBody+ <*> parseFlagUseNumberedVariantConstructors+ <*> parseFlagUseFloatWithArbitraryPrecision+ <*> parseFlagUseIntWithArbitraryPrecision+ <*> parseFlagUseDateTypesAsString+ <*> parseFlagConvertToCamelCase+ <*> parseFlagPropertyTypeSuffix+ <*> parseFlagResponseTypeSuffix+ <*> parseFlagResponseBodyTypeSuffix+ <*> parseFlagRequestBodyTypeSuffix+ <*> parseFlagArrayItemTypeSuffix+ <*> parseFlagParametersTypeSuffix+ <*> parseFlagParameterQueryPrefix+ <*> parseFlagParameterPathPrefix+ <*> parseFlagParameterCookiePrefix+ <*> parseFlagParameterHeaderPrefix+ <*> parseFlagOperationsToGenerate+ <*> parseFlagOpaqueSchemas+ <*> parseFlagWhiteListedSchemas++parseFlagConfiguration :: Parser (Maybe Text)+parseFlagConfiguration =+ optional $+ strOption $+ mconcat+ [ metavar "FILEPATH",+ help "The path to a configuration file which allows to configure the generation. Should be a YAML file (default: 'openapi-configuration.yml'). For an example see https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator/blob/master/openapi-configuration.yml.",+ long "configuration"+ ]++parseFlagOpenApiSpecification :: Parser (Maybe Text)+parseFlagOpenApiSpecification =+ let helpText = "The OpenAPI 3 specification file which code should be generated for (default: 'openapi-specification.yml')."+ varName = "FILEPATH"+ in optional $+ strArgument+ ( mconcat+ [ metavar varName,+ help helpText+ ]+ )+ <|> strOption+ ( mconcat+ [ metavar varName,+ help helpText,+ long "specification"+ ]+ )++parseFlagOutputDir :: Parser (Maybe Text)+parseFlagOutputDir =+ optional $+ strOption $+ mconcat+ [ metavar "OUTDIR",+ help "The directory where the generated output is stored (default: 'out').",+ long "output-dir",+ short 'o'+ ]++parseFlagPackageName :: Parser (Maybe Text)+parseFlagPackageName =+ optional $+ strOption $+ mconcat+ [ metavar "PACKAGE",+ help "Name of the stack project (default: 'openapi')",+ long "package-name"+ ]++parseFlagModuleName :: Parser (Maybe Text)+parseFlagModuleName =+ optional $+ strOption $+ mconcat+ [ metavar "MODULE",+ help "Name of the module (default: 'OpenAPI')",+ long "module-name"+ ]++parseFlagLogLevel :: Parser (Maybe OAL.LogSeverity)+parseFlagLogLevel =+ optional $+ option auto $+ mconcat+ [ metavar "LOGLEVEL",+ help "Set the minium log level (e. g. WARN to only print warnings and errors). Possible values: TRACE, INFO, WARN, ERROR (default: 'INFO')",+ long "log-level",+ completeWith ["TRACE", "INFO", "WARN", "ERROR"]+ ]++boolReader :: ReadM Bool+boolReader =+ maybeReader+ ( \case+ "true" -> Just True+ "True" -> Just True+ "false" -> Just False+ "False" -> Just False+ _ -> Nothing+ )++booleanFlag :: String -> String -> Maybe Char -> Parser (Maybe Bool)+booleanFlag helpText longName shortName =+ optional $+ flag'+ True+ ( mconcat+ [ help $ helpText <> " Use without argument (e. g. --" <> longName <> " to set the flag to true or use it with --" <> longName <> "=false to set it to false (or true). The equal sign is required for the parser.",+ long longName,+ maybe mempty short shortName+ ]+ )+ <|> option+ boolReader+ ( mconcat+ [ long longName,+ maybe mempty short shortName,+ internal+ ]+ )++parseFlagForce :: Parser (Maybe Bool)+parseFlagForce = booleanFlag "Overwrite output directory without question." "force" (Just 'f')++parseFlagIncremental :: Parser (Maybe Bool)+parseFlagIncremental = booleanFlag "Only write new/changed files. Does not need --force flag to overwrite files." "incremental" (Just 'i')++parseFlagDryRun :: Parser (Maybe Bool)+parseFlagDryRun = booleanFlag "Do not generate the output files but only print the generated code." "dry-run" Nothing++parseFlagDoNotGenerateStackProject :: Parser (Maybe Bool)+parseFlagDoNotGenerateStackProject = booleanFlag "Do not generate a stack project alongside the raw Haskell files." "do-not-generate-stack-project" Nothing++parseFlagGenerateNixFiles :: Parser (Maybe Bool)+parseFlagGenerateNixFiles = booleanFlag "Generate Nix files alongside the raw Haskell files." "generate-nix-files" Nothing++parseFlagOmitAdditionalOperationFunctions :: Parser (Maybe Bool)+parseFlagOmitAdditionalOperationFunctions = booleanFlag "Omit the additional operation functions, which are: with explicit configuration and raw variants (returning the plain ByteString) for both with and without explicit configuration." "omit-additional-operation-functions" Nothing++parseFlagGenerateOptionalEmptyRequestBody :: Parser (Maybe Bool)+parseFlagGenerateOptionalEmptyRequestBody = booleanFlag "Force the generator to create types for empty request bodies which are optional (e. g. no properties and required equals false)." "generate-optional-empty-request-body" Nothing++parseFlagUseNumberedVariantConstructors :: Parser (Maybe Bool)+parseFlagUseNumberedVariantConstructors = booleanFlag "Use numbered data constructors (e. g. Variant1, Variant 2, etc.) for one-of types." "use-numbered-variant-constructors" Nothing++parseFlagUseFloatWithArbitraryPrecision :: Parser (Maybe Bool)+parseFlagUseFloatWithArbitraryPrecision = booleanFlag "Use Data.Scientific instead of Double to support arbitary number precision." "use-float-with-arbitrary-precision" Nothing++parseFlagUseIntWithArbitraryPrecision :: Parser (Maybe Bool)+parseFlagUseIntWithArbitraryPrecision = booleanFlag "Use 'Integer' instead of 'Int' to support arbitrary number precision." "use-int-with-arbitrary-precision" Nothing++parseFlagUseDateTypesAsString :: Parser (Maybe Bool)+parseFlagUseDateTypesAsString = booleanFlag "Convert strings formatted as date / date-time to date types." "use-date-types-as-string" Nothing++parseFlagConvertToCamelCase :: Parser (Maybe Bool)+parseFlagConvertToCamelCase = booleanFlag "Convert names to CamelCase instead of using names which are as close as possible to the names provided in the specification." "convert-to-camel-case" Nothing++parseFlagPropertyTypeSuffix :: Parser (Maybe Text)+parseFlagPropertyTypeSuffix =+ optional $+ strOption $+ mconcat+ [ metavar "SUFFIX",+ help "Add a suffix to property types to prevent naming conflicts (default: '')",+ long "property-type-suffix"+ ]++parseFlagResponseTypeSuffix :: Parser (Maybe Text)+parseFlagResponseTypeSuffix =+ optional $+ strOption $+ mconcat+ [ metavar "SUFFIX",+ help "The suffix which is added to the response data types (default: 'Response')",+ long "response-type-suffix"+ ]++parseFlagResponseBodyTypeSuffix :: Parser (Maybe Text)+parseFlagResponseBodyTypeSuffix =+ optional $+ strOption $+ mconcat+ [ metavar "SUFFIX",+ help "The suffix which is added to the response body data types (default: 'ResponseBody')",+ long "response-body-type-suffix"+ ]++parseFlagRequestBodyTypeSuffix :: Parser (Maybe Text)+parseFlagRequestBodyTypeSuffix =+ optional $+ strOption $+ mconcat+ [ metavar "SUFFIX",+ help "The suffix which is added to the request body data types (default: 'RequestBody')",+ long "request-body-type-suffix"+ ]++parseFlagArrayItemTypeSuffix :: Parser (Maybe Text)+parseFlagArrayItemTypeSuffix =+ optional $+ strOption $+ mconcat+ [ metavar "SUFFIX",+ help "The suffix which is added to the item type of an array (default: 'Item'). This is only applied to item types of top level array types which an alias is generated for.",+ long "array-item-type-suffix"+ ]++parseFlagParametersTypeSuffix :: Parser (Maybe Text)+parseFlagParametersTypeSuffix =+ optional $+ strOption $+ mconcat+ [ metavar "SUFFIX",+ help "The suffix which is added to the parameters type of operations (default: 'Parameters')",+ long "parameters-type-suffix"+ ]++parseFlagParameterQueryPrefix :: Parser (Maybe Text)+parseFlagParameterQueryPrefix =+ optional $+ strOption $+ mconcat+ [ metavar "PREFIX",+ help "The prefix which is added to query parameters (default: 'query')",+ long "parameter-query-prefix"+ ]++parseFlagParameterPathPrefix :: Parser (Maybe Text)+parseFlagParameterPathPrefix =+ optional $+ strOption $+ mconcat+ [ metavar "PREFIX",+ help "The prefix which is added to path parameters (default: 'path')",+ long "parameter-path-prefix"+ ]++parseFlagParameterCookiePrefix :: Parser (Maybe Text)+parseFlagParameterCookiePrefix =+ optional $+ strOption $+ mconcat+ [ metavar "PREFIX",+ help "The prefix which is added to cookie parameters (default: 'cookie')",+ long "parameter-cookie-prefix"+ ]++parseFlagParameterHeaderPrefix :: Parser (Maybe Text)+parseFlagParameterHeaderPrefix =+ optional $+ strOption $+ mconcat+ [ metavar "PREFIX",+ help "The prefix which is added to header parameters (default: 'header')",+ long "parameter-header-prefix"+ ]++parseFlagOperationsToGenerate :: Parser (Maybe [Text])+parseFlagOperationsToGenerate =+ optional $+ some $+ strOption $+ mconcat+ [ metavar "OPERATIONID",+ help "If not all operations should be generated, this option can be used to specify all of them which should be generated. The value has to correspond to the value in the 'operationId' field in the OpenAPI 3 specification.",+ long "operation-to-generate"+ ]++parseFlagOpaqueSchemas :: Parser (Maybe [Text])+parseFlagOpaqueSchemas =+ optional $+ some $+ strOption $+ mconcat+ [ metavar "SCHEMA",+ help "A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) which are not further investigated while generating code from the specification. Only a type alias to 'Aeson.Value' is created for these schemas.",+ long "opaque-schema"+ ]++parseFlagWhiteListedSchemas :: Parser (Maybe [Text])+parseFlagWhiteListedSchemas =+ optional $+ some $+ strOption $+ mconcat+ [ metavar "SCHEMA",+ help "A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) which need to be generated. For all other schemas only a type alias to 'Aeson.Value' is created.",+ long "white-listed-schema"+ ]
src/OpenAPI/Generate/Response.hs view
@@ -23,11 +23,12 @@ import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Types as HT import qualified OpenAPI.Generate.Doc as Doc-import qualified OpenAPI.Generate.Flags as OAF import OpenAPI.Generate.Internal.Operation import OpenAPI.Generate.Internal.Util import qualified OpenAPI.Generate.Model as Model+import qualified OpenAPI.Generate.ModelDependencies as Dep import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Types as OAT -- | Generates a response type with a constructor for all possible response types of the operation.@@ -40,40 +41,37 @@ (Text -> Text) -> -- | Returns the name of the reponse data type, the response transformation function and the document containing -- the definitions of all response types.- OAM.Generator (Name, Q Exp, Q Doc)-getResponseDefinitions operation appendToOperationName = do- convertToCamelCase <- OAM.getFlag OAF.optConvertToCamelCase- responseSuffix <- OAM.getFlag $ T.pack . OAF.optResponseTypeSuffix- responseBodySuffix <- OAM.getFlag $ T.pack . OAF.optResponseBodyTypeSuffix+ OAM.Generator (Name, Q Exp, Q Doc, Dep.Models)+getResponseDefinitions operation appendToOperationName = OAM.nested "responses" $ do+ convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase+ responseSuffix <- OAM.getSetting OAO.settingResponseTypeSuffix+ responseBodySuffix <- OAM.getSetting OAO.settingResponseBodyTypeSuffix let responsesObject = OAT.responses (operation :: OAT.OperationObject) createBodyName = createResponseNameAsText convertToCamelCase appendToOperationName . (responseBodySuffix <>) createName = createResponseName convertToCamelCase appendToOperationName . (responseSuffix <>) responseName = createName "" responseReferenceCases = getStatusCodeResponseCases responsesObject <> getRangeResponseCases responsesObject responseCases <- resolveResponseReferences responseReferenceCases- let responseDescriptions = getResponseDescription . (\(_, _, r) -> r) <$> responseCases+ let responseDescriptions = getResponseDescription . (\(_, _, (r, _)) -> r) <$> responseCases schemas <- generateResponseCaseDefinitions createBodyName responseCases- pure $ (responseName,createResponseTransformerFn createName schemas,) $- vcat- <$> sequence- [ pure $- Doc.generateHaddockComment- [ "Represents a response of the operation '" <> appendToOperationName "" <> "'.",- "",- "The response constructor is chosen by the status code of the response. If no case matches (no specific case for the response code, no range case, no default case), '"- <> createResponseNameAsText convertToCamelCase appendToOperationName (responseSuffix <> errorSuffix)- <> "' is used."- ],- ( `Doc.sideBySide`- (text "" $$ Doc.sideComments ("Means either no matching case available or a parse error" : responseDescriptions))- )- . Doc.breakOnTokensWithReplacement- ( \case- "=" -> "=\n "- token -> "\n " <> token- )- ["=", "deriving", "|"]- . ppr+ let dependencies = Set.unions $ snd . snd <$> Maybe.mapMaybe (\(_, _, x) -> x) schemas+ pure $+ (responseName,createResponseTransformerFn createName schemas,,dependencies) $+ vcat+ <$> sequence+ [ pure $+ Doc.generateHaddockComment+ [ "Represents a response of the operation '" <> appendToOperationName "" <> "'.",+ "",+ "The response constructor is chosen by the status code of the response. If no case matches (no specific case for the response code, no range case, no default case), '"+ <> createResponseNameAsText convertToCamelCase appendToOperationName (responseSuffix <> errorSuffix)+ <> "' is used."+ ],+ ( `Doc.sideBySide`+ (text "" $$ Doc.sideComments ("Means either no matching case available or a parse error" : responseDescriptions))+ )+ . Doc.reformatADT+ . ppr <$> dataD (cxt []) responseName@@ -91,8 +89,8 @@ ((errorSuffix, [||const True||], Just ([t|String|], (Doc.emptyDoc, Set.empty))) : schemas) ) [derivClause Nothing [conT ''Show, conT ''Eq]],- printSchemaDefinitions schemas- ]+ printSchemaDefinitions schemas+ ] -- | First: suffix to append to the data constructor name -- Second: an expression which can be used to determine if this case should be used in regard to the response status@@ -100,7 +98,7 @@ type ResponseReferenceCase = (Text, TExpQ (HT.Status -> Bool), OAT.Referencable OAT.ResponseObject) -- | Same as @ResponseReferenceCase@ but with resolved reference-type ResponseCase = (Text, TExpQ (HT.Status -> Bool), OAT.ResponseObject)+type ResponseCase = (Text, TExpQ (HT.Status -> Bool), (OAT.ResponseObject, [Text])) -- | Same as @ResponseReferenceCase@ but with type definition type ResponseCaseDefinition = (Text, TExpQ (HT.Status -> Bool), Maybe Model.TypeWithDeclaration)@@ -153,9 +151,9 @@ generateResponseCaseDefinitions :: (Text -> Text) -> [ResponseCase] -> OAM.Generator [ResponseCaseDefinition] generateResponseCaseDefinitions createBodyName = mapM- ( \(suffix, guard, r) -> OAM.nested suffix $ do- responseSchema <- getResponseSchema r- (suffix,guard,) <$> mapM (Model.defineModelForSchemaNamed $ createBodyName suffix) responseSchema+ ( \(suffix, guard, (r, path)) -> OAM.resetPath path $ do+ (responseSchema, path') <- getResponseSchema r+ (suffix,guard,) <$> mapM (OAM.resetPath path' . Model.defineModelForSchemaNamed (createBodyName suffix)) responseSchema ) -- | Prints the definitions of the different response case data types in 'Q'@@ -184,7 +182,7 @@ schemas <> [normalGE [|otherwise|] [|Left "Missing default response type"|]] transformLambda = lamE [varP responseArgName, varP bodyName] ifCases- in [|fmap (fmap (\response -> fmap (Either.either $(varE $ createName errorSuffix) id . $transformLambda response) response))|]+ in [|fmap (\response -> fmap (Either.either $(varE $ createName errorSuffix) id . $transformLambda response) response)|] getResponseDescription :: OAT.ResponseObject -> Text getResponseDescription response = Doc.escapeText $ OAT.description (response :: OAT.ResponseObject)
src/OpenAPI/Generate/SecurityScheme.hs view
@@ -10,7 +10,7 @@ import qualified Data.Bifunctor as BF import qualified Data.Maybe as Maybe-import Data.Text (Text)+import Data.Text (Text, unpack) import Language.Haskell.TH import Language.Haskell.TH.PprLib hiding ((<>)) import qualified Network.HTTP.Client as HC@@ -28,9 +28,9 @@ let securitySchemeDefinitions = fmap (BF.second $ defineSecurityScheme moduleName) securitySchemes mapM_ ( \(name, _) ->- OAM.nested name- $ OAM.logWarning- $ "The security scheme '" <> name <> "' is not supported (currently only http-basic and http-bearer are supported)."+ OAM.nested name $+ OAM.logWarning $+ "The security scheme '" <> name <> "' is not supported (currently only http-basic and http-bearer are supported)." ) $ filter (Maybe.isNothing . snd) securitySchemeDefinitions pure $ fmap vcat $ mapM (fmap ($$ text "") . snd) $ Maybe.mapMaybe sequence securitySchemeDefinitions@@ -43,20 +43,20 @@ "basic" -> Just $ basicAuthenticationScheme moduleName description "bearer" -> Just $ bearerAuthenticationScheme moduleName description _ -> Nothing+defineSecurityScheme moduleName (OAT.ApiKeySecuritySchemeObject scheme) =+ let description = Doc.escapeText $ Maybe.fromMaybe "" $ OAT.description (scheme :: OAT.ApiKeySecurityScheme)+ name = OAT.name (scheme :: OAT.ApiKeySecurityScheme)+ in case OAT.in' (scheme :: OAT.ApiKeySecurityScheme) of+ OAT.HeaderApiKeySecuritySchemeLocation -> Just $ apiKeyInHeaderAuthenticationScheme name moduleName description+ _ -> Nothing defineSecurityScheme _ _ = Nothing --- | The name used in the instance declaration (referencing 'OC.authenticateRequest').--- It is necessary because it is not possible to fully qualify the name in the instance declaration.-authenticateRequestName :: Name-authenticateRequestName = mkName "authenticateRequest"- -- | BasicAuthentication scheme with simple username and password basicAuthenticationScheme :: Text -> Text -> Q Doc basicAuthenticationScheme moduleName description =- let dataName = mkName "BasicAuthenticationSecurityScheme"- usernameName = mkName "basicAuthenticationSecuritySchemeUsername"- passwordName = mkName "basicAuthenticationSecuritySchemePassword"- paramName = mkName "basicAuth"+ let dataName = mkName "BasicAuthenticationData"+ usernameName = mkName "basicAuthenticationDataUsername"+ passwordName = mkName "basicAuthenticationDataPassword" dataDefinition = dataD (cxt [])@@ -70,97 +70,96 @@ ] ] [derivClause Nothing [conT ''Show, conT ''Ord, conT ''Eq]]- instanceDefinition =- instanceD- (cxt [])- (appT (conT ''OC.SecurityScheme) (conT dataName))- [ funD- authenticateRequestName- [ clause- [varP paramName]- ( normalB- [|- HC.applyBasicAuth- (OC.textToByte $ $(varE usernameName) $(varE paramName))- (OC.textToByte $ $(varE passwordName) $(varE paramName))- |]- )- []- ]- ]+ fnName = mkName "basicAuthenticationSecurityScheme"+ functionType = sigD fnName [t|$(varT dataName) -> OC.SecurityScheme|]+ functionBody =+ [d|+ $(varP fnName) = \basicAuth ->+ HC.applyBasicAuth+ (OC.textToByte $ $(varE usernameName) basicAuth)+ (OC.textToByte $ $(varE passwordName) basicAuth)+ |] in vcat <$> sequence [ ($$ text "") . ( Doc.generateHaddockComment- [ "Use this security scheme to use basic authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.",- "",- description,- "",- "@",- "'" <> moduleName <> ".Configuration.defaultConfiguration'",- " { configSecurityScheme =",- " 'BasicAuthenticationSecurityScheme'",- " { 'basicAuthenticationSecuritySchemeUsername' = \"user\",",- " 'basicAuthenticationSecuritySchemePassword' = \"pw\"",- " }",- " }",- "@"+ [ "Used to pass the authentication information for BasicAuthentication to 'basicAuthenticationSecurityScheme'." ] $$ )- . ppr <$> dataDefinition,- ppr <$> instanceDefinition+ . ppr+ <$> dataDefinition,+ ( Doc.generateHaddockComment+ [ "Use this security scheme to use basic authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.",+ "",+ description,+ "",+ "@",+ "'" <> moduleName <> ".Configuration.defaultConfiguration'",+ " { configSecurityScheme =",+ " 'basicAuthenticationSecurityScheme' 'BasicAuthenticationData'",+ " { 'basicAuthenticationDataUsername' = \"user\",",+ " 'basicAuthenticationDataPassword' = \"pw\"",+ " }",+ " }",+ "@"+ ]+ $$+ )+ . ppr+ <$> functionType,+ ppr <$> functionBody ] -- | BearerAuthentication scheme with a bearer token bearerAuthenticationScheme :: Text -> Text -> Q Doc bearerAuthenticationScheme moduleName description =- let dataName = mkName "BearerAuthenticationSecurityScheme"- tokenName = mkName "token"- dataDefinition =- dataD- (cxt [])- dataName- []- Nothing- [ normalC- dataName- [bangType (bang noSourceUnpackedness noSourceStrictness) $ conT ''Text]- ]- [derivClause Nothing [conT ''Show, conT ''Ord, conT ''Eq]]- instanceDefinition =- instanceD- (cxt [])- (appT (conT ''OC.SecurityScheme) (conT dataName))- [ funD- authenticateRequestName- [ clause- [conP dataName [varP tokenName]]- ( normalB- [|- HS.addRequestHeader "Authorization" $ OC.textToByte $ "Bearer " <> $(varE tokenName)- |]- )- []- ]+ let fnName = mkName "bearerAuthenticationSecurityScheme"+ functionType = sigD fnName [t|Text -> OC.SecurityScheme|]+ functionBody = [d|$(varP fnName) = \token -> HS.addRequestHeader "Authorization" $ OC.textToByte $ "Bearer " <> token|]+ in vcat+ <$> sequence+ [ ( Doc.generateHaddockComment+ [ "Use this security scheme to use bearer authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.",+ "",+ description,+ "",+ "@",+ "'" <> moduleName <> ".Configuration.defaultConfiguration'",+ " { configSecurityScheme = 'bearerAuthenticationSecurityScheme' \"token\"",+ " }",+ "@"+ ]+ $$+ )+ . ppr+ <$> functionType,+ ppr <$> functionBody ]++-- | ApiKeyAuthentication scheme with a bearer token+apiKeyInHeaderAuthenticationScheme :: Text -> Text -> Text -> Q Doc+apiKeyInHeaderAuthenticationScheme headerName moduleName description =+ let fnName = mkName "apiKeyInHeaderAuthenticationSecurityScheme"+ functionType = sigD fnName [t|Text -> OC.SecurityScheme|]+ headerName' = stringE $ Data.Text.unpack headerName+ functionBody = [d|$(varP fnName) = HS.addRequestHeader $(headerName') . OC.textToByte|] in vcat <$> sequence- [ ($$ text "")- . ( Doc.generateHaddockComment- [ "Use this security scheme to use bearer authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.",- "",- description,- "",- "@",- "'" <> moduleName <> ".Configuration.defaultConfiguration'",- " { configSecurityScheme = 'BearerAuthenticationSecurityScheme' \"token\"",- " }",- "@"- ]- $$- )+ [ ( Doc.generateHaddockComment+ [ "Use this security scheme to use token in HTTP header for authentication. Should be used in a 'OpenAPI.Common.Configuration'.",+ "",+ description,+ "",+ "@",+ "'" <> moduleName <> ".Configuration.defaultConfiguration'",+ " { configSecurityScheme = 'apiKeyInHeaderAuthenticationSecurityScheme' \"token\"",+ " }",+ "@"+ ]+ $$+ ) . ppr- <$> dataDefinition,- ppr <$> instanceDefinition+ <$> functionType,+ ppr <$> functionBody ]
src/OpenAPI/Generate/Types.hs view
@@ -30,17 +30,16 @@ import OpenAPI.Generate.Types.Schema (Schema) import Text.Read (readMaybe) -data OpenApiSpecification- = OpenApiSpecification- { openapi :: Text,- info :: InfoObject,- servers :: [ServerObject],- paths :: PathsObject,- components :: ComponentsObject,- security :: [SecurityRequirementObject],- tags :: [TagObject],- externalDocs :: Maybe ExternalDocumentationObject- }+data OpenApiSpecification = OpenApiSpecification+ { openapi :: Text,+ info :: InfoObject,+ servers :: [ServerObject],+ paths :: PathsObject,+ components :: ComponentsObject,+ security :: [SecurityRequirementObject],+ tags :: [TagObject],+ externalDocs :: Maybe ExternalDocumentationObject+ } deriving (Show, Eq, Generic) instance FromJSON OpenApiSpecification where@@ -64,56 +63,52 @@ <*> o .:? "tags" .!= [] <*> o .:? "externalDocs" -data InfoObject- = InfoObject- { title :: Text,- description :: Maybe Text,- termsOfService :: Maybe Text,- contact :: Maybe ContactObject,- license :: Maybe LicenseObject,- version :: Text- }+data InfoObject = InfoObject+ { title :: Text,+ description :: Maybe Text,+ termsOfService :: Maybe Text,+ contact :: Maybe ContactObject,+ license :: Maybe LicenseObject,+ version :: Text+ } deriving (Show, Eq, Generic) instance FromJSON InfoObject -data ContactObject- = ContactObject- { name :: Maybe Text,- url :: Maybe Text,- email :: Maybe Text- }+data ContactObject = ContactObject+ { name :: Maybe Text,+ url :: Maybe Text,+ email :: Maybe Text+ } deriving (Show, Eq, Generic) instance FromJSON ContactObject -data LicenseObject- = LicenseObject- { name :: Text,- url :: Maybe Text- }+data LicenseObject = LicenseObject+ { name :: Text,+ url :: Maybe Text+ } deriving (Show, Eq, Generic) instance FromJSON LicenseObject type PathsObject = Map.Map Text PathItemObject -data PathItemObject- = PathItemObject- { ref :: Maybe Text,- summary :: Maybe Text,- description :: Maybe Text,- get :: Maybe OperationObject,- put :: Maybe OperationObject,- post :: Maybe OperationObject,- delete :: Maybe OperationObject,- options :: Maybe OperationObject,- head :: Maybe OperationObject,- patch :: Maybe OperationObject,- trace :: Maybe OperationObject,- servers :: [ServerObject],- parameters :: [Referencable ParameterObject]- }+data PathItemObject = PathItemObject+ { ref :: Maybe Text,+ summary :: Maybe Text,+ description :: Maybe Text,+ get :: Maybe OperationObject,+ put :: Maybe OperationObject,+ post :: Maybe OperationObject,+ delete :: Maybe OperationObject,+ options :: Maybe OperationObject,+ head :: Maybe OperationObject,+ patch :: Maybe OperationObject,+ trace :: Maybe OperationObject,+ servers :: [ServerObject],+ parameters :: [Referencable ParameterObject]+ } deriving (Show, Eq, Generic) instance FromJSON PathItemObject where@@ -133,21 +128,20 @@ <*> o .:? "servers" .!= [] <*> o .:? "parameters" .!= [] -data OperationObject- = OperationObject- { tags :: [Text],- summary :: Maybe Text,- description :: Maybe Text,- externalDocs :: Maybe ExternalDocumentationObject,- operationId :: Maybe Text,- parameters :: [Referencable ParameterObject],- requestBody :: Maybe (Referencable RequestBodyObject),- responses :: ResponsesObject,- deprecated :: Bool,- security :: [SecurityRequirementObject],- servers :: [ServerObject]- -- callbacks (http://spec.openapis.org/oas/v3.0.3#operation-object) are omitted because they are not needed- }+data OperationObject = OperationObject+ { tags :: [Text],+ summary :: Maybe Text,+ description :: Maybe Text,+ externalDocs :: Maybe ExternalDocumentationObject,+ operationId :: Maybe Text,+ parameters :: [Referencable ParameterObject],+ requestBody :: Maybe (Referencable RequestBodyObject),+ responses :: ResponsesObject,+ deprecated :: Bool,+ security :: [SecurityRequirementObject],+ servers :: [ServerObject]+ -- callbacks (http://spec.openapis.org/oas/v3.0.3#operation-object) are omitted because they are not needed+ } deriving (Show, Eq, Generic) instance FromJSON OperationObject where@@ -167,12 +161,11 @@ type SecurityRequirementObject = Map.Map Text [Text] -data RequestBodyObject- = RequestBodyObject- { content :: Map.Map Text MediaTypeObject,- description :: Maybe Text,- required :: Bool- }+data RequestBodyObject = RequestBodyObject+ { content :: Map.Map Text MediaTypeObject,+ description :: Maybe Text,+ required :: Bool+ } deriving (Show, Eq, Generic) instance FromJSON RequestBodyObject where@@ -182,13 +175,12 @@ <*> o .:? "description" <*> o .:? "required" .!= False -data MediaTypeObject- = MediaTypeObject- { schema :: Maybe Schema,- example :: Maybe Value,- examples :: Map.Map Text (Referencable ExampleObject),- encoding :: Map.Map Text EncodingObject- }+data MediaTypeObject = MediaTypeObject+ { schema :: Maybe Schema,+ example :: Maybe Value,+ examples :: Map.Map Text (Referencable ExampleObject),+ encoding :: Map.Map Text EncodingObject+ } deriving (Show, Eq, Generic) instance FromJSON MediaTypeObject where@@ -199,25 +191,23 @@ <*> o .:? "examples" .!= Map.empty <*> o .:? "encoding" .!= Map.empty -data ExampleObject- = ExampleObject- { summary :: Maybe Text,- description :: Maybe Text,- value :: Maybe Value, -- value and externalValue are mutually exclusive, maybe this should be encoded in this data type- externalValue :: Maybe Text- }+data ExampleObject = ExampleObject+ { summary :: Maybe Text,+ description :: Maybe Text,+ value :: Maybe Value, -- value and externalValue are mutually exclusive, maybe this should be encoded in this data type+ externalValue :: Maybe Text+ } deriving (Show, Eq, Generic) instance FromJSON ExampleObject -data EncodingObject- = EncodingObject- { contentType :: Maybe Text,- headers :: Map.Map Text (Referencable HeaderObject),- style :: Maybe Text,- explode :: Bool,- allowReserved :: Bool- }+data EncodingObject = EncodingObject+ { contentType :: Maybe Text,+ headers :: Map.Map Text (Referencable HeaderObject),+ style :: Maybe Text,+ explode :: Bool,+ allowReserved :: Bool+ } deriving (Show, Eq, Generic) instance FromJSON EncodingObject where@@ -229,16 +219,15 @@ <*> o .:? "explode" .!= True <*> o .:? "allowReserved" .!= False -data ResponsesObject- = ResponsesObject- { default' :: Maybe (Referencable ResponseObject),- range1XX :: Maybe (Referencable ResponseObject),- range2XX :: Maybe (Referencable ResponseObject),- range3XX :: Maybe (Referencable ResponseObject),- range4XX :: Maybe (Referencable ResponseObject),- range5XX :: Maybe (Referencable ResponseObject),- perStatusCode :: Map.Map Int (Referencable ResponseObject)- }+data ResponsesObject = ResponsesObject+ { default' :: Maybe (Referencable ResponseObject),+ range1XX :: Maybe (Referencable ResponseObject),+ range2XX :: Maybe (Referencable ResponseObject),+ range3XX :: Maybe (Referencable ResponseObject),+ range4XX :: Maybe (Referencable ResponseObject),+ range5XX :: Maybe (Referencable ResponseObject),+ perStatusCode :: Map.Map Int (Referencable ResponseObject)+ } deriving (Show, Eq, Generic) instance FromJSON ResponsesObject where@@ -260,13 +249,12 @@ $ HMap.toList o ) -data ResponseObject- = ResponseObject- { description :: Text,- headers :: Map.Map Text (Referencable HeaderObject),- content :: Map.Map Text MediaTypeObject- -- links (http://spec.openapis.org/oas/v3.0.3#fixed-fields-14) are omitted because they are not needed- }+data ResponseObject = ResponseObject+ { description :: Text,+ headers :: Map.Map Text (Referencable HeaderObject),+ content :: Map.Map Text MediaTypeObject+ -- links (http://spec.openapis.org/oas/v3.0.3#fixed-fields-14) are omitted because they are not needed+ } deriving (Show, Eq, Generic) instance FromJSON ResponseObject where@@ -276,12 +264,11 @@ <*> o .:? "headers" .!= Map.empty <*> o .:? "content" .!= Map.empty -data ServerObject- = ServerObject- { url :: Text,- description :: Maybe Text,- variables :: Map.Map Text ServerVariableObject- }+data ServerObject = ServerObject+ { url :: Text,+ description :: Maybe Text,+ variables :: Map.Map Text ServerVariableObject+ } deriving (Show, Eq, Generic) instance FromJSON ServerObject where@@ -291,12 +278,11 @@ <*> o .:? "description" <*> o .:? "variables" .!= Map.empty -data ServerVariableObject- = ServerVariableObject- { enum :: [Text],- default' :: Text,- description :: Maybe Text- }+data ServerVariableObject = ServerVariableObject+ { enum :: [Text],+ default' :: Text,+ description :: Maybe Text+ } deriving (Show, Eq, Generic) instance FromJSON ServerVariableObject where@@ -306,16 +292,15 @@ <*> o .: "default" <*> o .:? "description" -data ParameterObject- = ParameterObject- { name :: Text,- in' :: ParameterObjectLocation,- description :: Maybe Text,- required :: Bool,- deprecated :: Bool,- allowEmptyValue :: Bool,- schema :: ParameterObjectSchema- }+data ParameterObject = ParameterObject+ { name :: Text,+ in' :: ParameterObjectLocation,+ description :: Maybe Text,+ required :: Bool,+ deprecated :: Bool,+ allowEmptyValue :: Bool,+ schema :: ParameterObjectSchema+ } deriving (Show, Eq, Generic) instance FromJSON ParameterObject where@@ -329,7 +314,11 @@ <*> o .:? "allowEmptyValue" .!= False <*> parseJSON (Object o) -data ParameterObjectLocation = QueryParameterObjectLocation | HeaderParameterObjectLocation | PathParameterObjectLocation | CookieParameterObjectLocation+data ParameterObjectLocation+ = QueryParameterObjectLocation+ | HeaderParameterObjectLocation+ | PathParameterObjectLocation+ | CookieParameterObjectLocation deriving (Show, Eq, Generic) instance FromJSON ParameterObjectLocation where@@ -341,14 +330,7 @@ _ -> fail "A ParameterObject must have a value of 'query', 'header', 'path' or 'cookie' in the property 'in'." data ParameterObjectSchema- = SimpleParameterObjectSchema- { style :: Maybe Text,- explode :: Bool,- allowReserved :: Bool,- schema :: Schema,- example :: Maybe Value,- examples :: Map.Map Text (Referencable ExampleObject)- }+ = SimpleParameterObjectSchema SimpleParameterSchema | ComplexParameterObjectSchema (Map.Map Text MediaTypeObject) deriving (Show, Eq, Generic) @@ -356,19 +338,33 @@ parseJSON = withObject "ParameterObjectSchema" $ \o -> do maybeSchema <- o .:? "schema" maybeContent <- o .:? "content"- case (maybeSchema, maybeContent) of- (Just schema', Nothing) ->- SimpleParameterObjectSchema- <$> o .:? "style"- <*> o .:? "explode" .!= True- <*> o .:? "allowReserved" .!= False- <*> pure schema'- <*> o .:? "example"- <*> o .:? "examples" .!= Map.empty+ case (maybeSchema :: Maybe Schema, maybeContent) of+ (Just _, Nothing) -> SimpleParameterObjectSchema <$> parseJSON (Object o) (Nothing, Just content') -> pure $ ComplexParameterObjectSchema content' (Just _, Just _) -> fail "ParameterObject (http://spec.openapis.org/oas/v3.0.3#parameter-object) only allows one of the properties schema and content." (Nothing, Nothing) -> fail "ParameterObject (http://spec.openapis.org/oas/v3.0.3#parameter-object) requires one of the properties schema and content to be present." +data SimpleParameterSchema = SimpleParameterSchema+ { style :: Maybe Text,+ explode :: Bool,+ allowReserved :: Bool,+ schema :: Schema,+ example :: Maybe Value,+ examples :: Map.Map Text (Referencable ExampleObject)+ }+ deriving (Show, Eq, Generic)++instance FromJSON SimpleParameterSchema where+ parseJSON = withObject "SimpleParameterSchema" $ \o -> do+ maybeStyle <- o .:? "style"+ SimpleParameterSchema+ <$> o .:? "style"+ <*> o .:? "explode" .!= ((maybeStyle :: Maybe Text) == Just "form") -- The default value is true for form and false otherwise (http://spec.openapis.org/oas/v3.0.3#parameterExplode)+ <*> o .:? "allowReserved" .!= False+ <*> o .: "schema"+ <*> o .:? "example"+ <*> o .:? "examples" .!= Map.empty+ newtype HeaderObject = HeaderObject ParameterObject deriving (Show, Eq, Generic) @@ -383,17 +379,16 @@ <*> parseJSON (Object o) ) -data ComponentsObject- = ComponentsObject- { schemas :: Map.Map Text Schema,- responses :: Map.Map Text (Referencable ResponseObject),- parameters :: Map.Map Text (Referencable ParameterObject),- examples :: Map.Map Text (Referencable ExampleObject),- requestBodies :: Map.Map Text (Referencable RequestBodyObject),- headers :: Map.Map Text (Referencable HeaderObject),- securitySchemes :: Map.Map Text (Referencable SecuritySchemeObject)- -- links and callbacks are omitted because they are not supported in the generator- }+data ComponentsObject = ComponentsObject+ { schemas :: Map.Map Text Schema,+ responses :: Map.Map Text (Referencable ResponseObject),+ parameters :: Map.Map Text (Referencable ParameterObject),+ examples :: Map.Map Text (Referencable ExampleObject),+ requestBodies :: Map.Map Text (Referencable RequestBodyObject),+ headers :: Map.Map Text (Referencable HeaderObject),+ securitySchemes :: Map.Map Text (Referencable SecuritySchemeObject)+ -- links and callbacks are omitted because they are not supported in the generator+ } deriving (Show, Eq, Generic) instance FromJSON ComponentsObject where@@ -424,12 +419,11 @@ "openIdConnect" -> OpenIdConnectSecuritySchemeObject <$> parseJSON (Object o) _ -> fail "A SecuritySchemeObject must have a value of 'apiKey', 'http', 'oauth2' or 'openIdConnect' in the property 'type'." -data ApiKeySecurityScheme- = ApiKeySecurityScheme- { description :: Maybe Text,- name :: Text,- in' :: ApiKeySecuritySchemeLocation- }+data ApiKeySecurityScheme = ApiKeySecurityScheme+ { description :: Maybe Text,+ name :: Text,+ in' :: ApiKeySecuritySchemeLocation+ } deriving (Show, Eq, Generic) instance FromJSON ApiKeySecurityScheme where@@ -449,62 +443,56 @@ "cookie" -> pure CookieApiKeySecuritySchemeLocation _ -> fail "A SecuritySchemeObject with type 'apiKey' must have a value of 'query', 'header' or 'cookie' in the property 'in'." -data HttpSecurityScheme- = HttpSecurityScheme- { description :: Maybe Text,- scheme :: Text,- bearerFormat :: Maybe Text- }+data HttpSecurityScheme = HttpSecurityScheme+ { description :: Maybe Text,+ scheme :: Text,+ bearerFormat :: Maybe Text+ } deriving (Show, Eq, Generic) instance FromJSON HttpSecurityScheme -data OAuth2SecurityScheme- = OAuth2SecurityScheme- { description :: Maybe Text,- flows :: OAuthFlowsObject- }+data OAuth2SecurityScheme = OAuth2SecurityScheme+ { description :: Maybe Text,+ flows :: OAuthFlowsObject+ } deriving (Show, Eq, Generic) instance FromJSON OAuth2SecurityScheme -data OAuthFlowsObject- = OAuthFlowsObject- { implicit :: Maybe OAuthFlowObject,- password :: Maybe OAuthFlowObject,- clientCredentials :: Maybe OAuthFlowObject,- authorizationCode :: Maybe OAuthFlowObject- }+data OAuthFlowsObject = OAuthFlowsObject+ { implicit :: Maybe OAuthFlowObject,+ password :: Maybe OAuthFlowObject,+ clientCredentials :: Maybe OAuthFlowObject,+ authorizationCode :: Maybe OAuthFlowObject+ } deriving (Show, Eq, Generic) instance FromJSON OAuthFlowsObject -data OAuthFlowObject- = OAuthFlowObject- { authorizationUrl :: Maybe Text, -- applies only to implicit and authorizationCode- tokenUrl :: Maybe Text, -- applies only to password, clientCredentials and authorizationCode- refreshUrl :: Maybe Text,- scopes :: Map.Map Text Text- }+data OAuthFlowObject = OAuthFlowObject+ { authorizationUrl :: Maybe Text, -- applies only to implicit and authorizationCode+ tokenUrl :: Maybe Text, -- applies only to password, clientCredentials and authorizationCode+ refreshUrl :: Maybe Text,+ scopes :: Map.Map Text Text+ } deriving (Show, Eq, Generic) instance FromJSON OAuthFlowObject -data OpenIdConnectSecurityScheme- = OpenIdConnectSecurityScheme- { description :: Maybe Text,- openIdConnectUrl :: Text- }+data OpenIdConnectSecurityScheme = OpenIdConnectSecurityScheme+ { description :: Maybe Text,+ openIdConnectUrl :: Text+ } deriving (Show, Eq, Generic) instance FromJSON OpenIdConnectSecurityScheme -data TagObject- = TagObject- { name :: Text,- description :: Maybe Text,- externalDocs :: Maybe ExternalDocumentationObject- }+data TagObject = TagObject+ { name :: Text,+ description :: Maybe Text,+ externalDocs :: Maybe ExternalDocumentationObject+ } deriving (Show, Eq, Generic) instance FromJSON TagObject
src/OpenAPI/Generate/Types/ExternalDocumentation.hs view
@@ -7,11 +7,10 @@ import Data.Yaml import GHC.Generics -data ExternalDocumentationObject- = ExternalDocumentationObject- { url :: Text,- description :: Maybe Text- }+data ExternalDocumentationObject = ExternalDocumentationObject+ { url :: Text,+ description :: Maybe Text+ } deriving (Show, Ord, Eq, Generic) instance FromJSON ExternalDocumentationObject
src/OpenAPI/Generate/Types/Schema.hs view
@@ -13,57 +13,58 @@ import qualified Data.Map as Map import qualified Data.Scientific as Scientific-import Data.Set as Set-import qualified Data.Text as T+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (Text)+import qualified Data.Text as T import Data.Yaml import GHC.Generics import OpenAPI.Generate.Types.ExternalDocumentation import OpenAPI.Generate.Types.Referencable+import Prelude hiding (maximum, minimum, not) type Schema = Referencable SchemaObject -data SchemaObject- = SchemaObject- { type' :: SchemaType,- title :: Maybe Text,- multipleOf :: Maybe Integer,- maximum :: Maybe Float,- exclusiveMaximum :: Bool,- minimum :: Maybe Float,- exclusiveMinimum :: Bool,- maxLength :: Maybe Word,- minLength :: Maybe Word,- pattern' :: Maybe Text,- maxItems :: Maybe Word,- minItems :: Maybe Word,- uniqueItems :: Bool,- maxProperties :: Maybe Word,- minProperties :: Maybe Word,- required :: Set Text,- enum :: Set Value,- allOf :: Set Schema,- oneOf :: Set Schema,- anyOf :: Set Schema,- not :: Maybe Schema,- properties :: Map.Map Text Schema,- additionalProperties :: AdditionalProperties,- description :: Maybe Text,- format :: Maybe Text,- -- default would have the same value type as restricted by- -- the schema. Stripe only uses Text default values- default' :: Maybe ConcreteValue,- nullable :: Bool,- discriminator :: Maybe DiscriminatorObject,- readOnly :: Bool,- writeOnly :: Bool,- xml :: Maybe XMLObject,- externalDocs :: Maybe ExternalDocumentationObject,- example :: Maybe Value,- deprecated :: Bool,- items :: Maybe Schema- }- deriving (Show, Eq, Ord, Generic)+data SchemaObject = SchemaObject+ { type' :: SchemaType,+ title :: Maybe Text,+ multipleOf :: Maybe Integer,+ maximum :: Maybe Float,+ exclusiveMaximum :: Bool,+ minimum :: Maybe Float,+ exclusiveMinimum :: Bool,+ maxLength :: Maybe Word,+ minLength :: Maybe Word,+ pattern' :: Maybe Text,+ maxItems :: Maybe Word,+ minItems :: Maybe Word,+ uniqueItems :: Bool,+ maxProperties :: Maybe Word,+ minProperties :: Maybe Word,+ required :: Set Text,+ enum :: [Value],+ allOf :: [Schema],+ oneOf :: [Schema],+ anyOf :: [Schema],+ not :: Maybe Schema,+ properties :: Map.Map Text Schema,+ additionalProperties :: AdditionalProperties,+ description :: Maybe Text,+ format :: Maybe Text,+ -- default would have the same value type as restricted by+ -- the schema. Stripe only uses Text default values+ default' :: Maybe ConcreteValue,+ nullable :: Bool,+ discriminator :: Maybe DiscriminatorObject,+ readOnly :: Bool,+ writeOnly :: Bool,+ xml :: Maybe XMLObject,+ externalDocs :: Maybe ExternalDocumentationObject,+ example :: Maybe Value,+ deprecated :: Bool,+ items :: Maybe Schema+ }+ deriving (Show, Eq, Generic) instance FromJSON SchemaObject where parseJSON = withObject "SchemaObject" $ \o ->@@ -84,10 +85,10 @@ <*> o .:? "maxProperties" <*> o .:? "minProperties" <*> o .:? "required" .!= Set.empty- <*> o .:? "enum" .!= Set.empty- <*> o .:? "allOf" .!= Set.empty- <*> o .:? "oneOf" .!= Set.empty- <*> o .:? "anyOf" .!= Set.empty+ <*> o .:? "enum" .!= []+ <*> o .:? "allOf" .!= []+ <*> o .:? "oneOf" .!= []+ <*> o .:? "anyOf" .!= [] <*> o .:? "not" <*> o .:? "properties" .!= Map.empty <*> o .:? "additionalProperties" .!= HasAdditionalProperties@@ -104,6 +105,55 @@ <*> o .:? "deprecated" .!= False <*> o .:? "items" +defaultSchema :: SchemaObject+defaultSchema =+ SchemaObject+ { type' = SchemaTypeObject,+ title = Nothing,+ multipleOf = Nothing,+ maximum = Nothing,+ exclusiveMaximum = False,+ minimum = Nothing,+ exclusiveMinimum = False,+ maxLength = Nothing,+ minLength = Nothing,+ pattern' = Nothing,+ maxItems = Nothing,+ minItems = Nothing,+ uniqueItems = False,+ maxProperties = Nothing,+ minProperties = Nothing,+ required = Set.empty,+ enum = [],+ allOf = [],+ oneOf = [],+ anyOf = [],+ not = Nothing,+ properties = Map.empty,+ additionalProperties = HasAdditionalProperties,+ OpenAPI.Generate.Types.Schema.description = Nothing,+ format = Nothing,+ default' = Nothing,+ nullable = False,+ discriminator = Nothing,+ readOnly = False,+ writeOnly = False,+ xml = Nothing,+ externalDocs = Nothing,+ example = Nothing,+ deprecated = False,+ items = Nothing+ }++-- | Checks if the given schema is an empty object schema (without properties)+isSchemaEmpty :: SchemaObject -> Bool+isSchemaEmpty s =+ SchemaTypeObject == type' s+ && Map.null (properties s)+ && null (allOf s)+ && null (oneOf s)+ && null (anyOf s)+ data SchemaType = SchemaTypeString | SchemaTypeNumber@@ -120,14 +170,13 @@ parseJSON (String "boolean") = pure SchemaTypeBool parseJSON (String "array") = pure SchemaTypeArray parseJSON (String "object") = pure SchemaTypeObject- parseJSON (String x) = fail $ "Only types integer, string, number, bool, array and object are supported but got: " <> T.unpack x+ parseJSON (String x) = fail $ "Only types integer, string, number, boolean, array and object are supported but got: " <> T.unpack x parseJSON _ = fail "type must be of type string" -data DiscriminatorObject- = DiscriminatorObject- { propertyName :: Text,- mapping :: Map.Map Text Text- }+data DiscriminatorObject = DiscriminatorObject+ { propertyName :: Text,+ mapping :: Map.Map Text Text+ } deriving (Show, Eq, Ord, Generic) instance FromJSON DiscriminatorObject where@@ -136,31 +185,12 @@ <$> o .: "propertyName" <*> o .:? "mapping" .!= Map.empty --- So that Sets are possible-instance Ord Value where- (Object a) `compare` (Object b) = compare a b- (Array a) `compare` (Array b) = compare a b- (String a) `compare` (String b) = compare a b- (Number a) `compare` (Number b) = compare a b- (Bool a) `compare` (Bool b) = compare a b- Null `compare` Null = EQ- (Object _) `compare` _ = GT- _ `compare` (Object _) = LT- (Array _) `compare` _ = GT- _ `compare` (Array _) = LT- (String _) `compare` _ = GT- _ `compare` (String _) = LT- (Number _) `compare` _ = GT- _ `compare` (Number _) = LT- (Bool _) `compare` _ = GT- _ `compare` (Bool _) = LT- data ConcreteValue = StringDefaultValue Text | NumericDefaultValue Scientific.Scientific | BoolDefaultValue Bool | OtherDefaultValue Value- deriving (Show, Eq, Ord, Generic)+ deriving (Show, Eq, Generic) instance FromJSON ConcreteValue where parseJSON v@(String _) = StringDefaultValue <$> parseJSON v@@ -172,21 +202,20 @@ = NoAdditionalProperties | HasAdditionalProperties | AdditionalPropertiesWithSchema Schema- deriving (Show, Eq, Ord, Generic)+ deriving (Show, Eq, Generic) instance FromJSON AdditionalProperties where parseJSON (Bool False) = pure NoAdditionalProperties parseJSON (Bool True) = pure HasAdditionalProperties parseJSON v = AdditionalPropertiesWithSchema <$> parseJSON v -data XMLObject- = XMLObject- { name :: Maybe Text,- namespace :: Maybe Text,- prefix :: Maybe Text,- attribute :: Bool,- wrapped :: Bool- }+data XMLObject = XMLObject+ { name :: Maybe Text,+ namespace :: Maybe Text,+ prefix :: Maybe Text,+ attribute :: Bool,+ wrapped :: Bool+ } deriving (Show, Eq, Ord, Generic) instance FromJSON XMLObject where
test/OpenAPI/Generate/DocSpec.hs view
@@ -3,11 +3,11 @@ module OpenAPI.Generate.DocSpec where +import Data.List import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.PprLib import OpenAPI.Generate.Doc-import OpenAPI.Generate.Internal.Util import Test.Hspec import Test.QuickCheck import Test.Validity@@ -44,7 +44,7 @@ ) (text "b" $$ text "d" $$ text "e") )- `shouldBe` show (text "a b" $$ text "c d" $$ text " e")+ `shouldBe` show (text "a b" $$ text "c d" $$ text "e") it "should not indent if left doc is longer" $ show ( sideBySide@@ -54,7 +54,7 @@ ) `shouldBe` show (text "a b" $$ text "c d" $$ text "e") it "should have the length of the longer document" $ do- let numberOfLinesOfDoc = length . splitOn '\n' . show+ let numberOfLinesOfDoc = length . dropWhileEnd null . lines . show forAllValid $ \(MultiLineString doc1, MultiLineString doc2) -> numberOfLinesOfDoc ( sideBySide@@ -62,80 +62,77 @@ (text doc2) ) == max (numberOfLinesOfDoc $ text doc1) (numberOfLinesOfDoc $ text doc2)- describe "generateHaddockComment"- $ it "should place every item on a new line and respect newline characters"- $ show (generateHaddockComment ["Line 1", "Line 2", "", "Line 3\nLine 4"])- `shouldBe` init- ( unlines- [ "-- | Line 1",- "-- Line 2",- "-- ",- "-- Line 3",- "-- Line 4"- ]- )- describe "sideComments"- $ it "should convert every item to a side comment and replace newlines with spaces"- $ show (sideComments ["Line 1", "Line 2", "", "Line 3\nLine 4"])- `shouldBe` init- ( unlines- [ "-- ^ Line 1",- "-- ^ Line 2",- "-- ^ ",- "-- ^ Line 3 Line 4"- ]- )- describe "appendDoc"- $ it "should append two docs"- $ do- content <- runQ $ pure (text "a") `appendDoc` pure (text "b")- show content `shouldBe` "a\nb"- describe "breakOnTokens"- $ it "place a line feed before the tokens and add an indentation"- $ show- ( breakOnTokens [",", "}"] $ text $- init- ( unlines+ describe "generateHaddockComment" $+ it "should place every item on a new line and respect newline characters" $+ show (generateHaddockComment ["Line 1", "Line 2", "", "Line 3\nLine 4"])+ `shouldBe` init+ ( unlines+ [ "-- | Line 1",+ "-- Line 2",+ "-- ",+ "-- Line 3",+ "-- Line 4"+ ]+ )+ describe "sideComments" $+ it "should convert every item to a side comment and replace newlines with spaces" $+ show (sideComments ["Line 1", "Line 2", "", "Line 3\nLine 4"])+ `shouldBe` init+ ( unlines+ [ "-- ^ Line 1",+ "-- ^ Line 2",+ "-- ^ ",+ "-- ^ Line 3 Line 4"+ ]+ )+ describe "appendDoc" $+ it "should append two docs" $+ do+ content <- runQ $ pure (text "a") `appendDoc` pure (text "b")+ show content `shouldBe` "a\nb"+ describe "breakOnTokens" $+ it "place a line feed before the tokens and add an indentation" $+ show+ ( breakOnTokens [",", "}"] $+ text $+ unlines [ "foo = {", " a = 123, b = 321,", " c = A", " } deriving Foo" ]- )- )- `shouldBe` init- ( unlines- [ "foo = { a = 123",- " , b = 321",- " , c = A ",- " } deriving Foo"- ] )- describe "zipCodeAndComments"- $ it "should intertwine code and comments"- $ show- ( zipCodeAndComments- [ "foo = {",- " a = 123",+ `shouldBe` unlines+ [ "foo = { a = 123", " , b = 321",- " , c = A ",+ " , c = A", " } deriving Foo" ]- [ "a is foo",- "b is bar\nbut remember the line feed",- "c is A"- ]- )- `shouldBe` init- ( unlines+ describe "zipCodeAndComments" $+ it "should intertwine code and comments" $+ show+ ( zipCodeAndComments [ "foo = {",- " -- | a is foo", " a = 123",- " -- | b is bar",- " -- but remember the line feed", " , b = 321",- " -- | c is A", " , c = A ", " } deriving Foo" ]+ [ "a is foo",+ "b is bar\nbut remember the line feed",+ "c is A"+ ] )+ `shouldBe` init+ ( unlines+ [ "foo = {",+ " -- | a is foo",+ " a = 123",+ " -- | b is bar",+ " -- but remember the line feed",+ " , b = 321",+ " -- | c is A",+ " , c = A ",+ " } deriving Foo"+ ]+ )
test/OpenAPI/Generate/Internal/UtilSpec.hs view
@@ -49,28 +49,20 @@ spec :: Spec spec = do- describe "splitOn" $ do- it "should split string into pieces" $- splitOn 'a' "abcabca" `shouldBe` ["", "bc", "bc", ""]- it "should have one split more than elements to split on"- $ forAllValid- $ \(x, list) ->- length (splitOn (x :: Char) list)- == length (filter (== x) list) + 1 describe "haskellifyText" $ do- it "uppercase without CamelCase"- $ forAllValid- $ isValidConId . haskellifyText False True- it "uppercase with CamelCase"- $ forAllValid- $ isValidConId . haskellifyText True True- it "lowercase without CamelCase"- $ forAllValid- $ isValidVarId . haskellifyText False False- it "lowercase with CamelCase"- $ forAllValid- $ isValidVarId . haskellifyText True False- describe "transformToModuleName"- $ it "should be valid module name"- $ forAllValid- $ isValidConId . T.unpack . transformToModuleName+ it "uppercase without CamelCase" $+ forAllValid $+ isValidConId . haskellifyText False True+ it "uppercase with CamelCase" $+ forAllValid $+ isValidConId . haskellifyText True True+ it "lowercase without CamelCase" $+ forAllValid $+ isValidVarId . haskellifyText False False+ it "lowercase with CamelCase" $+ forAllValid $+ isValidVarId . haskellifyText True False+ describe "transformToModuleName" $+ it "should be valid module name" $+ forAllValid $+ isValidConId . T.unpack . transformToModuleName
test/OpenAPI/Generate/ModelDependenciesSpec.hs view
@@ -14,37 +14,38 @@ spec :: Spec spec = describe "getModelModulesFromModelsWithDependencies" $ do- let sut = getModelModulesFromModelsWithDependencies "OpenAPI"+ let sut = getModelModulesFromModelsWithDependencies "OpenAPI" (Set.fromList ["A", "B", "C", "D", "E", "F", "G"]) t = pure . text it "should split string into pieces" $ do result <- runQ $ sut- [ ("A", (t "aToken", Set.fromList [])),- ("B", (t "bToken", Set.fromList ["A"])),- ("C", (t "cToken", Set.fromList ["A", "B"])),- ("D", (t "dToken", Set.fromList ["C"])),- ("E", (t "eToken", Set.fromList ["E"])),- ("F", (t "fToken", Set.fromList ["G"])),- ("G", (t "gToken", Set.fromList ["F"]))+ [ ("A", (t "data A", Set.fromList [])),+ ("B", (t "data B", Set.fromList ["A"])),+ ("C", (t "type C", Set.fromList ["A", "B"])),+ ("D", (t "type D\ndata D", Set.fromList ["C"])),+ ("E", (t "data E", Set.fromList ["E"])),+ ("F", (t "-- XYZ\ntype F", Set.fromList ["G"])),+ ("G", (t "data G", Set.fromList ["F"])) ] sortBy (\(a, _) (b, _) -> compare a b) (fmap (second show) result) `shouldSatisfy` ( \case- [ (["CyclicTypes"], cyclicContent),+ [ (["TypeAlias"], typeAliasContent), (["Types"], _), (["Types", "A"], aContent), (["Types", "B"], bContent),- (["Types", "C"], cContent),- (["Types", "D"], dContent)+ (["Types", "D"], dContent),+ (["Types", "E"], eContent),+ (["Types", "G"], gContent) ] -> and- [ "aToken" `isInfixOf` aContent,- "bToken" `isInfixOf` bContent,- "cToken" `isInfixOf` cContent,- "dToken" `isInfixOf` dContent,- "eToken" `isInfixOf` cyclicContent,- "fToken" `isInfixOf` cyclicContent,- "gToken" `isInfixOf` cyclicContent+ [ "data A" `isInfixOf` aContent,+ "data B" `isInfixOf` bContent,+ "type D\ndata D" `isInfixOf` dContent,+ "data E" `isInfixOf` eContent,+ "data G" `isInfixOf` gContent,+ "type C" `isInfixOf` typeAliasContent,+ "-- XYZ\ntype F" `isInfixOf` typeAliasContent ] _ -> False )
test/OpenAPI/Generate/MonadSpec.hs view
@@ -9,8 +9,9 @@ import qualified Data.Map as Map import qualified Data.Text as T import Data.Validity.Text ()-import qualified OpenAPI.Generate.Flags as OAF+import qualified OpenAPI.Generate.Log as OAL import OpenAPI.Generate.Monad+import qualified OpenAPI.Generate.OptParse as OAO import OpenAPI.Generate.Reference import OpenAPI.Generate.Types as OAT import Test.Hspec@@ -18,23 +19,26 @@ spec :: Spec spec = do- let run = runGenerator (createEnvironment OAF.defaultFlags Map.empty)+ defaultSettings <- runIO OAO.getSettings+ let run = runGenerator (createEnvironment defaultSettings Map.empty) describe "nested" $ do it "should nest path correct with simple example" $ do let (currentPath', _) = run $ nested "a" $ nested "b" $ nested "c" $ asks currentPath currentPath' `shouldBe` ["a", "b", "c"]- it "should nest path correct with property" $ forAllValid $ \list -> do- let (currentPath', _) = run $ foldr nested (asks currentPath) list- currentPath' `shouldBe` list+ it "should nest path correct with property" $+ forAllValid $ \list -> do+ let (currentPath', _) = run $ foldr nested (asks currentPath) list+ currentPath' `shouldBe` list it "should save path with logs" $- let (_, logs) = run $ nested "a" $ do- logInfo "1"- nested "b" $ do- logInfo "2"- nested "c" $ logInfo "3"- logInfo "4"- logInfo "5"- in fmap (\l -> (path l, message l)) logs+ let (_, logs) = run $+ nested "a" $ do+ logInfo "1"+ nested "b" $ do+ logInfo "2"+ nested "c" $ logInfo "3"+ logInfo "4"+ logInfo "5"+ in fmap (\l -> (OAL.logEntryPath l, OAL.logEntryMessage l)) logs `shouldBe` [ (["a"], "1"), (["a", "b"], "2"), (["a", "b", "c"], "3"),@@ -42,27 +46,30 @@ (["a"], "5") ] describe "logs" $ do- let msgAndLogToTupleList list logs = bimap T.unpack T.unpack <$> zip list (transformGeneratorLogs logs)+ let msgAndLogToTupleList list logs = bimap T.unpack T.unpack <$> zip list (OAL.transformLogs logs) logContainsMsgPredicate = all $ uncurry isInfixOf- it "should contain all logged info messages" $ forAllValid $ \list -> do- let (_, logs) = run $ foldr ((>>) . logInfo) (pure ()) list- shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate- it "should contain all logged warn messages" $ forAllValid $ \list -> do- let (_, logs) = run $ foldr ((>>) . logWarning) (pure ()) list- shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate- it "should contain all logged error messages" $ forAllValid $ \list -> do- let (_, logs) = run $ foldr ((>>) . logError) (pure ()) list- shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate+ it "should contain all logged info messages" $+ forAllValid $ \list -> do+ let (_, logs) = run $ foldr ((>>) . logInfo) (pure ()) list+ shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate+ it "should contain all logged warn messages" $+ forAllValid $ \list -> do+ let (_, logs) = run $ foldr ((>>) . logWarning) (pure ()) list+ shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate+ it "should contain all logged error messages" $+ forAllValid $ \list -> do+ let (_, logs) = run $ foldr ((>>) . logError) (pure ()) list+ shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate describe "reference lookup" $ do let e = OAT.ExampleObject (Just "foo") Nothing Nothing (Just "http://example.com") b = OAT.RequestBodyObject Map.empty Nothing False runWithEnv =- runGenerator- $ createEnvironment OAF.defaultFlags- $ Map.fromList- [ ("#/components/examples/example1", ExampleReference e),- ("#/components/requestBodies/body1", RequestBodyReference b)- ]+ runGenerator $+ createEnvironment defaultSettings $+ Map.fromList+ [ ("#/components/examples/example1", ExampleReference e),+ ("#/components/requestBodies/body1", RequestBodyReference b)+ ] it "should find existing reference to example" $ do let (maybeExample, _) = runWithEnv $ getExampleReferenceM "#/components/examples/example1" maybeExample `shouldBe` Just e
test/OpenAPI/Generate/OperationTHSpec.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module OpenAPI.Generate.OperationTHSpec where@@ -27,19 +28,18 @@ res <- runQ is expected `shouldBe` res schemaObject = Maybe.fromJust $ decodeThrow "{}" :: OAS.SchemaObject- testParameterSchema = OAT.SimpleParameterObjectSchema Nothing False False (OAT.Concrete schemaObject) Nothing Map.empty+ testParameterSchema = OAT.SimpleParameterObjectSchema $ OAT.SimpleParameterSchema Nothing False False (OAT.Concrete schemaObject) Nothing Map.empty testParameter = OAT.ParameterObject "testName" OAT.QueryParameterObjectLocation Nothing True False True testParameterSchema testParameterOtherName = OAT.ParameterObject "testName2" OAT.QueryParameterObjectLocation Nothing True False True testParameterSchema- testTHName = mkName "myTestName"- testTHE = [|B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE testTHName))|]+ testTHName = varE $ mkName "myTestName"+ testTHE = [|B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $testTHName)|] monadName = mkName "m"- securitySchemeName = mkName "s" in do describe "generateQueryParams" $ singleTestTH "should generate empty list" (generateQueryParams [])- [|[]|]+ [|mempty|] describe "generateParameterizedRequestPath" $ do singleTestTH "should not change empty path without arguments"@@ -51,27 +51,27 @@ [|"/my/path/"|] singleTestTH "should ignore params not names"- (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/my/path/"))+ (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/my/path/")) [|"/my/path/"|] singleTestTH "should replace one occurences at the end"- (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/my/path/{testName}"))+ (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/my/path/{testName}")) [|"/my/path/" ++ $(testTHE) ++ ""|] singleTestTH "should replace one occurences at the end"- (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/my/path/{testName}/"))+ (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/my/path/{testName}/")) [|"/my/path/" ++ $(testTHE) ++ "/"|] singleTestTH "should replace one occurences at the beginning"- (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "{testName}/my/path/"))+ (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "{testName}/my/path/")) [|"" ++ $(testTHE) ++ "/my/path/"|] singleTestTH "should replace one occurences at the beginning"- (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/{testName}/my/path/"))+ (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/{testName}/my/path/")) [|"/" ++ $(testTHE) ++ "/my/path/"|] singleTestTH "should replace one occurences in the middle"- (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/another/test/{testName}/my/path/"))+ (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/another/test/{testName}/my/path/")) [|"/another/test/" ++ $(testTHE) ++ "/my/path/"|] singleTestTH "should ignore names not given"@@ -80,33 +80,33 @@ singleTestTH "should replace two occurences" ( generateParameterizedRequestPath- [(mkName "myTestName", testParameter), (mkName "myTestName2", testParameterOtherName)]+ [(testTHName, testParameter), (varE $ mkName "myTestName2", testParameterOtherName)] (T.pack "/{testName2}/my//test/{testName}/my/path/") ) [|("/" ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE $ mkName "myTestName2")) ++ "/my//test/") ++ $(testTHE) ++ "/my/path/"|] singleTestTH "should replace one variable twice in the path" ( generateParameterizedRequestPath- [(mkName "myTestName", testParameter)]+ [(testTHName, testParameter)] (T.pack "/{testName}/my//test/{testName}/my/path/") ) [|"/" ++ $(testTHE) ++ "/my//test/" ++ $(testTHE) ++ "/my/path/"|] describe "getParametersTypeForSignature" $ do let responseTypeName = mkName "Test"- responseType = [t|$(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]+ responseType = [t|$(varT monadName) (HS.Response $(varT responseTypeName))|] singleTestTH "no parameters"- (getParametersTypeForSignature [] responseTypeName monadName securitySchemeName)- [t|OC.Configuration $(varT securitySchemeName) -> $(responseType)|]+ (getParametersTypeForSignature [] responseTypeName monadName)+ [t|OC.Configuration -> $(responseType)|] singleTestTH "One parameters"- (getParametersTypeForSignature [conT ''Int] responseTypeName monadName securitySchemeName)- [t|OC.Configuration $(varT securitySchemeName) -> Int -> $(responseType)|]+ (getParametersTypeForSignature [conT ''Int] responseTypeName monadName)+ [t|OC.Configuration -> Int -> $(responseType)|] singleTestTH "Optional parameters"- (getParametersTypeForSignature [[t|Maybe Int|]] responseTypeName monadName securitySchemeName)- [t|OC.Configuration $(varT securitySchemeName) -> Maybe Int -> $(responseType)|]+ (getParametersTypeForSignature [[t|Maybe Int|]] responseTypeName monadName)+ [t|OC.Configuration -> Maybe Int -> $(responseType)|] singleTestTH "Two parameters"- (getParametersTypeForSignature [conT ''Int, conT ''T.Text] responseTypeName monadName securitySchemeName)- [t|OC.Configuration $(varT securitySchemeName) -> Int -> T.Text -> $(responseType)|]+ (getParametersTypeForSignature [conT ''Int, conT ''T.Text] responseTypeName monadName)+ [t|OC.Configuration -> Int -> T.Text -> $(responseType)|]