packages feed

openapi3-code-generator (empty) → 0.1.0.0

raw patch · 32 files changed

+4498/−0 lines, 32 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, containers, directory, filepath, 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

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for openapi3-code-generator++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,22 @@++MIT License++Copyright (c) 2020 Haskell-OpenAPI-Code-Generator++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,42 @@+# openapi3-code-generator+[![CircleCI](https://circleci.com/gh/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator.svg?style=svg)](https://circleci.com/gh/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator)++## How to use?+1. install [stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/)+1. `stack install openapi3-code-generator`+1. `openapi3-code-generator 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.++## 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.++- `property-type-suffix`+- `response-type-suffix`+- `response-body-type-suffix`+- `request-body-type-suffix`+- `use-numbered-variant-constructors`+- `convert-to-camel-case`+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ app/Embed.hs view
@@ -0,0 +1,10 @@+{-# 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
@@ -0,0 +1,171 @@+{-# 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."
+ openapi3-code-generator.cabal view
@@ -0,0 +1,153 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4b9fb84a6053e692ba6c4475ec1d147da46049a8f5f454dc5fc408c8344f04bb++name:           openapi3-code-generator+version:        0.1.0.0+synopsis:       OpenAPI3 Haskell Client Code Generator+description:    Please see the README on GitHub at <https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library#readme>+category:       Code-Generator+homepage:       https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library#readme+bug-reports:    https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library/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/Stripe-Haskell-Library++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+  other-modules:+      Paths_openapi3_code_generator+  hs-source-dirs:+      src+  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+  default-language: Haskell2010++executable openapi3-code-generator-exe+  main-is: Main.hs+  other-modules:+      Embed+      Paths_openapi3_code_generator+  hs-source-dirs:+      app+  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+  default-language: Haskell2010++test-suite openapi3-code-generator-test+  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+    , 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+  default-language: Haskell2010
+ src/OpenAPI/Common.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module serves the purpose of defining common functionality which remains the same across all OpenAPI specifications.+module OpenAPI.Common+  ( Configuration (..),+    doCallWithConfiguration,+    doCallWithConfigurationM,+    doBodyCallWithConfiguration,+    doBodyCallWithConfigurationM,+    runWithConfiguration,+    MonadHTTP (..),+    stringifyModel,+    StringifyModel,+    SecurityScheme (..),+    AnonymousSecurityScheme (..),+    textToByte,+    JsonByteString (..),+    JsonDateTime (..),+    RequestBodyEncoding (..),+  )+where++import qualified Control.Exception as Exception+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.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.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))++-- | 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)++instance MonadHTTP m => MonadHTTP (MR.ReaderT r m) where+  httpBS = MT.lift . httpBS++-- | An operation can and must be configured with data, which may be common+-- for many operations.+--+-- This configuration consists of information about the server URL and the used security scheme.+--+-- In OpenAPI these information can be defined+--+-- * Root level+-- * Path level+-- * Operation level+--+-- 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.+--+-- > defaultConfiguration+-- >   { configSecurityScheme = BearerAuthenticationSecurityScheme "token" }+data Configuration s+  = Configuration+      { configBaseURL :: Text,+        configSecurityScheme :: s+      }+  deriving (Show, Ord, Eq, Generic)++-- | Defines how a request body is encoded+data RequestBodyEncoding+  = -- | Encode the body as JSON+    RequestBodyEncodingJSON+  | -- | 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++-- | Instance for the anonymous scheme which does not alter the request in any way+instance SecurityScheme AnonymousSecurityScheme where+  authenticateRequest = const id++-- | 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++-- | This is the main functionality of this module+--+--   It makes a concrete Call to a Server without a body+doCallWithConfiguration ::+  (MonadHTTP m, SecurityScheme s) =>+  -- | Configuration options like base URL and security scheme+  Configuration s ->+  -- | 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)] ->+  -- | The raw response from the server+  m (Either HS.HttpException (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) =>+  Text ->+  Text ->+  [(Text, Maybe String)] ->+  MR.ReaderT (Configuration s) m (Either HS.HttpException (HS.Response B8.ByteString))+doCallWithConfigurationM method path queryParams = do+  config <- MR.ask+  MT.lift $ doCallWithConfiguration config method path queryParams++-- | This is the main functionality of this module+--+--   It makes a concrete Call to a Server with a body+doBodyCallWithConfiguration ::+  (MonadHTTP m, SecurityScheme s, Aeson.ToJSON body) =>+  -- | Configuration options like base URL and security scheme+  Configuration s ->+  -- | 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)] ->+  -- | Request body+  Maybe body ->+  -- | JSON or form data deepobjects+  RequestBodyEncoding ->+  -- | The raw response from the server+  m (Either HS.HttpException (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+  where+    baseRequest = createBaseRequest config method path queryParams+doBodyCallWithConfiguration config method path queryParams (Just body) RequestBodyEncodingFormData =+  httpBS $ HS.setRequestMethod (textToByte method) $ HS.setRequestBodyURLEncoded byteStringData baseRequest+  where+    baseRequest = createBaseRequest config method path queryParams+    byteStringData = createFormData body++-- | 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) =>+  Text ->+  Text ->+  [(Text, Maybe String)] ->+  Maybe body ->+  RequestBodyEncoding ->+  MR.ReaderT (Configuration s) m (Either HS.HttpException (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.)+  Text ->+  -- | The path for which the placeholders have already been replaced+  Text ->+  -- | Query Parameters+  [(Text, Maybe String)] ->+  -- | 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+  where+    baseRequest = parseURL $ configBaseURL config+    basePath = HC.path baseRequest+    basePathModifier =+      if basePath == B8.pack "/" && T.isPrefixOf "/" path+        then ""+        else basePath+    -- filters all maybe+    query = [(textToByte a, Just $ B8.pack b) | (a, Just b) <- queryParams]++-- | creates form data bytestring array+createFormData :: (Aeson.ToJSON a) => a -> [(B8.ByteString, B8.ByteString)]+createFormData body =+  let formData = jsonToFormData $ Aeson.toJSON body+   in fmap (BF.bimap textToByte textToByte) formData++-- | Convert a 'B8.ByteString' to 'Text'+byteToText :: B8.ByteString -> Text+byteToText = T.pack . B8.unpack++-- | Convert 'Text' a to 'B8.ByteString'+textToByte :: Text -> B8.ByteString+textToByte = B8.pack . T.unpack++parseURL :: Text -> HS.Request+parseURL url =+  Maybe.fromMaybe HS.defaultRequest+    $ HS.parseRequest+    $ T.unpack url++jsonToFormData :: Aeson.Value -> [(Text, Text)]+jsonToFormData = jsonToFormDataPrefixed ""++jsonToFormDataPrefixed :: Text -> Aeson.Value -> [(Text, Text)]+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 _ Aeson.Null = []+jsonToFormDataPrefixed prefix (Aeson.String a) = [(prefix, a)]+jsonToFormDataPrefixed "" (Aeson.Object object) =+  HMap.toList object >>= uncurry jsonToFormDataPrefixed+jsonToFormDataPrefixed prefix (Aeson.Object object) =+  HMap.toList object >>= (\(x, y) -> jsonToFormDataPrefixed (prefix <> "[" <> x <> "]") y)+jsonToFormDataPrefixed prefix (Aeson.Array vector) =+  Vector.toList vector >>= jsonToFormDataPrefixed (prefix <> "[]")++-- | This type class makes the code generation for URL parameters easier as it allows to stringify a value+--+-- The 'Show' class is not sufficient as strings should not be stringified with quotes.+class Show a => StringifyModel a where+  -- | Stringifies a showable value+  --+  -- >>> stringifyModel "Test"+  -- "Test"+  --+  -- >>> stringifyModel 123+  -- "123"+  stringifyModel :: a -> String++instance StringifyModel String where+  -- stringifyModel :: String -> String+  stringifyModel = id++instance {-# OVERLAPS #-} Show a => StringifyModel a where+  -- stringifyModel :: Show a => a -> String+  stringifyModel = show++-- | Wraps a 'B8.ByteString' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'+newtype JsonByteString = JsonByteString B8.ByteString+  deriving (Show, Eq, Ord)++instance Aeson.ToJSON JsonByteString where+  toJSON (JsonByteString s) = Aeson.toJSON $ B8.unpack s++instance Aeson.FromJSON JsonByteString where+  parseJSON (Aeson.String s) = pure $ JsonByteString $ textToByte s+  parseJSON _ = fail "Value cannot be converted to a 'JsonByteString'"++-- | Wraps a 'Time.ZonedTime' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'+newtype JsonDateTime = JsonDateTime Time.ZonedTime+  deriving (Show)++instance Eq JsonDateTime where+  (JsonDateTime d1) == (JsonDateTime d2) = Time.zonedTimeToUTC d1 == Time.zonedTimeToUTC d2++instance Ord JsonDateTime where+  (JsonDateTime d1) <= (JsonDateTime d2) = Time.zonedTimeToUTC d1 <= Time.zonedTimeToUTC d2++instance Aeson.ToJSON JsonDateTime where+  toJSON (JsonDateTime d) = Aeson.toJSON d++instance Aeson.FromJSON JsonDateTime where+  parseJSON o = JsonDateTime <$> Aeson.parseJSON o
+ src/OpenAPI/Generate.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | 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.Types as OAT+import System.Exit++-- | Decodes an OpenAPI File+decodeOpenApi :: String -> IO OAT.OpenApiSpecification+decodeOpenApi fileName = do+  res <- decodeFileEither fileName+  case res of+    Left exc -> die $ "Could not parse OpenAPI specification '" <> 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) = 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
+ src/OpenAPI/Generate/Doc.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Utility functions for 'Language.Haskell.TH.PprLib.Doc' manipulation+module OpenAPI.Generate.Doc+  ( emptyDoc,+    appendDoc,+    generateHaddockComment,+    escapeText,+    breakOnTokens,+    breakOnTokensWithReplacement,+    sideComments,+    zipCodeAndComments,+    sideBySide,+    addOperationsModuleHeader,+    addSecuritySchemesModuleHeader,+    addConfigurationModuleHeader,+    createModuleHeaderWithReexports,+    addModelModuleHeader,+  )+where++import qualified Control.Applicative as Applicative+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH.PprLib hiding ((<>))+import OpenAPI.Generate.Internal.Util++-- | Empty document inside an 'Applicative' (typically 'Language.Haskell.TH.Q')+emptyDoc :: Applicative f => f Doc+emptyDoc = pure empty++haddockIntro :: Doc+haddockIntro = text "-- |"++haddockLine :: Doc+haddockLine = text "--"++textToDoc :: Text -> Doc+textToDoc = text . T.unpack++line :: String -> Doc -> Doc+line = ($$) . text++emptyLine :: Doc -> Doc+emptyLine = line ""++languageExtension :: String -> Doc -> Doc+languageExtension = line . ("{-# LANGUAGE " <>) . (<> " #-}")++importQualified :: String -> Doc -> Doc+importQualified = importUnqualified . ("qualified " <>)++importUnqualified :: String -> Doc -> Doc+importUnqualified = line . ("import " <>)++moduleDescription :: String -> Doc -> Doc+moduleDescription = line . ("-- | " <>)++moduleDeclaration :: String -> String -> Doc -> Doc+moduleDeclaration modulePrefix name = line ("module " <> modulePrefix <> "." <> name <> " where")++-- | Append a 'Doc' to another inside an 'Applicative' (typically 'Language.Haskell.TH.Q')+appendDoc :: Applicative f => f Doc -> f Doc -> f Doc+appendDoc = Applicative.liftA2 ($$)++-- | Generate a Haddock comment with multiple lines+generateHaddockComment :: [Text] -> Doc+generateHaddockComment =+  generateHaddockCommentWithoutNewlines+    . ( >>=+          ( \case+              [] -> [""]+              x -> x+          )+            . T.lines+      )++generateHaddockCommentWithoutNewlines :: [Text] -> Doc+generateHaddockCommentWithoutNewlines [] = empty+generateHaddockCommentWithoutNewlines [x] = haddockIntro <+> textToDoc x+generateHaddockCommentWithoutNewlines xs =+  generateHaddockCommentWithoutNewlines (init xs)+    $$ haddockLine <+> textToDoc (last xs)++-- | Escape text for use in Haddock comment+escapeText :: Text -> Text+escapeText =+  T.replace "'" "\\'"+    . T.replace "\"" "\\\""+    . T.replace "`" "\\`"+    . T.replace "@" "\\@"+    . T.replace "$" "\\$"+    . T.replace "#" "\\#"+    . T.replace "<" "\\<"+    . T.replace "/" "\\/"+    . T.replace "\\" "\\\\"++-- | Add line breaks to a 'Doc' at all occurrences of the passed tokens (removes all other line breaks).+breakOnTokens :: [Text] -> Doc -> Doc+breakOnTokens = breakOnTokensWithReplacement ("\n  " <>)++-- | Add line breaks to a 'Doc' at all occurrences of the passed tokens (removes all other line breaks).+-- The replacement function is used to generate the text replacing the tokens.+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++removeDuplicateSpaces :: Text -> Text+removeDuplicateSpaces t =+  let t' = T.replace "  " " " t+   in if t == t' then t' else removeDuplicateSpaces t'++-- | Convert a list of lines to side comments+sideComments :: [Text] -> Doc+sideComments = vcat . fmap (text . T.unpack . T.replace "\n" " " . ("-- ^ " <>))++-- | Intertwine code lines with comment lines+--+-- The code lines should have one more line (the first line is not commented)+zipCodeAndComments :: [Text] -> [Text] -> Doc+zipCodeAndComments [] _ = empty+zipCodeAndComments [x] _ = textToDoc x+zipCodeAndComments (x : xs) [] = textToDoc x $$ zipCodeAndComments xs []+zipCodeAndComments (x : xs) (y : ys) = textToDoc x $$ nest 2 (generateHaddockComment [y]) $$ zipCodeAndComments xs ys++-- | 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+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'+   in foldl ($$) empty $+        zipWith+          ($$)+          (if isRightLonger then leftDoc' <> repeat empty else leftDoc')+          (if isLeftLonger then rightDoc' <> repeat empty else rightDoc')++-- | Add the module header to a module of an operation+addOperationsModuleHeader :: String -> String -> String -> Doc -> Doc+addOperationsModuleHeader mainModuleName moduleName operationId =+  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.Trans.Reader"+    . importQualified "Data.Aeson"+    . importQualified "Data.Aeson as Data.Aeson.Types"+    . importQualified "Data.Aeson as Data.Aeson.Types.FromJSON"+    . importQualified "Data.Aeson as Data.Aeson.Types.ToJSON"+    . importQualified "Data.Aeson as Data.Aeson.Types.Internal"+    . importQualified "Data.ByteString.Char8"+    . importQualified "Data.ByteString.Char8 as Data.ByteString.Internal"+    . importQualified "Data.Either"+    . importQualified "Data.Functor"+    . importQualified "Data.Scientific"+    . importQualified "Data.Text"+    . importQualified "Data.Text.Internal"+    . importQualified "Data.Time.Calendar as Data.Time.Calendar.Days"+    . 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 "Network.HTTP.Client"+    . importQualified "Network.HTTP.Client as Network.HTTP.Client.Request"+    . importQualified "Network.HTTP.Client as Network.HTTP.Client.Types"+    . importQualified "Network.HTTP.Simple"+    . importQualified "Network.HTTP.Types"+    . importQualified "Network.HTTP.Types as Network.HTTP.Types.Status"+    . importQualified "Network.HTTP.Types as Network.HTTP.Types.URI"+    . importQualified (mainModuleName <> ".Common")+    . importUnqualified (mainModuleName <> ".Types")+    . emptyLine++-- | Add the module header to a module of a model+addModelModuleHeader :: String -> String -> [String] -> String -> Doc -> Doc+addModelModuleHeader mainModuleName moduleName modelModulesToImport description =+  languageExtension "OverloadedStrings"+    . languageExtension "DeriveGeneric"+    . emptyLine+    . moduleDescription description+    . moduleDeclaration mainModuleName moduleName+    . emptyLine+    . importQualified "Prelude as GHC.Integer.Type"+    . importQualified "Prelude as GHC.Maybe"+    . importQualified "Data.Aeson"+    . importQualified "Data.Aeson as Data.Aeson.Types"+    . importQualified "Data.Aeson as Data.Aeson.Types.FromJSON"+    . importQualified "Data.Aeson as Data.Aeson.Types.ToJSON"+    . importQualified "Data.Aeson as Data.Aeson.Types.Internal"+    . importQualified "Data.ByteString.Char8"+    . importQualified "Data.ByteString.Char8 as Data.ByteString.Internal"+    . importQualified "Data.Functor"+    . importQualified "Data.Scientific"+    . importQualified "Data.Text"+    . importQualified "Data.Text.Internal"+    . importQualified "Data.Time.Calendar as Data.Time.Calendar.Days"+    . 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) $$)+    . emptyLine++-- | Add the module header to the security scheme module+addSecuritySchemesModuleHeader :: String -> Doc -> Doc+addSecuritySchemesModuleHeader moduleName =+  languageExtension "OverloadedStrings"+    . emptyLine+    . moduleDescription "Contains all supported security schemes defined in the specification"+    . moduleDeclaration moduleName "SecuritySchemes"+    . emptyLine+    . importQualified "Data.Text.Internal"+    . importQualified "GHC.Base"+    . importQualified "GHC.Classes"+    . importQualified "GHC.Show"+    . importQualified "Network.HTTP.Client as Network.HTTP.Client.Request"+    . importQualified "Network.HTTP.Simple"+    . importQualified (moduleName <> ".Common")+    . emptyLine++-- | Add the module header to the configuration module+addConfigurationModuleHeader :: String -> Doc -> Doc+addConfigurationModuleHeader moduleName =+  languageExtension "OverloadedStrings"+    . emptyLine+    . moduleDescription "Contains the default configuration"+    . moduleDeclaration moduleName "Configuration"+    . emptyLine+    . importQualified "Data.Text"+    . importQualified (moduleName <> ".Common")+    . emptyLine++-- | Create a 'Doc' containing a module which imports other modules and re-exports them+createModuleHeaderWithReexports :: String -> [String] -> String -> Doc+createModuleHeaderWithReexports moduleName modulesToExport description =+  let exports = vcat $ fmap (text . ("module " <>) . (<> ",")) modulesToExport+      imports = vcat $ fmap (text . ("import " <>)) modulesToExport+   in moduleDescription description $+        text ("module " <> moduleName <> " (")+          $$ nest+            2+            ( exports+                $$ text ") where"+            )+          $$ text ""+          $$ imports
+ src/OpenAPI/Generate/Flags.hs view
@@ -0,0 +1,118 @@+-- | 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/Internal/Operation.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Helpers for the generation of the operation functions+module OpenAPI.Generate.Internal.Operation+  ( getResponseObject,+    getResponseSchema,+    defineOperationFunction,+    getParameterDescription,+    getParameterType,+    getParametersTypeForSignature,+    getParametersTypeForSignatureWithMonadTransformer,+    getOperationName,+    getOperationDescription,+    getParametersFromOperationConcrete,+    getBodySchemaFromOperation,+    generateParameterizedRequestPath,+    generateQueryParams,+    RequestBodyDefinition (..),+  )+where++import Control.Monad+import qualified Control.Monad.Reader as MR+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 Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH+import Language.Haskell.TH.PprLib hiding ((<>))+import qualified Network.HTTP.Simple as HS+import qualified Network.HTTP.Types as HT+import qualified OpenAPI.Common as OC+import qualified OpenAPI.Generate.Doc as Doc+import qualified OpenAPI.Generate.Flags as OAF+import OpenAPI.Generate.Internal.Util+import qualified OpenAPI.Generate.Model as Model+import qualified OpenAPI.Generate.Monad as OAM+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+      }++-- | wrapper for ambigious usage+getParametersFromOperationReference :: OAT.OperationObject -> [OAT.Referencable OAT.ParameterObject]+getParametersFromOperationReference = OAT.parameters++-- | wrapper for ambigious usage+getSchemaFromParameterInner :: OAT.ParameterObject -> OAT.ParameterObjectSchema+getSchemaFromParameterInner = OAT.schema++-- | wrapper for ambigious usage+getRequiredFromParameter :: OAT.ParameterObject -> Bool+getRequiredFromParameter = OAT.required++-- | wrapper for ambigious usage+getInFromParameterObject :: OAT.ParameterObject -> OAT.ParameterObjectLocation+getInFromParameterObject = OAT.in'++-- | 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 =+  OAM.nested "parameters"+    . fmap Maybe.catMaybes+    . mapM+      ( \case+          OAT.Concrete p -> pure $ Just p+          OAT.Reference ref -> 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+      )+    . getParametersFromOperationReference++-- | Reads the Schema from the ParameterObjectSchema+--   Only application/json or simple Object Schema is read+getSchemaFromParameterOuter :: OAT.ParameterObjectSchema -> OAS.SchemaObject+getSchemaFromParameterOuter OAT.SimpleParameterObjectSchema {..} = case schema of+  OAT.Concrete e -> e+  _ -> error "not yet implemented"+getSchemaFromParameterOuter _ = error "not yet implemented"++-- | Reads the Schema from the Parameter+getSchemaFromParameter :: OAT.ParameterObject -> OAS.SchemaObject+getSchemaFromParameter = getSchemaFromParameterOuter . getSchemaFromParameterInner++getNameFromParameter :: OAT.ParameterObject -> Text+getNameFromParameter = OAT.name++-- | Gets the Type definition dependent on the number of parameters/types+--   A monadic name for which its forall structure is defined outside+--   this function can be given+--+--   @+--     [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 =+  createFunctionType+    ( [t|OC.Configuration $(varT securitySchemeName)|]+        : types+        <> [[t|$(varT monadName) (Either HS.HttpException (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 =+  createFunctionType+    ( types+        <> [[t|MR.ReaderT (OC.Configuration $(varT securitySchemeName)) $(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]]+    )++createFunctionType :: [Q Type] -> Q Type+createFunctionType =+  foldr1+    (\t1 t2 -> [t|$t1 -> $t2|])++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 :: OAF.Flags -> OAT.ParameterObject -> Q Type+getParameterType flags parameter =+  let paramType = varT $ Model.getSchemaType flags (getSchemaFromParameter parameter)+   in ( 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)+  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)++-- | Defines the body of an Operation function+--   The Operation function calls an generall HTTP function+--   all Parameters are arguments to the function+defineOperationFunction ::+  -- | Should the configuration be passed explicitly as parameter?+  Bool ->+  -- | How the function should be called+  Name ->+  -- | The parameters+  [OAT.ParameterObject] ->+  -- | The request path. It may contain placeholders in the form /my/{var}/path/+  Text ->+  -- | HTTP Method (POST,GET,etc.)+  Text ->+  -- | Schema of body+  Maybe RequestBodyDefinition ->+  -- | An expression used to transform the response from 'B8.ByteString' to the required response type.+  -- Note that the response is nested within a HTTP monad and an 'Either'.+  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+      bodyName = mkName "body"+  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 method)+                    (T.pack $(request))+                    $(queryParameters)+                    $(if required then [|Just $(varE bodyName)|] else varE bodyName)+                    $(encodeExpr)+                  )+              |]+      Nothing ->+        [d|+          $(conP fnName fnPatterns) =+            $responseTransformerExp+              ( $( if useExplicitConfiguration+                     then [|OC.doCallWithConfiguration $(varE configArg)|]+                     else [|OC.doCallWithConfigurationM|]+                 )+                (T.toUpper method)+                (T.pack $(request))+                $(queryParameters)+              )+          |]++-- | 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+  requestBody <- getRequestBodyObject operation+  case requestBody of+    Just body -> getRequestBodySchema body+    Nothing -> pure Nothing++getRequestBodyContent :: OAT.RequestBodyObject -> Map.Map Text OAT.MediaTypeObject+getRequestBodyContent = OAT.content++getSchemaFromMedia :: OAT.MediaTypeObject -> Maybe OAT.Schema+getSchemaFromMedia = OAT.schema++getRequestBodySchema :: OAT.RequestBodyObject -> OAM.Generator (Maybe RequestBodyDefinition)+getRequestBodySchema body =+  let content = Map.lookup "application/json" $ getRequestBodyContent body+      createRequestBodyDefinition encoding schema =+        Just $+          RequestBodyDefinition+            { schema = schema,+              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++getRequestBodyObject :: OAT.OperationObject -> OAM.Generator (Maybe OAT.RequestBodyObject)+getRequestBodyObject operation =+  case OAT.requestBody operation of+    Nothing -> pure Nothing+    Just (OAT.Concrete p) -> pure $ Just p+    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++-- | 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+  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++-- | 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.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++-- | Generates query params in the form of [(Text,ByteString)]+generateQueryParams :: [(Name, OAT.ParameterObject)] -> Q Exp+generateQueryParams ((name, param) : xs) =+  infixE (Just [|(queryName, $(expr))|]) (varE $ mkName ":") (Just $ generateQueryParams xs)+  where+    queryName = getNameFromParameter param+    required = getRequiredFromParameter param+    expr =+      if required+        then [|$(varE $ mkName "GHC.Base.Just") $ OC.stringifyModel $(varE name)|]+        else [|OC.stringifyModel <$> $(varE name)|]+generateQueryParams _ = [|[]|]++-- | 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 ((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)++-- | 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)+      ]++-- | Constructs the name of an operation.+-- If an 'OAT.operationId' is available, this is the primary choice.+-- If it is not available, the id is constructed based on the request path and method.+getOperationName :: Text -> Text -> OAT.OperationObject -> OAM.Generator Name+getOperationName requestPath method operation =+  let operationId = OAT.operationId operation+      textName = Maybe.fromMaybe (T.map Char.toLower method <> requestPath) operationId+   in haskellifyNameM False textName
+ src/OpenAPI/Generate/Internal/Util.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Utility functions for the OpenAPI code generator+module OpenAPI.Generate.Internal.Util+  ( haskellifyText,+    haskellifyName,+    haskellifyNameM,+    transformToModuleName,+    uppercaseFirstText,+    mapMaybeM,+    liftedAppend,+    splitOn,+    joinWithPoint,+    joinWith,+  )+where++import qualified Control.Applicative as Applicative+import qualified Data.Char as Char+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++-- | Transform an identifier to ensure it is a valid Haskell identifier+-- Additionally, this function applies style settings according to the need of the consumer.+haskellifyText ::+  -- | Should the identifier be transformed to CamelCase?+  Bool ->+  -- | Should the first character of the identifier be uppercase?+  Bool ->+  -- | The identifier to transform+  Text ->+  -- | The resulting identifier+  String+haskellifyText convertToCamelCase startWithUppercase name =+  let casefn = if startWithUppercase then Char.toUpper else Char.toLower+      replaceChar '.' = '\''+      replaceChar '\'' = '\''+      replaceChar a = if Char.isAlphaNum a then a else '_'+      caseFirstCharCorrectly (x : xs) = casefn x : xs+      caseFirstCharCorrectly x = x+      nameWithoutSpecialChars a = replaceChar <$> a+      toCamelCase (x : y : xs) | not (Char.isAlphaNum x) && x /= '\'' && Char.isAlpha y = Char.toUpper y : toCamelCase xs+      toCamelCase (x : xs) = x : toCamelCase xs+      toCamelCase xs = xs+      replaceReservedWord "case" = "case'"+      replaceReservedWord "class" = "class'"+      replaceReservedWord "data" = "data'"+      replaceReservedWord "deriving" = "deriving'"+      replaceReservedWord "do" = "do'"+      replaceReservedWord "else" = "else'"+      replaceReservedWord "if" = "if'"+      replaceReservedWord "import" = "import'"+      replaceReservedWord "in" = "in'"+      replaceReservedWord "infix" = "infix'"+      replaceReservedWord "infixl" = "infixl'"+      replaceReservedWord "infixr" = "infixr'"+      replaceReservedWord "instance" = "instance'"+      replaceReservedWord "let" = "let'"+      replaceReservedWord "of" = "of'"+      replaceReservedWord "module" = "module'"+      replaceReservedWord "newtype" = "newtype'"+      replaceReservedWord "then" = "then'"+      replaceReservedWord "type" = "type'"+      replaceReservedWord "where" = "where'"+      replaceReservedWord "Configuration" = "Configuration'"+      replaceReservedWord "MonadHTTP" = "MonadHTTP'"+      replaceReservedWord "StringifyModel" = "StringifyModel'"+      replaceReservedWord "SecurityScheme" = "SecurityScheme'"+      replaceReservedWord "AnonymousSecurityScheme" = "AnonymousSecurityScheme'"+      replaceReservedWord "JsonByteString" = "JsonByteString'"+      replaceReservedWord "JsonDateTime" = "JsonDateTime'"+      replaceReservedWord "RequestBodyEncoding" = "RequestBodyEncoding'"+      replaceReservedWord ('_' : rest) = replaceReservedWord rest+      replaceReservedWord a = a+      replacePlus ('+' : rest) = "Plus" <> replacePlus rest+      replacePlus (x : xs) = x : replacePlus xs+      replacePlus a = a+   in replaceReservedWord+        $ caseFirstCharCorrectly+        $ (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+haskellifyName convertToCamelCase startWithUppercase name = mkName $ haskellifyText convertToCamelCase startWithUppercase name++-- | '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++-- | Transform a module name to ensure it is valid for file names+transformToModuleName :: Text -> Text+transformToModuleName =+  let toCamelCase (x : y : xs) | not (Char.isAlphaNum x) && Char.isAlpha y = Char.toUpper y : toCamelCase xs+      toCamelCase (x : xs) = x : toCamelCase xs+      toCamelCase xs = xs+   in T.pack+        . toCamelCase+        . uppercaseFirst+        . T.unpack+        . T.dropWhile (== '_')+        . T.map (\c -> if Char.isAlphaNum c then c else '_')++uppercaseFirst :: String -> String+uppercaseFirst (x : xs) = Char.toUpper x : xs+uppercaseFirst x = x++-- | Uppercase the first character of a 'Text'+uppercaseFirstText :: Text -> Text+uppercaseFirstText = T.pack . uppercaseFirst . T.unpack++-- | Concat a list of strings with a point+--+-- >>> joinWithPoint ["a", "b", "c"]+-- "a.b.c"+joinWithPoint :: [String] -> String+joinWithPoint = joinWith "."++-- | Concat a list of values separated by an other value+joinWith :: Monoid a => a -> [a] -> a+joinWith _ [] = mempty+joinWith separator xs =+  foldr1+    ( \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+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM op = foldr f (pure [])+  where+    f x xs = do x' <- op x; case x' of { Nothing -> xs; Just x'' -> do { xs' <- xs; pure $ x'' : xs' } }++-- | Lifted version of '<>' which can be used with 'Semigroup's inside 'Applicative's+liftedAppend :: (Applicative f, Semigroup a) => f a -> f a -> f a+liftedAppend = Applicative.liftA2 (<>)
+ src/OpenAPI/Generate/Model.hs view
@@ -0,0 +1,671 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- | Defines functionality for the generation of models from OpenAPI schemas+module OpenAPI.Generate.Model+  ( getSchemaType,+    resolveSchemaReferenceWithoutWarning,+    getConstraintDescriptionsOfSchema,+    defineModelForSchemaNamed,+    defineModelForSchema,+    TypeWithDeclaration,+  )+where++import Control.Monad+import qualified Data.Aeson as Aeson+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 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.Types as OAT+import qualified OpenAPI.Generate.Types.Schema as OAS+import Prelude hiding (maximum, minimum, not)++-- | The type of a model and the declarations needed for defining it+type TypeWithDeclaration = (Q Type, Dep.ModelContentWithDependencies)++type BangTypesSelfDefined = (Q [VarBangType], Q Doc, Dep.Models)++data TypeAliasStrategy = CreateTypeAlias | DontCreateTypeAlias+  deriving (Show, Eq, Ord)++addDependencies :: Dep.Models -> OAM.Generator TypeWithDeclaration -> OAM.Generator TypeWithDeclaration+addDependencies dependenciesToAdd typeDef = do+  (type', (content, dependencies)) <- typeDef+  pure (type', (content, Set.union dependencies dependenciesToAdd))++-- | default derive clause for the objects+objectDeriveClause :: [Q DerivClause]+objectDeriveClause =+  [ derivClause+      Nothing+      [ conT ''Show,+        conT ''Eq+        -- makes the programm compilation unusable slow+        -- conT ''Generic+      ]+  ]++-- | Defines all the models for a schema+defineModelForSchema :: Text -> OAS.Schema -> OAM.Generator Dep.ModelWithDependencies+defineModelForSchema schemaName schema = do+  namedSchema <- defineModelForSchemaNamedWithTypeAliasStrategy CreateTypeAlias schemaName schema+  pure (transformToModuleName schemaName, snd namedSchema)++-- | Defines all the models for a schema and returns the declarations with the type of the root model+defineModelForSchemaNamed :: Text -> OAS.Schema -> OAM.Generator TypeWithDeclaration+defineModelForSchemaNamed = defineModelForSchemaNamedWithTypeAliasStrategy DontCreateTypeAlias++-- | 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 $+  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))++-- | 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)+resolveSchemaReferenceWithoutWarning schema =+  case schema of+    OAT.Concrete concrete -> pure $ Just concrete+    OAT.Reference ref -> OAM.getSchemaReferenceM ref++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 "+            <> schemaName+            <> " could not be found and therefore will be skipped."+        pure $ (,Set.singleton $ transformToModuleName 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+  pure $ case strategy of+    CreateTypeAlias ->+      ( type',+        ( content+            `appendDoc` ( ( Doc.generateHaddockComment+                              [ "Defines an alias for the schema " <> Doc.escapeText schemaName,+                                "",+                                description+                              ]+                              $$+                          )+                            . ppr <$> tySynD schemaName' [] type'+                        ),+          dependencies+        )+      )+    DontCreateTypeAlias -> (type', (content, dependencies))++-- | returns the type of a schema. Second return value is a 'Q' Monad, for the types that have to be created+defineModelForSchemaConcrete :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration+defineModelForSchemaConcrete strategy schemaName schema =+  let enumValues = OAS.enum schema+   in if null enumValues+        then defineModelForSchemaConcreteIgnoreEnum strategy schemaName schema+        else defineEnumModel strategy 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+  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+       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+    _ ->+      typeAliasing $ pure (varT $ getSchemaType flags 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+  let getConstructor (a, _, _) = a+  let getValueInfo value = do+        cname <- haskellifyNameM True (schemaName <> T.pack "Enum" <> T.replace "\"" "" (T.pack (show value)))+        pure (normalC cname [], cname, value)+  name <- haskellifyNameM True schemaName+  (typ, (content, dependencies)) <- defineModelForSchemaConcreteIgnoreEnum strategy (schemaName <> T.pack "EnumValue") schema+  constructorsInfo <- mapM getValueInfo enumValues+  otherName <- haskellifyNameM True (schemaName <> T.pack "EnumOther")+  typedName <- haskellifyNameM True (schemaName <> T.pack "EnumTyped")+  let nameValuePairs = fmap (\(_, a, b) -> (a, b)) constructorsInfo+  let 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 =+        ( Doc.generateHaddockComment+            [ "Defines the enum schema " <> Doc.escapeText schemaName,+              "",+              getDescriptionOfSchema schema+            ]+            $$+        )+          . ppr+          <$> dataD+            (pure [])+            name+            []+            Nothing+            (otherC : typedC : (getConstructor <$> constructorsInfo))+            objectDeriveClause+  pure (varT name, (content `appendDoc` newType `appendDoc` jsonImplementation, dependencies))++defineJsonImplementationForEnum :: Name -> Name -> [Name] -> [(Name, Aeson.Value)] -> Q Doc+defineJsonImplementationForEnum name fallbackName specialCons 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)+      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"))|])+          []+      toJsonFn =+        funD+          (mkName "toJSON")+          ((toSpecialCons <$> specialCons) <> (toJsonClause <$> nameValues))+      toJson = instanceD (pure []) (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT name) [toJsonFn]+   in fmap ppr toJson `appendDoc` fmap ppr fromJson++-- | defines anyOf types+--+-- If the subschemas consist only of objects an allOf type without any required field can be generated+-- 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++--    this would be the correct implementation+--    but it generates endless loop because some implementations use anyOf as a oneOf+--    where the schema reference itself+--      let objectSchemas = filter (\o -> OAS.type' o == OAS.SchemaTypeObject) concreteSchemas+--      (propertiesCombined, _) <- fuseSchemasAllOf schemaName (fmap OAT.Concrete objectSchemas)+--      if null propertiesCombined then+--        createAlias schemaName strategy $ defineOneOfSchema schemaName schemas+--        else+--          let schemaPrototype = head objectSchemas+--              newSchema = schemaPrototype {OAS.properties = propertiesCombined, OAS.required = Set.empty}+--          in+--            createAlias schemaName strategy $ defineOneOfSchema schemaName (fmap OAT.Concrete (newSchema : notObjectSchemas))++-- | defines a OneOf Schema+--+-- creates types for all the subschemas and then creates an adt with constructors for the different+-- 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])+      defineIndexed schema index = defineModelForSchemaNamed (schemaName <> "OneOf" <> T.pack (show index)) schema+  variants <- mapM (uncurry defineIndexed) indexedSchemas+  let variantDefinitions = vcat <$> mapM (fst . snd) variants+      dependencies = Set.unions $ fmap (snd . snd) variants+      types = fmap fst variants+      indexedTypes = zip types ([1 ..] :: [Integer])+      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+        normalC haskellifiedName [pure (bang', t)]+      emptyCtx = pure []+      name = haskellifyName (OAF.optConvertToCamelCase flags) True $ schemaName <> "Variants"+      fromJsonFn =+        funD+          (mkName "parseJSON")+          [ clause+              []+              ( normalB+                  [|+                    Aeson.genericParseJSON Aeson.defaultOptions {Aeson.sumEncoding = Aeson.UntaggedValue}+                    |]+              )+              []+          ]+      toJsonFn =+        funD+          (mkName "toJSON")+          [ clause+              []+              ( normalB+                  [|+                    Aeson.genericToJSON Aeson.defaultOptions {Aeson.sumEncoding = Aeson.UntaggedValue}+                    |]+              )+              []+          ]+      dataDefinition =+        ( Doc.generateHaddockComment+            [ "Define the one-of schema " <> Doc.escapeText schemaName,+              "",+              description+            ]+            $$+        )+          . ppr+          <$> dataD+            emptyCtx+            name+            []+            Nothing+            (createTypeConstruct <$> indexedTypes)+            [ derivClause+                Nothing+                [ conT ''Show,+                  conT ''Eq,+                  -- makes the programm slow, but oneOf is not used that often+                  conT ''Generic+                ]+            ]+      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]+      innerRes = (varT name, (variantDefinitions `appendDoc` dataDefinition `appendDoc` toJson `appendDoc` fromJson, dependencies))+  pure innerRes++typeToSuffix :: Type -> Text+typeToSuffix (ConT name') = T.pack $ nameBase name'+typeToSuffix (VarT name') =+  let x = T.pack $ nameBase name'+   in if x == "[]" then "List" else x+typeToSuffix (AppT type1 type2) = typeToSuffix type1 <> typeToSuffix type2+typeToSuffix x = T.pack $ show x++-- | combines schemas so that it is usefull for a allOf fusion+fuseSchemasAllOf :: Text -> [OAS.Schema] -> OAM.Generator (Map.Map Text OAS.Schema, Set.Set Text)+fuseSchemasAllOf schemaName schemas = do+  schemasWithDependencies <- mapMaybeM (resolveSchemaReference schemaName) schemas+  let concreteSchemas = fmap fst schemasWithDependencies+  subSchemaInformation <- mapM (getPropertiesForAllOf schemaName) concreteSchemas+  let propertiesCombined = foldl (Map.unionWith const) Map.empty (fmap fst subSchemaInformation)+  let requiredCombined = foldl Set.union Set.empty (fmap snd subSchemaInformation)+  pure (propertiesCombined, requiredCombined)++-- | gets properties for an allOf merge+-- looks if subschemas define further subschemas+getPropertiesForAllOf :: Text -> OAS.SchemaObject -> OAM.Generator (Map.Map Text OAS.Schema, Set.Set Text)+getPropertiesForAllOf schemaName schema =+  let allOf = OAS.allOf schema+      anyOf = OAS.anyOf schema+      relevantSubschemas = Set.union 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+          pure (Map.unionWith const allOfProps anyOfProps, allOfRequired)++-- | defines a allOf subschema+-- Fuses the subschemas together+defineAllOfSchema :: Text -> Text -> [OAS.Schema] -> OAM.Generator TypeWithDeclaration+defineAllOfSchema schemaName description schemas = do+  newDefs <- defineNewSchemaForAllOf schemaName description schemas+  case newDefs of+    Just (newSchema, newDependencies) ->+      addDependencies newDependencies $ defineModelForSchemaConcrete DontCreateTypeAlias schemaName newSchema+    Nothing -> pure (varT ''String, (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"+      pure Nothing+    else+      let schemaPrototype = head concreteSchemas+          newSchema = schemaPrototype {OAS.properties = propertiesCombined, OAS.required = requiredCombined, OAS.description = Just description}+       in pure $ Just (newSchema, newDependencies)++-- | defines an array+defineArrayModelForSchema :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration+defineArrayModelForSchema strategy schemaName schema = do+  (type', (content, dependencies)) <-+    case OAS.items schema of+      Just itemSchema -> defineModelForSchemaNamed schemaName itemSchema+      -- not allowed by the spec+      Nothing -> do+        OAM.logWarning $ T.pack "items is empty for an array (assume string) " <> schemaName+        pure (varT ''String, (emptyDoc, Set.empty))+  let arrayType = appT (varT $ mkName "[]") type'+  schemaName' <- haskellifyNameM True schemaName+  pure+    ( arrayType,+      ( content `appendDoc` case strategy of+          CreateTypeAlias ->+            ( Doc.generateHaddockComment+                [ "Defines an alias for the schema " <> Doc.escapeText schemaName,+                  "",+                  getDescriptionOfSchema schema+                ]+                $$+            )+              . ppr+              <$> tySynD schemaName' [] arrayType+          DontCreateTypeAlias -> emptyDoc,+        dependencies+      )+    )++-- | 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+              ]+          )+          `appendDoc` dataDefinition+          `appendDoc` toJsonInstance+          `appendDoc` fromJsonInstance+          `appendDoc` propertyContent,+        propertyDependencies+      )+    )++-- | create toJSON implementation for an object+createToJSONImplementation :: Name -> [(Text, Name)] -> Q Doc+createToJSONImplementation objectName recordNames =+  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+      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)+                          |]+                    )+                    []+                ]+            ]+   in ppr <$> instanceD emptyDefs (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT objectName) defaultJsonImplementation++-- | create FromJSON implementation for an object+createFromJSONImplementation :: Name -> [(Text, Name)] -> Set.Set Text -> Q Doc+createFromJSONImplementation objectName recordNames required =+  let fnArgName = mkName "obj"+      withObjectLamda =+        foldl+          ( \prev (propName, _) ->+              let propName' = litE $ stringL $ T.unpack propName+                  arg = varE fnArgName+                  readPropE =+                    if propName `elem` required+                      then [|$arg Aeson..: $propName'|]+                      else [|$arg Aeson..:? $propName'|]+               in [|$prev <*> $readPropE|]+          )+          [|pure $(varE objectName)|]+          recordNames+   in ppr+        <$> instanceD+          (cxt [])+          [t|Aeson.FromJSON $(varT objectName)|]+          [ funD+              (mkName "parseJSON")+              [ clause+                  []+                  ( normalB+                      [|Aeson.withObject $(litE $ stringL $ show objectName) $(lam1E (varP fnArgName) withObjectLamda)|]+                  )+                  []+              ]+          ]++-- | 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+      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+        pure (myBang, content, depenencies)+      foldFn :: OAM.Generator BangTypesSelfDefined -> (Text, OAS.Schema) -> OAM.Generator BangTypesSelfDefined+      foldFn accHolder next = do+        (varBang, content, dependencies) <- accHolder+        (nextVarBang, nextContent, nextDependencies) <- propToBangType next+        pure+          ( varBang `liftedAppend` fmap pure nextVarBang,+            content `appendDoc` nextContent,+            Set.union dependencies nextDependencies+          )+  foldl foldFn (pure (pure [], emptyDoc, Set.empty)) props++getDescriptionOfSchema :: OAS.SchemaObject -> Text+getDescriptionOfSchema schema = Doc.escapeText $ Maybe.fromMaybe "" $ OAS.description schema++getDescriptionOfProperties :: [(Text, OAS.Schema)] -> OAM.Generator [Text]+getDescriptionOfProperties =+  mapM+    ( \(name, schema) -> do+        schema' <- resolveSchemaReferenceWithoutWarning schema+        let description = maybe "" (": " <>) $ schema' >>= OAS.description+            constraints = T.unlines $ ("* " <>) <$> getConstraintDescriptionsOfSchema schema'+        pure $ Doc.escapeText $ name <> description <> (if T.null constraints then "" else "\n\nConstraints:\n\n" <> constraints)+    )++-- | Extracts the constraints of a 'OAS.SchemaObject' as human readable text+getConstraintDescriptionsOfSchema :: Maybe OAS.SchemaObject -> [Text]+getConstraintDescriptionsOfSchema schema =+  let showConstraint desc = showConstraintSurrounding desc ""+      showConstraintSurrounding prev after = fmap $ (prev <>) . (<> after) . T.pack . show+      exclusiveMaximum = maybe False OAS.exclusiveMaximum schema+      exclusiveMinimum = maybe False OAS.exclusiveMinimum schema+   in Maybe.catMaybes+        [ showConstraint "Must be a multiple of " $ schema >>= OAS.multipleOf,+          showConstraint ("Maxium " <> if exclusiveMaximum then " (exclusive)" else "" <> " of ") $ schema >>= OAS.maximum,+          showConstraint ("Minimum " <> if exclusiveMinimum then " (exclusive)" else "" <> " of ") $ schema >>= OAS.minimum,+          showConstraint "Maximum length of " $ schema >>= OAS.maxLength,+          showConstraint "Minimum length of " $ schema >>= OAS.minLength,+          ("Must match pattern '" <>) . (<> "'") <$> (schema >>= OAS.pattern'),+          showConstraintSurrounding "Must have a maximum of " " items" $ schema >>= OAS.maxItems,+          showConstraintSurrounding "Must have a minimum of " " items" $ schema >>= OAS.minItems,+          schema+            >>= ( \case+                    True -> Just "Must have unique items"+                    False -> Nothing+                )+            . 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, ..} = ''String+getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeBool, ..} = ''Bool+getSchemaType _ OAS.SchemaObject {..} = ''String
+ src/OpenAPI/Generate/ModelDependencies.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | Functionality to split models into multiple modules according to their dependencies+module OpenAPI.Generate.ModelDependencies+  ( getModelModulesFromModelsWithDependencies,+    ModuleDefinition,+    Models,+    ModelContentWithDependencies,+    ModelWithDependencies,+  )+where++import Data.List+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text (Text)+import Language.Haskell.TH+import Language.Haskell.TH.PprLib hiding ((<>))+import qualified OpenAPI.Generate.Doc as Doc+import OpenAPI.Generate.Internal.Util++-- | A module definition with a name as a string list with the different module levels (e. g. [\"OpenAPI\", \"Generate\"] for "OpenAPI.Generate")+-- and the 'Doc' representing the module content+type ModuleDefinition = ([String], Doc)++-- | A set of model names (typically used as dependency list)+type Models = Set.Set Text++-- | A tuple containing the content and the dependencies of a model+type ModelContentWithDependencies = (Q Doc, Models)++-- | Represents a model with a name, content and dependencies+type ModelWithDependencies = (Text, ModelContentWithDependencies)++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 <-+    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+      )+      models+  let modelModuleNames = fmap (joinWithPoint . fst) modules+  pure $+    ( [typesModule],+      Doc.createModuleHeaderWithReexports+        (prependMainModule typesModule)+        (fmap prependMainModule (cyclicTypesModule : modelModuleNames))+        "Rexports all type modules (used in the operation modules)."+    )+      : ( [cyclicTypesModule],+          Doc.addModelModuleHeader+            mainModuleName+            cyclicTypesModule+            modelModuleNames+            "Contains all types with cyclic dependencies (between each other or to itself)"+            cyclicModuleContent+        )+      : modules++extractCyclicModuleDependentModels :: [ModelWithDependencies] -> ([ModelWithDependencies], Q Doc)+extractCyclicModuleDependentModels models =+  let (cyclicModels, extractedModels) = extractUnidirectionallyDependentModels (models, [])+   in (extractedModels, vcat <$> mapM (fst . snd) cyclicModels)++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)
+ src/OpenAPI/Generate/Monad.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | This module contains the 'Generator' monad and functions which deal with this monad.+-- In addition this module contains the means for logging and resolving references since they are+-- closely linked to the 'Generator' monad.+module OpenAPI.Generate.Monad where++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.Reference as Ref+import qualified OpenAPI.Generate.Types as OAT+import qualified OpenAPI.Generate.Types.Schema as OAS++-- | The reader environment of the 'Generator' monad+--+-- 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+      }+  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)++-- | Runs the generator monad within a provided environment.+runGenerator :: GeneratorEnvironment -> Generator a -> (a, GeneratorLogs)+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 =+  GeneratorEnvironment+    { currentPath = [],+      references = references,+      flags = flags+    }++-- | 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}]++-- | Writes an error to a 'Generator' monad+logError :: Text -> Generator ()+logError = logMessage ErrorSeverity++-- | Writes a warning to a 'Generator' monad+logWarning :: Text -> Generator ()+logWarning = logMessage 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"++-- | Transforms the path to a 'Text' representation (parts are seperated with a dot)+transformPath :: [Text] -> Text+transformPath = mconcat . intersperse "."++-- | 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]}++-- | 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++-- | Resolve a 'OAS.SchemaObject' reference from within the 'Generator' monad+getSchemaReferenceM :: Text -> Generator (Maybe OAS.SchemaObject)+getSchemaReferenceM = createReferenceLookupM Ref.getSchemaReference++-- | Resolve a 'OAT.ResponseObject' reference from within the 'Generator' monad+getResponseReferenceM :: Text -> Generator (Maybe OAT.ResponseObject)+getResponseReferenceM = createReferenceLookupM Ref.getResponseReference++-- | Resolve a 'OAT.ParameterObject' reference from within the 'Generator' monad+getParameterReferenceM :: Text -> Generator (Maybe OAT.ParameterObject)+getParameterReferenceM = createReferenceLookupM Ref.getParameterReference++-- | Resolve a 'OAT.ExampleObject' reference from within the 'Generator' monad+getExampleReferenceM :: Text -> Generator (Maybe OAT.ExampleObject)+getExampleReferenceM = createReferenceLookupM Ref.getExampleReference++-- | Resolve a 'OAT.RequestBodyObject' reference from within the 'Generator' monad+getRequestBodyReferenceM :: Text -> Generator (Maybe OAT.RequestBodyObject)+getRequestBodyReferenceM = createReferenceLookupM Ref.getRequestBodyReference++-- | Resolve a 'OAT.HeaderObject' reference from within the 'Generator' monad+getHeaderReferenceM :: Text -> Generator (Maybe OAT.HeaderObject)+getHeaderReferenceM = createReferenceLookupM Ref.getHeaderReference++-- | Resolve a 'OAT.SecuritySchemeObject' reference from within the 'Generator' monad+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 a specific flag selected by @f@+getFlag :: (OAF.Flags -> a) -> Generator a+getFlag f = MR.asks $ f . flags
+ src/OpenAPI/Generate/Operation.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- | Contains the functionality to define operation functions for path items.+module OpenAPI.Generate.Operation+  ( defineOperationsForPath,+  )+where++import qualified Data.Bifunctor as BF+import qualified Data.ByteString.Char8 as B8+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.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+      (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)+            ]+      )++-- | 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]++-- |+--  Defines an Operation for a Method and a Path+--  Uses an OperationObject+--+--  Returns a commented function definition and implementation in a Q Monad+defineModuleForOperation ::+  -- | The main module name passed via CLI options+  String ->+  -- | The path to the request (This is the key from the map of Operations)+  --  It may contain placeholder variables in the form of /my/{var}/path/+  Text ->+  -- | HTTP Method (GET,POST,etc)+  Text ->+  -- | The Operation Object+  OAT.OperationObject ->+  -- | commented function definition and implementation+  OAM.Generator (Q Dep.ModuleDefinition)+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"+      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+  let types = (getParameterType flags <$> params) <> 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+      createFunSignature operationName fnType' =+        ppr+          <$> sigD+            operationName+            ( forallT+                [plainTV monadName, plainTV securitySchemeName]+                (cxt [appT (conT ''OC.MonadHTTP) (varT monadName), appT (conT ''OC.SecurityScheme) (varT securitySchemeName)])+                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+          )++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
+ src/OpenAPI/Generate/Reference.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Contains function to resolve references within the OpenAPI specification+module OpenAPI.Generate.Reference+  ( ReferenceMap,+    ComponentReference (..),+    buildReferenceMap,+    getSchemaReference,+    getResponseReference,+    getParameterReference,+    getExampleReference,+    getRequestBodyReference,+    getHeaderReference,+    getSecuritySchemeReference,+  )+where++import Control.Monad+import qualified Data.Bifunctor as BF+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import Data.Text (Text)+import GHC.Generics+import qualified OpenAPI.Generate.Types as OAT+import qualified OpenAPI.Generate.Types.Schema as OAS++-- | Represents all types the 'ReferenceMap' can hold+data ComponentReference+  = SchemaReference OAS.SchemaObject+  | ResponseReference OAT.ResponseObject+  | ParameterReference OAT.ParameterObject+  | ExampleReference OAT.ExampleObject+  | RequestBodyReference OAT.RequestBodyObject+  | HeaderReference OAT.HeaderObject+  | SecuritySchemeReference OAT.SecuritySchemeObject+  deriving (Show, Eq, Generic)++-- | A lookup table for references within the OpenAPI specification+type ReferenceMap = Map.Map Text ComponentReference++-- | Creates a 'ReferenceMap' from an 'OAT.OpenApiSpecification' containing all elements within components.+-- It does not capture possibly referenced locations anywhere else in the specification.+buildReferenceMap :: OAT.OpenApiSpecification -> ReferenceMap+buildReferenceMap =+  Map.fromList+    . ( \o ->+          buildReferencesForComponentType "schemas" SchemaReference (OAT.schemas o)+            <> buildReferencesForComponentType "responses" ResponseReference (OAT.responses (o :: OAT.ComponentsObject))+            <> buildReferencesForComponentType "parameters" ParameterReference (OAT.parameters (o :: OAT.ComponentsObject))+            <> buildReferencesForComponentType "examples" ExampleReference (OAT.examples (o :: OAT.ComponentsObject))+            <> buildReferencesForComponentType "requestBodies" RequestBodyReference (OAT.requestBodies o)+            <> buildReferencesForComponentType "headers" HeaderReference (OAT.headers (o :: OAT.ComponentsObject))+            <> buildReferencesForComponentType "securitySchemes" SecuritySchemeReference (OAT.securitySchemes o)+      )+    . OAT.components++-- | Maps the subtypes of components to the entries of the 'ReferenceMap' and filters references (the lookup table should only contain concrete values).+buildReferencesForComponentType ::+  Text ->+  (a -> ComponentReference) ->+  Map.Map Text (OAT.Referencable a) ->+  [(Text, ComponentReference)]+buildReferencesForComponentType componentName constructor =+  fmap (BF.first (("#/components/" <> componentName <> "/") <>))+    . Maybe.mapMaybe (convertReferencableToReference constructor)+    . Map.toList++convertReferencableToReference ::+  (a -> ComponentReference) ->+  (Text, OAT.Referencable a) ->+  Maybe (Text, ComponentReference)+convertReferencableToReference constructor (name', OAT.Concrete object) = Just (name', constructor object)+convertReferencableToReference _ (_, OAT.Reference _) = Nothing++getReference :: Text -> ReferenceMap -> Maybe ComponentReference+getReference = Map.lookup++createReferenceLookup :: (ComponentReference -> Maybe a) -> Text -> ReferenceMap -> Maybe a+createReferenceLookup conversionFn key = getReference key >=> conversionFn++-- | Resolve a 'OAS.SchemaObject' reference from a 'ReferenceMap'+getSchemaReference :: Text -> ReferenceMap -> Maybe OAS.SchemaObject+getSchemaReference = createReferenceLookup $ \case+  SchemaReference r -> Just r+  _ -> Nothing++-- | Resolve a 'OAT.ResponseObject' reference from a 'ReferenceMap'+getResponseReference :: Text -> ReferenceMap -> Maybe OAT.ResponseObject+getResponseReference = createReferenceLookup $ \case+  ResponseReference r -> Just r+  _ -> Nothing++-- | Resolve a 'OAT.ParameterObject' reference from a 'ReferenceMap'+getParameterReference :: Text -> ReferenceMap -> Maybe OAT.ParameterObject+getParameterReference = createReferenceLookup $ \case+  ParameterReference r -> Just r+  _ -> Nothing++-- | Resolve a 'OAT.ExampleObject' reference from a 'ReferenceMap'+getExampleReference :: Text -> ReferenceMap -> Maybe OAT.ExampleObject+getExampleReference = createReferenceLookup $ \case+  ExampleReference r -> Just r+  _ -> Nothing++-- | Resolve a 'OAT.RequestBodyObject' reference from a 'ReferenceMap'+getRequestBodyReference :: Text -> ReferenceMap -> Maybe OAT.RequestBodyObject+getRequestBodyReference = createReferenceLookup $ \case+  RequestBodyReference r -> Just r+  _ -> Nothing++-- | Resolve a 'OAT.HeaderObject' reference from a 'ReferenceMap'+getHeaderReference :: Text -> ReferenceMap -> Maybe OAT.HeaderObject+getHeaderReference = createReferenceLookup $ \case+  HeaderReference r -> Just r+  _ -> Nothing++-- | Resolve a 'OAT.SecuritySchemeObject' reference from a 'ReferenceMap'+getSecuritySchemeReference :: Text -> ReferenceMap -> Maybe OAT.SecuritySchemeObject+getSecuritySchemeReference = createReferenceLookup $ \case+  SecuritySchemeReference r -> Just r+  _ -> Nothing
+ src/OpenAPI/Generate/Response.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- | This module contains the utilities to define the data types of the response type of an operation+module OpenAPI.Generate.Response+  ( getResponseDefinitions,+  )+where++import qualified Data.Aeson as Aeson+import qualified Data.Either as Either+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 Language.Haskell.TH.Syntax+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.Monad as OAM+import qualified OpenAPI.Generate.Types as OAT++-- | Generates a response type with a constructor for all possible response types of the operation.+--+-- Always generates an error case which is used if no other case matches.+getResponseDefinitions ::+  -- | The operation to generate the response types for+  OAT.OperationObject ->+  -- | A function which appends the passed 'Text' to the operation name and returns it+  (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+  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+  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+              <$> dataD+                (cxt [])+                responseName+                []+                Nothing+                ( fmap+                    ( \(suffix, _, maybeSchema) ->+                        normalC+                          (createName suffix)+                          ( case maybeSchema of+                              Just (type', _) -> [bangType (bang noSourceUnpackedness noSourceStrictness) type']+                              Nothing -> []+                          )+                    )+                    ((errorSuffix, [||const True||], Just ([t|String|], (Doc.emptyDoc, Set.empty))) : schemas)+                )+                [derivClause Nothing [conT ''Show, conT ''Eq]],+          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+-- Third: Reference or concrete response object+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)++-- | Same as @ResponseReferenceCase@ but with type definition+type ResponseCaseDefinition = (Text, TExpQ (HT.Status -> Bool), Maybe Model.TypeWithDeclaration)++-- | Suffix used for the error case+errorSuffix :: Text+errorSuffix = "Error"++-- | Create the name as 'Text' of the response type / data constructor based on a suffix+createResponseNameAsText :: Bool -> (Text -> Text) -> Text -> Text+createResponseNameAsText convertToCamelCase appendToOperationName = T.pack . haskellifyText convertToCamelCase True . appendToOperationName++-- | Create the name as 'Name' of the response type / data constructor based on a suffix+createResponseName :: Bool -> (Text -> Text) -> Text -> Name+createResponseName convertToCamelCase appendToOperationName = mkName . T.unpack . createResponseNameAsText convertToCamelCase appendToOperationName++-- | Generate the response cases which have a range instead of a single status code+getRangeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase]+getRangeResponseCases responsesObject =+  Maybe.catMaybes+    [ ("1XX",[||HT.statusIsInformational||],) <$> OAT.range1XX responsesObject,+      ("2XX",[||HT.statusIsSuccessful||],) <$> OAT.range2XX responsesObject,+      ("3XX",[||HT.statusIsRedirection||],) <$> OAT.range3XX responsesObject,+      ("4XX",[||HT.statusIsClientError||],) <$> OAT.range4XX responsesObject,+      ("5XX",[||HT.statusIsServerError||],) <$> OAT.range5XX responsesObject,+      ("Default",[||const True||],) <$> OAT.default' (responsesObject :: OAT.ResponsesObject)+    ]++-- | Generate the response cases based on the available status codes+getStatusCodeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase]+getStatusCodeResponseCases =+  fmap (\(code, response) -> (T.pack $ show code, [||\status -> HT.statusCode status == code||], response))+    . Map.toList+    . OAT.perStatusCode++-- | Resolve the references in response cases+--+-- Note: Discards the unresolved references and generates a log message for them+resolveResponseReferences :: [ResponseReferenceCase] -> OAM.Generator [ResponseCase]+resolveResponseReferences =+  fmap Maybe.catMaybes+    . mapM+      ( \(suffix, guard, response) ->+          fmap (suffix,guard,) <$> OAM.nested suffix (getResponseObject response)+      )++-- | Generate the response definitions+--+-- If no response schema is available for a case (or with an unsupported media type), an empty data constructor is used+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+    )++-- | Prints the definitions of the different response case data types in 'Q'+printSchemaDefinitions :: [ResponseCaseDefinition] -> Q Doc+printSchemaDefinitions =+  fmap vcat+    . sequence+    . Maybe.mapMaybe (\(_, _, namedTypeDef) -> fmap (fst . snd) namedTypeDef)++-- | Creates a function as 'Q Exp' which can be used in the generated code to transform the response+createResponseTransformerFn :: (Text -> Name) -> [ResponseCaseDefinition] -> Q Exp+createResponseTransformerFn createName schemas =+  let responseArgName = mkName "response"+      bodyName = mkName "body"+      ifCases =+        multiIfE $+          fmap+            ( \(suffix, guard, maybeSchema) ->+                normalGE+                  [|$(unTypeQ guard) (HC.responseStatus $(varE responseArgName))|]+                  ( case maybeSchema of+                      Just (type', _) -> [|$(varE $ createName suffix) <$> (Aeson.eitherDecodeStrict $(varE bodyName) :: Either String $type')|]+                      Nothing -> [|Right $(varE $ createName suffix)|]+                  )+            )+            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))|]++getResponseDescription :: OAT.ResponseObject -> Text+getResponseDescription response = Doc.escapeText $ OAT.description (response :: OAT.ResponseObject)
+ src/OpenAPI/Generate/SecurityScheme.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Provides the generation functions for the supported security schemes+module OpenAPI.Generate.SecurityScheme+  ( defineSupportedSecuritySchemes,+  )+where++import qualified Data.Bifunctor as BF+import qualified Data.Maybe as Maybe+import Data.Text (Text)+import Language.Haskell.TH+import Language.Haskell.TH.PprLib hiding ((<>))+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Simple as HS+import qualified OpenAPI.Common as OC+import qualified OpenAPI.Generate.Doc as Doc+import qualified OpenAPI.Generate.Monad as OAM+import qualified OpenAPI.Generate.Types as OAT++-- | Defines the security schemes which are configured in the OpenAPI specification+--+-- Generates warnings if unsupported schemes are defined in the specification+defineSupportedSecuritySchemes :: Text -> [(Text, OAT.SecuritySchemeObject)] -> OAM.Generator (Q Doc)+defineSupportedSecuritySchemes moduleName securitySchemes = OAM.nested "securitySchemes" $ do+  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)."+    )+    $ filter (Maybe.isNothing . snd) securitySchemeDefinitions+  pure $ fmap vcat $ mapM (fmap ($$ text "") . snd) $ Maybe.mapMaybe sequence securitySchemeDefinitions++-- | Defines the security scheme for one 'OAT.SecuritySchemeObject'+defineSecurityScheme :: Text -> OAT.SecuritySchemeObject -> Maybe (Q Doc)+defineSecurityScheme moduleName (OAT.HttpSecuritySchemeObject scheme) =+  let description = Doc.escapeText $ Maybe.fromMaybe "" $ OAT.description (scheme :: OAT.HttpSecurityScheme)+   in case OAT.scheme scheme of+        "basic" -> Just $ basicAuthenticationScheme moduleName description+        "bearer" -> Just $ bearerAuthenticationScheme 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"+      dataDefinition =+        dataD+          (cxt [])+          dataName+          []+          Nothing+          [ recC+              dataName+              [ varBangType usernameName $ bangType (bang noSourceUnpackedness noSourceStrictness) $ conT ''Text,+                varBangType passwordName $ 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+                  [varP paramName]+                  ( normalB+                      [|+                        HC.applyBasicAuth+                          (OC.textToByte $ $(varE usernameName) $(varE paramName))+                          (OC.textToByte $ $(varE passwordName) $(varE paramName))+                        |]+                  )+                  []+              ]+          ]+   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\"",+                      "        }",+                      "  }",+                      "@"+                    ]+                    $$+                )+              . ppr <$> dataDefinition,+            ppr <$> instanceDefinition+          ]++-- | 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)+                        |]+                  )+                  []+              ]+          ]+   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\"",+                      "  }",+                      "@"+                    ]+                    $$+                )+              . ppr+              <$> dataDefinition,+            ppr <$> instanceDefinition+          ]
+ src/OpenAPI/Generate/Types.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | This module specifies the data types from the OpenAPI specification 3.0.3+--+-- For more information see http://spec.openapis.org/oas/v3.0.3+--+-- All names in this module correspond to the respective OpenAPI types+module OpenAPI.Generate.Types+  ( module OpenAPI.Generate.Types.ExternalDocumentation,+    module OpenAPI.Generate.Types.Referencable,+    module OpenAPI.Generate.Types.Schema,+    module OpenAPI.Generate.Types,+  )+where++import qualified Data.HashMap.Strict as HMap+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 GHC.Generics+import OpenAPI.Generate.Types.ExternalDocumentation+import OpenAPI.Generate.Types.Referencable+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+      }+  deriving (Show, Eq, Generic)++instance FromJSON OpenApiSpecification where+  parseJSON = withObject "OpenApiSpecification" $ \o ->+    OpenApiSpecification+      <$> o .: "openapi"+      <*> o .: "info"+      <*> o .:? "servers" .!= []+      <*> o .: "paths"+      <*> o .:? "components"+        .!= ComponentsObject+          { schemas = Map.empty,+            responses = Map.empty,+            parameters = Map.empty,+            examples = Map.empty,+            requestBodies = Map.empty,+            headers = Map.empty,+            securitySchemes = Map.empty+          }+      <*> o .:? "security" .!= []+      <*> o .:? "tags" .!= []+      <*> o .:? "externalDocs"++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+      }+  deriving (Show, Eq, Generic)++instance FromJSON ContactObject++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]+      }+  deriving (Show, Eq, Generic)++instance FromJSON PathItemObject where+  parseJSON = withObject "PathItemObject" $ \o ->+    PathItemObject+      <$> o .:? "ref"+      <*> o .:? "summary"+      <*> o .:? "description"+      <*> o .:? "get"+      <*> o .:? "put"+      <*> o .:? "post"+      <*> o .:? "delete"+      <*> o .:? "options"+      <*> o .:? "head"+      <*> o .:? "patch"+      <*> o .:? "trace"+      <*> 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+      }+  deriving (Show, Eq, Generic)++instance FromJSON OperationObject where+  parseJSON = withObject "OperationObject" $ \o ->+    OperationObject+      <$> o .:? "tags" .!= []+      <*> o .:? "summary"+      <*> o .:? "description"+      <*> o .:? "externalDocs"+      <*> o .:? "operationId"+      <*> o .:? "parameters" .!= []+      <*> o .:? "requestBody"+      <*> o .: "responses"+      <*> o .:? "deprecated" .!= False+      <*> o .:? "security" .!= []+      <*> o .:? "servers" .!= []++type SecurityRequirementObject = Map.Map Text [Text]++data RequestBodyObject+  = RequestBodyObject+      { content :: Map.Map Text MediaTypeObject,+        description :: Maybe Text,+        required :: Bool+      }+  deriving (Show, Eq, Generic)++instance FromJSON RequestBodyObject where+  parseJSON = withObject "RequestBodyObject" $ \o ->+    RequestBodyObject+      <$> o .: "content"+      <*> 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+      }+  deriving (Show, Eq, Generic)++instance FromJSON MediaTypeObject where+  parseJSON = withObject "MediaTypeObject" $ \o ->+    MediaTypeObject+      <$> o .:? "schema"+      <*> o .:? "example"+      <*> 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+      }+  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+      }+  deriving (Show, Eq, Generic)++instance FromJSON EncodingObject where+  parseJSON = withObject "EncodingObject" $ \o ->+    EncodingObject+      <$> o .:? "contentType"+      <*> o .:? "headers" .!= Map.empty+      <*> o .:? "style"+      <*> 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)+      }+  deriving (Show, Eq, Generic)++instance FromJSON ResponsesObject where+  parseJSON = withObject "ResponsesObject" $ \o ->+    ResponsesObject+      <$> o .:? "default"+      <*> o .:? "1XX"+      <*> o .:? "2XX"+      <*> o .:? "3XX"+      <*> o .:? "4XX"+      <*> o .:? "5XX"+      <*> mapM+        parseJSON+        ( Map.fromList+            . filter (\(code, _) -> code >= 100 && code < 600)+            . Maybe.mapMaybe+              ( \(code, response) -> fmap (,response) . readMaybe . T.unpack $ code+              )+            $ 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+      }+  deriving (Show, Eq, Generic)++instance FromJSON ResponseObject where+  parseJSON = withObject "ResponseObject" $ \o ->+    ResponseObject+      <$> o .: "description"+      <*> o .:? "headers" .!= Map.empty+      <*> o .:? "content" .!= Map.empty++data ServerObject+  = ServerObject+      { url :: Text,+        description :: Maybe Text,+        variables :: Map.Map Text ServerVariableObject+      }+  deriving (Show, Eq, Generic)++instance FromJSON ServerObject where+  parseJSON = withObject "ServerObject" $ \o ->+    ServerObject+      <$> o .: "url"+      <*> o .:? "description"+      <*> o .:? "variables" .!= Map.empty++data ServerVariableObject+  = ServerVariableObject+      { enum :: [Text],+        default' :: Text,+        description :: Maybe Text+      }+  deriving (Show, Eq, Generic)++instance FromJSON ServerVariableObject where+  parseJSON = withObject "ServerVariableObject" $ \o ->+    ServerVariableObject+      <$> o .:? "enum" .!= []+      <*> o .: "default"+      <*> o .:? "description"++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+  parseJSON = withObject "ParameterObject" $ \o ->+    ParameterObject+      <$> o .: "name"+      <*> o .: "in"+      <*> o .:? "description"+      <*> o .:? "required" .!= False+      <*> o .:? "deprecated" .!= False+      <*> o .:? "allowEmptyValue" .!= False+      <*> parseJSON (Object o)++data ParameterObjectLocation = QueryParameterObjectLocation | HeaderParameterObjectLocation | PathParameterObjectLocation | CookieParameterObjectLocation+  deriving (Show, Eq, Generic)++instance FromJSON ParameterObjectLocation where+  parseJSON = withText "ParameterObjectLocation" $ \case+    "query" -> pure QueryParameterObjectLocation+    "header" -> pure HeaderParameterObjectLocation+    "path" -> pure PathParameterObjectLocation+    "cookie" -> pure CookieParameterObjectLocation+    _ -> 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)+      }+  | ComplexParameterObjectSchema (Map.Map Text MediaTypeObject)+  deriving (Show, Eq, Generic)++instance FromJSON ParameterObjectSchema where+  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+      (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."++newtype HeaderObject = HeaderObject ParameterObject+  deriving (Show, Eq, Generic)++instance FromJSON HeaderObject where+  parseJSON = withObject "HeaderObject" $ \o ->+    HeaderObject+      <$> ( ParameterObject "name MUST NOT be specified, it is given in the corresponding headers map" HeaderParameterObjectLocation+              <$> o .:? "description"+              <*> o .:? "required" .!= False+              <*> o .:? "deprecated" .!= False+              <*> o .:? "allowEmptyValue" .!= False+              <*> 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+      }+  deriving (Show, Eq, Generic)++instance FromJSON ComponentsObject where+  parseJSON = withObject "ComponentsObject" $ \o ->+    ComponentsObject+      <$> o .:? "schemas" .!= Map.empty+      <*> o .:? "responses" .!= Map.empty+      <*> o .:? "parameters" .!= Map.empty+      <*> o .:? "examples" .!= Map.empty+      <*> o .:? "requestBodies" .!= Map.empty+      <*> o .:? "headers" .!= Map.empty+      <*> o .:? "securitySchemes" .!= Map.empty++data SecuritySchemeObject+  = ApiKeySecuritySchemeObject ApiKeySecurityScheme+  | HttpSecuritySchemeObject HttpSecurityScheme+  | OAuth2SecuritySchemeObject OAuth2SecurityScheme+  | OpenIdConnectSecuritySchemeObject OpenIdConnectSecurityScheme+  deriving (Show, Eq, Generic)++instance FromJSON SecuritySchemeObject where+  parseJSON = withObject "SecuritySchemeObject" $ \o -> do+    type' <- o .: "type"+    case (type' :: Text) of+      "apiKey" -> ApiKeySecuritySchemeObject <$> parseJSON (Object o)+      "http" -> HttpSecuritySchemeObject <$> parseJSON (Object o)+      "oauth2" -> OAuth2SecuritySchemeObject <$> parseJSON (Object o)+      "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+      }+  deriving (Show, Eq, Generic)++instance FromJSON ApiKeySecurityScheme where+  parseJSON = withObject "ApiKeySecurityScheme" $ \o ->+    ApiKeySecurityScheme+      <$> o .:? "description"+      <*> o .: "name"+      <*> o .: "in"++data ApiKeySecuritySchemeLocation = QueryApiKeySecuritySchemeLocation | HeaderApiKeySecuritySchemeLocation | CookieApiKeySecuritySchemeLocation+  deriving (Show, Eq, Generic)++instance FromJSON ApiKeySecuritySchemeLocation where+  parseJSON = withText "ApiKeySecuritySchemeLocation" $ \case+    "query" -> pure QueryApiKeySecuritySchemeLocation+    "header" -> pure HeaderApiKeySecuritySchemeLocation+    "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+      }+  deriving (Show, Eq, Generic)++instance FromJSON HttpSecurityScheme++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+      }+  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+      }+  deriving (Show, Eq, Generic)++instance FromJSON OAuthFlowObject++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+      }+  deriving (Show, Eq, Generic)++instance FromJSON TagObject
+ src/OpenAPI/Generate/Types/ExternalDocumentation.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}++-- | For more information see http://spec.openapis.org/oas/v3.0.3#external-documentation-object+module OpenAPI.Generate.Types.ExternalDocumentation where++import Data.Text (Text)+import Data.Yaml+import GHC.Generics++data ExternalDocumentationObject+  = ExternalDocumentationObject+      { url :: Text,+        description :: Maybe Text+      }+  deriving (Show, Ord, Eq, Generic)++instance FromJSON ExternalDocumentationObject
+ src/OpenAPI/Generate/Types/Referencable.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Many fields in OpenAPI can be either a reference or a concrete object.+-- This module adds this capabilities.+--+-- For more information see http://spec.openapis.org/oas/v3.0.3#reference-object+module OpenAPI.Generate.Types.Referencable where++import Data.Text (Text)+import Data.Yaml++-- | Represents either a reference or a concrete value+data Referencable a+  = -- | A reference with the JSON reference string pointing to the referenced target+    Reference Text+  | -- | A concrete value which can be used directly+    Concrete a+  deriving (Show, Eq, Ord)++instance FromJSON a => FromJSON (Referencable a) where+  parseJSON (Object v) = do+    maybeReference <- v .:? "$ref"+    case maybeReference of+      (Just reference) -> pure (Reference reference)+      Nothing -> Concrete <$> parseJSON (Object v)+  parseJSON v = Concrete <$> parseJSON v
+ src/OpenAPI/Generate/Types/Schema.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This module specifies the data types from the OpenAPI specification 3.0.3 Schema+--+-- For more information see http://spec.openapis.org/oas/v3.0.3+-- and https://json-schema.org/+--+-- All names in this module correspond to the respective OpenAPI types+module OpenAPI.Generate.Types.Schema where++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.Text (Text)+import Data.Yaml+import GHC.Generics+import OpenAPI.Generate.Types.ExternalDocumentation+import OpenAPI.Generate.Types.Referencable++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)++instance FromJSON SchemaObject where+  parseJSON = withObject "SchemaObject" $ \o ->+    SchemaObject+      <$> o .:? "type" .!= SchemaTypeObject+      <*> o .:? "title"+      <*> o .:? "multipleOf"+      <*> o .:? "maximum"+      <*> o .:? "exclusiveMaximum" .!= False+      <*> o .:? "minimum"+      <*> o .:? "exclusiveMinimum" .!= False+      <*> o .:? "maxLength"+      <*> o .:? "minLength"+      <*> o .:? "pattern"+      <*> o .:? "maxItems"+      <*> o .:? "minItems"+      <*> o .:? "uniqueItems" .!= False+      <*> 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 .:? "not"+      <*> o .:? "properties" .!= Map.empty+      <*> o .:? "additionalProperties" .!= HasAdditionalProperties+      <*> o .:? "description"+      <*> o .:? "format"+      <*> o .:? "default"+      <*> o .:? "nullable" .!= False+      <*> o .:? "discriminator"+      <*> o .:? "readOnly" .!= False+      <*> o .:? "writeOnly" .!= False+      <*> o .:? "xml"+      <*> o .:? "externalDocs"+      <*> o .:? "example"+      <*> o .:? "deprecated" .!= False+      <*> o .:? "items"++data SchemaType+  = SchemaTypeString+  | SchemaTypeNumber+  | SchemaTypeInteger+  | SchemaTypeBool+  | SchemaTypeObject+  | SchemaTypeArray+  deriving (Show, Eq, Ord, Generic)++instance FromJSON SchemaType where+  parseJSON (String "integer") = pure SchemaTypeInteger+  parseJSON (String "string") = pure SchemaTypeString+  parseJSON (String "number") = pure SchemaTypeNumber+  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 _ = fail "type must be of type string"++data DiscriminatorObject+  = DiscriminatorObject+      { propertyName :: Text,+        mapping :: Map.Map Text Text+      }+  deriving (Show, Eq, Ord, Generic)++instance FromJSON DiscriminatorObject where+  parseJSON = withObject "DiscriminatorObject" $ \o ->+    DiscriminatorObject+      <$> 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)++instance FromJSON ConcreteValue where+  parseJSON v@(String _) = StringDefaultValue <$> parseJSON v+  parseJSON v@(Number _) = NumericDefaultValue <$> parseJSON v+  parseJSON v@(Bool _) = BoolDefaultValue <$> parseJSON v+  parseJSON v = pure $ OtherDefaultValue v++data AdditionalProperties+  = NoAdditionalProperties+  | HasAdditionalProperties+  | AdditionalPropertiesWithSchema Schema+  deriving (Show, Eq, Ord, 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+      }+  deriving (Show, Eq, Ord, Generic)++instance FromJSON XMLObject where+  parseJSON = withObject "SchemaObject" $ \o ->+    XMLObject+      <$> o .:? "name"+      <*> o .:? "namespace"+      <*> o .:? "prefix"+      <*> o .:? "attribute" .!= False+      <*> o .:? "wrapped" .!= False
+ test/OpenAPI/Generate/DocSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.DocSpec where++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++newtype MultiLineString = MultiLineString String+  deriving (Eq, Show, Generic)++instance Validity MultiLineString++instance GenUnchecked MultiLineString where+  genUnchecked =+    MultiLineString+      <$> genListOf+        ( frequency [(9, genUnchecked :: Gen Char), (1, pure '\n')]+        )++instance GenValid MultiLineString++spec :: Spec+spec = do+  describe "sideBySide" $ do+    it "should place equally long docs" $+      show+        ( sideBySide+            ( text "a" $$ text "c"+            )+            (text "b" $$ text "d")+        )+        `shouldBe` show (text "a b" $$ text "c d")+    it "should indent if right doc is longer" $+      show+        ( sideBySide+            ( text "a" $$ text "c"+            )+            (text "b" $$ text "d" $$ text "e")+        )+        `shouldBe` show (text "a b" $$ text "c d" $$ text "  e")+    it "should not indent if left doc is longer" $+      show+        ( sideBySide+            ( text "a" $$ text "c" $$ text "e"+            )+            (text "b" $$ text "d")+        )+        `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+      forAllValid $ \(MultiLineString doc1, MultiLineString doc2) ->+        numberOfLinesOfDoc+          ( sideBySide+              (text doc1)+              (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+                [ "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",+            "  , b = 321",+            "  , 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
@@ -0,0 +1,16 @@+module OpenAPI.Generate.Internal.UtilSpec where++import OpenAPI.Generate.Internal.Util+import Test.Hspec+import Test.Validity++spec :: Spec+spec =+  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
+ test/OpenAPI/Generate/ModelDependenciesSpec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.ModelDependenciesSpec where++import Data.Bifunctor+import Data.List+import qualified Data.Set as Set+import Language.Haskell.TH+import Language.Haskell.TH.PprLib hiding ((<>))+import OpenAPI.Generate.ModelDependencies+import Test.Hspec++spec :: Spec+spec =+  describe "getModelModulesFromModelsWithDependencies" $ do+    let sut = getModelModulesFromModelsWithDependencies "OpenAPI"+        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"]))+            ]+      sortBy (\(a, _) (b, _) -> compare a b) (fmap (second show) result)+        `shouldSatisfy` ( \case+                            [ (["CyclicTypes"], cyclicContent),+                              (["Types"], _),+                              (["Types", "A"], aContent),+                              (["Types", "B"], bContent),+                              (["Types", "C"], cContent),+                              (["Types", "D"], dContent)+                              ] ->+                                and+                                  [ "aToken" `isInfixOf` aContent,+                                    "bToken" `isInfixOf` bContent,+                                    "cToken" `isInfixOf` cContent,+                                    "dToken" `isInfixOf` dContent,+                                    "eToken" `isInfixOf` cyclicContent,+                                    "fToken" `isInfixOf` cyclicContent,+                                    "gToken" `isInfixOf` cyclicContent+                                  ]+                            _ -> False+                        )
+ test/OpenAPI/Generate/MonadSpec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.MonadSpec where++import Control.Monad.Reader+import Data.Bifunctor+import Data.GenValidity.Text ()+import Data.List+import qualified Data.Map as Map+import qualified Data.Text as T+import Data.Validity.Text ()+import qualified OpenAPI.Generate.Flags as OAF+import OpenAPI.Generate.Monad+import OpenAPI.Generate.Reference+import OpenAPI.Generate.Types as OAT+import Test.Hspec+import Test.Validity++spec :: Spec+spec = do+  let run = runGenerator (createEnvironment OAF.defaultFlags 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 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+            `shouldBe` [ (["a"], "1"),+                         (["a", "b"], "2"),+                         (["a", "b", "c"], "3"),+                         (["a", "b"], "4"),+                         (["a"], "5")+                       ]+  describe "logs" $ do+    let msgAndLogToTupleList list logs = bimap T.unpack T.unpack <$> zip list (transformGeneratorLogs 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+  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)+              ]+    it "should find existing reference to example" $ do+      let (maybeExample, _) = runWithEnv $ getExampleReferenceM "#/components/examples/example1"+      maybeExample `shouldBe` Just e+    it "should find existing reference to request body" $ do+      let (maybeBody, _) = runWithEnv $ getRequestBodyReferenceM "#/components/requestBodies/body1"+      maybeBody `shouldBe` Just b+    it "should not find existing reference with wrong type" $ do+      let (maybeExample, _) = runWithEnv $ getExampleReferenceM "#/components/requestBodies/body1"+      maybeExample `shouldBe` Nothing+    it "should not find non-existing reference" $ do+      let (maybeExample, _) = runWithEnv $ getExampleReferenceM "#/components/examples/example99"+      maybeExample `shouldBe` Nothing
+ test/OpenAPI/Generate/OperationGetOperationDescriptionSpec.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.OperationGetOperationDescriptionSpec where++import qualified Data.Map as Map+import OpenAPI.Generate.Internal.Operation+import OpenAPI.Generate.Types as OAT+import Test.Hspec++spec :: Spec+spec =+  let emptyResponseObject =+        OAT.ResponsesObject+          { default' = Nothing,+            range1XX = Nothing,+            range2XX = Nothing,+            range3XX = Nothing,+            range4XX = Nothing,+            range5XX = Nothing,+            perStatusCode = Map.empty+          }+      testOperation =+        OAT.OperationObject+          { tags = [],+            summary = Nothing,+            description = Nothing,+            externalDocs = Nothing,+            operationId = Nothing,+            parameters = [],+            requestBody = Nothing,+            responses = emptyResponseObject,+            deprecated = False,+            security = [],+            servers = []+          }+      testOperation2 =+        testOperation+          { summary = Just "my summary"+          } ::+          OAT.OperationObject+      testOperation3 =+        testOperation+          { description = Just "my description"+          } ::+          OAT.OperationObject+      testOperation4 =+        testOperation+          { summary = Just "my summary",+            description = Just "my description"+          } ::+          OAT.OperationObject+   in describe "getOperationDesciption" $ do+        it+          "should return an empty string"+          (getOperationDescription testOperation `shouldBe` "")+        it+          "should return description"+          (getOperationDescription testOperation2 `shouldBe` "my summary")+        it+          "should return summary"+          (getOperationDescription testOperation3 `shouldBe` "my description")+        it+          "should return description"+          (getOperationDescription testOperation4 `shouldBe` "my description")
+ test/OpenAPI/Generate/OperationTHSpec.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module OpenAPI.Generate.OperationTHSpec where++import qualified Data.ByteString.Char8 as B8+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import Data.Text as T+import Data.Yaml+import Language.Haskell.TH+import qualified Network.HTTP.Simple as HS+import qualified Network.HTTP.Types as HT+import qualified OpenAPI.Common as OC+import OpenAPI.Generate.Internal.Operation+import OpenAPI.Generate.Types as OAT+import OpenAPI.Generate.Types.Schema as OAS+import Test.Hspec++spec :: Spec+spec =+  let singleTestTH desc should is =+        it desc $ do+          expected <- runQ should+          res <- runQ is+          expected `shouldBe` res+      schemaObject = Maybe.fromJust $ decodeThrow "{}" :: OAS.SchemaObject+      testParameterSchema = OAT.SimpleParameterObjectSchema 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))|]+      monadName = mkName "m"+      securitySchemeName = mkName "s"+   in do+        describe "generateQueryParams" $+          singleTestTH+            "should generate empty list"+            (generateQueryParams [])+            [|[]|]+        describe "generateParameterizedRequestPath" $ do+          singleTestTH+            "should not change empty path without arguments"+            (generateParameterizedRequestPath [] (T.pack ""))+            [|""|]+          singleTestTH+            "should not change path without arguments"+            (generateParameterizedRequestPath [] (T.pack "/my/path/"))+            [|"/my/path/"|]+          singleTestTH+            "should ignore params not names"+            (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/my/path/"))+            [|"/my/path/"|]+          singleTestTH+            "should replace one occurences at the end"+            (generateParameterizedRequestPath [(mkName "myTestName", 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}/"))+            [|"/my/path/" ++ $(testTHE) ++ "/"|]+          singleTestTH+            "should replace one occurences at the beginning"+            (generateParameterizedRequestPath [(mkName "myTestName", 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/"))+            [|"/" ++ $(testTHE) ++ "/my/path/"|]+          singleTestTH+            "should replace one occurences in the middle"+            (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/another/test/{testName}/my/path/"))+            [|"/another/test/" ++ $(testTHE) ++ "/my/path/"|]+          singleTestTH+            "should ignore names not given"+            (generateParameterizedRequestPath [] (T.pack "/another/test/{testName}/my/path/"))+            [|"/another/test/{testName}/my/path/"|]+          singleTestTH+            "should replace two occurences"+            ( generateParameterizedRequestPath+                [(mkName "myTestName", testParameter), (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)]+                (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)))|]+          singleTestTH+            "no parameters"+            (getParametersTypeForSignature [] responseTypeName monadName securitySchemeName)+            [t|OC.Configuration $(varT securitySchemeName) -> $(responseType)|]+          singleTestTH+            "One parameters"+            (getParametersTypeForSignature [conT ''Int] responseTypeName monadName securitySchemeName)+            [t|OC.Configuration $(varT securitySchemeName) -> Int -> $(responseType)|]+          singleTestTH+            "Optional parameters"+            (getParametersTypeForSignature [[t|Maybe Int|]] responseTypeName monadName securitySchemeName)+            [t|OC.Configuration $(varT securitySchemeName) -> Maybe Int -> $(responseType)|]+          singleTestTH+            "Two parameters"+            (getParametersTypeForSignature [conT ''Int, conT ''String] responseTypeName monadName securitySchemeName)+            [t|OC.Configuration $(varT securitySchemeName) -> Int -> String -> $(responseType)|]
+ test/OpenAPI/Generate/ReferenceSpec.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.ReferenceSpec where++import qualified Data.Map as Map+import OpenAPI.Generate.Reference+import OpenAPI.Generate.Types as OAT+import Test.Hspec++spec :: Spec+spec = do+  let i =+        OAT.InfoObject+          { title = "",+            description = Nothing,+            termsOfService = Nothing,+            contact = Nothing,+            license = Nothing,+            version = "0.0.1"+          }+      e = OAT.ExampleObject {summary = Just "foo", description = Nothing, value = Nothing, externalValue = Just "http://example.com"}+      c =+        OAT.ComponentsObject+          { schemas = Map.empty,+            responses = Map.empty,+            parameters = Map.empty,+            examples =+              Map.fromList+                [ ("example1", OAT.Concrete e),+                  ("example2", OAT.Reference "#/components/examples/example1")+                ],+            requestBodies = Map.empty,+            headers = Map.empty,+            securitySchemes = Map.empty+          }+      openApiSpec =+        OAT.OpenApiSpecification+          { openapi = "3.0.3",+            info = i,+            servers = [],+            paths = Map.empty,+            components = c,+            security = [],+            tags = [],+            externalDocs = Nothing+          }+  describe "buildReferenceMap" $ do+    it "should find reference" $+      getExampleReference "#/components/examples/example1" (buildReferenceMap openApiSpec)+        `shouldBe` Just e+    it "should not find reference pointing to other reference" $+      getExampleReference "#/components/examples/example2" (buildReferenceMap openApiSpec) `shouldBe` Nothing+    it "should not find unexisting reference" $+      getExampleReference "#/components/examples/example99" (buildReferenceMap openApiSpec) `shouldBe` Nothing
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}