openapi3-code-generator 0.1.0.7 → 0.2.0.0
raw patch · 32 files changed
+1241/−842 lines, 32 filesnew-uploader
Files
- openapi3-code-generator.cabal +3/−4
- src/OpenAPI/Common.hs +114/−65
- src/OpenAPI/Generate.hs +1/−2
- src/OpenAPI/Generate/Doc.hs +20/−11
- src/OpenAPI/Generate/IO.hs +53/−35
- src/OpenAPI/Generate/Internal/Embed.hs +1/−4
- src/OpenAPI/Generate/Internal/Operation.hs +107/−98
- src/OpenAPI/Generate/Internal/Unknown.hs +6/−4
- src/OpenAPI/Generate/Internal/Util.hs +33/−32
- src/OpenAPI/Generate/Main.hs +19/−11
- src/OpenAPI/Generate/Model.hs +262/−173
- src/OpenAPI/Generate/ModelDependencies.hs +16/−13
- src/OpenAPI/Generate/Monad.hs +24/−14
- src/OpenAPI/Generate/Operation.hs +32/−23
- src/OpenAPI/Generate/OptParse.hs +28/−8
- src/OpenAPI/Generate/OptParse/Configuration.hs +10/−1
- src/OpenAPI/Generate/OptParse/Flags.hs +38/−1
- src/OpenAPI/Generate/OptParse/Types.hs +72/−0
- src/OpenAPI/Generate/Reference.hs +8/−9
- src/OpenAPI/Generate/Response.hs +18/−13
- src/OpenAPI/Generate/SecurityScheme.hs +5/−6
- src/OpenAPI/Generate/Types.hs +196/−142
- src/OpenAPI/Generate/Types/ExternalDocumentation.hs +8/−3
- src/OpenAPI/Generate/Types/Referencable.hs +1/−1
- src/OpenAPI/Generate/Types/Schema.hs +82/−82
- test/OpenAPI/Generate/DocSpec.hs +3/−5
- test/OpenAPI/Generate/Internal/UtilSpec.hs +12/−7
- test/OpenAPI/Generate/ModelDependenciesSpec.hs +1/−1
- test/OpenAPI/Generate/MonadSpec.hs +2/−2
- test/OpenAPI/Generate/OperationGetOperationDescriptionSpec.hs +25/−29
- test/OpenAPI/Generate/OperationTHSpec.hs +19/−20
- test/OpenAPI/Generate/ReferenceSpec.hs +22/−23
openapi3-code-generator.cabal view
@@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack------ hash: 32506648aaf0bd947f7c5eab0209f3426a5e70f31645b6045ab0a9c326ea3167 name: openapi3-code-generator-version: 0.1.0.7+version: 0.2.0.0 synopsis: OpenAPI3 Haskell Client Code Generator description: Please see the README on GitHub at <https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator#readme> category: Code-Generator@@ -45,6 +43,7 @@ OpenAPI.Generate.OptParse OpenAPI.Generate.OptParse.Configuration OpenAPI.Generate.OptParse.Flags+ OpenAPI.Generate.OptParse.Types OpenAPI.Generate.Reference OpenAPI.Generate.Response OpenAPI.Generate.SecurityScheme
src/OpenAPI/Common.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}@@ -13,16 +15,18 @@ doBodyCallWithConfigurationM, runWithConfiguration, textToByte,+ byteToText, stringifyModel, anonymousSecurityScheme,+ jsonObjectToList, Configuration (..), SecurityScheme, MonadHTTP (..),- StringifyModel, JsonByteString (..), JsonDateTime (..), RequestBodyEncoding (..), QueryParameter (..),+ Nullable (..), ClientT (..), ClientM, )@@ -32,33 +36,45 @@ import qualified Control.Monad.Reader as MR import qualified Control.Monad.Trans.Class as MT import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Encoding+import Data.Aeson.Text (encodeToTextBuilder) import qualified Data.Bifunctor as BF-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as LB8-import qualified Data.HashMap.Strict as HMap+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import qualified Data.Maybe as Maybe import qualified Data.Scientific as Scientific import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText) import qualified Data.Time.LocalTime as Time import qualified Data.Vector as Vector import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Simple as HS+import qualified Network.HTTP.Types as HT +#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as HMap+#endif+ -- | 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 (HS.Response B8.ByteString)+class (Monad m) => MonadHTTP m where+ httpBS :: HS.Request -> m (HS.Response BS.ByteString) -- | This instance is the default instance used for production code instance MonadHTTP IO where httpBS = HS.httpBS -instance MonadHTTP m => MonadHTTP (MR.ReaderT r m) where+instance (MonadHTTP m) => MonadHTTP (MR.ReaderT r m) where httpBS = MT.lift . httpBS -instance MonadHTTP m => MonadHTTP (ClientT m) where+instance (MonadHTTP m) => MonadHTTP (ClientT m) where httpBS = MT.lift . httpBS -- | The monad in which the operations can be run.@@ -71,7 +87,7 @@ instance MT.MonadTrans ClientT where lift = ClientT . MT.lift -instance MIO.MonadIO m => MIO.MonadIO (ClientT m) where+instance (MIO.MonadIO m) => MIO.MonadIO (ClientT m) where liftIO = ClientT . MIO.liftIO -- | Utility type which uses 'IO' as underlying monad@@ -99,8 +115,18 @@ -- > defaultConfiguration -- > { configSecurityScheme = bearerAuthenticationSecurityScheme "token" } data Configuration = Configuration- { configBaseURL :: Text,- configSecurityScheme :: SecurityScheme+ { -- | The path of the operation is appended to this URL+ configBaseURL :: Text,+ -- | The 'SecurityScheme' which is applied to the request+ -- This is used to set the @Authentication@ header for example+ configSecurityScheme :: SecurityScheme,+ -- | This flag indicates if an automatically generated @User-Agent@ header+ -- should be added to the request. This allows the server to detect with+ -- which version of the generator the code was generated.+ configIncludeUserAgent :: Bool,+ -- | The application name which will be included in the @User-Agent@ header+ -- if 'configIncludeUserAgent' is set to 'True'+ configApplicationName :: Text } -- | Defines how a request body is encoded@@ -130,7 +156,7 @@ -- -- It makes a concrete Call to a Server without a body doCallWithConfiguration ::- MonadHTTP m =>+ (MonadHTTP m) => -- | Configuration options like base URL and security scheme Configuration -> -- | HTTP method (GET, POST, etc.)@@ -140,18 +166,18 @@ -- | Query parameters [QueryParameter] -> -- | The raw response from the server- m (HS.Response B8.ByteString)+ m (HS.Response BS.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 =>+ (MonadHTTP m) => Text -> Text -> [QueryParameter] ->- ClientT m (HS.Response B8.ByteString)+ ClientT m (HS.Response BS.ByteString) doCallWithConfigurationM method path queryParams = do config <- MR.ask MT.lift $ doCallWithConfiguration config method path queryParams@@ -174,7 +200,7 @@ -- | JSON or form data deepobjects RequestBodyEncoding -> -- | The raw response from the server- m (HS.Response B8.ByteString)+ m (HS.Response BS.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@@ -195,7 +221,7 @@ [QueryParameter] -> Maybe body -> RequestBodyEncoding ->- ClientT m (HS.Response B8.ByteString)+ ClientT m (HS.Response BS.ByteString) doBodyCallWithConfigurationM method path queryParams body encoding = do config <- MR.ask MT.lift $ doBodyCallWithConfiguration config method path queryParams body encoding@@ -214,27 +240,45 @@ HS.Request createBaseRequest config method path queryParams = configSecurityScheme config $- HS.setRequestMethod (textToByte method) $- HS.setRequestQueryString query $- HS.setRequestPath- (B8.pack (T.unpack $ byteToText basePathModifier <> path))- baseRequest+ addUserAgent $+ HS.setRequestMethod (textToByte method) $+ HS.setRequestQueryString query $+ HS.setRequestPath+ (textToByte $ basePathModifier <> path)+ baseRequest where baseRequest = parseURL $ configBaseURL config- basePath = HC.path baseRequest+ basePath = byteToText $ HC.path baseRequest basePathModifier =- if basePath == B8.pack "/" && T.isPrefixOf "/" path+ if basePath == "/" && T.isPrefixOf "/" path then "" else basePath -- filters all maybe query = BF.second pure <$> serializeQueryParams queryParams+ userAgent = configApplicationName config <> " openapi3-code-generator/VERSION_TO_REPLACE (https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator)"+ addUserAgent =+ if configIncludeUserAgent config+ then HS.addRequestHeader HT.hUserAgent $ textToByte userAgent+ else id -serializeQueryParams :: [QueryParameter] -> [(B8.ByteString, B8.ByteString)]+serializeQueryParams :: [QueryParameter] -> [(BS.ByteString, BS.ByteString)] serializeQueryParams = (>>= serializeQueryParam) -serializeQueryParam :: QueryParameter -> [(B8.ByteString, B8.ByteString)]+serializeQueryParam :: QueryParameter -> [(BS.ByteString, BS.ByteString)] serializeQueryParam QueryParameter {..} =- let concatValues joinWith = if queryParamExplode then pure . (queryParamName,) . B8.intercalate joinWith . fmap snd else id+ let concatValues :: BS.ByteString -> [(Maybe Text, BS.ByteString)] -> [(Text, BS.ByteString)]+ concatValues joinWith =+ if queryParamExplode+ then fmap (BF.first $ Maybe.fromMaybe queryParamName)+ else+ pure+ . (queryParamName,)+ . BS.intercalate joinWith+ . fmap+ ( \case+ (Nothing, value) -> value+ (Just name, value) -> textToByte name <> joinWith <> value+ ) in BF.first textToByte <$> case queryParamValue of Nothing -> [] Just value ->@@ -245,31 +289,31 @@ "deepObject" -> const $ BF.second textToByte <$> jsonToFormDataPrefixed queryParamName value _ -> const [] )- $ jsonToFormDataFlat queryParamName value+ $ jsonToFormDataFlat Nothing value -encodeStrict :: Aeson.ToJSON a => a -> B8.ByteString-encodeStrict = LB8.toStrict . Aeson.encode+encodeStrict :: (Aeson.ToJSON a) => a -> BS.ByteString+encodeStrict = LBS.toStrict . Aeson.encode -jsonToFormDataFlat :: Text -> Aeson.Value -> [(Text, B8.ByteString)]+jsonToFormDataFlat :: Maybe Text -> Aeson.Value -> [(Maybe Text, BS.ByteString)] jsonToFormDataFlat _ Aeson.Null = [] jsonToFormDataFlat name (Aeson.Number a) = [(name, encodeStrict a)] jsonToFormDataFlat name (Aeson.String a) = [(name, textToByte a)] jsonToFormDataFlat name (Aeson.Bool a) = [(name, encodeStrict a)]-jsonToFormDataFlat _ (Aeson.Object object) = HMap.toList object >>= uncurry jsonToFormDataFlat+jsonToFormDataFlat _ (Aeson.Object object) = jsonObjectToList object >>= uncurry jsonToFormDataFlat . BF.first Just jsonToFormDataFlat name (Aeson.Array vector) = Vector.toList vector >>= jsonToFormDataFlat name -- | creates form data bytestring array-createFormData :: (Aeson.ToJSON a) => a -> [(B8.ByteString, B8.ByteString)]+createFormData :: (Aeson.ToJSON a) => a -> [(BS.ByteString, BS.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 = TE.decodeUtf8+-- | Convert a 'BS.ByteString' to 'Text'+byteToText :: BS.ByteString -> Text+byteToText = TE.decodeUtf8With lenientDecode --- | Convert 'Text' a to 'B8.ByteString'-textToByte :: Text -> B8.ByteString+-- | Convert 'Text' a to 'BS.ByteString'+textToByte :: Text -> BS.ByteString textToByte = TE.encodeUtf8 parseURL :: Text -> HS.Request@@ -290,43 +334,26 @@ jsonToFormDataPrefixed _ Aeson.Null = [] jsonToFormDataPrefixed prefix (Aeson.String a) = [(prefix, a)] jsonToFormDataPrefixed "" (Aeson.Object object) =- HMap.toList object >>= uncurry jsonToFormDataPrefixed+ jsonObjectToList object >>= uncurry jsonToFormDataPrefixed jsonToFormDataPrefixed prefix (Aeson.Object object) =- HMap.toList object >>= (\(x, y) -> jsonToFormDataPrefixed (prefix <> "[" <> x <> "]") y)+ jsonObjectToList 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+-- | This function 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 StringifyModel Text where- -- stringifyModel :: Text -> String- stringifyModel = T.unpack--instance {-# OVERLAPS #-} Show a => StringifyModel a where- -- stringifyModel :: Show a => a -> String- stringifyModel = show+stringifyModel :: (Aeson.ToJSON a) => a -> Text+stringifyModel x = case Aeson.toJSON x of+ Aeson.String s -> s+ v -> toStrict $ toLazyText $ encodeToTextBuilder v --- | Wraps a 'B8.ByteString' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'-newtype JsonByteString = JsonByteString B8.ByteString+-- | Wraps a 'BS.ByteString' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'+newtype JsonByteString = JsonByteString BS.ByteString deriving (Show, Eq, Ord) instance Aeson.ToJSON JsonByteString where- toJSON (JsonByteString s) = Aeson.toJSON $ B8.unpack s+ toJSON (JsonByteString s) = Aeson.toJSON $ byteToText s instance Aeson.FromJSON JsonByteString where parseJSON (Aeson.String s) = pure $ JsonByteString $ textToByte s@@ -347,3 +374,25 @@ instance Aeson.FromJSON JsonDateTime where parseJSON o = JsonDateTime <$> Aeson.parseJSON o++data Nullable a = NonNull a | Null+ deriving (Show, Eq)++instance (Aeson.ToJSON a) => Aeson.ToJSON (Nullable a) where+ toJSON Null = Aeson.Null+ toJSON (NonNull x) = Aeson.toJSON x++ toEncoding Null = Encoding.null_+ toEncoding (NonNull x) = Aeson.toEncoding x++instance (Aeson.FromJSON a) => Aeson.FromJSON (Nullable a) where+ parseJSON Aeson.Null = pure Null+ parseJSON x = NonNull <$> Aeson.parseJSON x++#if MIN_VERSION_aeson(2,0,0)+jsonObjectToList :: KeyMap.KeyMap v -> [(Text, v)]+jsonObjectToList = fmap (BF.first Key.toText) . KeyMap.toList+#else+jsonObjectToList :: HMap.HashMap Text v -> [(Text, v)]+jsonObjectToList = HMap.toList+#endif
src/OpenAPI/Generate.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -36,7 +35,7 @@ putStrLn content putStrLn "---\n\n" )- moduleFiles+ outputFilesModuleFiles else do proceed <- OAI.permitProceed settings if proceed
src/OpenAPI/Generate/Doc.hs view
@@ -32,7 +32,7 @@ typeAliasModule = "TypeAlias" -- | Empty document inside an 'Applicative' (typically 'Language.Haskell.TH.Q')-emptyDoc :: Applicative f => f Doc+emptyDoc :: (Applicative f) => f Doc emptyDoc = pure empty haddockIntro :: Doc@@ -69,7 +69,7 @@ generatorNote = line "-- CHANGE WITH CAUTION: This is a generated code file generated by https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator." . emptyLine -- | Append a 'Doc' to another inside an 'Applicative' (typically 'Language.Haskell.TH.Q')-appendDoc :: Applicative f => f Doc -> f Doc -> f Doc+appendDoc :: (Applicative f) => f Doc -> f Doc -> f Doc appendDoc = Applicative.liftA2 ($$) -- | Generate a Haddock comment with multiple lines@@ -89,7 +89,8 @@ generateHaddockCommentWithoutNewlines [x] = haddockIntro <+> textToDoc x generateHaddockCommentWithoutNewlines xs = generateHaddockCommentWithoutNewlines (init xs)- $$ haddockLine <+> textToDoc (last xs)+ $$ haddockLine+ <+> textToDoc (last xs) -- | Escape text for use in Haddock comment escapeText :: Text -> Text@@ -113,7 +114,8 @@ 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+ in text+ . T.unpack . T.unlines . fmap T.stripEnd . T.lines@@ -198,13 +200,16 @@ . 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.ByteString"+ . importQualified "Data.ByteString as Data.ByteString.Internal"+ . importQualified "Data.ByteString as Data.ByteString.Internal.Type" . importQualified "Data.Either"+ . importQualified "Data.Foldable" . importQualified "Data.Functor"+ . importQualified "Data.Maybe" . importQualified "Data.Scientific" . importQualified "Data.Text"- . importQualified "Data.Text.Internal"+ . importQualified "Data.Text as Data.Text.Internal" . importQualified "Data.Time.Calendar as Data.Time.Calendar.Days" . importQualified "Data.Time.LocalTime as Data.Time.LocalTime.Internal.ZonedTime" . importQualified "Data.Vector"@@ -243,12 +248,14 @@ . 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.ByteString"+ . importQualified "Data.ByteString as Data.ByteString.Internal"+ . importQualified "Data.Foldable" . importQualified "Data.Functor"+ . importQualified "Data.Maybe" . importQualified "Data.Scientific" . importQualified "Data.Text"- . importQualified "Data.Text.Internal"+ . importQualified "Data.Text as 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"@@ -270,7 +277,7 @@ . moduleDescription "Contains all supported security schemes defined in the specification" . moduleDeclaration moduleName "SecuritySchemes" . emptyLine- . importQualified "Data.Text.Internal"+ . importQualified "Data.Text as Data.Text.Internal" . importQualified "GHC.Base" . importQualified "GHC.Classes" . importQualified "GHC.Show"@@ -289,6 +296,8 @@ . moduleDeclaration moduleName "Configuration" . emptyLine . importQualified "Data.Text"+ . importQualified "Data.Text as Data.Text.Internal"+ . importQualified "GHC.Types " . importQualified (moduleName <> ".Common") . emptyLine
src/OpenAPI/Generate/IO.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -10,6 +9,7 @@ import Control.Monad import qualified Data.Bifunctor as BF import qualified Data.Text as T+import Data.Version (showVersion) import Language.Haskell.TH import qualified OpenAPI.Generate.Doc as Doc import OpenAPI.Generate.Internal.Embed@@ -20,6 +20,7 @@ import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Reference as Ref import qualified OpenAPI.Generate.Types as OAT+import Paths_openapi3_code_generator (version) import System.Directory import System.FilePath import System.IO.Error@@ -82,7 +83,7 @@ stackProjectFiles = [ ( "stack.yaml", unlines- [ "resolver: lts-18.16",+ [ "resolver: lts-21.22", "packages:", "- ." ]@@ -115,10 +116,16 @@ 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.replace "OpenAPI.Common" (T.pack $ moduleName ++ ".Common") $+ T.replace "OpenAPI.Configuration" (T.pack $ moduleName ++ ".Configuration") $ T.pack contents +replaceVersionNumber :: String -> String+replaceVersionNumber contents =+ T.unpack $+ T.replace "VERSION_TO_REPLACE" (T.pack $ showVersion version) $+ T.pack contents+ permitProceed :: OAO.Settings -> IO Bool permitProceed settings = do let outputDirectory = T.unpack $ OAO.settingOutputDir settings@@ -145,13 +152,19 @@ getHsBootFiles :: OAO.Settings -> [([String], String)] -> FilesWithContent getHsBootFiles settings modelModules = let outputDirectory = T.unpack $ OAO.settingOutputDir settings- moduleName = T.unpack $ OAO.settingModuleName settings+ moduleName = OAO.settingModuleName settings+ moduleNameStr = OAO.getModuleName moduleName+ modulePathInfo = OAO.mkModulePathInfo moduleName in BF.bimap- ((outputDirectory </>) . (srcDirectory </>) . (moduleName </>) . (<> ".hs-boot") . foldr1 (</>))+ ((\suffix -> outputDirectory </> srcDirectory </> OAO.getModuleInfoPath modulePathInfo (Just suffix) ".hs-boot") . foldr1 (</>)) ( T.unpack . T.unlines . ( \xs -> case xs of- x : xs' -> x : "import Data.Aeson" : "import qualified Data.Aeson as Data.Aeson.Types.Internal" : xs'+ x : xs' ->+ x+ : "import qualified Data.Aeson"+ : "import qualified " <> T.pack moduleNameStr <> ".Common"+ : xs' _ -> xs ) . ( ( \l ->@@ -161,8 +174,8 @@ [ l, "instance Show" <> suffix, "instance Eq" <> suffix,- "instance FromJSON" <> suffix,- "instance ToJSON" <> suffix+ "instance Data.Aeson.FromJSON" <> suffix,+ "instance Data.Aeson.ToJSON" <> suffix ] ) $ T.stripPrefix "data" l@@ -182,28 +195,30 @@ modelModules data OutputFiles = OutputFiles- { moduleFiles :: FilesWithContent,- cabalFiles :: FilesWithContent,- stackFiles :: FilesWithContent,- nixFiles :: FilesWithContent+ { outputFilesModuleFiles :: FilesWithContent,+ outputFilesCabalFiles :: FilesWithContent,+ outputFilesStackFiles :: FilesWithContent,+ outputFilesNixFiles :: FilesWithContent } generateFilesToCreate :: OAT.OpenApiSpecification -> OAO.Settings -> IO OutputFiles generateFilesToCreate spec settings = do let outputDirectory = T.unpack $ OAO.settingOutputDir settings- moduleName = T.unpack $ OAO.settingModuleName settings+ moduleName = OAO.settingModuleName settings+ modulePathInfo = OAO.mkModulePathInfo moduleName+ moduleNameStr = OAO.getModuleName moduleName packageName = T.unpack $ OAO.settingPackageName settings env = OAM.createEnvironment settings $ Ref.buildReferenceMap spec logMessages = mapM_ (putStrLn . T.unpack) . OAL.filterAndTransformLogs (OAO.settingLogLevel settings)- showAndReplace = replaceOpenAPI moduleName . show- ((operationsQ, operationDependencies), logs) = OAM.runGenerator env $ defineOperations moduleName spec+ showAndReplace = replaceOpenAPI moduleNameStr . show+ ((operationsQ, operationDependencies), logs) = OAM.runGenerator env $ defineOperations moduleNameStr spec logMessages logs operationModules <- runQ operationsQ- configurationInfo <- runQ $ defineConfigurationInformation moduleName spec- let (modelsQ, logsModels) = OAM.runGenerator env $ defineModels moduleName spec operationDependencies+ configurationInfo <- runQ $ defineConfigurationInformation moduleNameStr spec+ let (modelsQ, logsModels) = OAM.runGenerator env $ defineModels moduleNameStr spec operationDependencies logMessages logsModels modelModules <- fmap (BF.second showAndReplace) <$> runQ modelsQ- let (securitySchemesQ, logs') = OAM.runGenerator env $ defineSecuritySchemes moduleName spec+ let (securitySchemesQ, logs') = OAM.runGenerator env $ defineSecuritySchemes moduleNameStr spec logMessages logs' securitySchemes' <- runQ securitySchemesQ let modules =@@ -211,48 +226,51 @@ <> modelModules <> [ (["Configuration"], showAndReplace configurationInfo), (["SecuritySchemes"], showAndReplace securitySchemes'),- (["Common"], replaceOpenAPI moduleName $(embedFile "src/OpenAPI/Common.hs"))+ (["Common"], replaceOpenAPI moduleNameStr $ replaceVersionNumber $(embedFile "src/OpenAPI/Common.hs")) ] modulesToExport = fmap- ( (moduleName <>) . ("." <>)+ ( (moduleNameStr <>)+ . ("." <>) . joinWithPoint . fst ) modules- mainFile = outputDirectory </> srcDirectory </> (moduleName ++ ".hs")- mainModuleContent = show $ Doc.createModuleHeaderWithReexports moduleName modulesToExport "The main module which exports all functionality."+ mainFile = outputDirectory </> srcDirectory </> OAO.getModuleInfoPath modulePathInfo Nothing ".hs"+ mainModuleContent = show $ Doc.createModuleHeaderWithReexports moduleNameStr modulesToExport "The main module which exports all functionality." hsBootFiles = getHsBootFiles settings modelModules pure $ OutputFiles ( BF.second (unlines . lines)- <$> (mainFile, mainModuleContent) :- (BF.first ((outputDirectory </>) . (srcDirectory </>) . (moduleName </>) . (<> ".hs") . foldr1 (</>)) <$> modules)- <> hsBootFiles+ <$> (mainFile, mainModuleContent)+ : (BF.first ((\suffix -> outputDirectory </> srcDirectory </> OAO.getModuleInfoPath modulePathInfo (Just suffix) ".hs") . foldr1 (</>)) <$> modules)+ <> hsBootFiles )- (BF.first (outputDirectory </>) <$> cabalProjectFiles packageName moduleName modulesToExport)+ (BF.first (outputDirectory </>) <$> cabalProjectFiles packageName moduleNameStr modulesToExport) (BF.first (outputDirectory </>) <$> stackProjectFiles) (BF.first (outputDirectory </>) <$> nixProjectFiles packageName) writeFiles :: OAO.Settings -> OutputFiles -> IO () writeFiles settings OutputFiles {..} = do let outputDirectory = T.unpack $ OAO.settingOutputDir settings- moduleName = T.unpack $ OAO.settingModuleName settings+ modulePathInfo = OAO.mkModulePathInfo $ OAO.settingModuleName settings+ moduleDir = OAO.getModuleInfoDir modulePathInfo incremental = OAO.settingIncremental settings write = mapM_ $ if incremental then writeFileIncremental else writeFileWithLog putStrLn "Remove old output directory" unless incremental $- tryIOError (removeDirectoryRecursive outputDirectory) >> pure ()+ void $+ tryIOError (removeDirectoryRecursive outputDirectory) putStrLn "Output directory removed, create missing directories"- createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleName </> "Operations")- createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleName </> "Types")+ createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleDir </> "Operations")+ createDirectoryIfMissing True (outputDirectory </> srcDirectory </> moduleDir </> "Types") putStrLn "Directories created"- write moduleFiles- write cabalFiles+ write outputFilesModuleFiles+ write outputFilesCabalFiles unless (OAO.settingDoNotGenerateStackProject settings) $- write stackFiles+ write outputFilesStackFiles when (OAO.settingGenerateNixFiles settings) $- write nixFiles+ write outputFilesNixFiles writeFileWithLog :: FileWithContent -> IO () writeFileWithLog (filePath, content) = do
src/OpenAPI/Generate/Internal/Embed.hs view
@@ -1,10 +1,7 @@-{-# LANGUAGE TemplateHaskell #-}- module OpenAPI.Generate.Internal.Embed where import Language.Haskell.TH import Language.Haskell.TH.Syntax embedFile :: FilePath -> Q Exp-embedFile fp =- [|$(LitE . StringL <$> (qAddDependentFile fp >> runIO (readFile fp)))|]+embedFile fp = LitE . StringL <$> (qAddDependentFile fp >> runIO (readFile fp))
src/OpenAPI/Generate/Internal/Operation.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -29,7 +28,6 @@ import Control.Monad import qualified Data.Aeson as Aeson import qualified Data.Bifunctor as BF-import qualified Data.ByteString.Char8 as B8 import qualified Data.Char as Char import qualified Data.List.Split as Split import qualified Data.Map as Map@@ -48,14 +46,15 @@ import qualified OpenAPI.Generate.ModelDependencies as Dep import qualified OpenAPI.Generate.Monad as OAM import qualified OpenAPI.Generate.OptParse as OAO+import OpenAPI.Generate.OptParse.Types 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+ { requestBodyDefinitionSchema :: OAT.Schema,+ requestBodyDefinitionEncoding :: OC.RequestBodyEncoding,+ requestBodyDefinitionRequired :: Bool } -- | Defines the type of a parameter bundle including the information to access the specific parameters@@ -77,18 +76,6 @@ | SingleParameter (Q Type) Dep.ModelContentWithDependencies OAT.ParameterObject | MultipleParameters ParameterTypeDefinition --- | wrapper for ambigious usage-getParametersFromOperationReference :: OAT.OperationObject -> [OAT.Referencable OAT.ParameterObject]-getParametersFromOperationReference = OAT.parameters---- | wrapper for ambigious usage-getRequiredFromParameter :: OAT.ParameterObject -> Bool-getRequiredFromParameter = OAT.required---- | wrapper for ambigious usage-getInFromParameterObject :: OAT.ParameterObject -> OAT.ParameterObjectLocation-getInFromParameterObject = OAT.in'- -- | Generates the parameter type for an operation. See 'ParameterCardinality' for further information. generateParameterTypeFromOperation :: Text -> OAT.OperationObject -> OAM.Generator ParameterCardinality generateParameterTypeFromOperation operationName = getParametersFromOperationConcrete >=> generateParameterType operationName@@ -101,17 +88,18 @@ [ ((parameter, path), mergeDescriptionOfParameterWithSchema parameter schema) | ((parameter, path), Just schema) <- zip parameters maybeSchemas,- getInFromParameterObject parameter `elem` [OAT.QueryParameterObjectLocation, OAT.PathParameterObjectLocation]+ OAT.parameterObjectIn parameter `elem` [OAT.QueryParameterObjectLocation, OAT.PathParameterObjectLocation] ] schemaName = operationName <> parametersSuffix when (length parameters > length parametersWithSchemas) $ OAM.logWarning "Parameters are only supported in query and path (skipping parameters in cookie and header)." case parametersWithSchemas of [] -> pure NoParameters [((parameter, path), schema)] -> do- (paramType, model) <- OAM.resetPath (path <> ["schema"]) $ Model.defineModelForSchemaNamed (schemaName <> uppercaseFirstText (getNameFromParameter parameter)) schema+ -- TODO disable fixed value generation for parameters+ (paramType, model) <- OAM.resetPath (path <> ["schema"]) $ Model.defineModelForSchemaNamed (schemaName <> uppercaseFirstText (OAT.parameterObjectName parameter)) schema pure $ SingleParameter- ( if getRequiredFromParameter parameter+ ( if OAT.parameterObjectRequired parameter then paramType else [t|Maybe $(paramType)|] )@@ -122,31 +110,36 @@ mapM ( \((parameter, _), schema) -> do prefix <- getParameterLocationPrefix parameter- pure (prefix <> uppercaseFirstText (getNameFromParameter parameter), schema)+ pure (prefix <> uppercaseFirstText (OAT.parameterObjectName parameter), schema) ) parametersWithSchemas let parametersWithNames = zip (fst <$> properties) (fst <$> parametersWithSchemas) requiredProperties = Set.fromList $- fst <$> filter ((OAT.required :: OAT.ParameterObject -> Bool) . fst . snd) parametersWithNames+ fst <$> filter (OAT.parameterObjectRequired . fst . snd) parametersWithNames (parameterTypeDefinitionType, (parameterTypeDefinitionDoc, parameterTypeDefinitionDependencies)) <-- Model.defineModelForSchemaNamed schemaName $- OAT.Concrete $- OAS.defaultSchema {OAS.properties = Map.fromList properties, OAS.required = requiredProperties}+ -- Explicitly include fixed value properties since this is not+ -- a user defined object schema but one that is defined by the+ -- generator and is only here to make the usage easier.+ -- It should therefore not change the semantics.+ OAM.adjustSettings (\settings -> settings {OAO.settingFixedValueStrategy = FixedValueStrategyInclude}) $+ Model.defineModelForSchemaNamed schemaName $+ OAT.Concrete $+ OAS.defaultSchema {OAS.schemaObjectProperties = Map.fromList properties, OAS.schemaObjectRequired = requiredProperties} convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase let parametersWithPropertyNames = BF.bimap (haskellifyName convertToCamelCase False . (schemaName <>) . uppercaseFirstText) fst <$> parametersWithNames- filterByType t = filter ((== t) . getInFromParameterObject . snd) parametersWithPropertyNames+ filterByType t = filter ((== t) . OAT.parameterObjectIn . snd) parametersWithPropertyNames parameterTypeDefinitionQueryParams = filterByType OAT.QueryParameterObjectLocation parameterTypeDefinitionPathParams = filterByType OAT.PathParameterObjectLocation pure $ MultipleParameters ParameterTypeDefinition {..} mergeDescriptionOfParameterWithSchema :: OAT.ParameterObject -> OAS.Schema -> OAS.Schema mergeDescriptionOfParameterWithSchema parameter (OAT.Concrete schema) =- let parameterName = OAT.name (parameter :: OAT.ParameterObject)- descriptionParameter = Maybe.maybeToList $ OAT.description (parameter :: OAT.ParameterObject)- descriptionSchema = Maybe.maybeToList $ OAS.description schema+ let parameterName = OAT.parameterObjectName parameter+ descriptionParameter = Maybe.maybeToList $ OAT.parameterObjectDescription parameter+ descriptionSchema = Maybe.maybeToList $ OAS.schemaObjectDescription schema mergedDescription = T.intercalate "\n\n" (("Represents the parameter named '" <> parameterName <> "'") : descriptionParameter <> descriptionSchema)- in OAT.Concrete $ schema {OAS.description = Just mergedDescription}+ in OAT.Concrete $ schema {OAS.schemaObjectDescription = Just mergedDescription} mergeDescriptionOfParameterWithSchema _ schema = schema getParameterLocationPrefix :: OAT.ParameterObject -> OAM.Generator Text@@ -157,7 +150,7 @@ OAT.CookieParameterObjectLocation -> OAM.getSetting OAO.settingParameterCookiePrefix OAT.HeaderParameterObjectLocation -> OAM.getSetting OAO.settingParameterHeaderPrefix )- . getInFromParameterObject+ . OAT.parameterObjectIn -- | Extracts all parameters of an operation --@@ -179,20 +172,17 @@ pure $ (,["components", "parameters", name]) <$> p ) . zip ([0 ..] :: [Int])- . getParametersFromOperationReference+ . OAT.operationObjectParameters getSchemaFromParameterObjectSchema :: OAT.ParameterObjectSchema -> OAM.Generator (Maybe OAS.Schema)-getSchemaFromParameterObjectSchema (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) = pure $ Just schema+getSchemaFromParameterObjectSchema (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) = pure $ Just simpleParameterSchemaSchema getSchemaFromParameterObjectSchema (OAT.ComplexParameterObjectSchema _) = OAM.nested "content" $ do OAM.logWarning "Complex parameter schemas are not supported and therefore will be skipped." pure Nothing -- | Reads the schema from the parameter getSchemaFromParameter :: OAT.ParameterObject -> OAM.Generator (Maybe OAS.Schema)-getSchemaFromParameter OAT.ParameterObject {..} = getSchemaFromParameterObjectSchema schema--getNameFromParameter :: OAT.ParameterObject -> Text-getNameFromParameter = OAT.name+getSchemaFromParameter = getSchemaFromParameterObjectSchema . OAT.parameterObjectSchema -- | Gets the Type definition dependent on the number of parameters/types -- A monadic name for which its forall structure is defined outside@@ -205,9 +195,9 @@ getParametersTypeForSignature :: [Q Type] -> Name -> Name -> Q Type getParametersTypeForSignature types responseTypeName monadName = createFunctionType- ( [t|OC.Configuration|] :- types- <> [[t|$(varT monadName) (HS.Response $(varT responseTypeName))|]]+ ( [t|OC.Configuration|]+ : types+ <> [[t|$(varT monadName) (HS.Response $(varT responseTypeName))|]] ) -- | Same as 'getParametersTypeForSignature' but with the configuration in 'MR.ReaderT' instead of a parameter@@ -224,7 +214,7 @@ (\t1 t2 -> [t|$t1 -> $t2|]) getParameterName :: OAT.ParameterObject -> OAM.Generator Name-getParameterName parameter = haskellifyNameM False $ getNameFromParameter parameter+getParameterName parameter = haskellifyNameM False $ OAT.parameterObjectName parameter -- | Get a description of a parameter object (the name and if available the description from the specification) getParameterDescription :: OAT.ParameterObject -> OAM.Generator Text@@ -232,14 +222,14 @@ schema <- case getSchemaOfParameterObject parameter of Just schema -> Model.resolveSchemaReferenceWithoutWarning schema Nothing -> pure Nothing- let name = OAT.name (parameter :: OAT.ParameterObject)- description = maybe "" (": " <>) $ OAT.description (parameter :: OAT.ParameterObject)+ let name = OAT.parameterObjectName parameter+ description = maybe "" (": " <>) $ OAT.parameterObjectDescription parameter constraints = joinWith ", " $ Model.getConstraintDescriptionsOfSchema schema pure $ Doc.escapeText $ name <> description <> (if T.null constraints then "" else " | Constraints: " <> constraints) getSchemaOfParameterObject :: OAT.ParameterObject -> Maybe OAS.Schema-getSchemaOfParameterObject parameterObject = case OAT.schema (parameterObject :: OAT.ParameterObject) of- (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) -> Just schema+getSchemaOfParameterObject parameterObject = case OAT.parameterObjectSchema parameterObject of+ (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) -> Just simpleParameterSchemaSchema OAT.ComplexParameterObjectSchema _ -> Nothing -- | Defines the body of an Operation function@@ -258,7 +248,7 @@ Text -> -- | Schema of body Maybe RequestBodyDefinition ->- -- | An expression used to transform the response from 'B8.ByteString' to the required response type.+ -- | An expression used to transform the response from 'BS.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@@ -279,7 +269,7 @@ paramName' <- getParameterName parameter let paramExpr = (varE paramName', parameter) pure $- if getInFromParameterObject parameter == OAT.PathParameterObjectLocation+ if OAT.parameterObjectIn parameter == OAT.PathParameterObjectLocation then ([paramExpr], []) else ([], [paramExpr]) MultipleParameters paramDefinition ->@@ -294,25 +284,25 @@ ppr <$> case bodySchema of Just RequestBodyDefinition {..} | generateBody ->- let encodeExpr =- varE $- case encoding of- OC.RequestBodyEncodingFormData -> 'OC.RequestBodyEncodingFormData- OC.RequestBodyEncodingJSON -> 'OC.RequestBodyEncodingJSON- in [d|- $(conP fnName $ fnPatterns <> [varP bodyName]) =- $responseTransformerExp- ( $( if useExplicitConfiguration- then [|OC.doBodyCallWithConfiguration $(varE configName)|]- else [|OC.doBodyCallWithConfigurationM|]- )- (T.toUpper $ T.pack $methodLit)- (T.pack $(request))- $(queryParameters')- $(if required then [|Just $(varE bodyName)|] else varE bodyName)- $(encodeExpr)- )- |]+ let encodeExpr =+ varE $+ case requestBodyDefinitionEncoding of+ OC.RequestBodyEncodingFormData -> 'OC.RequestBodyEncodingFormData+ OC.RequestBodyEncodingJSON -> 'OC.RequestBodyEncodingJSON+ in [d|+ $(conP fnName $ fnPatterns <> [varP bodyName]) =+ $responseTransformerExp+ ( $( if useExplicitConfiguration+ then [|OC.doBodyCallWithConfiguration $(varE configName)|]+ else [|OC.doBodyCallWithConfigurationM|]+ )+ (T.toUpper $ T.pack $methodLit)+ $(request)+ $(queryParameters')+ $(if requestBodyDefinitionRequired then [|Just $(varE bodyName)|] else varE bodyName)+ $(encodeExpr)+ )+ |] _ -> [d| $(conP fnName fnPatterns) =@@ -321,9 +311,9 @@ then [|OC.doCallWithConfiguration $(varE configName)|] else [|OC.doCallWithConfigurationM|] )- (T.toUpper $ T.pack $methodLit)- (T.pack $(request))- $(queryParameters')+ (T.toUpper $ T.pack $methodLit)+ $(request)+ $(queryParameters') ) |] @@ -331,14 +321,14 @@ shouldGenerateRequestBody :: Maybe RequestBodyDefinition -> OAM.Generator Bool shouldGenerateRequestBody Nothing = pure False shouldGenerateRequestBody (Just RequestBodyDefinition {..}) = do- maybeSchema <- Model.resolveSchemaReferenceWithoutWarning schema+ maybeSchema <- Model.resolveSchemaReferenceWithoutWarning requestBodyDefinitionSchema generateEmptyRequestBody <- OAM.getSetting OAO.settingGenerateOptionalEmptyRequestBody case maybeSchema of Just s | not generateEmptyRequestBody- && not required+ && not requestBodyDefinitionRequired && OAS.isSchemaEmpty s ->- pure False+ pure False _ -> pure True -- | Extracts the request body schema from an operation and the encoding which should be used on the body data.@@ -349,25 +339,20 @@ Just (body, path) -> OAM.resetPath path $ 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, [Text]) getRequestBodySchema body = OAM.nested "content" $ do- let content = Map.lookup "application/json" $ getRequestBodyContent body+ let contentMap = OAT.requestBodyObjectContent body+ content = getJsonMediaTypeObject contentMap createRequestBodyDefinition encoding schema = Just $ RequestBodyDefinition- { schema = schema,- encoding = encoding,- required = OAT.required (body :: OAT.RequestBodyObject)+ { requestBodyDefinitionSchema = schema,+ requestBodyDefinitionEncoding = encoding,+ requestBodyDefinitionRequired = OAT.requestBodyObjectRequired body } case content of Nothing ->- let formContent = Map.lookup "application/x-www-form-urlencoded" $ getRequestBodyContent body+ let formContent = getValueByContentTypeIgnoringCharset "application/x-www-form-urlencoded" contentMap in case formContent of Nothing -> do OAM.logWarning "Only content type application/json and application/x-www-form-urlencoded is supported"@@ -375,21 +360,21 @@ Just media -> do path <- OAM.appendToPath ["application/x-www-form-urlencoded", "schema"] pure- ( getSchemaFromMedia media+ ( OAT.mediaTypeObjectSchema media >>= createRequestBodyDefinition OC.RequestBodyEncodingFormData, path ) Just media -> do path <- OAM.appendToPath ["application/json", "schema"] pure- ( getSchemaFromMedia media+ ( OAT.mediaTypeObjectSchema media >>= createRequestBodyDefinition OC.RequestBodyEncodingJSON, path ) getRequestBodyObject :: OAT.OperationObject -> OAM.Generator (Maybe (OAT.RequestBodyObject, [Text])) getRequestBodyObject operation =- case OAT.requestBody operation of+ case OAT.operationObjectRequestBody operation of Nothing -> pure Nothing Just (OAT.Concrete p) -> do path <- OAM.getCurrentPath@@ -405,12 +390,36 @@ -- A warning is logged if the response does not contain one of the supported media types. getResponseSchema :: OAT.ResponseObject -> OAM.Generator (Maybe OAT.Schema, [Text]) getResponseSchema response = OAM.nested "content" $ do- let contentMap = OAT.content (response :: OAT.ResponseObject)- schema = Map.lookup "application/json" contentMap >>= getSchemaFromMedia+ let contentMap = OAT.responseObjectContent response+ schema = getJsonMediaTypeObject contentMap >>= OAT.mediaTypeObjectSchema when (Maybe.isNothing schema && not (Map.null contentMap)) $ OAM.logWarning "Only content type application/json is supported for response bodies." path <- OAM.appendToPath ["application/json", "schema"] pure (schema, path) +getValueByContentTypeIgnoringCharset :: Text -> Map.Map Text OAT.MediaTypeObject -> Maybe OAT.MediaTypeObject+getValueByContentTypeIgnoringCharset contentType contentMap =+ case Map.lookup contentType contentMap of+ Just content -> Just content+ Nothing -> case Map.elems $ Map.filterWithKey (\key _ -> getMediaTypeWithoutCharset key == Just contentType) contentMap of+ [] -> Nothing+ content : _ -> Just content++getMediaTypeWithoutCharset :: Text -> Maybe Text+getMediaTypeWithoutCharset = Maybe.listToMaybe . T.splitOn ";"++getJsonMediaTypeObject :: Map.Map Text OAT.MediaTypeObject -> Maybe OAT.MediaTypeObject+getJsonMediaTypeObject contentMap =+ case getValueByContentTypeIgnoringCharset "application/json" contentMap of+ Just content -> Just content+ Nothing -> case Map.elems $ Map.filterWithKey (\key _ -> maybe False isCustomJsonMediaType $ Maybe.listToMaybe (T.splitOn ";" key)) contentMap of+ [] -> Nothing+ content : _ -> Just content++isCustomJsonMediaType :: Text -> Bool+isCustomJsonMediaType mediaType = case T.splitOn "+" mediaType of+ [_, "json"] -> True+ _ -> False+ -- | Resolve a possibly referenced response to a concrete value. -- -- A warning is logged if the reference is not found.@@ -431,16 +440,16 @@ listE . fmap ( \(var, param) ->- let queryName = stringE $ T.unpack $ getNameFromParameter param- required = getRequiredFromParameter param- (maybeStyle, explode') = case OAT.schema (param :: OAT.ParameterObject) of- (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) -> (style, explode)+ let queryName = stringE $ T.unpack $ OAT.parameterObjectName param+ required = OAT.parameterObjectRequired param+ (maybeStyle, explode') = case OAT.parameterObjectSchema param of+ (OAT.SimpleParameterObjectSchema OAT.SimpleParameterSchema {..}) -> (simpleParameterSchemaStyle, simpleParameterSchemaExplode) OAT.ComplexParameterObjectSchema _ -> (Just "form", True) style' = stringE $ T.unpack $ Maybe.fromMaybe- ( case OAT.in' (param :: OAT.ParameterObject) of+ ( case OAT.parameterObjectIn param of OAT.QueryParameterObjectLocation -> "form" OAT.HeaderParameterObjectLocation -> "simple" OAT.PathParameterObjectLocation -> "simple"@@ -464,10 +473,10 @@ generateParameterizedRequestPath ((paramName, param) : xs) path = foldr1 (foldingFn paramName) partExpressiones where- parts = Split.splitOn ("{" <> T.unpack (getNameFromParameter param) <> "}") (T.unpack path)+ parts = Split.splitOn ("{" <> T.unpack (OAT.parameterObjectName param) <> "}") (T.unpack path) partExpressiones = generateParameterizedRequestPath xs . T.pack <$> parts foldingFn :: Q Exp -> Q Exp -> Q Exp -> Q Exp- foldingFn var a b = [|$(a) ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $var) ++ $(b)|]+ foldingFn var a b = [|$(a) <> OC.byteToText (HT.urlEncode True $ OC.textToByte $ OC.stringifyModel $var) <> $(b)|] generateParameterizedRequestPath _ path = stringE $ T.unpack path -- | Extracts a description from an 'OAT.OperationObject'.@@ -478,8 +487,8 @@ Maybe.fromMaybe "" $ Maybe.listToMaybe $ Maybe.catMaybes- [ OAT.description (operation :: OAT.OperationObject),- OAT.summary (operation :: OAT.OperationObject)+ [ OAT.operationObjectDescription operation,+ OAT.operationObjectSummary operation ] -- | Constructs the name of an operation.@@ -487,6 +496,6 @@ -- 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+ let operationId = OAT.operationObjectOperationId operation textName = Maybe.fromMaybe (T.map Char.toLower method <> requestPath) operationId in haskellifyNameM False textName
src/OpenAPI/Generate/Internal/Unknown.hs view
@@ -21,9 +21,9 @@ -- | Warn about operations listed as CLI options which do not appear in the provided OpenAPI specification warnAboutUnknownOperations :: [(Text, OAT.PathItemObject)] -> OAM.Generator () warnAboutUnknownOperations operationDefinitions = do- let getAllOperationObjectsFromPathItemObject = ([OAT.get, OAT.put, OAT.post, OAT.delete, OAT.options, OAT.head, OAT.patch, OAT.trace] <*>) . pure+ let getAllOperationObjectsFromPathItemObject = ([OAT.pathItemObjectGet, OAT.pathItemObjectPut, OAT.pathItemObjectPost, OAT.pathItemObjectDelete, OAT.pathItemObjectOptions, OAT.pathItemObjectHead, OAT.pathItemObjectPatch, OAT.pathItemObjectTrace] <*>) . pure operationIds =- Maybe.mapMaybe OAT.operationId $+ Maybe.mapMaybe OAT.operationObjectOperationId $ Maybe.catMaybes $ operationDefinitions >>= getAllOperationObjectsFromPathItemObject . snd operationsToGenerate <- OAM.getSetting OAO.settingOperationsToGenerate@@ -44,14 +44,16 @@ mapM_ ( \name -> unless (name `elem` namesFromSpecification) $- OAM.logWarning $ generateMessage name $ getProposedOptionsFromNameAndAvailableSchemas name namesFromSpecification+ OAM.logWarning $+ generateMessage name $+ getProposedOptionsFromNameAndAvailableSchemas name namesFromSpecification ) getProposedOptionsFromNameAndAvailableSchemas :: Text -> [Text] -> Text getProposedOptionsFromNameAndAvailableSchemas name = getProposedOptions . sortByLongestCommonSubstring name sortByLongestCommonSubstring :: Text -> [Text] -> [Text]-sortByLongestCommonSubstring needle = fmap fst . L.sortOn snd . fmap (\x -> (x, - (longestCommonSubstringCount needle x)))+sortByLongestCommonSubstring needle = fmap fst . L.sortOn snd . fmap (\x -> (x, -(longestCommonSubstringCount needle x))) getProposedOptions :: [Text] -> Text getProposedOptions [] = "Specification does not contain any."
src/OpenAPI/Generate/Internal/Util.hs view
@@ -49,7 +49,7 @@ -- | The identifier to transform Text -> -- | The resulting identifier- String+ Text haskellifyText convertToCamelCase startWithUppercase name = let casefn = if startWithUppercase then Char.toUpper else Char.toLower replaceChar '.' = '\''@@ -84,28 +84,29 @@ 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 "QueryParameter" = "QueryParameter'" replaceReservedWord a = a replacePlus ('+' : rest) = "Plus" <> replacePlus rest replacePlus (x : xs) = x : replacePlus xs replacePlus a = a- in replaceReservedWord $- caseFirstCharCorrectly $- generateNameForEmptyIdentifier name $- removeIllegalLeadingCharacters $- (if convertToCamelCase then toCamelCase else id) $- nameWithoutSpecialChars $- replacePlus $- T.unpack name+ in T.pack $+ replaceReservedWord $+ caseFirstCharCorrectly $+ generateNameForEmptyIdentifier name $+ removeIllegalLeadingCharacters $+ (if convertToCamelCase then toCamelCase else id) $+ nameWithoutSpecialChars $+ replacePlus $+ T.unpack name -- | The same as 'haskellifyText' but transform the result to a 'Name' haskellifyName :: Bool -> Bool -> Text -> Name-haskellifyName convertToCamelCase startWithUppercase name = mkName $ haskellifyText convertToCamelCase startWithUppercase name+haskellifyName convertToCamelCase startWithUppercase name = mkName . T.unpack $ haskellifyText convertToCamelCase startWithUppercase name -- | 'OAM.Generator' version of 'haskellifyName' haskellifyNameM :: Bool -> Text -> OAM.Generator Name@@ -120,24 +121,24 @@ toCamelCase ('\'' : y : xs) | isCasableAlpha y = '\'' : Char.toUpper y : toCamelCase xs toCamelCase (x : xs) = x : toCamelCase xs toCamelCase xs = xs- in T.pack $- uppercaseFirst $- generateNameForEmptyIdentifier name $- removeIllegalLeadingCharacters $- fmap- ( \case- '\'' -> '_'- c -> c- )- $ toCamelCase $- T.unpack $- T.map- ( \case- '.' -> '\''- c | isValidCharaterInSuffixExceptUnderscore c -> c- _ -> '_'- )- name+ in T.pack+ $ uppercaseFirst+ $ generateNameForEmptyIdentifier name+ $ removeIllegalLeadingCharacters+ $ fmap+ ( \case+ '\'' -> '_'+ c -> c+ )+ $ toCamelCase+ $ T.unpack+ $ T.map+ ( \case+ '.' -> '\''+ c | isValidCharaterInSuffixExceptUnderscore c -> c+ _ -> '_'+ )+ name uppercaseFirst :: String -> String uppercaseFirst (x : xs) = Char.toUpper x : xs@@ -155,7 +156,7 @@ joinWithPoint = joinWith "." -- | Concat a list of values separated by an other value-joinWith :: Monoid a => a -> [a] -> a+joinWith :: (Monoid a) => a -> [a] -> a joinWith _ [] = mempty joinWith separator xs = foldr1@@ -165,10 +166,10 @@ -- | 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 :: (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' } }+ 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
src/OpenAPI/Generate/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,7 +9,6 @@ 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 ((<>))@@ -29,7 +27,7 @@ -- | Defines all the operations as functions and the common imports defineOperations :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q [Dep.ModuleDefinition], Dep.Models) defineOperations moduleName specification =- let paths = Map.toList $ OAT.paths specification+ let paths = Map.toList $ OAT.openApiSpecificationPaths specification in OAM.nested "paths" $ do warnAboutUnknownOperations paths fmap@@ -45,10 +43,11 @@ -- | 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'+ let defaultURL = getServerURL $ OAT.openApiSpecificationServers spec defaultURLName = mkName "defaultURL"- getServerURL = maybe "/" (OAT.url :: OAT.ServerObject -> Text) . Maybe.listToMaybe+ getServerURL = maybe "/" OAT.serverObjectUrl . Maybe.listToMaybe+ defaultApplicationNameVarName = mkName "defaultApplicationName"+ defaultApplicationName = OAT.infoObjectTitle $ OAT.openApiSpecificationInfo spec in Doc.addConfigurationModuleHeader moduleName . vcat <$> sequence@@ -60,21 +59,30 @@ ], ppr <$> [d|$(varP defaultURLName) = T.pack $(stringE $ T.unpack defaultURL)|],+ pure $+ Doc.generateHaddockComment+ [ "The default application name used in the @User-Agent@ header which is based on the @info.title@ field of the specification",+ "",+ "@" <> defaultApplicationName <> "@"+ ],+ ppr+ <$> [d|$(varP defaultApplicationNameVarName) = T.pack $(stringE $ T.unpack defaultApplicationName)|], pure $ Doc.generateHaddockComment ["The default configuration containing the 'defaultURL' and no authorization"],- ppr <$> [d|$(varP $ mkName "defaultConfiguration") = OC.Configuration $(varE defaultURLName) OC.anonymousSecurityScheme|]+ ppr <$> [d|$(varP $ mkName "defaultConfiguration") = OC.Configuration $(varE defaultURLName) OC.anonymousSecurityScheme True $(varE defaultApplicationNameVarName)|] ] -- | Defines all models in the components.schemas section of the 'OAT.OpenApiSpecification' defineModels :: String -> OAT.OpenApiSpecification -> Dep.Models -> OAM.Generator (Q [Dep.ModuleDefinition]) defineModels moduleName spec operationDependencies =- let schemaDefinitions = Map.toList $ OAT.schemas $ OAT.components spec+ let schemaDefinitions = Map.toList $ OAT.componentsObjectSchemas $ OAT.openApiSpecificationComponents spec in OAM.nested "components" $ OAM.nested "schemas" $ do warnAboutUnknownWhiteListedOrOpaqueSchemas schemaDefinitions models <- mapM (uncurry Model.defineModelForSchema) schemaDefinitions whiteListedSchemas <- OAM.getSetting OAO.settingWhiteListedSchemas+ outputAllSchemas <- OAM.getSetting OAO.settingOutputAllSchemas let dependencies = Set.union operationDependencies $ Set.fromList $ fmap transformToModuleName whiteListedSchemas- pure $ Dep.getModelModulesFromModelsWithDependencies moduleName dependencies models+ pure $ Dep.getModelModulesFromModelsWithDependencies moduleName dependencies outputAllSchemas models -- | Defines all supported security schemes from the 'OAT.OpenApiSpecification'. defineSecuritySchemes :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q Doc)@@ -88,5 +96,5 @@ OAT.Reference _ -> Nothing ) . Map.toList- . OAT.securitySchemes- . OAT.components+ . OAT.componentsObjectSecuritySchemes+ . OAT.openApiSpecificationComponents
src/OpenAPI/Generate/Model.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}@@ -23,6 +23,8 @@ import qualified Data.Bifunctor as BF import qualified Data.Either as E import qualified Data.Int as Int+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Scientific as Scientific@@ -33,7 +35,6 @@ import Data.Time.Calendar 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@@ -41,6 +42,7 @@ import qualified OpenAPI.Generate.ModelDependencies as Dep import qualified OpenAPI.Generate.Monad as OAM import qualified OpenAPI.Generate.OptParse as OAO+import OpenAPI.Generate.OptParse.Types import qualified OpenAPI.Generate.Types as OAT import qualified OpenAPI.Generate.Types.Schema as OAS import Prelude hiding (maximum, minimum, not)@@ -74,6 +76,12 @@ in if useOverloadedStrings then [|$s|] else [|Aeson.String $s|]+liftAesonValueWithOverloadedStrings _ (Aeson.Number n) =+ -- Without the manual handling of numbers, TH tries to use+ -- `Scientific.Scientific` which is not exposed.+ let coefficient = Scientific.coefficient n+ base10Exponent = Scientific.base10Exponent n+ in [|Aeson.Number (Scientific.scientific coefficient base10Exponent)|] liftAesonValueWithOverloadedStrings _ a = [|a|] liftAesonValue :: Aeson.Value -> Q Exp@@ -121,7 +129,8 @@ OAT.Reference reference -> do refName <- haskellifyNameM True $ getSchemaNameFromReference reference OAM.logTrace $ "Encountered reference '" <> reference <> "' which references the type '" <> T.pack (nameBase refName) <> "'"- pure (varT refName, (emptyDoc, transformReferenceToDependency reference))+ createAlias schemaName "" strategy $+ pure (varT refName, (emptyDoc, transformReferenceToDependency reference)) getSchemaNameFromReference :: Text -> Text getSchemaNameFromReference = T.replace "#/components/schemas/" ""@@ -145,7 +154,9 @@ p <- OAM.getSchemaReferenceM ref when (Maybe.isNothing p) $ OAM.logWarning $- "Reference '" <> ref <> "' to schema from '"+ "Reference '"+ <> ref+ <> "' to schema from '" <> schemaName <> "' could not be found and therefore will be skipped." pure $ (,transformReferenceToDependency ref) <$> p@@ -177,12 +188,47 @@ -- | 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 schemaName schema enumValues+defineModelForSchemaConcrete strategy schemaName schema = do+ nonNullableTypeSuffix <- OAM.getSetting OAO.settingNonNullableTypeSuffix+ let enumValues = OAS.schemaObjectEnum schema+ schemaNameWithNonNullableSuffix = if OAS.schemaObjectNullable schema then schemaName <> nonNullableTypeSuffix else schemaName+ typeWithDeclaration <-+ if null enumValues+ then defineModelForSchemaConcreteIgnoreEnum strategy schemaNameWithNonNullableSuffix schema+ else defineEnumModel schemaNameWithNonNullableSuffix schema enumValues+ if OAS.schemaObjectNullable schema+ then defineNullableTypeAlias strategy schemaName typeWithDeclaration+ else pure typeWithDeclaration +defineNullableTypeAlias :: TypeAliasStrategy -> Text -> TypeWithDeclaration -> OAM.Generator TypeWithDeclaration+defineNullableTypeAlias strategy schemaName (type', (content, dependencies)) = do+ nonNullableTypeSuffix <- OAM.getSetting OAO.settingNonNullableTypeSuffix+ let nullableType = appT (varT ''OC.Nullable) type'+ case strategy of+ CreateTypeAlias -> do+ path <- getCurrentPathEscaped+ name <- haskellifyNameM True schemaName+ pure+ ( varT name,+ ( content+ `appendDoc` ( ( Doc.generateHaddockComment+ [ "Defines a nullable type alias for '"+ <> schemaName+ <> nonNullableTypeSuffix+ <> "' as the schema located at @"+ <> path+ <> "@ in the specification is marked as nullable."+ ]+ $$+ )+ . ppr+ <$> tySynD name [] nullableType+ ),+ dependencies+ )+ )+ DontCreateTypeAlias -> pure (nullableType, (content, dependencies))+ -- | Creates a Model, ignores enum values defineModelForSchemaConcreteIgnoreEnum :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration defineModelForSchemaConcreteIgnoreEnum strategy schemaName schema = do@@ -190,15 +236,15 @@ 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 = null $ OAS.allOf schema- oneOfNull = null $ OAS.oneOf schema- anyOfNull = null $ OAS.anyOf schema+ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeArray} -> defineArrayModelForSchema strategy schemaName schema+ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeObject} ->+ let allOfNull = null $ OAS.schemaObjectAllOf schema+ oneOfNull = null $ OAS.schemaObjectOneOf schema+ anyOfNull = null $ OAS.schemaObjectAnyOf schema in case (allOfNull, oneOfNull, anyOfNull) of- (False, _, _) -> OAM.nested "allOf" $ defineAllOfSchema schemaName schemaDescription $ OAS.allOf schema- (_, False, _) -> OAM.nested "oneOf" $ typeAliasing $ defineOneOfSchema schemaName schemaDescription $ OAS.oneOf schema- (_, _, False) -> OAM.nested "anyOf" $ defineAnyOfSchema strategy schemaName schemaDescription $ OAS.anyOf schema+ (False, _, _) -> OAM.nested "allOf" $ defineAllOfSchema schemaName schemaDescription $ OAS.schemaObjectAllOf schema+ (_, False, _) -> OAM.nested "oneOf" $ typeAliasing $ defineOneOfSchema schemaName schemaDescription $ OAS.schemaObjectOneOf schema+ (_, _, False) -> OAM.nested "anyOf" $ defineAnyOfSchema strategy schemaName schemaDescription $ OAS.schemaObjectAnyOf schema _ -> defineObjectModelForSchema strategy schemaName schema _ -> typeAliasing $ pure (varT $ getSchemaType settings schema, (emptyDoc, Set.empty))@@ -236,9 +282,9 @@ . ( `Doc.sideBySide` ( text "" $$ Doc.sideComments- ( "This case is used if the value encountered during decoding does not match any of the provided cases in the specification." :- "This constructor can be used to send values to the server which are not present in the specification yet." :- comments+ ( "This case is used if the value encountered during decoding does not match any of the provided cases in the specification."+ : "This constructor can be used to send values to the server which are not present in the specification yet."+ : comments ) ) )@@ -270,21 +316,20 @@ (mkName "parseJSON") [clause [p] (normalB [|pure $fromJsonCases|]) []] fromJson = instanceD (cxt []) [t|Aeson.FromJSON $(varT name)|] [fromJsonFn]- toJsonClause (name', value) = clause [conP name' []] (normalB $ liftAesonValue $ Aeson.toJSON value) []- toJsonFn =+ toJsonFnClause n ps ex = funD (mkName "toJSON")- ( clause- [conP fallbackName [p]]- (normalB e)- [] :- clause- [conP typedName [p]]- (normalB [|Aeson.toJSON $e|])- [] :- (toJsonClause <$> nameValues)- )- toJson = instanceD (cxt []) [t|Aeson.ToJSON $(varT name)|] [toJsonFn]+ [ clause+ [conP n ps]+ (normalB ex)+ []+ ]+ toJsonClause (name', value) = toJsonFnClause name' [] $ liftAesonValue $ Aeson.toJSON value+ toJsonFns =+ toJsonFnClause fallbackName [p] e+ : toJsonFnClause typedName [p] [|Aeson.toJSON $e|]+ : (toJsonClause <$> nameValues)+ toJson = instanceD (cxt []) [t|Aeson.ToJSON $(varT name)|] toJsonFns in fmap ppr toJson `appendDoc` fmap ppr fromJson -- | defines anyOf types@@ -295,8 +340,8 @@ defineAnyOfSchema strategy schemaName description schemas = do 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+ schemasWithoutRequired = fmap (\o -> o {OAS.schemaObjectRequired = Set.empty}) concreteSchemas+ notObjectSchemas = filter (\o -> OAS.schemaObjectType o /= OAS.SchemaTypeObject) concreteSchemas newDependencies = Set.unions $ fmap snd schemasWithDependencies if null notObjectSchemas then do@@ -309,13 +354,13 @@ -- 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+-- let objectSchemas = filter (\o -> OAS.schemaObjectType 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}+-- newSchema = schemaPrototype {OAS.schemaObjectProperties = propertiesCombined, OAS.schemaObjectRequired = Set.empty} -- in -- createAlias schemaName strategy $ defineOneOfSchema schemaName (fmap OAT.Concrete (newSchema : notObjectSchemas)) @@ -324,21 +369,28 @@ -- 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- when (null schemas) $ OAM.logWarning "oneOf does not contain any sub-schemas and will therefore be defined as a void type"+defineOneOfSchema schemaName description allSchemas = do+ when (null allSchemas) $ OAM.logWarning "oneOf does not contain any sub-schemas and will therefore be defined as a void type" settings <- OAM.getSettings- let name = haskellifyName (OAO.settingConvertToCamelCase settings) True $ schemaName <> "Variants"- (schemas', schemasWithFixedValues) = extractSchemasWithFixedValues schemas- indexedSchemas = zip schemas' ([1 ..] :: [Integer])+ let haskellifyConstructor = haskellifyName (OAO.settingConvertToCamelCase settings) True+ name = haskellifyConstructor $ schemaName <> "Variants"+ fixedValueStrategy = OAO.settingFixedValueStrategy settings+ (otherSchemas, fixedValueSchemas, singleFieldedSchemas) =+ let (s', fixedValue) = extractSchemasWithFixedValues fixedValueStrategy allSchemas+ (s'', singleFielded) = extractSchemasWithSingleField s'+ in (s'', fixedValue, singleFielded)+ defineSingleFielded field = defineModelForSchemaNamed (schemaName <> haskellifyText (OAO.settingConvertToCamelCase settings) True field)+ indexedSchemas = zip otherSchemas ([1 ..] :: [Integer]) defineIndexed schema index = defineModelForSchemaNamed (schemaName <> "OneOf" <> T.pack (show index)) schema OAM.logInfo $ "Define as oneOf named '" <> T.pack (nameBase name) <> "'"- variants <- mapM (uncurry defineIndexed) indexedSchemas+ singleFieldedVariants <- mapM (uncurry defineSingleFielded) singleFieldedSchemas+ indexedVariants <- mapM (uncurry defineIndexed) indexedSchemas path <- getCurrentPathEscaped- let variantDefinitions = vcat <$> mapM (fst . snd) variants+ let variants = indexedVariants <> singleFieldedVariants+ variantDefinitions = vcat <$> mapM (fst . snd) variants dependencies = Set.unions $ fmap (snd . snd) variants types = fmap fst variants indexedTypes = zip types ([1 ..] :: [Integer])- haskellifyConstructor = haskellifyName (OAO.settingConvertToCamelCase settings) True getConstructorName (typ, n) = do t <- typ let suffix = if OAO.settingUseNumberedVariantConstructors settings then "Variant" <> T.pack (show n) else typeToSuffix t@@ -356,7 +408,7 @@ createConstructorForSchemaWithFixedValue = (`normalC` []) . createConstructorNameForSchemaWithFixedValue- fixedValueComments = fmap (("Represents the JSON value @" <>) . (<> "@") . showAesonValue) schemasWithFixedValues+ fixedValueComments = fmap (("Represents the JSON value @" <>) . (<> "@") . showAesonValue) fixedValueSchemas emptyCtx = pure [] patternName = mkName "a" p = varP patternName@@ -378,7 +430,7 @@ Aeson.Success $p -> pure $e Aeson.Error $p -> fail $e |]- case schemasWithFixedValues of+ case fixedValueSchemas of [] -> parserExpr _ -> multiIfE $@@ -387,7 +439,7 @@ let constructorName = createConstructorNameForSchemaWithFixedValue value in normalGE [|$(varE paramName) == $(liftAesonValue value)|] [|pure $(varE constructorName)|] )- schemasWithFixedValues+ fixedValueSchemas <> [normalGE [|otherwise|] parserExpr] in funD (mkName "parseJSON")@@ -396,28 +448,27 @@ (normalB body) [] ]- toJsonFn =+ toJsonFnConstructor constructorName = do+ n <- constructorName funD (mkName "toJSON")- ( fmap- ( \constructorName -> do- n <- constructorName- clause- [conP n [p]]- (normalB [|Aeson.toJSON $e|])- []- )- constructorNames- <> fmap- ( \value ->- let constructorName = createConstructorNameForSchemaWithFixedValue value- in clause- [conP constructorName []]- (normalB $ liftAesonValue value)- []- )- schemasWithFixedValues- )+ [ clause+ [conP n [p]]+ (normalB [|Aeson.toJSON $e|])+ []+ ]+ toJsonFnFixedValues value =+ let constructorName = createConstructorNameForSchemaWithFixedValue value+ in funD+ (mkName "toJSON")+ [ clause+ [conP constructorName []]+ (normalB $ liftAesonValue value)+ []+ ]+ toJsonFns =+ fmap toJsonFnConstructor constructorNames+ <> fmap toJsonFnFixedValues fixedValueSchemas dataDefinition = ( Doc.generateHaddockComment [ "Defines the oneOf schema located at @" <> path <> "@ in the specification.",@@ -434,14 +485,14 @@ name [] Nothing- (fmap createConstructorForSchemaWithFixedValue schemasWithFixedValues <> fmap createTypeConstruct indexedTypes)+ (fmap createConstructorForSchemaWithFixedValue fixedValueSchemas <> fmap createTypeConstruct indexedTypes) [ derivClause Nothing [ conT ''Show, conT ''Eq ] ]- toJson = ppr <$> instanceD emptyCtx [t|Aeson.ToJSON $(varT name)|] [toJsonFn]+ toJson = ppr <$> instanceD emptyCtx [t|Aeson.ToJSON $(varT name)|] toJsonFns fromJson = ppr <$> instanceD emptyCtx [t|Aeson.FromJSON $(varT name)|] [fromJsonFn] innerRes = (varT name, (variantDefinitions `appendDoc` dataDefinition `appendDoc` toJson `appendDoc` fromJson, dependencies)) pure innerRes@@ -468,11 +519,11 @@ -- 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+ let allOf = OAS.schemaObjectAllOf schema+ anyOf = OAS.schemaObjectAnyOf schema relevantSubschemas = allOf <> anyOf in if null relevantSubschemas- then pure (OAS.properties schema, OAS.required schema)+ then pure (OAS.schemaObjectProperties schema, OAS.schemaObjectRequired schema) else do (allOfProps, allOfRequired) <- fuseSchemasAllOf schemaName allOf (anyOfProps, _) <- fuseSchemasAllOf schemaName anyOf@@ -501,7 +552,7 @@ pure Nothing else do let schemaPrototype = head concreteSchemas- newSchema = schemaPrototype {OAS.properties = propertiesCombined, OAS.required = requiredCombined, OAS.description = Just description}+ newSchema = schemaPrototype {OAS.schemaObjectProperties = propertiesCombined, OAS.schemaObjectRequired = requiredCombined, OAS.schemaObjectDescription = Just description} OAM.logTrace $ "Define allOf as record named '" <> schemaName <> "'" pure $ Just (newSchema, newDependencies) @@ -512,13 +563,16 @@ CreateTypeAlias -> OAM.getSetting OAO.settingArrayItemTypeSuffix DontCreateTypeAlias -> pure "" -- The suffix is only relevant for top level declarations because only there a named type of the array even exists (type', (content, dependencies)) <-- case OAS.items schema of+ case OAS.schemaObjectItems schema of Just itemSchema -> OAM.nested "items" $ defineModelForSchemaNamed (schemaName <> arrayItemTypeSuffix) itemSchema -- not allowed by the spec Nothing -> do OAM.logWarning "Array type was defined without a items schema and therefore cannot be defined correctly" pure ([t|Aeson.Object|], (emptyDoc, Set.empty))- let arrayType = appT listT type'+ let arrayType =+ case OAS.schemaObjectMinItems schema of+ Just w | w > 0 -> appT [t|NonEmpty|] type'+ _ -> appT listT type' schemaName' <- haskellifyNameM True schemaName OAM.logTrace $ "Define as list named '" <> T.pack (nameBase schemaName') <> "'" path <- getCurrentPathEscaped@@ -540,6 +594,24 @@ ) ) +data Field = Field+ { fieldProp :: Text,+ fieldName :: Text,+ fieldSchema :: OAS.Schema,+ fieldRequired :: Bool,+ fieldHaskellName :: Name+ }++toField :: Bool -> Text -> Text -> OAS.Schema -> Set.Set Text -> Field+toField convertToCamelCase propName fieldName fieldSchema required =+ Field+ { fieldProp = propName,+ fieldName,+ fieldSchema,+ fieldRequired = propName `Set.member` required,+ fieldHaskellName = haskellifyName convertToCamelCase False fieldName+ }+ -- | Defines a record defineObjectModelForSchema :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration defineObjectModelForSchema strategy schemaName schema =@@ -550,13 +622,20 @@ path <- getCurrentPathEscaped let convertToCamelCase = OAO.settingConvertToCamelCase settings name = haskellifyName convertToCamelCase True schemaName- required = OAS.required schema- (props, propsWithFixedValues) = extractPropertiesWithFixedValues required $ Map.toList $ OAS.properties schema- propsWithNames = zip (fmap fst props) $ fmap (haskellifyName convertToCamelCase False . (schemaName <>) . uppercaseFirstText . fst) props+ required = OAS.schemaObjectRequired schema+ fixedValueStrategy = OAO.settingFixedValueStrategy settings+ shortenSingleFieldObjects = OAO.settingShortenSingleFieldObjects settings+ (props, propsWithFixedValues) = extractPropertiesWithFixedValues fixedValueStrategy required $ Map.toList $ OAS.schemaObjectProperties schema+ propFields = case props of+ [(propName, subschema)]+ | shortenSingleFieldObjects ->+ [(propName, toField convertToCamelCase propName schemaName subschema required)]+ _ -> flip fmap props $ \(propName, subschema) ->+ (propName, toField convertToCamelCase propName (schemaName <> uppercaseFirstText propName) subschema required) emptyCtx = pure [] OAM.logInfo $ "Define as record named '" <> T.pack (nameBase name) <> "'"- (bangTypes, propertyContent, propertyDependencies) <- propertiesToBangTypes schemaName props required- propertyDescriptions <- getDescriptionOfProperties props+ (bangTypes, propertyContent, propertyDependencies) <- propertiesToBangTypes propFields+ propertyDescriptions <- getDescriptionOfProperties propFields let dataDefinition = do bangs <- bangTypes let record = recC name (pure <$> bangs)@@ -567,9 +646,9 @@ . Doc.reformatRecord . ppr <$> dataD emptyCtx name [] Nothing [record] objectDeriveClause- toJsonInstance = createToJSONImplementation name propsWithNames propsWithFixedValues- fromJsonInstance = createFromJSONImplementation name propsWithNames required- mkFunction = createMkFunction name propsWithNames required bangTypes+ toJsonInstance = createToJSONImplementation name propFields propsWithFixedValues+ fromJsonInstance = createFromJSONImplementation name propFields+ mkFunction = createMkFunction name propFields bangTypes pure ( varT name, ( pure@@ -588,41 +667,52 @@ ) ) -extractPropertiesWithFixedValues :: Set.Set Text -> [(Text, OAS.Schema)] -> ([(Text, OAS.Schema)], [(Text, Aeson.Value)])-extractPropertiesWithFixedValues required =+extractPropertiesWithFixedValues :: FixedValueStrategy -> Set.Set Text -> [(Text, OAS.Schema)] -> ([(Text, OAS.Schema)], [(Text, Aeson.Value)])+extractPropertiesWithFixedValues fixedValueStrategy required = E.partitionEithers . fmap ( \(name, schema) -> BF.bimap (name,) (name,) $ if name `Set.member` required- then extractSchemaWithFixedValue schema+ then extractSchemaWithFixedValue fixedValueStrategy schema else Left schema ) -extractSchemasWithFixedValues :: [OAS.Schema] -> ([OAS.Schema], [Aeson.Value])-extractSchemasWithFixedValues = E.partitionEithers . fmap extractSchemaWithFixedValue+extractSchemasWithFixedValues :: FixedValueStrategy -> [OAS.Schema] -> ([OAS.Schema], [Aeson.Value])+extractSchemasWithFixedValues fixedValueStrategy =+ E.partitionEithers . fmap (extractSchemaWithFixedValue fixedValueStrategy) -extractSchemaWithFixedValue :: OAS.Schema -> Either OAS.Schema Aeson.Value-extractSchemaWithFixedValue schema@(OAT.Concrete OAS.SchemaObject {..}) = case enum of+extractSchemaWithFixedValue :: FixedValueStrategy -> OAS.Schema -> Either OAS.Schema Aeson.Value+extractSchemaWithFixedValue FixedValueStrategyExclude schema@(OAT.Concrete OAS.SchemaObject {..}) = case schemaObjectEnum of [value] -> Right value _ -> Left schema-extractSchemaWithFixedValue schema = Left schema+extractSchemaWithFixedValue _ schema = Left schema -createMkFunction :: Name -> [(Text, Name)] -> Set.Set Text -> Q [VarBangType] -> Q Doc-createMkFunction name propsWithNames required bangTypes = do+extractSchemasWithSingleField :: [OAS.Schema] -> ([OAS.Schema], [(Text, OAS.Schema)])+extractSchemasWithSingleField = E.partitionEithers . fmap extractSchemaWithSingleField++extractSchemaWithSingleField :: OAS.Schema -> Either OAS.Schema (Text, OAS.Schema)+extractSchemaWithSingleField schema@(OAT.Concrete OAS.SchemaObject {..}) = case Map.toList schemaObjectProperties of+ [(field, _)] -> Right (field, schema)+ _ -> Left schema+extractSchemaWithSingleField schema = Left schema++createMkFunction :: Name -> [(Text, Field)] -> Q [VarBangType] -> Q Doc+createMkFunction name propFields bangTypes = do bangs <- bangTypes let fnName = mkName $ "mk" <> nameBase name- propsWithTypes =- ( \((originalName, propertyName), (_, _, propertyType)) ->- (propertyName, propertyType, originalName `Set.member` required)+ fieldsWithBangs =+ ( \((_, record), (_, _, propType)) ->+ (record, propType) )- <$> zip propsWithNames bangs- requiredPropsWithTypes = filter (\(_, _, isRequired) -> isRequired) propsWithTypes- parameterPatterns = (\(propertyName, _, _) -> varP propertyName) <$> requiredPropsWithTypes- parameterDescriptions = (\(propertyName, _, _) -> "'" <> T.pack (nameBase propertyName) <> "'") <$> requiredPropsWithTypes- recordExpr = (\(propertyName, _, isRequired) -> fieldExp propertyName (if isRequired then varE propertyName else [|Nothing|])) <$> propsWithTypes+ <$> zip propFields bangs+ requiredFieldsWithBangs = filter (\(Field {..}, _) -> fieldRequired) fieldsWithBangs+ parameterPatterns = (\(Field {..}, _) -> varP fieldHaskellName) <$> requiredFieldsWithBangs+ parameterDescriptions = (\(Field {..}, _) -> "'" <> T.pack (nameBase fieldHaskellName) <> "'") <$> requiredFieldsWithBangs+ recordExpr = (\(Field {..}, _) -> fieldExp fieldHaskellName (if fieldRequired then varE fieldHaskellName else [|Nothing|])) <$> fieldsWithBangs expr = recConE name recordExpr- fnType = foldr (\(_, propertyType, _) t -> [t|$(pure propertyType) -> $t|]) (conT name) requiredPropsWithTypes+ fnType = foldr (\(_, propertyType) t -> [t|$(pure propertyType) -> $t|]) (conT name) requiredFieldsWithBangs+ pure ( Doc.generateHaddockComment [ "Create a new '" <> T.pack (nameBase name) <> "' with all required fields."@@ -639,26 +729,26 @@ `appendDoc` fmap ppr (funD fnName [clause parameterPatterns (normalB expr) []]) -- | create toJSON implementation for an object-createToJSONImplementation :: Name -> [(Text, Name)] -> [(Text, Aeson.Value)] -> Q Doc-createToJSONImplementation objectName recordNames propsWithFixedValues =+createToJSONImplementation :: Name -> [(Text, Field)] -> [(Text, Aeson.Value)] -> Q Doc+createToJSONImplementation objectName fieldProps propsWithFixedValues = let emptyDefs = pure [] fnArgName = mkName "obj"- toAssertion (jsonName, hsName) =- [|$(stringE $ T.unpack jsonName) Aeson..= $(varE hsName) $(varE fnArgName)|]- toFixedAssertion (jsonName, value) =- [|$(stringE $ T.unpack jsonName) Aeson..= $(liftAesonValueWithOverloadedStrings False value)|]- assertions = fmap toAssertion recordNames <> fmap toFixedAssertion propsWithFixedValues+ toAssertion (propName, Field {..}) =+ if fieldRequired+ then [|[$(stringE $ T.unpack propName) Aeson..= $(varE fieldHaskellName) $(varE fnArgName)]|]+ else [|(maybe mempty (pure . ($(stringE $ T.unpack propName) Aeson..=)) ($(varE fieldHaskellName) $(varE fnArgName)))|]+ toFixedAssertion (propName, value) =+ [|[$(stringE $ T.unpack propName) Aeson..= $(liftAesonValueWithOverloadedStrings False value)]|]+ assertions = fmap toAssertion fieldProps <> fmap toFixedAssertion propsWithFixedValues+ assertionsList = [|(List.concat $(toExprList assertions))|] toExprList = foldr (\x expr -> uInfixE x (varE $ mkName ":") expr) [|mempty|]- toExprCombination [] = [|[]|]- toExprCombination [x] = x- toExprCombination (x : xs) = [|$(x) <> $(toExprCombination xs)|] defaultJsonImplementation = [ funD (mkName "toJSON") [ clause [varP fnArgName] ( normalB- [|Aeson.object $(toExprList assertions)|]+ [|Aeson.object $assertionsList|] ) [] ],@@ -667,7 +757,7 @@ [ clause [varP fnArgName] ( normalB- [|Aeson.pairs $(toExprCombination assertions)|]+ [|Aeson.pairs (mconcat $assertionsList)|] ) [] ]@@ -675,22 +765,22 @@ in ppr <$> instanceD emptyDefs [t|Aeson.ToJSON $(varT objectName)|] defaultJsonImplementation -- | create FromJSON implementation for an object-createFromJSONImplementation :: Name -> [(Text, Name)] -> Set.Set Text -> Q Doc-createFromJSONImplementation objectName recordNames required =+createFromJSONImplementation :: Name -> [(Text, Field)] -> Q Doc+createFromJSONImplementation objectName fieldProps = let fnArgName = mkName "obj" withObjectLamda = foldl- ( \prev (propName, _) ->- let propName' = stringE $ T.unpack propName+ ( \prev (_, Field {..}) ->+ let fieldProp' = stringE $ T.unpack fieldProp arg = varE fnArgName readPropE =- if propName `Set.member` required- then [|$arg Aeson..: $propName'|]- else [|$arg Aeson..:? $propName'|]+ if fieldRequired+ then [|$arg Aeson..: $fieldProp'|]+ else [|$arg Aeson..:! $fieldProp'|] in [|$prev <*> $readPropE|] ) [|pure $(varE objectName)|]- recordNames+ fieldProps in ppr <$> instanceD (cxt [])@@ -707,47 +797,46 @@ ] -- | 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 = OAM.nested "properties" $ do- propertySuffix <- OAM.getSetting OAO.settingPropertyTypeSuffix+propertiesToBangTypes :: [(Text, Field)] -> OAM.Generator BangTypesSelfDefined+propertiesToBangTypes [] = pure (pure [], emptyDoc, Set.empty)+propertiesToBangTypes fieldProps = OAM.nested "properties" $ do convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase- let createBang :: Text -> Text -> Q Type -> Q VarBangType- createBang recordName propName myType = do+ propTypeSuffix <- OAM.getSetting OAO.settingPropertyTypeSuffix+ let createBang :: Field -> Q Type -> Q VarBangType+ createBang Field {..} myType = do bang' <- bang noSourceUnpackedness noSourceStrictness type' <-- if recordName `Set.member` required+ if fieldRequired then myType else appT (varT ''Maybe) myType- pure (haskellifyName convertToCamelCase False propName, bang', type')- propToBangType :: (Text, OAS.Schema) -> OAM.Generator (Q VarBangType, Q Doc, Dep.Models)- propToBangType (recordName, schema) = do- let propName = schemaName <> uppercaseFirstText recordName- (myType, (content, depenencies)) <- OAM.nested recordName $ defineModelForSchemaNamed (propName <> propertySuffix) schema- let myBang = createBang recordName propName myType- pure (myBang, content, depenencies)- foldFn :: OAM.Generator BangTypesSelfDefined -> (Text, OAS.Schema) -> OAM.Generator BangTypesSelfDefined+ pure (haskellifyName convertToCamelCase False fieldName, bang', type')+ propToBangType :: Field -> OAM.Generator (Q VarBangType, Q Doc, Dep.Models)+ propToBangType field@Field {..} = do+ (myType, (content, dependencies)) <- OAM.nested fieldProp $ defineModelForSchemaNamed (fieldName <> propTypeSuffix) fieldSchema+ let myBang = createBang field myType+ pure (myBang, content, dependencies)+ foldFn :: OAM.Generator BangTypesSelfDefined -> (Text, Field) -> OAM.Generator BangTypesSelfDefined foldFn accHolder next = do (varBang, content, dependencies) <- accHolder- (nextVarBang, nextContent, nextDependencies) <- propToBangType next+ (nextVarBang, nextContent, nextDependencies) <- propToBangType $ snd next pure ( varBang `liftedAppend` fmap pure nextVarBang, content `appendDoc` nextContent, Set.union dependencies nextDependencies )- foldl foldFn (pure (pure [], emptyDoc, Set.empty)) props+ foldl foldFn (pure (pure [], emptyDoc, Set.empty)) fieldProps getDescriptionOfSchema :: OAS.SchemaObject -> Text-getDescriptionOfSchema schema = Doc.escapeText $ Maybe.fromMaybe "" $ OAS.description schema+getDescriptionOfSchema schema = Doc.escapeText $ Maybe.fromMaybe "" $ OAS.schemaObjectDescription schema -getDescriptionOfProperties :: [(Text, OAS.Schema)] -> OAM.Generator [Text]+getDescriptionOfProperties :: [(Text, Field)] -> OAM.Generator [Text] getDescriptionOfProperties = mapM- ( \(name, schema) -> do- schema' <- resolveSchemaReferenceWithoutWarning schema- let description = maybe "" (": " <>) $ schema' >>= OAS.description+ ( \(propName, Field {..}) -> do+ schema' <- resolveSchemaReferenceWithoutWarning fieldSchema+ let description = maybe "" (": " <>) $ schema' >>= OAS.schemaObjectDescription constraints = T.unlines $ ("* " <>) <$> getConstraintDescriptionsOfSchema schema'- pure $ Doc.escapeText $ name <> description <> (if T.null constraints then "" else "\n\nConstraints:\n\n" <> constraints)+ pure $ Doc.escapeText $ propName <> description <> (if T.null constraints then "" else "\n\nConstraints:\n\n" <> constraints) ) -- | Extracts the constraints of a 'OAS.SchemaObject' as human readable text@@ -755,43 +844,43 @@ 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+ exclusiveMaximum = maybe False OAS.schemaObjectExclusiveMaximum schema+ exclusiveMinimum = maybe False OAS.schemaObjectExclusiveMinimum 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,+ [ showConstraint "Must be a multiple of " $ schema >>= OAS.schemaObjectMultipleOf,+ showConstraint ("Maxium " <> if exclusiveMaximum then " (exclusive)" else "" <> " of ") $ schema >>= OAS.schemaObjectMaximum,+ showConstraint ("Minimum " <> if exclusiveMinimum then " (exclusive)" else "" <> " of ") $ schema >>= OAS.schemaObjectMinimum,+ showConstraint "Maximum length of " $ schema >>= OAS.schemaObjectMaxLength,+ showConstraint "Minimum length of " $ schema >>= OAS.schemaObjectMinLength,+ ("Must match pattern '" <>) . (<> "'") <$> (schema >>= OAS.schemaObjectPattern),+ showConstraintSurrounding "Must have a maximum of " " items" $ schema >>= OAS.schemaObjectMaxItems,+ showConstraintSurrounding "Must have a minimum of " " items" $ schema >>= OAS.schemaObjectMinItems, 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+ . OAS.schemaObjectUniqueItems,+ showConstraintSurrounding "Must have a maximum of " " properties" $ schema >>= OAS.schemaObjectMaxProperties,+ showConstraintSurrounding "Must have a minimum of " " properties" $ schema >>= OAS.schemaObjectMinProperties ] -- | Extracts the 'Name' of a 'OAS.SchemaObject' which should be used for primitive types getSchemaType :: OAO.Settings -> OAS.SchemaObject -> Name-getSchemaType OAO.Settings {settingUseIntWithArbitraryPrecision = True} OAS.SchemaObject {type' = OAS.SchemaTypeInteger} = ''Integer-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int32"} = ''Int.Int32-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int64"} = ''Int.Int64-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger} = ''Int-getSchemaType OAO.Settings {settingUseFloatWithArbitraryPrecision = True} OAS.SchemaObject {type' = OAS.SchemaTypeNumber} = ''Scientific.Scientific-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "float"} = ''Float-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "double"} = ''Double-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber} = ''Double-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "byte"} = ''OC.JsonByteString-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "binary"} = ''OC.JsonByteString-getSchemaType OAO.Settings {settingUseDateTypesAsString = True} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date"} = ''Day-getSchemaType OAO.Settings {settingUseDateTypesAsString = True} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date-time"} = ''OC.JsonDateTime-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString} = ''Text-getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeBool} = ''Bool+getSchemaType OAO.Settings {settingUseIntWithArbitraryPrecision = True} OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeInteger} = ''Integer+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeInteger, schemaObjectFormat = Just "int32"} = ''Int.Int32+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeInteger, schemaObjectFormat = Just "int64"} = ''Int.Int64+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeInteger} = ''Int+getSchemaType OAO.Settings {settingUseFloatWithArbitraryPrecision = True} OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeNumber} = ''Scientific.Scientific+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeNumber, schemaObjectFormat = Just "float"} = ''Float+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeNumber, schemaObjectFormat = Just "double"} = ''Double+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeNumber} = ''Double+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeString, schemaObjectFormat = Just "byte"} = ''OC.JsonByteString+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeString, schemaObjectFormat = Just "binary"} = ''OC.JsonByteString+getSchemaType OAO.Settings {settingUseDateTypesAsString = True} OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeString, schemaObjectFormat = Just "date"} = ''Day+getSchemaType OAO.Settings {settingUseDateTypesAsString = True} OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeString, schemaObjectFormat = Just "date-time"} = ''OC.JsonDateTime+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeString} = ''Text+getSchemaType _ OAS.SchemaObject {schemaObjectType = OAS.SchemaTypeBool} = ''Bool getSchemaType _ OAS.SchemaObject {} = ''Text getCurrentPathEscaped :: OAM.Generator Text
src/OpenAPI/Generate/ModelDependencies.hs view
@@ -38,9 +38,12 @@ -- | Analyzes the dependencies of the provided models and splits them into modules. -- All models which would form an own module but only consist of a type alias are put in a module named by 'Doc.typeAliasModule'.-getModelModulesFromModelsWithDependencies :: String -> Models -> [ModelWithDependencies] -> Q [ModuleDefinition]-getModelModulesFromModelsWithDependencies mainModuleName operationAndWhiteListDependencies models = do- let modelsToGenerate = filterRequiredModels operationAndWhiteListDependencies models+getModelModulesFromModelsWithDependencies :: String -> Models -> Bool -> [ModelWithDependencies] -> Q [ModuleDefinition]+getModelModulesFromModelsWithDependencies mainModuleName operationAndWhiteListDependencies outputAllSchemas models = do+ let modelsToGenerate =+ if outputAllSchemas+ then models+ else filterRequiredModels operationAndWhiteListDependencies models prependTypesModule = ((typesModule <> ".") <>) . T.unpack prependMainModule = ((mainModuleName <> ".") <>) modelsWithResolvedContent <-@@ -78,16 +81,16 @@ (prependMainModule typesModule) (fmap prependMainModule (Doc.typeAliasModule : modelModuleNames)) "Rexports all type modules (used in the operation modules)."- ) :- ( [Doc.typeAliasModule],- Doc.addModelModuleHeader- mainModuleName- Doc.typeAliasModule- (prependTypesModule <$> Set.toList (Set.difference typeAliasDependencies typeAliasModuleNames))- "Contains all types with cyclic dependencies (between each other or to itself)"- typeAliasContent- ) :- modules+ )+ : ( [Doc.typeAliasModule],+ Doc.addModelModuleHeader+ mainModuleName+ Doc.typeAliasModule+ (prependTypesModule <$> Set.toList (Set.difference typeAliasDependencies typeAliasModuleNames))+ "Contains all types with cyclic dependencies (between each other or to itself)"+ typeAliasContent+ )+ : modules isTypeAliasModule :: Doc -> Bool isTypeAliasModule =
src/OpenAPI/Generate/Monad.hs view
@@ -18,13 +18,13 @@ -- | The reader environment of the 'Generator' monad ----- The 'currentPath' is updated using the 'nested' function to track the current position within the specification.+-- The 'generatorEnvironmentCurrentPath' 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.+-- The 'generatorEnvironmentReferences' map is a lookup table for references within the OpenAPI specification. data GeneratorEnvironment = GeneratorEnvironment- { currentPath :: [Text],- references :: Ref.ReferenceMap,- settings :: OAO.Settings+ { generatorEnvironmentCurrentPath :: [Text],+ generatorEnvironmentReferences :: Ref.ReferenceMap,+ generatorEnvironmentSettings :: OAO.Settings } deriving (Show, Eq) @@ -41,9 +41,9 @@ createEnvironment :: OAO.Settings -> Ref.ReferenceMap -> GeneratorEnvironment createEnvironment settings references = GeneratorEnvironment- { currentPath = [],- references = references,- settings = settings+ { generatorEnvironmentCurrentPath = [],+ generatorEnvironmentReferences = references,+ generatorEnvironmentSettings = settings } -- | Writes a log message to a 'Generator' monad@@ -70,23 +70,33 @@ -- | 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]}+nested pathItem = MR.local $ \g ->+ g+ { generatorEnvironmentCurrentPath = generatorEnvironmentCurrentPath g <> [pathItem]+ } -- | This function can be used to tell the 'Generator' monad where in the OpenAPI specification the generator currently is (ignoring any previous path changes) resetPath :: [Text] -> Generator a -> Generator a-resetPath path = MR.local $ \g -> g {currentPath = path}+resetPath path = MR.local $ \g -> g {generatorEnvironmentCurrentPath = path} getCurrentPath :: Generator [Text]-getCurrentPath = MR.asks currentPath+getCurrentPath = MR.asks generatorEnvironmentCurrentPath appendToPath :: [Text] -> Generator [Text] appendToPath path = do p <- getCurrentPath pure $ p <> path +-- | Allows to adjust the settings for certain parts of the generation.+adjustSettings :: (OAO.Settings -> OAO.Settings) -> Generator a -> Generator a+adjustSettings f = MR.local $ \g ->+ g+ { generatorEnvironmentSettings = f (generatorEnvironmentSettings g)+ }+ -- | 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+createReferenceLookupM fn key = MR.asks $ fn key . generatorEnvironmentReferences -- | Resolve a 'OAS.SchemaObject' reference from within the 'Generator' monad getSchemaReferenceM :: Text -> Generator (Maybe OAS.SchemaObject)@@ -118,8 +128,8 @@ -- | Get all settings passed to the program getSettings :: Generator OAO.Settings-getSettings = MR.asks settings+getSettings = MR.asks generatorEnvironmentSettings -- | Get a specific setting selected by @f@ getSetting :: (OAO.Settings -> a) -> Generator a-getSetting f = MR.asks $ f . settings+getSetting f = MR.asks $ f . generatorEnvironmentSettings
src/OpenAPI/Generate/Operation.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections #-} -- | Contains the functionality to define operation functions for path items.@@ -13,7 +13,7 @@ import qualified Control.Applicative as Applicative import Control.Monad import qualified Data.Bifunctor as BF-import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString as BS import qualified Data.Maybe as Maybe import qualified Data.Set as Set import Data.Text (Text)@@ -31,6 +31,14 @@ import qualified OpenAPI.Generate.Response as OAR import qualified OpenAPI.Generate.Types as OAT +#if MIN_VERSION_template_haskell(2,17,0)+nameToTypeVariable :: Name -> Q (TyVarBndr Specificity)+nameToTypeVariable monadName = plainInvisTV monadName specifiedSpec+#else+nameToTypeVariable :: Name -> Q TyVarBndr+nameToTypeVariable monadName = pure $ plainTV monadName+#endif+ -- | Defines the operations for all paths and their methods defineOperationsForPath :: String -> Text -> OAT.PathItemObject -> OAM.Generator (Q [Dep.ModuleDefinition], Dep.Models) defineOperationsForPath mainModuleName requestPath pathItemObject = OAM.nested requestPath $ do@@ -40,21 +48,21 @@ (uncurry (defineModuleForOperation mainModuleName requestPath)) $ filterEmptyAndOmittedOperations operationsToGenerate- [ ("GET", OAT.get pathItemObject),- ("PUT", OAT.put pathItemObject),- ("POST", OAT.post pathItemObject),- ("DELETE", OAT.delete pathItemObject),- ("OPTIONS", OAT.options pathItemObject),- ("HEAD", OAT.head pathItemObject),- ("PATCH", OAT.patch pathItemObject),- ("TRACE", OAT.trace pathItemObject)+ [ ("GET", OAT.pathItemObjectGet pathItemObject),+ ("PUT", OAT.pathItemObjectPut pathItemObject),+ ("POST", OAT.pathItemObjectPost pathItemObject),+ ("DELETE", OAT.pathItemObjectDelete pathItemObject),+ ("OPTIONS", OAT.pathItemObjectOptions pathItemObject),+ ("HEAD", OAT.pathItemObjectHead pathItemObject),+ ("PATCH", OAT.pathItemObjectPatch pathItemObject),+ ("TRACE", OAT.pathItemObjectTrace pathItemObject) ] filterEmptyAndOmittedOperations :: [Text] -> [(Text, Maybe OAT.OperationObject)] -> [(Text, OAT.OperationObject)] filterEmptyAndOmittedOperations operationsToGenerate xs = [ (method, operation) | (method, Just operation) <- xs,- null operationsToGenerate || OAT.operationId operation `elem` fmap Just operationsToGenerate+ null operationsToGenerate || OAT.operationObjectOperationId operation `elem` fmap Just operationsToGenerate ] -- |@@ -79,7 +87,7 @@ convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase let operationIdAsText = T.pack $ show operationIdName appendToOperationName = ((T.pack $ nameBase operationIdName) <>)- moduleName = haskellifyText convertToCamelCase True operationIdAsText+ moduleName = T.unpack $ haskellifyText convertToCamelCase True operationIdAsText OAM.logInfo $ "Generating operation with name '" <> operationIdAsText <> "'" (bodySchema, bodyPath) <- getBodySchemaFromOperation operation (responseTypeName, responseTransformerExp, responseBodyDefinitions, responseBodyDependencies) <- OAR.getResponseDefinitions operation appendToOperationName@@ -102,12 +110,13 @@ ) types = paramType <> bodyType monadName = mkName "m"- createFunSignature operationName fnType' =+ createFunSignature operationName fnType' = do+ tv <- nameToTypeVariable monadName ppr <$> sigD operationName ( forallT- [plainTV monadName]+ [tv] (cxt [appT (conT ''OC.MonadHTTP) (varT monadName)]) fnType' )@@ -119,7 +128,7 @@ availableOperationCombinations = cartesianProduct [ (id, responseTransformerExp, responseTypeName),- (addToName "Raw", [|id|], ''B8.ByteString)+ (addToName "Raw", [|id|], ''BS.ByteString) ] [ (id, False, getParametersTypeForSignatureWithMonadTransformer), (addToName "WithConfiguration", True, getParametersTypeForSignature)@@ -128,8 +137,8 @@ comments = [ [operationDescription [description]], [paramDoc, bodyDefinition, responseBodyDefinitions, operationDescription ["The same as '" <> operationIdAsText <> "' but accepts an explicit configuration."]],- [operationDescription ["The same as '" <> operationIdAsText <> "' but returns the raw 'Data.ByteString.Char8.ByteString'."]],- [operationDescription ["The same as '" <> operationIdAsText <> "' but accepts an explicit configuration and returns the raw 'Data.ByteString.Char8.ByteString'."]]+ [operationDescription ["The same as '" <> operationIdAsText <> "' but returns the raw 'Data.ByteString.ByteString'."]],+ [operationDescription ["The same as '" <> operationIdAsText <> "' but accepts an explicit configuration and returns the raw 'Data.ByteString.ByteString'."]] ] functionDefinitions <- mapM@@ -156,9 +165,9 @@ [ [operationDescription [description]], [paramDoc, bodyDefinition, responseBodyDefinitions] ]- $ (<> [[Doc.emptyDoc]]) $- maybe [] pure $- Maybe.listToMaybe functionDefinitions+ $ (<> [[Doc.emptyDoc]])+ $ maybe [] pure+ $ Maybe.listToMaybe functionDefinitions else zipWith (<>) comments functionDefinitions OAM.logTrace $ T.intercalate ", " $ Set.toList $ Set.unions [paramDependencies, bodyDependencies, responseBodyDependencies] pure@@ -176,7 +185,7 @@ generateBody <- shouldGenerateRequestBody requestBody case requestBody of Just RequestBodyDefinition {..} | generateBody -> do- let transformType = pure . (if required then id else appT $ varT ''Maybe)+ let transformType = pure . (if requestBodyDefinitionRequired then id else appT $ varT ''Maybe) requestBodySuffix <- OAM.getSetting OAO.settingRequestBodyTypeSuffix- BF.first transformType <$> Model.defineModelForSchemaNamed (appendToOperationName requestBodySuffix) schema+ BF.first transformType <$> Model.defineModelForSchemaNamed (appendToOperationName requestBodySuffix) requestBodyDefinitionSchema _ -> pure ([], (Doc.emptyDoc, Set.empty))
src/OpenAPI/Generate/OptParse.hs view
@@ -7,6 +7,7 @@ module OpenAPI.Generate.OptParse ( Settings (..), getSettings,+ module OAT, ) where @@ -16,14 +17,13 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Encoding as TE import qualified OpenAPI.Generate.Log as OAL import OpenAPI.Generate.OptParse.Configuration import OpenAPI.Generate.OptParse.Flags+import OpenAPI.Generate.OptParse.Types as OAT import Options.Applicative-import Options.Applicative.Help (string)+import Path import Path.IO-import Path.Posix import System.Exit getSettings :: IO Settings@@ -42,7 +42,7 @@ -- | Name of the stack project settingPackageName :: !Text, -- | Name of the module- settingModuleName :: !Text,+ settingModuleName :: !ModuleName, -- | The minimum log level to output settingLogLevel :: !OAL.LogSeverity, -- | Overwrite output directory without question@@ -79,6 +79,8 @@ settingRequestBodyTypeSuffix :: !Text, -- | The suffix which is added to the item type of an array. This is only applied to item types of top level array types which an alias is generated for. settingArrayItemTypeSuffix :: !Text,+ -- | The suffix which is added to the non-nullable part of a nullable type. This is only applied to top level nullable schemas as they are the only ones which need to be referencable by name.+ settingNonNullableTypeSuffix :: !Text, -- | The suffix which is added to the parameters type of operations settingParametersTypeSuffix :: !Text, -- | The prefix which is added to query parameters@@ -98,7 +100,20 @@ -- | A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) -- which need to be generated. -- For all other schemas only a type alias to 'Aeson.Value' is created.- settingWhiteListedSchemas :: ![Text]+ settingWhiteListedSchemas :: ![Text],+ -- | Output all schemas.+ settingOutputAllSchemas :: !Bool,+ -- | In OpenAPI 3, fixed values can be defined as an enum with only one allowed value.+ -- If such a constant value is encountered as a required property of an object,+ -- the generator excludes this property by default ("exclude" strategy) and+ -- adds the value in the 'ToJSON' instance and expects the value to be there+ -- in the 'FromJSON' instance.+ -- This setting allows to change this behavior by including all fixed value+ -- fields instead ("include" strategy), i.e. just not trying to do anything smart.+ settingFixedValueStrategy :: !FixedValueStrategy,+ -- | When encountering an object with a single field, shorten the field of that object to be the+ -- schema name. Respects property type suffix.+ settingShortenSingleFieldObjects :: !Bool } deriving (Show, Eq) @@ -115,7 +130,7 @@ let settingOpenApiSpecification = fromMaybe "openapi-specification.yml" $ flagOpenApiSpecification <|> mConfigOpenApiSpecification settingOutputDir = fromMaybe "out" $ flagOutputDir <|> mConfigOutputDir settingPackageName = fromMaybe "openapi" $ flagPackageName <|> mc configPackageName- settingModuleName = fromMaybe "OpenAPI" $ flagModuleName <|> mc configModuleName+ settingModuleName = mkModuleName . T.unpack $ fromMaybe "OpenAPI" (flagModuleName <|> mc configModuleName) settingLogLevel = fromMaybe OAL.InfoSeverity $ flagLogLevel <|> mc configLogLevel settingForce = fromMaybe False $ flagForce <|> mc configForce settingIncremental = fromMaybe False $ flagIncremental <|> mc configIncremental@@ -134,6 +149,7 @@ settingResponseBodyTypeSuffix = fromMaybe "ResponseBody" $ flagResponseBodyTypeSuffix <|> mc configResponseBodyTypeSuffix settingRequestBodyTypeSuffix = fromMaybe "RequestBody" $ flagRequestBodyTypeSuffix <|> mc configRequestBodyTypeSuffix settingArrayItemTypeSuffix = fromMaybe "Item" $ flagArrayItemTypeSuffix <|> mc configArrayItemTypeSuffix+ settingNonNullableTypeSuffix = fromMaybe "NonNullable" $ flagNonNullableTypeSuffix <|> mc configNonNullableTypeSuffix settingParametersTypeSuffix = fromMaybe "Parameters" $ flagParametersTypeSuffix <|> mc configParametersTypeSuffix settingParameterQueryPrefix = fromMaybe "query" $ flagParameterQueryPrefix <|> mc configParameterQueryPrefix settingParameterPathPrefix = fromMaybe "path" $ flagParameterPathPrefix <|> mc configParameterPathPrefix@@ -142,6 +158,9 @@ settingOperationsToGenerate = fromMaybe [] $ flagOperationsToGenerate <|> mc configOperationsToGenerate settingOpaqueSchemas = fromMaybe [] $ flagOpaqueSchemas <|> mc configOpaqueSchemas settingWhiteListedSchemas = fromMaybe [] $ flagWhiteListedSchemas <|> mc configWhiteListedSchemas+ settingOutputAllSchemas = fromMaybe False $ flagOutputAllSchemas <|> mc configOutputAllSchemas+ settingFixedValueStrategy = fromMaybe FixedValueStrategyExclude $ flagFixedValueStrategy <|> mc configFixedValueStrategy+ settingShortenSingleFieldObjects = fromMaybe False $ flagShortenSingleFieldObjects <|> mc configShortenSingleFieldObjects pure Settings {..} where@@ -162,7 +181,8 @@ flagsParser = info (helper <*> parseFlags)- ( fullDesc <> footerDoc (Just $ string footerStr)+ ( fullDesc+ <> footer footerStr <> progDesc "This tool can be used to generate Haskell code from OpenAPI 3 specifications. For more information see https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator." <> header "Generate Haskell code from OpenAPI 3 specifications" )@@ -171,5 +191,5 @@ unlines [ "Configuration file format:", "",- T.unpack $ TE.decodeUtf8 $ renderColouredSchemaViaCodec @Configuration+ T.unpack $ renderColouredSchemaViaCodec @Configuration ]
src/OpenAPI/Generate/OptParse/Configuration.hs view
@@ -13,6 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified OpenAPI.Generate.Log as OAL+import OpenAPI.Generate.OptParse.Types import Path.IO data Configuration = Configuration@@ -38,6 +39,7 @@ configResponseBodyTypeSuffix :: !(Maybe Text), configRequestBodyTypeSuffix :: !(Maybe Text), configArrayItemTypeSuffix :: !(Maybe Text),+ configNonNullableTypeSuffix :: !(Maybe Text), configParametersTypeSuffix :: !(Maybe Text), configParameterQueryPrefix :: !(Maybe Text), configParameterPathPrefix :: !(Maybe Text),@@ -45,7 +47,10 @@ configParameterHeaderPrefix :: !(Maybe Text), configOperationsToGenerate :: !(Maybe [Text]), configOpaqueSchemas :: !(Maybe [Text]),- configWhiteListedSchemas :: !(Maybe [Text])+ configWhiteListedSchemas :: !(Maybe [Text]),+ configOutputAllSchemas :: !(Maybe Bool),+ configFixedValueStrategy :: !(Maybe FixedValueStrategy),+ configShortenSingleFieldObjects :: !(Maybe Bool) } deriving stock (Show, Eq) deriving (FromJSON, ToJSON) via (Autodocodec Configuration)@@ -76,6 +81,7 @@ <*> optionalField "responseBodyTypeSuffix" "The suffix which is added to the response body data types" .= configResponseBodyTypeSuffix <*> optionalField "requestBodyTypeSuffix" "The suffix which is added to the request body data types" .= configRequestBodyTypeSuffix <*> optionalField "arrayItemTypeSuffix" "The suffix which is added to the item type of an array. This is only applied to item types of top level array types which an alias is generated for." .= configArrayItemTypeSuffix+ <*> optionalField "nonNullableTypeSuffix" "The suffix which is added to the non-nullable part of a nullable type. This is only applied to top level nullable schemas as they are the only ones which need to be referencable by name." .= configNonNullableTypeSuffix <*> optionalField "parametersTypeSuffix" "The suffix which is added to the parameters type of operations" .= configParametersTypeSuffix <*> optionalField "parameterQueryPrefix" "The prefix which is added to query parameters" .= configParameterQueryPrefix <*> optionalField "parameterPathPrefix" "The prefix which is added to path parameters" .= configParameterPathPrefix@@ -84,6 +90,9 @@ <*> optionalField "operationsToGenerate" "If not all operations should be generated, this option can be used to specify all of them which should be generated. The value has to correspond to the value in the 'operationId' field in the OpenAPI 3 specification." .= configOperationsToGenerate <*> optionalField "opaqueSchemas" "A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) which are not further investigated while generating code from the specification. Only a type alias to 'Aeson.Value' is created for these schemas." .= configOpaqueSchemas <*> optionalField "whiteListedSchemas" "A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) which need to be generated. For all other schemas only a type alias to 'Aeson.Value' is created." .= configWhiteListedSchemas+ <*> optionalField "outputAllSchemas" "Output all component schemas" .= configOutputAllSchemas+ <*> optionalField "fixedValueStrategy" "In OpenAPI 3, fixed values can be defined as an enum with only one allowed value. If such a constant value is encountered as a required property of an object, the generator excludes this property by default ('exclude' strategy) and adds the value in the 'ToJSON' instance and expects the value to be there in the 'FromJSON' instance. This setting allows to change this behavior by including all fixed value fields instead ('include' strategy), i.e. just not trying to do anything smart." .= configFixedValueStrategy+ <*> optionalField "shortenSingleFieldObjects" "When encountering an object with a single field, shorten the field of that object to be the schema name. Respects property type suffix." .= configShortenSingleFieldObjects getConfiguration :: Text -> IO (Maybe Configuration) getConfiguration path = resolveFile' (T.unpack path) >>= readYamlConfigFile
src/OpenAPI/Generate/OptParse/Flags.hs view
@@ -9,6 +9,7 @@ import Data.Text (Text) import qualified OpenAPI.Generate.Log as OAL+import OpenAPI.Generate.OptParse.Types import Options.Applicative data Flags = Flags@@ -35,6 +36,7 @@ flagResponseBodyTypeSuffix :: !(Maybe Text), flagRequestBodyTypeSuffix :: !(Maybe Text), flagArrayItemTypeSuffix :: !(Maybe Text),+ flagNonNullableTypeSuffix :: !(Maybe Text), flagParametersTypeSuffix :: !(Maybe Text), flagParameterQueryPrefix :: !(Maybe Text), flagParameterPathPrefix :: !(Maybe Text),@@ -42,7 +44,10 @@ flagParameterHeaderPrefix :: !(Maybe Text), flagOperationsToGenerate :: !(Maybe [Text]), flagOpaqueSchemas :: !(Maybe [Text]),- flagWhiteListedSchemas :: !(Maybe [Text])+ flagWhiteListedSchemas :: !(Maybe [Text]),+ flagOutputAllSchemas :: !(Maybe Bool),+ flagFixedValueStrategy :: !(Maybe FixedValueStrategy),+ flagShortenSingleFieldObjects :: !(Maybe Bool) } deriving (Show, Eq) @@ -72,6 +77,7 @@ <*> parseFlagResponseBodyTypeSuffix <*> parseFlagRequestBodyTypeSuffix <*> parseFlagArrayItemTypeSuffix+ <*> parseFlagNonNullableTypeSuffix <*> parseFlagParametersTypeSuffix <*> parseFlagParameterQueryPrefix <*> parseFlagParameterPathPrefix@@ -80,6 +86,9 @@ <*> parseFlagOperationsToGenerate <*> parseFlagOpaqueSchemas <*> parseFlagWhiteListedSchemas+ <*> parseFlagOutputAllSchemas+ <*> parseFlagFixedValueStrategy+ <*> parseFlagShortenSingleFieldObjects parseFlagConfiguration :: Parser (Maybe Text) parseFlagConfiguration =@@ -269,6 +278,16 @@ long "array-item-type-suffix" ] +parseFlagNonNullableTypeSuffix :: Parser (Maybe Text)+parseFlagNonNullableTypeSuffix =+ optional $+ strOption $+ mconcat+ [ metavar "SUFFIX",+ help "The suffix which is added to the non-nullable part of a nullable type (default: 'NonNullable'). This is only applied to top level nullable schemas as they are the only ones which need to be referencable by name.",+ long "non-nullable-type-suffix"+ ]+ parseFlagParametersTypeSuffix :: Parser (Maybe Text) parseFlagParametersTypeSuffix = optional $@@ -351,3 +370,21 @@ help "A list of schema names (exactly as they are named in the components.schemas section of the corresponding OpenAPI 3 specification) which need to be generated. For all other schemas only a type alias to 'Aeson.Value' is created.", long "white-listed-schema" ]++parseFlagOutputAllSchemas :: Parser (Maybe Bool)+parseFlagOutputAllSchemas =+ booleanFlag "Output all component schemas" "output-all-schemas" Nothing++parseFlagFixedValueStrategy :: Parser (Maybe FixedValueStrategy)+parseFlagFixedValueStrategy =+ optional $+ option auto $+ mconcat+ [ metavar "STRATEGY",+ help "In OpenAPI 3, fixed values can be defined as an enum with only one allowed value. If such a constant value is encountered as a required property of an object, the generator excludes this property by default ('exclude' strategy) and adds the value in the 'ToJSON' instance and expects the value to be there in the 'FromJSON' instance. This setting allows to change this behavior by including all fixed value fields instead ('include' strategy), i.e. just not trying to do anything smart (default: 'exclude').",+ long "fixed-value-strategy"+ ]++parseFlagShortenSingleFieldObjects :: Parser (Maybe Bool)+parseFlagShortenSingleFieldObjects =+ booleanFlag "When encountering an object with a single field, shorten the field of that object to be the schema name. Respects property type suffix." "shorten-single-field-objects" Nothing
+ src/OpenAPI/Generate/OptParse/Types.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenAPI.Generate.OptParse.Types+ ( FixedValueStrategy (..),+ ModuleName,+ ModulePathInfo,+ mkModuleName,+ getModuleName,+ mkModulePathInfo,+ getModuleInfoPath,+ getModuleInfoDir,+ )+where++import Autodocodec+import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import System.FilePath ((</>))++newtype ModuleName = ModuleName String+ deriving (Show, Eq)++newtype ModulePathInfo = ModulePathInfo (Maybe FilePath, FilePath)++mkModuleName :: String -> ModuleName+mkModuleName = ModuleName++getModuleName :: ModuleName -> String+getModuleName (ModuleName moduleNameStr) = moduleNameStr++mkModulePathInfo :: ModuleName -> ModulePathInfo+mkModulePathInfo (ModuleName moduleNameStr) =+ let (dirMay, fileNoExtensionMay) =+ foldl+ ( \acc next ->+ let dMay = case acc of+ (Nothing, Just prev) -> Just prev+ (Just dir, Just prev) -> Just $ dir </> prev+ (dMay', Nothing) -> dMay'+ in (dMay, Just $ T.unpack next)+ )+ (Nothing, Nothing)+ . T.splitOn "."+ . T.pack+ $ moduleNameStr+ in ModulePathInfo (dirMay, Maybe.fromMaybe moduleNameStr fileNoExtensionMay)++getModuleInfoPath :: ModulePathInfo -> Maybe String -> String -> FilePath+getModuleInfoPath (ModulePathInfo (dirMay, fileNoExtension)) suffixMay extension =+ let file = case suffixMay of+ Nothing -> fileNoExtension <> extension+ Just suffix -> fileNoExtension </> suffix <> extension+ in maybe file (</> file) dirMay++getModuleInfoDir :: ModulePathInfo -> FilePath+getModuleInfoDir (ModulePathInfo (dirMay, fileNoExtension)) =+ maybe fileNoExtension (</> fileNoExtension) dirMay++data FixedValueStrategy = FixedValueStrategyExclude | FixedValueStrategyInclude+ deriving (Eq, Bounded, Enum)++instance Show FixedValueStrategy where+ show FixedValueStrategyExclude = "exclude"+ show FixedValueStrategyInclude = "include"++instance Read FixedValueStrategy where+ readsPrec _ ('e' : 'x' : 'c' : 'l' : 'u' : 'd' : 'e' : rest) = [(FixedValueStrategyExclude, rest)]+ readsPrec _ ('i' : 'n' : 'c' : 'l' : 'u' : 'd' : 'e' : rest) = [(FixedValueStrategyInclude, rest)]+ readsPrec _ _ = []++instance HasCodec FixedValueStrategy where+ codec = shownBoundedEnumCodec
src/OpenAPI/Generate/Reference.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -47,15 +46,15 @@ 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)+ buildReferencesForComponentType "schemas" SchemaReference (OAT.componentsObjectSchemas o)+ <> buildReferencesForComponentType "responses" ResponseReference (OAT.componentsObjectResponses o)+ <> buildReferencesForComponentType "parameters" ParameterReference (OAT.componentsObjectParameters o)+ <> buildReferencesForComponentType "examples" ExampleReference (OAT.componentsObjectExamples o)+ <> buildReferencesForComponentType "requestBodies" RequestBodyReference (OAT.componentsObjectRequestBodies o)+ <> buildReferencesForComponentType "headers" HeaderReference (OAT.componentsObjectHeaders o)+ <> buildReferencesForComponentType "securitySchemes" SecuritySchemeReference (OAT.componentsObjectSecuritySchemes o) )- . OAT.components+ . OAT.openApiSpecificationComponents -- | Maps the subtypes of components to the entries of the 'ReferenceMap' and filters references (the lookup table should only contain concrete values). buildReferencesForComponentType ::
src/OpenAPI/Generate/Response.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}@@ -31,6 +31,11 @@ import qualified OpenAPI.Generate.OptParse as OAO import qualified OpenAPI.Generate.Types as OAT +#if !MIN_VERSION_template_haskell(2,17,0)+examineCode :: a -> a+examineCode = id+#endif+ -- | 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.@@ -46,7 +51,7 @@ convertToCamelCase <- OAM.getSetting OAO.settingConvertToCamelCase responseSuffix <- OAM.getSetting OAO.settingResponseTypeSuffix responseBodySuffix <- OAM.getSetting OAO.settingResponseBodyTypeSuffix- let responsesObject = OAT.responses (operation :: OAT.OperationObject)+ let responsesObject = OAT.operationObjectResponses operation createBodyName = createResponseNameAsText convertToCamelCase appendToOperationName . (responseBodySuffix <>) createName = createResponseName convertToCamelCase appendToOperationName . (responseSuffix <>) responseName = createName ""@@ -86,7 +91,7 @@ Nothing -> [] ) )- ((errorSuffix, [||const True||], Just ([t|String|], (Doc.emptyDoc, Set.empty))) : schemas)+ ((errorSuffix, examineCode [||const True||], Just ([t|String|], (Doc.emptyDoc, Set.empty))) : schemas) ) [derivClause Nothing [conT ''Show, conT ''Eq]], printSchemaDefinitions schemas@@ -109,7 +114,7 @@ -- | 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+createResponseNameAsText convertToCamelCase appendToOperationName = 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@@ -119,20 +124,20 @@ 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)+ [ ("1XX",examineCode [||HT.statusIsInformational||],) <$> OAT.responsesObjectRange1XX responsesObject,+ ("2XX",examineCode [||HT.statusIsSuccessful||],) <$> OAT.responsesObjectRange2XX responsesObject,+ ("3XX",examineCode [||HT.statusIsRedirection||],) <$> OAT.responsesObjectRange3XX responsesObject,+ ("4XX",examineCode [||HT.statusIsClientError||],) <$> OAT.responsesObjectRange4XX responsesObject,+ ("5XX",examineCode [||HT.statusIsServerError||],) <$> OAT.responsesObjectRange5XX responsesObject,+ ("Default",examineCode [||const True||],) <$> OAT.responsesObjectDefault 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))+ fmap (\(code, response) -> (T.pack $ show code, examineCode [||\status -> HT.statusCode status == code||], response)) . Map.toList- . OAT.perStatusCode+ . OAT.responsesObjectPerStatusCode -- | Resolve the references in response cases --@@ -185,4 +190,4 @@ in [|fmap (\response -> fmap (Either.either $(varE $ createName errorSuffix) id . $transformLambda response) response)|] getResponseDescription :: OAT.ResponseObject -> Text-getResponseDescription response = Doc.escapeText $ OAT.description (response :: OAT.ResponseObject)+getResponseDescription = Doc.escapeText . OAT.responseObjectDescription
src/OpenAPI/Generate/SecurityScheme.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -38,15 +37,15 @@ -- | 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+ let description = Doc.escapeText $ Maybe.fromMaybe "" $ OAT.httpSecuritySchemeDescription scheme+ in case OAT.httpSecuritySchemeScheme scheme of "basic" -> Just $ basicAuthenticationScheme moduleName description "bearer" -> Just $ bearerAuthenticationScheme moduleName description _ -> Nothing defineSecurityScheme moduleName (OAT.ApiKeySecuritySchemeObject scheme) =- let description = Doc.escapeText $ Maybe.fromMaybe "" $ OAT.description (scheme :: OAT.ApiKeySecurityScheme)- name = OAT.name (scheme :: OAT.ApiKeySecurityScheme)- in case OAT.in' (scheme :: OAT.ApiKeySecurityScheme) of+ let description = Doc.escapeText $ Maybe.fromMaybe "" $ OAT.apiKeySecuritySchemeDescription scheme+ name = OAT.apiKeySecuritySchemeName scheme+ in case OAT.apiKeySecuritySchemeIn scheme of OAT.HeaderApiKeySecuritySchemeLocation -> Just $ apiKeyInHeaderAuthenticationScheme name moduleName description _ -> Nothing defineSecurityScheme _ _ = Nothing
src/OpenAPI/Generate/Types.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -18,27 +18,27 @@ ) 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.Common (jsonObjectToList) 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+ { openApiSpecificationOpenapi :: Text,+ openApiSpecificationInfo :: InfoObject,+ openApiSpecificationServers :: [ServerObject],+ openApiSpecificationPaths :: PathsObject,+ openApiSpecificationComponents :: ComponentsObject,+ openApiSpecificationSecurity :: [SecurityRequirementObject],+ openApiSpecificationTags :: [TagObject],+ openApiSpecificationExternalDocs :: Maybe ExternalDocumentationObject } deriving (Show, Eq, Generic) @@ -49,65 +49,83 @@ <*> o .: "info" <*> o .:? "servers" .!= [] <*> o .: "paths"- <*> o .:? "components"+ <*> o+ .:? "components" .!= ComponentsObject- { schemas = Map.empty,- responses = Map.empty,- parameters = Map.empty,- examples = Map.empty,- requestBodies = Map.empty,- headers = Map.empty,- securitySchemes = Map.empty+ { componentsObjectSchemas = Map.empty,+ componentsObjectResponses = Map.empty,+ componentsObjectParameters = Map.empty,+ componentsObjectExamples = Map.empty,+ componentsObjectRequestBodies = Map.empty,+ componentsObjectHeaders = Map.empty,+ componentsObjectSecuritySchemes = 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+ { infoObjectTitle :: Text,+ infoObjectDescription :: Maybe Text,+ infoObjectTermsOfService :: Maybe Text,+ infoObjectContact :: Maybe ContactObject,+ infoObjectLicense :: Maybe LicenseObject,+ infoObjectVersion :: Text } deriving (Show, Eq, Generic) -instance FromJSON InfoObject+instance FromJSON InfoObject where+ parseJSON = withObject "InfoObject" $ \o ->+ InfoObject+ <$> o .: "title"+ <*> o .:? "description"+ <*> o .:? "termsOfService"+ <*> o .:? "contact"+ <*> o .:? "license"+ <*> o .: "version" data ContactObject = ContactObject- { name :: Maybe Text,- url :: Maybe Text,- email :: Maybe Text+ { contactObjectName :: Maybe Text,+ contactObjectUrl :: Maybe Text,+ contactObjectEmail :: Maybe Text } deriving (Show, Eq, Generic) -instance FromJSON ContactObject+instance FromJSON ContactObject where+ parseJSON = withObject "ContactObject" $ \o ->+ ContactObject+ <$> o .:? "name"+ <*> o .:? "url"+ <*> o .:? "email" data LicenseObject = LicenseObject- { name :: Text,- url :: Maybe Text+ { licenseObjectName :: Text,+ licenseObjectUrl :: Maybe Text } deriving (Show, Eq, Generic) -instance FromJSON LicenseObject+instance FromJSON LicenseObject where+ parseJSON = withObject "LicenseObject" $ \o ->+ LicenseObject+ <$> o .: "name"+ <*> o .:? "url" 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]+ { pathItemObjectRef :: Maybe Text,+ pathItemObjectSummary :: Maybe Text,+ pathItemObjectDescription :: Maybe Text,+ pathItemObjectGet :: Maybe OperationObject,+ pathItemObjectPut :: Maybe OperationObject,+ pathItemObjectPost :: Maybe OperationObject,+ pathItemObjectDelete :: Maybe OperationObject,+ pathItemObjectOptions :: Maybe OperationObject,+ pathItemObjectHead :: Maybe OperationObject,+ pathItemObjectPatch :: Maybe OperationObject,+ pathItemObjectTrace :: Maybe OperationObject,+ pathItemObjectServers :: [ServerObject],+ pathItemObjectParameters :: [Referencable ParameterObject] } deriving (Show, Eq, Generic) @@ -129,17 +147,17 @@ <*> 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]+ { operationObjectTags :: [Text],+ operationObjectSummary :: Maybe Text,+ operationObjectDescription :: Maybe Text,+ operationObjectExternalDocs :: Maybe ExternalDocumentationObject,+ operationObjectOperationId :: Maybe Text,+ operationObjectParameters :: [Referencable ParameterObject],+ operationObjectRequestBody :: Maybe (Referencable RequestBodyObject),+ operationObjectResponses :: ResponsesObject,+ operationObjectDeprecated :: Bool,+ operationObjectSecurity :: [SecurityRequirementObject],+ operationObjectServers :: [ServerObject] -- callbacks (http://spec.openapis.org/oas/v3.0.3#operation-object) are omitted because they are not needed } deriving (Show, Eq, Generic)@@ -162,9 +180,9 @@ type SecurityRequirementObject = Map.Map Text [Text] data RequestBodyObject = RequestBodyObject- { content :: Map.Map Text MediaTypeObject,- description :: Maybe Text,- required :: Bool+ { requestBodyObjectContent :: Map.Map Text MediaTypeObject,+ requestBodyObjectDescription :: Maybe Text,+ requestBodyObjectRequired :: Bool } deriving (Show, Eq, Generic) @@ -176,10 +194,10 @@ <*> o .:? "required" .!= False data MediaTypeObject = MediaTypeObject- { schema :: Maybe Schema,- example :: Maybe Value,- examples :: Map.Map Text (Referencable ExampleObject),- encoding :: Map.Map Text EncodingObject+ { mediaTypeObjectSchema :: Maybe Schema,+ mediaTypeObjectExample :: Maybe Value,+ mediaTypeObjectExamples :: Map.Map Text (Referencable ExampleObject),+ mediaTypeObjectEncoding :: Map.Map Text EncodingObject } deriving (Show, Eq, Generic) @@ -192,21 +210,27 @@ <*> 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+ { exampleObjectSummary :: Maybe Text,+ exampleObjectDescription :: Maybe Text,+ exampleObjectValue :: Maybe Value, -- value and externalValue are mutually exclusive, maybe this should be encoded in this data type+ exampleObjectExternalValue :: Maybe Text } deriving (Show, Eq, Generic) -instance FromJSON ExampleObject+instance FromJSON ExampleObject where+ parseJSON = withObject "ExampleObject" $ \o ->+ ExampleObject+ <$> o .:? "summary"+ <*> o .:? "description"+ <*> o .:? "value"+ <*> o .:? "externalValue" data EncodingObject = EncodingObject- { contentType :: Maybe Text,- headers :: Map.Map Text (Referencable HeaderObject),- style :: Maybe Text,- explode :: Bool,- allowReserved :: Bool+ { encodingObjectContentType :: Maybe Text,+ encodingObjectHeaders :: Map.Map Text (Referencable HeaderObject),+ encodingObjectStyle :: Maybe Text,+ encodingObjectExplode :: Bool,+ encodingObjectAllowReserved :: Bool } deriving (Show, Eq, Generic) @@ -220,13 +244,13 @@ <*> 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)+ { responsesObjectDefault :: Maybe (Referencable ResponseObject),+ responsesObjectRange1XX :: Maybe (Referencable ResponseObject),+ responsesObjectRange2XX :: Maybe (Referencable ResponseObject),+ responsesObjectRange3XX :: Maybe (Referencable ResponseObject),+ responsesObjectRange4XX :: Maybe (Referencable ResponseObject),+ responsesObjectRange5XX :: Maybe (Referencable ResponseObject),+ responsesObjectPerStatusCode :: Map.Map Int (Referencable ResponseObject) } deriving (Show, Eq, Generic) @@ -246,13 +270,13 @@ . Maybe.mapMaybe ( \(code, response) -> fmap (,response) . readMaybe . T.unpack $ code )- $ HMap.toList o+ $ jsonObjectToList o ) data ResponseObject = ResponseObject- { description :: Text,- headers :: Map.Map Text (Referencable HeaderObject),- content :: Map.Map Text MediaTypeObject+ { responseObjectDescription :: Text,+ responseObjectHeaders :: Map.Map Text (Referencable HeaderObject),+ responseObjectContent :: 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)@@ -265,9 +289,9 @@ <*> o .:? "content" .!= Map.empty data ServerObject = ServerObject- { url :: Text,- description :: Maybe Text,- variables :: Map.Map Text ServerVariableObject+ { serverObjectUrl :: Text,+ serverObjectDescription :: Maybe Text,+ serverObjectVariables :: Map.Map Text ServerVariableObject } deriving (Show, Eq, Generic) @@ -279,9 +303,9 @@ <*> o .:? "variables" .!= Map.empty data ServerVariableObject = ServerVariableObject- { enum :: [Text],- default' :: Text,- description :: Maybe Text+ { serverVariableObjectEnum :: [Text],+ serverVariableObjectDefault :: Text,+ serverVariableObjectDescription :: Maybe Text } deriving (Show, Eq, Generic) @@ -293,13 +317,13 @@ <*> o .:? "description" data ParameterObject = ParameterObject- { name :: Text,- in' :: ParameterObjectLocation,- description :: Maybe Text,- required :: Bool,- deprecated :: Bool,- allowEmptyValue :: Bool,- schema :: ParameterObjectSchema+ { parameterObjectName :: Text,+ parameterObjectIn :: ParameterObjectLocation,+ parameterObjectDescription :: Maybe Text,+ parameterObjectRequired :: Bool,+ parameterObjectDeprecated :: Bool,+ parameterObjectAllowEmptyValue :: Bool,+ parameterObjectSchema :: ParameterObjectSchema } deriving (Show, Eq, Generic) @@ -345,12 +369,12 @@ (Nothing, Nothing) -> fail "ParameterObject (http://spec.openapis.org/oas/v3.0.3#parameter-object) requires one of the properties schema and content to be present." data SimpleParameterSchema = SimpleParameterSchema- { style :: Maybe Text,- explode :: Bool,- allowReserved :: Bool,- schema :: Schema,- example :: Maybe Value,- examples :: Map.Map Text (Referencable ExampleObject)+ { simpleParameterSchemaStyle :: Maybe Text,+ simpleParameterSchemaExplode :: Bool,+ simpleParameterSchemaAllowReserved :: Bool,+ simpleParameterSchemaSchema :: Schema,+ simpleParameterSchemaExample :: Maybe Value,+ simpleParameterSchemaExamples :: Map.Map Text (Referencable ExampleObject) } deriving (Show, Eq, Generic) @@ -359,11 +383,11 @@ maybeStyle <- o .:? "style" SimpleParameterSchema <$> o .:? "style"- <*> o .:? "explode" .!= ((maybeStyle :: Maybe Text) == Just "form") -- The default value is true for form and false otherwise (http://spec.openapis.org/oas/v3.0.3#parameterExplode)- <*> o .:? "allowReserved" .!= False- <*> o .: "schema"- <*> o .:? "example"- <*> o .:? "examples" .!= Map.empty+ <*> o .:? "explode" .!= ((maybeStyle :: Maybe Text) == Just "form") -- The default value is true for form and false otherwise (http://spec.openapis.org/oas/v3.0.3#parameterExplode)+ <*> o .:? "allowReserved" .!= False+ <*> o .: "schema"+ <*> o .:? "example"+ <*> o .:? "examples" .!= Map.empty newtype HeaderObject = HeaderObject ParameterObject deriving (Show, Eq, Generic)@@ -380,13 +404,13 @@ ) 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)+ { componentsObjectSchemas :: Map.Map Text Schema,+ componentsObjectResponses :: Map.Map Text (Referencable ResponseObject),+ componentsObjectParameters :: Map.Map Text (Referencable ParameterObject),+ componentsObjectExamples :: Map.Map Text (Referencable ExampleObject),+ componentsObjectRequestBodies :: Map.Map Text (Referencable RequestBodyObject),+ componentsObjectHeaders :: Map.Map Text (Referencable HeaderObject),+ componentsObjectSecuritySchemes :: Map.Map Text (Referencable SecuritySchemeObject) -- links and callbacks are omitted because they are not supported in the generator } deriving (Show, Eq, Generic)@@ -420,9 +444,9 @@ _ -> 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+ { apiKeySecuritySchemeDescription :: Maybe Text,+ apiKeySecuritySchemeName :: Text,+ apiKeySecuritySchemeIn :: ApiKeySecuritySchemeLocation } deriving (Show, Eq, Generic) @@ -444,55 +468,85 @@ _ -> 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+ { httpSecuritySchemeDescription :: Maybe Text,+ httpSecuritySchemeScheme :: Text,+ httpSecuritySchemeBearerFormat :: Maybe Text } deriving (Show, Eq, Generic) -instance FromJSON HttpSecurityScheme+instance FromJSON HttpSecurityScheme where+ parseJSON = withObject "HttpSecurityScheme" $ \o ->+ HttpSecurityScheme+ <$> o .:? "description"+ <*> o .: "scheme"+ <*> o .:? "bearerFormat" data OAuth2SecurityScheme = OAuth2SecurityScheme- { description :: Maybe Text,- flows :: OAuthFlowsObject+ { oAuth2SecuritySchemeDescription :: Maybe Text,+ oAuth2SecuritySchemeFlows :: OAuthFlowsObject } deriving (Show, Eq, Generic) -instance FromJSON OAuth2SecurityScheme+instance FromJSON OAuth2SecurityScheme where+ parseJSON = withObject "OAuth2SecurityScheme" $ \o ->+ OAuth2SecurityScheme+ <$> o .:? "description"+ <*> o .: "flows" data OAuthFlowsObject = OAuthFlowsObject- { implicit :: Maybe OAuthFlowObject,- password :: Maybe OAuthFlowObject,- clientCredentials :: Maybe OAuthFlowObject,- authorizationCode :: Maybe OAuthFlowObject+ { oAuthFlowsObjectImplicit :: Maybe OAuthFlowObject,+ oAuthFlowsObjectPassword :: Maybe OAuthFlowObject,+ oAuthFlowsObjectClientCredentials :: Maybe OAuthFlowObject,+ oAuthFlowsObjectAuthorizationCode :: Maybe OAuthFlowObject } deriving (Show, Eq, Generic) -instance FromJSON OAuthFlowsObject+instance FromJSON OAuthFlowsObject where+ parseJSON = withObject "OAuthFlowsObject" $ \o ->+ OAuthFlowsObject+ <$> o .:? "implicit"+ <*> o .:? "password"+ <*> o .:? "clientCredentials"+ <*> o .:? "authorizationCode" 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+ { oAuthFlowObjectAuthorizationUrl :: Maybe Text, -- applies only to implicit and authorizationCode+ oAuthFlowObjectTokenUrl :: Maybe Text, -- applies only to password, clientCredentials and authorizationCode+ oAuthFlowObjectRefreshUrl :: Maybe Text,+ oAuthFlowObjectScopes :: Map.Map Text Text } deriving (Show, Eq, Generic) -instance FromJSON OAuthFlowObject+instance FromJSON OAuthFlowObject where+ parseJSON = withObject "OAuthFlowObject" $ \o ->+ OAuthFlowObject+ <$> o .:? "authorizationUrl"+ <*> o .:? "tokenUrl"+ <*> o .:? "refreshUrl"+ <*> o .: "scopes" data OpenIdConnectSecurityScheme = OpenIdConnectSecurityScheme- { description :: Maybe Text,- openIdConnectUrl :: Text+ { openIdConnectSecuritySchemeDescription :: Maybe Text,+ openIdConnectSecuritySchemeOpenIdConnectUrl :: Text } deriving (Show, Eq, Generic) -instance FromJSON OpenIdConnectSecurityScheme+instance FromJSON OpenIdConnectSecurityScheme where+ parseJSON = withObject "OpenIdConnectSecurityScheme" $ \o ->+ OpenIdConnectSecurityScheme+ <$> o .:? "description"+ <*> o .: "openIdConnectUrl" data TagObject = TagObject- { name :: Text,- description :: Maybe Text,- externalDocs :: Maybe ExternalDocumentationObject+ { tagObjectName :: Text,+ tagObjectDescription :: Maybe Text,+ tagObjectExternalDocs :: Maybe ExternalDocumentationObject } deriving (Show, Eq, Generic) -instance FromJSON TagObject+instance FromJSON TagObject where+ parseJSON = withObject "TagObject" $ \o ->+ TagObject+ <$> o .: "name"+ <*> o .:? "description"+ <*> o .:? "externalDocs"
src/OpenAPI/Generate/Types/ExternalDocumentation.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} -- | For more information see http://spec.openapis.org/oas/v3.0.3#external-documentation-object module OpenAPI.Generate.Types.ExternalDocumentation where@@ -8,9 +9,13 @@ import GHC.Generics data ExternalDocumentationObject = ExternalDocumentationObject- { url :: Text,- description :: Maybe Text+ { externalDocumentationObjectUrl :: Text,+ externalDocumentationObjectDescription :: Maybe Text } deriving (Show, Ord, Eq, Generic) -instance FromJSON ExternalDocumentationObject+instance FromJSON ExternalDocumentationObject where+ parseJSON = withObject "ExternalDocumentationObject" $ \o ->+ ExternalDocumentationObject+ <$> o .: "url"+ <*> o .:? "description"
src/OpenAPI/Generate/Types/Referencable.hs view
@@ -17,7 +17,7 @@ Concrete a deriving (Show, Eq, Ord) -instance FromJSON a => FromJSON (Referencable a) where+instance (FromJSON a) => FromJSON (Referencable a) where parseJSON (Object v) = do maybeReference <- v .:? "$ref" case maybeReference of
src/OpenAPI/Generate/Types/Schema.hs view
@@ -26,43 +26,43 @@ 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 :: [Value],- allOf :: [Schema],- oneOf :: [Schema],- anyOf :: [Schema],- not :: Maybe Schema,- properties :: Map.Map Text Schema,- additionalProperties :: AdditionalProperties,- description :: Maybe Text,- format :: Maybe Text,+ { schemaObjectType :: SchemaType,+ schemaObjectTitle :: Maybe Text,+ schemaObjectMultipleOf :: Maybe Float,+ schemaObjectMaximum :: Maybe Float,+ schemaObjectExclusiveMaximum :: Bool,+ schemaObjectMinimum :: Maybe Float,+ schemaObjectExclusiveMinimum :: Bool,+ schemaObjectMaxLength :: Maybe Word,+ schemaObjectMinLength :: Maybe Word,+ schemaObjectPattern :: Maybe Text,+ schemaObjectMaxItems :: Maybe Word,+ schemaObjectMinItems :: Maybe Word,+ schemaObjectUniqueItems :: Bool,+ schemaObjectMaxProperties :: Maybe Word,+ schemaObjectMinProperties :: Maybe Word,+ schemaObjectRequired :: Set Text,+ schemaObjectEnum :: [Value],+ schemaObjectAllOf :: [Schema],+ schemaObjectOneOf :: [Schema],+ schemaObjectAnyOf :: [Schema],+ schemaObjectNot :: Maybe Schema,+ schemaObjectProperties :: Map.Map Text Schema,+ schemaObjectAdditionalProperties :: AdditionalProperties,+ schemaObjectDescription :: Maybe Text,+ schemaObjectFormat :: 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+ schemaObjectDefault :: Maybe ConcreteValue,+ schemaObjectNullable :: Bool,+ schemaObjectDiscriminator :: Maybe DiscriminatorObject,+ schemaObjectReadOnly :: Bool,+ schemaObjectWriteOnly :: Bool,+ schemaObjectXml :: Maybe XMLObject,+ schemaObjectExternalDocs :: Maybe ExternalDocumentationObject,+ schemaObjectExample :: Maybe Value,+ schemaObjectDeprecated :: Bool,+ schemaObjectItems :: Maybe Schema } deriving (Show, Eq, Generic) @@ -108,51 +108,51 @@ defaultSchema :: SchemaObject defaultSchema = SchemaObject- { type' = SchemaTypeObject,- title = Nothing,- multipleOf = Nothing,- maximum = Nothing,- exclusiveMaximum = False,- minimum = Nothing,- exclusiveMinimum = False,- maxLength = Nothing,- minLength = Nothing,- pattern' = Nothing,- maxItems = Nothing,- minItems = Nothing,- uniqueItems = False,- maxProperties = Nothing,- minProperties = Nothing,- required = Set.empty,- enum = [],- allOf = [],- oneOf = [],- anyOf = [],- not = Nothing,- properties = Map.empty,- additionalProperties = HasAdditionalProperties,- OpenAPI.Generate.Types.Schema.description = Nothing,- format = Nothing,- default' = Nothing,- nullable = False,- discriminator = Nothing,- readOnly = False,- writeOnly = False,- xml = Nothing,- externalDocs = Nothing,- example = Nothing,- deprecated = False,- items = Nothing+ { schemaObjectType = SchemaTypeObject,+ schemaObjectTitle = Nothing,+ schemaObjectMultipleOf = Nothing,+ schemaObjectMaximum = Nothing,+ schemaObjectExclusiveMaximum = False,+ schemaObjectMinimum = Nothing,+ schemaObjectExclusiveMinimum = False,+ schemaObjectMaxLength = Nothing,+ schemaObjectMinLength = Nothing,+ schemaObjectPattern = Nothing,+ schemaObjectMaxItems = Nothing,+ schemaObjectMinItems = Nothing,+ schemaObjectUniqueItems = False,+ schemaObjectMaxProperties = Nothing,+ schemaObjectMinProperties = Nothing,+ schemaObjectRequired = Set.empty,+ schemaObjectEnum = [],+ schemaObjectAllOf = [],+ schemaObjectOneOf = [],+ schemaObjectAnyOf = [],+ schemaObjectNot = Nothing,+ schemaObjectProperties = Map.empty,+ schemaObjectAdditionalProperties = HasAdditionalProperties,+ schemaObjectDescription = Nothing,+ schemaObjectFormat = Nothing,+ schemaObjectDefault = Nothing,+ schemaObjectNullable = False,+ schemaObjectDiscriminator = Nothing,+ schemaObjectReadOnly = False,+ schemaObjectWriteOnly = False,+ schemaObjectXml = Nothing,+ schemaObjectExternalDocs = Nothing,+ schemaObjectExample = Nothing,+ schemaObjectDeprecated = False,+ schemaObjectItems = Nothing } -- | Checks if the given schema is an empty object schema (without properties) isSchemaEmpty :: SchemaObject -> Bool isSchemaEmpty s =- SchemaTypeObject == type' s- && Map.null (properties s)- && null (allOf s)- && null (oneOf s)- && null (anyOf s)+ SchemaTypeObject == schemaObjectType s+ && Map.null (schemaObjectProperties s)+ && null (schemaObjectAllOf s)+ && null (schemaObjectOneOf s)+ && null (schemaObjectAnyOf s) data SchemaType = SchemaTypeString@@ -174,8 +174,8 @@ parseJSON _ = fail "type must be of type string" data DiscriminatorObject = DiscriminatorObject- { propertyName :: Text,- mapping :: Map.Map Text Text+ { discriminatorObjectPropertyName :: Text,+ discriminatorObjectMapping :: Map.Map Text Text } deriving (Show, Eq, Ord, Generic) @@ -210,11 +210,11 @@ parseJSON v = AdditionalPropertiesWithSchema <$> parseJSON v data XMLObject = XMLObject- { name :: Maybe Text,- namespace :: Maybe Text,- prefix :: Maybe Text,- attribute :: Bool,- wrapped :: Bool+ { xMLObjectName :: Maybe Text,+ xMLObjectNamespace :: Maybe Text,+ xMLObjectPrefix :: Maybe Text,+ xMLObjectAttribute :: Bool,+ xMLObjectWrapped :: Bool } deriving (Show, Eq, Ord, Generic)
test/OpenAPI/Generate/DocSpec.hs view
@@ -17,14 +17,12 @@ instance Validity MultiLineString -instance GenUnchecked MultiLineString where- genUnchecked =+instance GenValid MultiLineString where+ genValid = MultiLineString <$> genListOf- ( frequency [(9, genUnchecked :: Gen Char), (1, pure '\n')]+ ( frequency [(9, genValid :: Gen Char), (1, pure '\n')] )--instance GenValid MultiLineString spec :: Spec spec = do
test/OpenAPI/Generate/Internal/UtilSpec.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+ module OpenAPI.Generate.Internal.UtilSpec where import qualified Data.Char as Char import Data.GenValidity.Text ()+import Data.Text (Text) import qualified Data.Text as T import Data.Validity.Text () import OpenAPI.Generate.Internal.Util@@ -9,8 +12,7 @@ import Test.Validity -- See https://www.haskell.org/onlinereport/lexemes.html § 2.4-isValidVarId :: String -> Bool-isValidVarId "" = False+isValidVarId :: Text -> Bool isValidVarId "case" = False isValidVarId "class" = False isValidVarId "data" = False@@ -32,11 +34,14 @@ isValidVarId "then" = False isValidVarId "type" = False isValidVarId "where" = False-isValidVarId (x : xs) = isValidSmall x && isValidSuffix xs+isValidVarId other = case T.unpack other of+ [] -> False+ (x : xs) -> isValidSmall x && isValidSuffix xs -isValidConId :: String -> Bool-isValidConId "" = False-isValidConId (x : xs) = isValidLarge x && isValidSuffix xs+isValidConId :: Text -> Bool+isValidConId other = case T.unpack other of+ [] -> False+ (x : xs) -> isValidLarge x && isValidSuffix xs isValidSmall :: Char -> Bool isValidSmall x = x == '_' || Char.isLower x@@ -65,4 +70,4 @@ describe "transformToModuleName" $ it "should be valid module name" $ forAllValid $- isValidConId . T.unpack . transformToModuleName+ isValidConId . transformToModuleName
test/OpenAPI/Generate/ModelDependenciesSpec.hs view
@@ -14,7 +14,7 @@ spec :: Spec spec = describe "getModelModulesFromModelsWithDependencies" $ do- let sut = getModelModulesFromModelsWithDependencies "OpenAPI" (Set.fromList ["A", "B", "C", "D", "E", "F", "G"])+ let sut = getModelModulesFromModelsWithDependencies "OpenAPI" (Set.fromList ["A", "B", "C", "D", "E", "F", "G"]) False t = pure . text it "should split string into pieces" $ do result <-
test/OpenAPI/Generate/MonadSpec.hs view
@@ -23,11 +23,11 @@ let run = runGenerator (createEnvironment defaultSettings Map.empty) describe "nested" $ do it "should nest path correct with simple example" $ do- let (currentPath', _) = run $ nested "a" $ nested "b" $ nested "c" $ asks currentPath+ let (currentPath', _) = run $ nested "a" $ nested "b" $ nested "c" $ asks generatorEnvironmentCurrentPath currentPath' `shouldBe` ["a", "b", "c"] it "should nest path correct with property" $ forAllValid $ \list -> do- let (currentPath', _) = run $ foldr nested (asks currentPath) list+ let (currentPath', _) = run $ foldr nested (asks generatorEnvironmentCurrentPath) list currentPath' `shouldBe` list it "should save path with logs" $ let (_, logs) = run $
test/OpenAPI/Generate/OperationGetOperationDescriptionSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module OpenAPI.Generate.OperationGetOperationDescriptionSpec where@@ -12,44 +11,41 @@ spec = let emptyResponseObject = OAT.ResponsesObject- { default' = Nothing,- range1XX = Nothing,- range2XX = Nothing,- range3XX = Nothing,- range4XX = Nothing,- range5XX = Nothing,- perStatusCode = Map.empty+ { responsesObjectDefault = Nothing,+ responsesObjectRange1XX = Nothing,+ responsesObjectRange2XX = Nothing,+ responsesObjectRange3XX = Nothing,+ responsesObjectRange4XX = Nothing,+ responsesObjectRange5XX = Nothing,+ responsesObjectPerStatusCode = Map.empty } testOperation = OAT.OperationObject- { tags = [],- summary = Nothing,- description = Nothing,- externalDocs = Nothing,- operationId = Nothing,- parameters = [],- requestBody = Nothing,- responses = emptyResponseObject,- deprecated = False,- security = [],- servers = []+ { operationObjectTags = [],+ operationObjectSummary = Nothing,+ operationObjectDescription = Nothing,+ operationObjectExternalDocs = Nothing,+ operationObjectOperationId = Nothing,+ operationObjectParameters = [],+ operationObjectRequestBody = Nothing,+ operationObjectResponses = emptyResponseObject,+ operationObjectDeprecated = False,+ operationObjectSecurity = [],+ operationObjectServers = [] } testOperation2 = testOperation- { summary = Just "my summary"- } ::- OAT.OperationObject+ { operationObjectSummary = Just "my summary"+ } testOperation3 = testOperation- { description = Just "my description"- } ::- OAT.OperationObject+ { operationObjectDescription = Just "my description"+ } testOperation4 = testOperation- { summary = Just "my summary",- description = Just "my description"- } ::- OAT.OperationObject+ { operationObjectSummary = Just "my summary",+ operationObjectDescription = Just "my description"+ } in describe "getOperationDesciption" $ do it "should return an empty string"
test/OpenAPI/Generate/OperationTHSpec.hs view
@@ -6,7 +6,6 @@ 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@@ -32,7 +31,7 @@ testParameter = OAT.ParameterObject "testName" OAT.QueryParameterObjectLocation Nothing True False True testParameterSchema testParameterOtherName = OAT.ParameterObject "testName2" OAT.QueryParameterObjectLocation Nothing True False True testParameterSchema testTHName = varE $ mkName "myTestName"- testTHE = [|B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $testTHName)|]+ testTHE = [|OC.byteToText (HT.urlEncode True $ OC.textToByte $ OC.stringifyModel $testTHName)|] monadName = mkName "m" in do describe "generateQueryParams" $@@ -43,54 +42,54 @@ describe "generateParameterizedRequestPath" $ do singleTestTH "should not change empty path without arguments"- (generateParameterizedRequestPath [] (T.pack ""))+ (generateParameterizedRequestPath [] "") [|""|] singleTestTH "should not change path without arguments"- (generateParameterizedRequestPath [] (T.pack "/my/path/"))+ (generateParameterizedRequestPath [] "/my/path/") [|"/my/path/"|] singleTestTH "should ignore params not names"- (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/my/path/"))+ (generateParameterizedRequestPath [(testTHName, testParameter)] "/my/path/") [|"/my/path/"|] singleTestTH "should replace one occurences at the end"- (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/my/path/{testName}"))- [|"/my/path/" ++ $(testTHE) ++ ""|]+ (generateParameterizedRequestPath [(testTHName, testParameter)] "/my/path/{testName}")+ [|"/my/path/" <> $(testTHE) <> ""|] singleTestTH "should replace one occurences at the end"- (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/my/path/{testName}/"))- [|"/my/path/" ++ $(testTHE) ++ "/"|]+ (generateParameterizedRequestPath [(testTHName, testParameter)] "/my/path/{testName}/")+ [|"/my/path/" <> $(testTHE) <> "/"|] singleTestTH "should replace one occurences at the beginning"- (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "{testName}/my/path/"))- [|"" ++ $(testTHE) ++ "/my/path/"|]+ (generateParameterizedRequestPath [(testTHName, testParameter)] "{testName}/my/path/")+ [|"" <> $(testTHE) <> "/my/path/"|] singleTestTH "should replace one occurences at the beginning"- (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/{testName}/my/path/"))- [|"/" ++ $(testTHE) ++ "/my/path/"|]+ (generateParameterizedRequestPath [(testTHName, testParameter)] "/{testName}/my/path/")+ [|"/" <> $(testTHE) <> "/my/path/"|] singleTestTH "should replace one occurences in the middle"- (generateParameterizedRequestPath [(testTHName, testParameter)] (T.pack "/another/test/{testName}/my/path/"))- [|"/another/test/" ++ $(testTHE) ++ "/my/path/"|]+ (generateParameterizedRequestPath [(testTHName, testParameter)] "/another/test/{testName}/my/path/")+ [|"/another/test/" <> $(testTHE) <> "/my/path/"|] singleTestTH "should ignore names not given"- (generateParameterizedRequestPath [] (T.pack "/another/test/{testName}/my/path/"))+ (generateParameterizedRequestPath [] "/another/test/{testName}/my/path/") [|"/another/test/{testName}/my/path/"|] singleTestTH "should replace two occurences" ( generateParameterizedRequestPath [(testTHName, testParameter), (varE $ mkName "myTestName2", testParameterOtherName)]- (T.pack "/{testName2}/my//test/{testName}/my/path/")+ "/{testName2}/my//test/{testName}/my/path/" )- [|("/" ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE $ mkName "myTestName2")) ++ "/my//test/") ++ $(testTHE) ++ "/my/path/"|]+ [|("/" <> OC.byteToText (HT.urlEncode True $ OC.textToByte $ OC.stringifyModel $(varE $ mkName "myTestName2")) <> "/my//test/") <> $(testTHE) <> "/my/path/"|] singleTestTH "should replace one variable twice in the path" ( generateParameterizedRequestPath [(testTHName, testParameter)]- (T.pack "/{testName}/my//test/{testName}/my/path/")+ "/{testName}/my//test/{testName}/my/path/" )- [|"/" ++ $(testTHE) ++ "/my//test/" ++ $(testTHE) ++ "/my/path/"|]+ [|"/" <> $(testTHE) <> "/my//test/" <> $(testTHE) <> "/my/path/"|] describe "getParametersTypeForSignature" $ do let responseTypeName = mkName "Test" responseType = [t|$(varT monadName) (HS.Response $(varT responseTypeName))|]
test/OpenAPI/Generate/ReferenceSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module OpenAPI.Generate.ReferenceSpec where@@ -12,38 +11,38 @@ spec = do let i = OAT.InfoObject- { title = "",- description = Nothing,- termsOfService = Nothing,- contact = Nothing,- license = Nothing,- version = "0.0.1"+ { infoObjectTitle = "",+ infoObjectDescription = Nothing,+ infoObjectTermsOfService = Nothing,+ infoObjectContact = Nothing,+ infoObjectLicense = Nothing,+ infoObjectVersion = "0.0.1" }- e = OAT.ExampleObject {summary = Just "foo", description = Nothing, value = Nothing, externalValue = Just "http://example.com"}+ e = OAT.ExampleObject {exampleObjectSummary = Just "foo", exampleObjectDescription = Nothing, exampleObjectValue = Nothing, exampleObjectExternalValue = Just "http://example.com"} c = OAT.ComponentsObject- { schemas = Map.empty,- responses = Map.empty,- parameters = Map.empty,- examples =+ { componentsObjectSchemas = Map.empty,+ componentsObjectResponses = Map.empty,+ componentsObjectParameters = Map.empty,+ componentsObjectExamples = Map.fromList [ ("example1", OAT.Concrete e), ("example2", OAT.Reference "#/components/examples/example1") ],- requestBodies = Map.empty,- headers = Map.empty,- securitySchemes = Map.empty+ componentsObjectRequestBodies = Map.empty,+ componentsObjectHeaders = Map.empty,+ componentsObjectSecuritySchemes = Map.empty } openApiSpec = OAT.OpenApiSpecification- { openapi = "3.0.3",- info = i,- servers = [],- paths = Map.empty,- components = c,- security = [],- tags = [],- externalDocs = Nothing+ { openApiSpecificationOpenapi = "3.0.3",+ openApiSpecificationInfo = i,+ openApiSpecificationServers = [],+ openApiSpecificationPaths = Map.empty,+ openApiSpecificationComponents = c,+ openApiSpecificationSecurity = [],+ openApiSpecificationTags = [],+ openApiSpecificationExternalDocs = Nothing } describe "buildReferenceMap" $ do it "should find reference" $