diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for openapi3-code-generator + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ + +MIT License + +Copyright (c) 2020 Haskell-OpenAPI-Code-Generator + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +# openapi3-code-generator +[![CircleCI](https://circleci.com/gh/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator.svg?style=svg)](https://circleci.com/gh/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator) + +## How to use? +1. install [stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/) +1. `stack install openapi3-code-generator` +1. `openapi3-code-generator my_specification.yml` + +An `out` directory is created with the generated code. Hint you can use `--output-dir` to specify another output directory. +You can use `openapi3-code-generator --help` to list all CLI options. + +## Example package +In the folder `example` is a package that uses the generated code from `specifications/petstore.yml`. +You can run `stack test` inside the `example` directory to run the code, it calls the server "https://petstore.swagger.io/v2" with some sample data. + +https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library uses this code generator to generate +a Stripe API client. + +## Documentation +The documentation for the code can be found at https://hackage.haskell.org/package/openapi3-code-generator +This package was created as part of a bachelor thesis. This thesis can be found here TODO. + +## Large specifications +For large specifications some modules (CyclicTypes.hs for example) can get pretty big. It may be necessary to use `--fast` with `stack build --fast` to build the code. + +## Module structure of the generated code. +All symbols are globally unique and are reexported in the module `OpenAPI` (Module name can be changed with `--module-name`). +To reduce compile time, the code is split up into multiple modules. +Mainly for every operation and for every schema. +Schemas with cyclic dependencies are are in the module `OpenAPI.CyclicTypes`. + +## Troubleshooting naming conflicts +Naming conflicts can happen, sometimes a little manual adjustment is needed. +With the following options naming conflicts can be resolved. + +- `property-type-suffix` +- `response-type-suffix` +- `response-body-type-suffix` +- `request-body-type-suffix` +- `use-numbered-variant-constructors` +- `convert-to-camel-case` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/app/Embed.hs b/app/Embed.hs new file mode 100644 --- /dev/null +++ b/app/Embed.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Embed where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +embedFile :: FilePath -> Q Exp +embedFile fp = + [|$(LitE . StringL <$> (qAddDependentFile fp >> runIO (readFile fp)))|] diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Monad +import qualified Data.Bifunctor as BF +import qualified Data.Text as T +import Embed +import Language.Haskell.TH +import OpenAPI.Generate +import qualified OpenAPI.Generate.Doc as Doc +import qualified OpenAPI.Generate.Flags as OAF +import OpenAPI.Generate.Internal.Util +import qualified OpenAPI.Generate.Monad as OAM +import qualified OpenAPI.Generate.Reference as Ref +import Options +import System.Directory +import System.Exit +import System.FilePath +import System.IO.Error + +srcDirectory :: FilePath +srcDirectory = "src" + +-- | Creates files from mostly static data +stackProjectFiles :: + -- | Name of the cabal project + String -> + -- | Name of the module + String -> + -- | Modules to export + [String] -> + [(FilePath, String)] +stackProjectFiles packageName moduleName modulesToExport = + [ ( packageName ++ ".cabal", + unlines $ + [ "cabal-version: 1.12", + "", + "name: " ++ packageName, + "version: 0.1.0.0", + "build-type: Simple", + "", + "library", + " exposed-modules:", + " " ++ moduleName + ] + <> fmap (" " <>) modulesToExport + <> [ " hs-source-dirs:", + " src", + " build-depends:", + " base >=4.7 && <5", + " , text", + " , ghc-prim", + " , http-conduit", + " , http-client", + " , http-types", + " , bytestring", + " , aeson", + " , unordered-containers", + " , vector", + " , scientific", + " , time", + " , mtl", + " , transformers", + " default-language: Haskell2010" + ] + ), + ( "stack.yaml", + unlines + [ "resolver: lts-15.3", + "packages:", + "- ." + ] + ) + ] + +replaceOpenAPI :: String -> String -> String +replaceOpenAPI moduleName contents = + T.unpack + $ T.replace (T.pack "OpenAPI.Common") (T.pack $ moduleName ++ ".Common") + $ T.replace (T.pack "OpenAPI.Configuration") (T.pack $ moduleName ++ ".Configuration") + $ T.pack contents + +permitProceed :: FilePath -> Bool -> IO Bool +permitProceed outputDirectory force = do + outputDirectoryExists <- doesPathExist outputDirectory + if outputDirectoryExists + then + if force + then do + putStrLn "output directory already exists and will be overwritten" + pure True + else do + putStrLn "The output directory " + putStrLn "" + putStrLn $ " " ++ show outputDirectory + putStrLn "" + putStrLn "already exists. overwrite? Y/N" + putStrLn "" + answer <- getLine + pure $ (answer == "Y") || (answer == "y") + else do + putStrLn "output directory will be created" + pure True + +main :: IO () +main = runCommand $ \opts args -> case args of + [path] -> do + spec <- decodeOpenApi path + let env = OAM.createEnvironment opts $ Ref.buildReferenceMap spec + logMessages = mapM_ (putStrLn . T.unpack) . OAM.transformGeneratorLogs + moduleName = OAF.optModuleName opts + (operationsQ, logs) = OAM.runGenerator env $ defineOperations (OAF.optModuleName opts) spec + logMessages logs + operationModules <- runQ operationsQ + configurationInfo <- runQ $ defineConfigurationInformation moduleName spec + let (modelsQ, logsModels) = OAM.runGenerator env $ defineModels moduleName spec + logMessages logsModels + modelModules <- runQ modelsQ + let (securitySchemesQ, logs') = OAM.runGenerator env $ defineSecuritySchemes moduleName spec + logMessages logs' + securitySchemes' <- runQ securitySchemesQ + let outputDirectory = OAF.optOutputDir opts + showAndReplace = replaceOpenAPI moduleName . show + modules = + fmap (BF.bimap ("Operations" :) showAndReplace) operationModules + <> fmap (BF.second showAndReplace) modelModules + <> [ (["Configuration"], showAndReplace configurationInfo), + (["SecuritySchemes"], showAndReplace securitySchemes'), + (["Common"], replaceOpenAPI moduleName $(embedFile "src/OpenAPI/Common.hs")) + ] + modulesToExport = + fmap + ( (moduleName <>) . ("." <>) + . joinWithPoint + . fst + ) + modules + mainFile = outputDirectory srcDirectory (moduleName ++ ".hs") + mainModuleContent = show $ Doc.createModuleHeaderWithReexports moduleName modulesToExport "The main module which exports all functionality." + filesToCreate = (mainFile, mainModuleContent) : (BF.first ((outputDirectory ) . (srcDirectory ) . (moduleName ) . (<> ".hs") . foldr1 ()) <$> modules) + if OAF.optDryRun opts + then + mapM_ + ( \(file, content) -> do + putStrLn $ "File: " <> file + putStrLn "---" + putStrLn content + putStrLn "---\n\n" + ) + filesToCreate + else do + proceed <- permitProceed outputDirectory (OAF.optForce opts) + if proceed + then do + _ <- tryIOError (removeDirectoryRecursive outputDirectory) + createDirectoryIfMissing True (outputDirectory srcDirectory) + createDirectoryIfMissing True (outputDirectory srcDirectory moduleName) + createDirectoryIfMissing True (outputDirectory srcDirectory moduleName "Operations") + createDirectoryIfMissing True (outputDirectory srcDirectory moduleName "Types") + mapM_ (uncurry writeFile) filesToCreate + when (OAF.optGenerateStackProject opts) $ + mapM_ + ( uncurry writeFile + . BF.first (outputDirectory ) + ) + (stackProjectFiles (OAF.optPackageName opts) moduleName modulesToExport) + putStrLn "finished" + else putStrLn "aborted" + _ -> die "Failed to generate code because no OpenAPI specification was provided. Pass the location of the OpenAPI specification as CLI argument. Run the CLI with --help to see further options." diff --git a/openapi3-code-generator.cabal b/openapi3-code-generator.cabal new file mode 100644 --- /dev/null +++ b/openapi3-code-generator.cabal @@ -0,0 +1,153 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4b9fb84a6053e692ba6c4475ec1d147da46049a8f5f454dc5fc408c8344f04bb + +name: openapi3-code-generator +version: 0.1.0.0 +synopsis: OpenAPI3 Haskell Client Code Generator +description: Please see the README on GitHub at +category: Code-Generator +homepage: https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library#readme +bug-reports: https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library/issues +author: Remo Dörig & Joel Fisch +maintainer: Joel Fisch & Remo Dörig +copyright: 2020 Remo Dörig & Joel Fisch +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + LICENSE + +source-repository head + type: git + location: https://github.com/Haskell-OpenAPI-Code-Generator/Stripe-Haskell-Library + +library + exposed-modules: + OpenAPI.Common + OpenAPI.Generate + OpenAPI.Generate.Doc + OpenAPI.Generate.Flags + OpenAPI.Generate.Internal.Operation + OpenAPI.Generate.Internal.Util + OpenAPI.Generate.Model + OpenAPI.Generate.ModelDependencies + OpenAPI.Generate.Monad + OpenAPI.Generate.Operation + OpenAPI.Generate.Reference + OpenAPI.Generate.Response + OpenAPI.Generate.SecurityScheme + OpenAPI.Generate.Types + OpenAPI.Generate.Types.ExternalDocumentation + OpenAPI.Generate.Types.Referencable + OpenAPI.Generate.Types.Schema + other-modules: + Paths_openapi3_code_generator + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers + , hashmap + , http-client + , http-conduit + , http-types + , mtl + , options + , scientific + , split + , template-haskell + , text + , time + , transformers + , unordered-containers + , vector + , yaml + default-language: Haskell2010 + +executable openapi3-code-generator-exe + main-is: Main.hs + other-modules: + Embed + Paths_openapi3_code_generator + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers + , directory + , filepath + , hashmap + , http-client + , http-conduit + , http-types + , mtl + , openapi3-code-generator + , options + , scientific + , split + , template-haskell + , text + , time + , transformers + , unordered-containers + , vector + , yaml + default-language: Haskell2010 + +test-suite openapi3-code-generator-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + OpenAPI.Generate.DocSpec + OpenAPI.Generate.Internal.UtilSpec + OpenAPI.Generate.ModelDependenciesSpec + OpenAPI.Generate.MonadSpec + OpenAPI.Generate.OperationGetOperationDescriptionSpec + OpenAPI.Generate.OperationTHSpec + OpenAPI.Generate.ReferenceSpec + Paths_openapi3_code_generator + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + QuickCheck + , aeson + , base >=4.7 && <5 + , bytestring + , containers + , genvalidity + , genvalidity-hspec + , genvalidity-text + , hashmap + , hspec + , http-client + , http-conduit + , http-types + , mtl + , openapi3-code-generator + , options + , scientific + , split + , template-haskell + , text + , time + , transformers + , unordered-containers + , validity + , validity-text + , vector + , yaml + default-language: Haskell2010 diff --git a/src/OpenAPI/Common.hs b/src/OpenAPI/Common.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Common.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module serves the purpose of defining common functionality which remains the same across all OpenAPI specifications. +module OpenAPI.Common + ( Configuration (..), + doCallWithConfiguration, + doCallWithConfigurationM, + doBodyCallWithConfiguration, + doBodyCallWithConfigurationM, + runWithConfiguration, + MonadHTTP (..), + stringifyModel, + StringifyModel, + SecurityScheme (..), + AnonymousSecurityScheme (..), + textToByte, + JsonByteString (..), + JsonDateTime (..), + RequestBodyEncoding (..), + ) +where + +import qualified Control.Exception as Exception +import qualified Control.Monad.Reader as MR +import qualified Control.Monad.Trans.Class as MT +import qualified Data.Aeson as Aeson +import qualified Data.Bifunctor as BF +import qualified Data.ByteString.Char8 as B8 +import qualified Data.HashMap.Strict as HMap +import qualified Data.Maybe as Maybe +import qualified Data.Scientific as Scientific +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Time.LocalTime as Time +import qualified Data.Vector as Vector +import GHC.Generics +import qualified Network.HTTP.Client as HC +import qualified Network.HTTP.Simple as HS + +-- | Abstracts the usage of 'Network.HTTP.Simple.httpBS' away, +-- so that it can be used for testing +class Monad m => MonadHTTP m where + httpBS :: HS.Request -> m (Either HS.HttpException (HS.Response B8.ByteString)) + +-- | This instance is the default instance used for production code +instance MonadHTTP IO where + httpBS request = + BF.first (\e -> e :: HS.HttpException) + <$> Exception.try (HS.httpBS request) + +instance MonadHTTP m => MonadHTTP (MR.ReaderT r m) where + httpBS = MT.lift . httpBS + +-- | An operation can and must be configured with data, which may be common +-- for many operations. +-- +-- This configuration consists of information about the server URL and the used security scheme. +-- +-- In OpenAPI these information can be defined +-- +-- * Root level +-- * Path level +-- * Operation level +-- +-- To get started, the 'OpenAPI.Configuration.defaultConfiguration' can be used and changed accordingly. +-- +-- Note that it is possible that @BearerAuthenticationSecurityScheme@ is not available because it is not a security scheme in the OpenAPI specification. +-- +-- > defaultConfiguration +-- > { configSecurityScheme = BearerAuthenticationSecurityScheme "token" } +data Configuration s + = Configuration + { configBaseURL :: Text, + configSecurityScheme :: s + } + deriving (Show, Ord, Eq, Generic) + +-- | Defines how a request body is encoded +data RequestBodyEncoding + = -- | Encode the body as JSON + RequestBodyEncodingJSON + | -- | Encode the body as form data + RequestBodyEncodingFormData + +-- | Allows to specify an authentication scheme for requests done with 'doCallWithConfiguration' +-- +-- This can be used to define custom schemes as well +class SecurityScheme s where + authenticateRequest :: s -> HS.Request -> HS.Request + +-- | The default authentication scheme which does not add any authentication information +data AnonymousSecurityScheme = AnonymousSecurityScheme + +-- | Instance for the anonymous scheme which does not alter the request in any way +instance SecurityScheme AnonymousSecurityScheme where + authenticateRequest = const id + +-- | Run the 'MR.ReaderT' monad with a specified configuration +-- +-- Note: This is just @'flip' 'MR.runReaderT'@. +runWithConfiguration :: SecurityScheme s => Configuration s -> MR.ReaderT (Configuration s) m a -> m a +runWithConfiguration = flip MR.runReaderT + +-- | This is the main functionality of this module +-- +-- It makes a concrete Call to a Server without a body +doCallWithConfiguration :: + (MonadHTTP m, SecurityScheme s) => + -- | Configuration options like base URL and security scheme + Configuration s -> + -- | HTTP method (GET, POST, etc.) + Text -> + -- | Path to append to the base URL (path parameters should already be replaced) + Text -> + -- | Query parameters + [(Text, Maybe String)] -> + -- | The raw response from the server + m (Either HS.HttpException (HS.Response B8.ByteString)) +doCallWithConfiguration config method path queryParams = + httpBS $ createBaseRequest config method path queryParams + +-- | Same as 'doCallWithConfiguration' but run in a 'MR.ReaderT' environment which contains the configuration. +-- This is useful if multiple calls have to be executed with the same configuration. +doCallWithConfigurationM :: + (MonadHTTP m, SecurityScheme s) => + Text -> + Text -> + [(Text, Maybe String)] -> + MR.ReaderT (Configuration s) m (Either HS.HttpException (HS.Response B8.ByteString)) +doCallWithConfigurationM method path queryParams = do + config <- MR.ask + MT.lift $ doCallWithConfiguration config method path queryParams + +-- | This is the main functionality of this module +-- +-- It makes a concrete Call to a Server with a body +doBodyCallWithConfiguration :: + (MonadHTTP m, SecurityScheme s, Aeson.ToJSON body) => + -- | Configuration options like base URL and security scheme + Configuration s -> + -- | HTTP method (GET, POST, etc.) + Text -> + -- | Path to append to the base URL (path parameters should already be replaced) + Text -> + -- | Query parameters + [(Text, Maybe String)] -> + -- | Request body + Maybe body -> + -- | JSON or form data deepobjects + RequestBodyEncoding -> + -- | The raw response from the server + m (Either HS.HttpException (HS.Response B8.ByteString)) +doBodyCallWithConfiguration config method path queryParams Nothing _ = doCallWithConfiguration config method path queryParams +doBodyCallWithConfiguration config method path queryParams (Just body) RequestBodyEncodingJSON = + httpBS $ HS.setRequestMethod (textToByte method) $ HS.setRequestBodyJSON body baseRequest + where + baseRequest = createBaseRequest config method path queryParams +doBodyCallWithConfiguration config method path queryParams (Just body) RequestBodyEncodingFormData = + httpBS $ HS.setRequestMethod (textToByte method) $ HS.setRequestBodyURLEncoded byteStringData baseRequest + where + baseRequest = createBaseRequest config method path queryParams + byteStringData = createFormData body + +-- | Same as 'doBodyCallWithConfiguration' but run in a 'MR.ReaderT' environment which contains the configuration. +-- This is useful if multiple calls have to be executed with the same configuration. +doBodyCallWithConfigurationM :: + (MonadHTTP m, SecurityScheme s, Aeson.ToJSON body) => + Text -> + Text -> + [(Text, Maybe String)] -> + Maybe body -> + RequestBodyEncoding -> + MR.ReaderT (Configuration s) m (Either HS.HttpException (HS.Response B8.ByteString)) +doBodyCallWithConfigurationM method path queryParams body encoding = do + config <- MR.ask + MT.lift $ doBodyCallWithConfiguration config method path queryParams body encoding + +-- | Creates a Base Request +createBaseRequest :: + SecurityScheme s => + -- | Common configuration Options + Configuration s -> + -- | HTTP Method (GET,POST,etc.) + Text -> + -- | The path for which the placeholders have already been replaced + Text -> + -- | Query Parameters + [(Text, Maybe String)] -> + -- | The Response from the server + HS.Request +createBaseRequest config method path queryParams = + authenticateRequest (configSecurityScheme config) + $ HS.setRequestMethod (textToByte method) + $ HS.setRequestQueryString query + $ HS.setRequestPath + (B8.pack (T.unpack $ byteToText basePathModifier <> path)) + baseRequest + where + baseRequest = parseURL $ configBaseURL config + basePath = HC.path baseRequest + basePathModifier = + if basePath == B8.pack "/" && T.isPrefixOf "/" path + then "" + else basePath + -- filters all maybe + query = [(textToByte a, Just $ B8.pack b) | (a, Just b) <- queryParams] + +-- | creates form data bytestring array +createFormData :: (Aeson.ToJSON a) => a -> [(B8.ByteString, B8.ByteString)] +createFormData body = + let formData = jsonToFormData $ Aeson.toJSON body + in fmap (BF.bimap textToByte textToByte) formData + +-- | Convert a 'B8.ByteString' to 'Text' +byteToText :: B8.ByteString -> Text +byteToText = T.pack . B8.unpack + +-- | Convert 'Text' a to 'B8.ByteString' +textToByte :: Text -> B8.ByteString +textToByte = B8.pack . T.unpack + +parseURL :: Text -> HS.Request +parseURL url = + Maybe.fromMaybe HS.defaultRequest + $ HS.parseRequest + $ T.unpack url + +jsonToFormData :: Aeson.Value -> [(Text, Text)] +jsonToFormData = jsonToFormDataPrefixed "" + +jsonToFormDataPrefixed :: Text -> Aeson.Value -> [(Text, Text)] +jsonToFormDataPrefixed prefix (Aeson.Number a) = case Scientific.toBoundedInteger a :: Maybe Int of + Just myInt -> [(prefix, T.pack $ show myInt)] + Nothing -> [(prefix, T.pack $ show a)] +jsonToFormDataPrefixed prefix (Aeson.Bool True) = [(prefix, T.pack "true")] +jsonToFormDataPrefixed prefix (Aeson.Bool False) = [(prefix, T.pack "false")] +jsonToFormDataPrefixed _ Aeson.Null = [] +jsonToFormDataPrefixed prefix (Aeson.String a) = [(prefix, a)] +jsonToFormDataPrefixed "" (Aeson.Object object) = + HMap.toList object >>= uncurry jsonToFormDataPrefixed +jsonToFormDataPrefixed prefix (Aeson.Object object) = + HMap.toList object >>= (\(x, y) -> jsonToFormDataPrefixed (prefix <> "[" <> x <> "]") y) +jsonToFormDataPrefixed prefix (Aeson.Array vector) = + Vector.toList vector >>= jsonToFormDataPrefixed (prefix <> "[]") + +-- | This type class makes the code generation for URL parameters easier as it allows to stringify a value +-- +-- The 'Show' class is not sufficient as strings should not be stringified with quotes. +class Show a => StringifyModel a where + -- | Stringifies a showable value + -- + -- >>> stringifyModel "Test" + -- "Test" + -- + -- >>> stringifyModel 123 + -- "123" + stringifyModel :: a -> String + +instance StringifyModel String where + -- stringifyModel :: String -> String + stringifyModel = id + +instance {-# OVERLAPS #-} Show a => StringifyModel a where + -- stringifyModel :: Show a => a -> String + stringifyModel = show + +-- | Wraps a 'B8.ByteString' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON' +newtype JsonByteString = JsonByteString B8.ByteString + deriving (Show, Eq, Ord) + +instance Aeson.ToJSON JsonByteString where + toJSON (JsonByteString s) = Aeson.toJSON $ B8.unpack s + +instance Aeson.FromJSON JsonByteString where + parseJSON (Aeson.String s) = pure $ JsonByteString $ textToByte s + parseJSON _ = fail "Value cannot be converted to a 'JsonByteString'" + +-- | Wraps a 'Time.ZonedTime' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON' +newtype JsonDateTime = JsonDateTime Time.ZonedTime + deriving (Show) + +instance Eq JsonDateTime where + (JsonDateTime d1) == (JsonDateTime d2) = Time.zonedTimeToUTC d1 == Time.zonedTimeToUTC d2 + +instance Ord JsonDateTime where + (JsonDateTime d1) <= (JsonDateTime d2) = Time.zonedTimeToUTC d1 <= Time.zonedTimeToUTC d2 + +instance Aeson.ToJSON JsonDateTime where + toJSON (JsonDateTime d) = Aeson.toJSON d + +instance Aeson.FromJSON JsonDateTime where + parseJSON o = JsonDateTime <$> Aeson.parseJSON o diff --git a/src/OpenAPI/Generate.hs b/src/OpenAPI/Generate.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Functionality to Generate Haskell Code out of an OpenAPI definition File +module OpenAPI.Generate where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Yaml +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import qualified OpenAPI.Common as OC +import qualified OpenAPI.Generate.Doc as Doc +import qualified OpenAPI.Generate.Model as Model +import qualified OpenAPI.Generate.ModelDependencies as Dep +import qualified OpenAPI.Generate.Monad as OAM +import qualified OpenAPI.Generate.Operation as Operation +import qualified OpenAPI.Generate.SecurityScheme as SecurityScheme +import qualified OpenAPI.Generate.Types as OAT +import System.Exit + +-- | Decodes an OpenAPI File +decodeOpenApi :: String -> IO OAT.OpenApiSpecification +decodeOpenApi fileName = do + res <- decodeFileEither fileName + case res of + Left exc -> die $ "Could not parse OpenAPI specification '" <> fileName <> "': " <> show exc + Right o -> pure o + +-- | Defines all the operations as functions and the common imports +defineOperations :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q [Dep.ModuleDefinition]) +defineOperations moduleName = + OAM.nested "paths" + . fmap + ( fmap + concat + . sequence + ) + . mapM (uncurry $ Operation.defineOperationsForPath moduleName) + . Map.toList + . OAT.paths + +-- | Defines the @defaultURL@ and the @defaultConfiguration@ containing this URL. +defineConfigurationInformation :: String -> OAT.OpenApiSpecification -> Q Doc +defineConfigurationInformation moduleName spec = + let servers' = (OAT.servers :: OAT.OpenApiSpecification -> [OAT.ServerObject]) spec + defaultURL = getServerURL servers' + defaultURLName = mkName "defaultURL" + getServerURL = maybe "/" (OAT.url :: OAT.ServerObject -> Text) . Maybe.listToMaybe + in Doc.addConfigurationModuleHeader moduleName + . vcat + <$> sequence + [ pure $ + Doc.generateHaddockComment + [ "The default url specified by the OpenAPI specification", + "", + "@" <> defaultURL <> "@" + ], + ppr + <$> [d|$(varP defaultURLName) = defaultURL|], + pure $ Doc.generateHaddockComment ["The default configuration containing the 'defaultURL' and no authorization"], + ppr <$> [d|$(varP $ mkName "defaultConfiguration") = OC.Configuration $(varE defaultURLName) OC.AnonymousSecurityScheme|] + ] + +-- | Defines all models in the components.schemas section of the 'OAT.OpenApiSpecification' +defineModels :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q [Dep.ModuleDefinition]) +defineModels moduleName spec = + let schemaDefinitions = Map.toList $ OAT.schemas $ OAT.components spec + in OAM.nested "schemas" $ do + models <- mapM (uncurry Model.defineModelForSchema) schemaDefinitions + pure $ Dep.getModelModulesFromModelsWithDependencies moduleName models + +-- | Defines all supported security schemes from the 'OAT.OpenApiSpecification'. +defineSecuritySchemes :: String -> OAT.OpenApiSpecification -> OAM.Generator (Q Doc) +defineSecuritySchemes moduleName = + OAM.nested "components" + . fmap (fmap $ Doc.addSecuritySchemesModuleHeader moduleName) + . SecurityScheme.defineSupportedSecuritySchemes (T.pack moduleName) + . Maybe.mapMaybe + ( \(name', scheme') -> case scheme' of + OAT.Concrete s -> Just (name', s) + OAT.Reference _ -> Nothing + ) + . Map.toList + . OAT.securitySchemes + . OAT.components diff --git a/src/OpenAPI/Generate/Doc.hs b/src/OpenAPI/Generate/Doc.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Doc.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Utility functions for 'Language.Haskell.TH.PprLib.Doc' manipulation +module OpenAPI.Generate.Doc + ( emptyDoc, + appendDoc, + generateHaddockComment, + escapeText, + breakOnTokens, + breakOnTokensWithReplacement, + sideComments, + zipCodeAndComments, + sideBySide, + addOperationsModuleHeader, + addSecuritySchemesModuleHeader, + addConfigurationModuleHeader, + createModuleHeaderWithReexports, + addModelModuleHeader, + ) +where + +import qualified Control.Applicative as Applicative +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH.PprLib hiding ((<>)) +import OpenAPI.Generate.Internal.Util + +-- | Empty document inside an 'Applicative' (typically 'Language.Haskell.TH.Q') +emptyDoc :: Applicative f => f Doc +emptyDoc = pure empty + +haddockIntro :: Doc +haddockIntro = text "-- |" + +haddockLine :: Doc +haddockLine = text "--" + +textToDoc :: Text -> Doc +textToDoc = text . T.unpack + +line :: String -> Doc -> Doc +line = ($$) . text + +emptyLine :: Doc -> Doc +emptyLine = line "" + +languageExtension :: String -> Doc -> Doc +languageExtension = line . ("{-# LANGUAGE " <>) . (<> " #-}") + +importQualified :: String -> Doc -> Doc +importQualified = importUnqualified . ("qualified " <>) + +importUnqualified :: String -> Doc -> Doc +importUnqualified = line . ("import " <>) + +moduleDescription :: String -> Doc -> Doc +moduleDescription = line . ("-- | " <>) + +moduleDeclaration :: String -> String -> Doc -> Doc +moduleDeclaration modulePrefix name = line ("module " <> modulePrefix <> "." <> name <> " where") + +-- | Append a 'Doc' to another inside an 'Applicative' (typically 'Language.Haskell.TH.Q') +appendDoc :: Applicative f => f Doc -> f Doc -> f Doc +appendDoc = Applicative.liftA2 ($$) + +-- | Generate a Haddock comment with multiple lines +generateHaddockComment :: [Text] -> Doc +generateHaddockComment = + generateHaddockCommentWithoutNewlines + . ( >>= + ( \case + [] -> [""] + x -> x + ) + . T.lines + ) + +generateHaddockCommentWithoutNewlines :: [Text] -> Doc +generateHaddockCommentWithoutNewlines [] = empty +generateHaddockCommentWithoutNewlines [x] = haddockIntro <+> textToDoc x +generateHaddockCommentWithoutNewlines xs = + generateHaddockCommentWithoutNewlines (init xs) + $$ haddockLine <+> textToDoc (last xs) + +-- | Escape text for use in Haddock comment +escapeText :: Text -> Text +escapeText = + T.replace "'" "\\'" + . T.replace "\"" "\\\"" + . T.replace "`" "\\`" + . T.replace "@" "\\@" + . T.replace "$" "\\$" + . T.replace "#" "\\#" + . T.replace "<" "\\<" + . T.replace "/" "\\/" + . T.replace "\\" "\\\\" + +-- | Add line breaks to a 'Doc' at all occurrences of the passed tokens (removes all other line breaks). +breakOnTokens :: [Text] -> Doc -> Doc +breakOnTokens = breakOnTokensWithReplacement ("\n " <>) + +-- | Add line breaks to a 'Doc' at all occurrences of the passed tokens (removes all other line breaks). +-- The replacement function is used to generate the text replacing the tokens. +breakOnTokensWithReplacement :: (Text -> Text) -> [Text] -> Doc -> Doc +breakOnTokensWithReplacement replaceFn tokens = + let addLineBreaks = foldr (\token f -> T.replace token (replaceFn token) . f) id tokens + in text . T.unpack . addLineBreaks . T.replace "\n" "" . removeDuplicateSpaces . T.pack . show + +removeDuplicateSpaces :: Text -> Text +removeDuplicateSpaces t = + let t' = T.replace " " " " t + in if t == t' then t' else removeDuplicateSpaces t' + +-- | Convert a list of lines to side comments +sideComments :: [Text] -> Doc +sideComments = vcat . fmap (text . T.unpack . T.replace "\n" " " . ("-- ^ " <>)) + +-- | Intertwine code lines with comment lines +-- +-- The code lines should have one more line (the first line is not commented) +zipCodeAndComments :: [Text] -> [Text] -> Doc +zipCodeAndComments [] _ = empty +zipCodeAndComments [x] _ = textToDoc x +zipCodeAndComments (x : xs) [] = textToDoc x $$ zipCodeAndComments xs [] +zipCodeAndComments (x : xs) (y : ys) = textToDoc x $$ nest 2 (generateHaddockComment [y]) $$ zipCodeAndComments xs ys + +-- | Place two documents side-by-side, aligned at the top line +-- +-- If one of the documents is longer than the other, the shorter one is extended with empty lines. +-- The lines of the right document are aligned in the same column, no matter if the left document is shorter or longer +-- +-- Example usage: +-- +-- >>> show $ sideBySide (text "a") (text "b" $$ text "c") +-- a b +-- c +sideBySide :: Doc -> Doc -> Doc +sideBySide leftDoc rightDoc = + let splitDoc = splitOn '\n' . show + leftDocLines = splitDoc leftDoc + leftDoc' = map text leftDocLines + maxLength = foldr max 0 (fmap length leftDocLines) + 1 + rightDoc' = map (nest maxLength . text) . splitDoc $ rightDoc + isLeftLonger = length leftDoc' > length rightDoc' + isRightLonger = length leftDoc' < length rightDoc' + in foldl ($$) empty $ + zipWith + ($$) + (if isRightLonger then leftDoc' <> repeat empty else leftDoc') + (if isLeftLonger then rightDoc' <> repeat empty else rightDoc') + +-- | Add the module header to a module of an operation +addOperationsModuleHeader :: String -> String -> String -> Doc -> Doc +addOperationsModuleHeader mainModuleName moduleName operationId = + languageExtension "OverloadedStrings" + . languageExtension "ExplicitForAll" + . languageExtension "MultiWayIf" + . languageExtension "DeriveGeneric" + . emptyLine + . moduleDescription ("Contains the different functions to run the operation " <> operationId) + . moduleDeclaration (mainModuleName <> ".Operations") moduleName + . emptyLine + . importQualified "Prelude as GHC.Integer.Type" + . importQualified "Prelude as GHC.Maybe" + . importQualified "Control.Monad.Trans.Reader" + . importQualified "Data.Aeson" + . importQualified "Data.Aeson as Data.Aeson.Types" + . importQualified "Data.Aeson as Data.Aeson.Types.FromJSON" + . importQualified "Data.Aeson as Data.Aeson.Types.ToJSON" + . importQualified "Data.Aeson as Data.Aeson.Types.Internal" + . importQualified "Data.ByteString.Char8" + . importQualified "Data.ByteString.Char8 as Data.ByteString.Internal" + . importQualified "Data.Either" + . importQualified "Data.Functor" + . importQualified "Data.Scientific" + . importQualified "Data.Text" + . importQualified "Data.Text.Internal" + . importQualified "Data.Time.Calendar as Data.Time.Calendar.Days" + . importQualified "Data.Time.LocalTime as Data.Time.LocalTime.Internal.ZonedTime" + . importQualified "GHC.Base" + . importQualified "GHC.Classes" + . importQualified "GHC.Generics" + . importQualified "GHC.Int" + . importQualified "GHC.Show" + . importQualified "GHC.Types" + . importQualified "Network.HTTP.Client" + . importQualified "Network.HTTP.Client as Network.HTTP.Client.Request" + . importQualified "Network.HTTP.Client as Network.HTTP.Client.Types" + . importQualified "Network.HTTP.Simple" + . importQualified "Network.HTTP.Types" + . importQualified "Network.HTTP.Types as Network.HTTP.Types.Status" + . importQualified "Network.HTTP.Types as Network.HTTP.Types.URI" + . importQualified (mainModuleName <> ".Common") + . importUnqualified (mainModuleName <> ".Types") + . emptyLine + +-- | Add the module header to a module of a model +addModelModuleHeader :: String -> String -> [String] -> String -> Doc -> Doc +addModelModuleHeader mainModuleName moduleName modelModulesToImport description = + languageExtension "OverloadedStrings" + . languageExtension "DeriveGeneric" + . emptyLine + . moduleDescription description + . moduleDeclaration mainModuleName moduleName + . emptyLine + . importQualified "Prelude as GHC.Integer.Type" + . importQualified "Prelude as GHC.Maybe" + . importQualified "Data.Aeson" + . importQualified "Data.Aeson as Data.Aeson.Types" + . importQualified "Data.Aeson as Data.Aeson.Types.FromJSON" + . importQualified "Data.Aeson as Data.Aeson.Types.ToJSON" + . importQualified "Data.Aeson as Data.Aeson.Types.Internal" + . importQualified "Data.ByteString.Char8" + . importQualified "Data.ByteString.Char8 as Data.ByteString.Internal" + . importQualified "Data.Functor" + . importQualified "Data.Scientific" + . importQualified "Data.Text" + . importQualified "Data.Text.Internal" + . importQualified "Data.Time.Calendar as Data.Time.Calendar.Days" + . importQualified "Data.Time.LocalTime as Data.Time.LocalTime.Internal.ZonedTime" + . importQualified "GHC.Base" + . importQualified "GHC.Classes" + . importQualified "GHC.Generics" + . importQualified "GHC.Int" + . importQualified "GHC.Show" + . importQualified "GHC.Types" + . importQualified (mainModuleName <> ".Common") + . (vcat (fmap (text . ("import " <>) . ((mainModuleName <> ".") <>)) modelModulesToImport) $$) + . emptyLine + +-- | Add the module header to the security scheme module +addSecuritySchemesModuleHeader :: String -> Doc -> Doc +addSecuritySchemesModuleHeader moduleName = + languageExtension "OverloadedStrings" + . emptyLine + . moduleDescription "Contains all supported security schemes defined in the specification" + . moduleDeclaration moduleName "SecuritySchemes" + . emptyLine + . importQualified "Data.Text.Internal" + . importQualified "GHC.Base" + . importQualified "GHC.Classes" + . importQualified "GHC.Show" + . importQualified "Network.HTTP.Client as Network.HTTP.Client.Request" + . importQualified "Network.HTTP.Simple" + . importQualified (moduleName <> ".Common") + . emptyLine + +-- | Add the module header to the configuration module +addConfigurationModuleHeader :: String -> Doc -> Doc +addConfigurationModuleHeader moduleName = + languageExtension "OverloadedStrings" + . emptyLine + . moduleDescription "Contains the default configuration" + . moduleDeclaration moduleName "Configuration" + . emptyLine + . importQualified "Data.Text" + . importQualified (moduleName <> ".Common") + . emptyLine + +-- | Create a 'Doc' containing a module which imports other modules and re-exports them +createModuleHeaderWithReexports :: String -> [String] -> String -> Doc +createModuleHeaderWithReexports moduleName modulesToExport description = + let exports = vcat $ fmap (text . ("module " <>) . (<> ",")) modulesToExport + imports = vcat $ fmap (text . ("import " <>)) modulesToExport + in moduleDescription description $ + text ("module " <> moduleName <> " (") + $$ nest + 2 + ( exports + $$ text ") where" + ) + $$ text "" + $$ imports diff --git a/src/OpenAPI/Generate/Flags.hs b/src/OpenAPI/Generate/Flags.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Flags.hs @@ -0,0 +1,118 @@ +-- | This module defines the available command line flags and their default values. +module OpenAPI.Generate.Flags where + +import Options + +-- | The options passed to the generator via CLI +data Flags + = Flags + { -- | The directory where the generated output is stored. + optOutputDir :: String, + -- | Generate a stack project alongside the raw Haskell files + optGenerateStackProject :: Bool, + -- | Do not generate the output files but only print the generated code + optDryRun :: Bool, + -- | Overwrite output directory without question + optForce :: Bool, + -- | Name of the stack project + optPackageName :: String, + -- | Name of the module + optModuleName :: String, + -- | Use Data.Scientific instead of Double to support arbitary number precision + optUseFloatWithArbitraryPrecision :: Bool, + -- | Convert strings formatted as date / date-time to date types + optUseDateTypesAsString :: Bool, + -- | Convert names to CamelCase instead of using names which are as close as possible to the names provided in the specification + optConvertToCamelCase :: Bool, + -- | Add a suffix to property types to prevent naming conflicts + optPropertyTypeSuffix :: String, + -- | The suffix which is added to the response data types + optResponseTypeSuffix :: String, + -- | The suffix which is added to the response body data types + optResponseBodyTypeSuffix :: String, + -- | The suffix which is added to the request body data types + optRequestBodyTypeSuffix :: String, + -- | Use numbered data constructors (e. g. Variant1, Variant 2, etc.) for one-of types + optUseNumberedVariantConstructors :: Bool + } + deriving (Show, Eq) + +instance Options Flags where + defineOptions = + Flags + <$> simpleOption + "output-dir" + (optOutputDir defaultFlags) + "The directory where the generated output is stored." + <*> simpleOption + "generate-stack-project" + (optGenerateStackProject defaultFlags) + "Generate a stack project alongside the raw Haskell files" + <*> simpleOption + "dry-run" + (optDryRun defaultFlags) + "Do not generate the output files but only print the generated code" + <*> simpleOption + "force" + (optForce defaultFlags) + "Overwrite output directory without question" + <*> simpleOption + "package-name" + (optPackageName defaultFlags) + "Name of the stack project" + <*> simpleOption + "module-name" + (optModuleName defaultFlags) + "Name of the module" + <*> simpleOption + "use-float-with-arbitrary-precision" + (optUseFloatWithArbitraryPrecision defaultFlags) + "Use Data.Scientific instead of Double to support arbitary number precision" + <*> simpleOption + "use-date-types-as-string" + (optUseDateTypesAsString defaultFlags) + "Convert strings formatted as date / date-time to date types" + <*> simpleOption + "convert-to-camel-case" + (optConvertToCamelCase defaultFlags) + "Convert names to CamelCase instead of using names which are as close as possible to the names provided in the specification" + <*> simpleOption + "property-type-suffix" + (optPropertyTypeSuffix defaultFlags) + "Add a suffix to property types to prevent naming conflicts" + <*> simpleOption + "response-type-suffix" + (optResponseTypeSuffix defaultFlags) + "The suffix which is added to the response data types" + <*> simpleOption + "response-body-type-suffix" + (optResponseBodyTypeSuffix defaultFlags) + "The suffix which is added to the response body data types" + <*> simpleOption + "request-body-type-suffix" + (optRequestBodyTypeSuffix defaultFlags) + "The suffix which is added to the request body data types" + <*> simpleOption + "use-numbered-variant-constructors" + (optUseNumberedVariantConstructors defaultFlags) + "Use numbered data constructors (e. g. Variant1, Variant 2, etc.) for one-of types" + +-- | Default flags which can be used for tests and as a reference which values actually are used +defaultFlags :: Flags +defaultFlags = + Flags + { optOutputDir = "out", + optGenerateStackProject = True, + optDryRun = False, + optForce = False, + optPackageName = "openapi", + optModuleName = "OpenAPI", + optUseFloatWithArbitraryPrecision = False, + optUseDateTypesAsString = False, + optConvertToCamelCase = False, + optPropertyTypeSuffix = "", + optResponseTypeSuffix = "Response", + optResponseBodyTypeSuffix = "ResponseBody", + optRequestBodyTypeSuffix = "RequestBody", + optUseNumberedVariantConstructors = False + } diff --git a/src/OpenAPI/Generate/Internal/Operation.hs b/src/OpenAPI/Generate/Internal/Operation.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Internal/Operation.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Helpers for the generation of the operation functions +module OpenAPI.Generate.Internal.Operation + ( getResponseObject, + getResponseSchema, + defineOperationFunction, + getParameterDescription, + getParameterType, + getParametersTypeForSignature, + getParametersTypeForSignatureWithMonadTransformer, + getOperationName, + getOperationDescription, + getParametersFromOperationConcrete, + getBodySchemaFromOperation, + generateParameterizedRequestPath, + generateQueryParams, + RequestBodyDefinition (..), + ) +where + +import Control.Monad +import qualified Control.Monad.Reader as MR +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Char as Char +import qualified Data.List.Split as Split +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import qualified Network.HTTP.Simple as HS +import qualified Network.HTTP.Types as HT +import qualified OpenAPI.Common as OC +import qualified OpenAPI.Generate.Doc as Doc +import qualified OpenAPI.Generate.Flags as OAF +import OpenAPI.Generate.Internal.Util +import qualified OpenAPI.Generate.Model as Model +import qualified OpenAPI.Generate.Monad as OAM +import qualified OpenAPI.Generate.Types as OAT +import qualified OpenAPI.Generate.Types.Schema as OAS + +-- | Extracted request body information which can be used for code generation +data RequestBodyDefinition + = RequestBodyDefinition + { schema :: OAT.Schema, + encoding :: OC.RequestBodyEncoding, + required :: Bool + } + +-- | wrapper for ambigious usage +getParametersFromOperationReference :: OAT.OperationObject -> [OAT.Referencable OAT.ParameterObject] +getParametersFromOperationReference = OAT.parameters + +-- | wrapper for ambigious usage +getSchemaFromParameterInner :: OAT.ParameterObject -> OAT.ParameterObjectSchema +getSchemaFromParameterInner = OAT.schema + +-- | wrapper for ambigious usage +getRequiredFromParameter :: OAT.ParameterObject -> Bool +getRequiredFromParameter = OAT.required + +-- | wrapper for ambigious usage +getInFromParameterObject :: OAT.ParameterObject -> OAT.ParameterObjectLocation +getInFromParameterObject = OAT.in' + +-- | Extracts all parameters of an operation +-- +-- Concrete objects are always added. References try to get resolved to a concrete object. +-- If this fails, the parameter is skipped and a warning gets produced. +getParametersFromOperationConcrete :: OAT.OperationObject -> OAM.Generator [OAT.ParameterObject] +getParametersFromOperationConcrete = + OAM.nested "parameters" + . fmap Maybe.catMaybes + . mapM + ( \case + OAT.Concrete p -> pure $ Just p + OAT.Reference ref -> do + p <- OAM.getParameterReferenceM ref + if Maybe.isJust p + then pure p + else do + OAM.logWarning $ "Reference " <> ref <> " to ParameterObject could not be found and therefore will be skipped." + pure p + ) + . getParametersFromOperationReference + +-- | Reads the Schema from the ParameterObjectSchema +-- Only application/json or simple Object Schema is read +getSchemaFromParameterOuter :: OAT.ParameterObjectSchema -> OAS.SchemaObject +getSchemaFromParameterOuter OAT.SimpleParameterObjectSchema {..} = case schema of + OAT.Concrete e -> e + _ -> error "not yet implemented" +getSchemaFromParameterOuter _ = error "not yet implemented" + +-- | Reads the Schema from the Parameter +getSchemaFromParameter :: OAT.ParameterObject -> OAS.SchemaObject +getSchemaFromParameter = getSchemaFromParameterOuter . getSchemaFromParameterInner + +getNameFromParameter :: OAT.ParameterObject -> Text +getNameFromParameter = OAT.name + +-- | Gets the Type definition dependent on the number of parameters/types +-- A monadic name for which its forall structure is defined outside +-- this function can be given +-- +-- @ +-- [t|OC.Configuration -> Int -> $(varT monadName) ($(responseType) $(responseInnerType))|] +-- = getParametersTypeForSignature [conT ''Int] (monadName) +-- @ +getParametersTypeForSignature :: [Q Type] -> Name -> Name -> Name -> Q Type +getParametersTypeForSignature types responseTypeName monadName securitySchemeName = + createFunctionType + ( [t|OC.Configuration $(varT securitySchemeName)|] + : types + <> [[t|$(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]] + ) + +-- | Same as 'getParametersTypeForSignature' but with the configuration in 'MR.ReaderT' instead of a parameter +getParametersTypeForSignatureWithMonadTransformer :: [Q Type] -> Name -> Name -> Name -> Q Type +getParametersTypeForSignatureWithMonadTransformer types responseTypeName monadName securitySchemeName = + createFunctionType + ( types + <> [[t|MR.ReaderT (OC.Configuration $(varT securitySchemeName)) $(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]] + ) + +createFunctionType :: [Q Type] -> Q Type +createFunctionType = + foldr1 + (\t1 t2 -> [t|$t1 -> $t2|]) + +getParameterName :: OAT.ParameterObject -> OAM.Generator Name +getParameterName parameter = haskellifyNameM False $ getNameFromParameter parameter + +-- | Get the type of a parameter depending on its schema type and the configuration options ('OAF.Flags'). +-- If the parameter is not required, a 'Maybe' type is produced. +getParameterType :: OAF.Flags -> OAT.ParameterObject -> Q Type +getParameterType flags parameter = + let paramType = varT $ Model.getSchemaType flags (getSchemaFromParameter parameter) + in ( if getRequiredFromParameter parameter + then paramType + else [t|Maybe $(paramType)|] + ) + +-- | Get a description of a parameter object (the name and if available the description from the specification) +getParameterDescription :: OAT.ParameterObject -> OAM.Generator Text +getParameterDescription parameter = do + schema <- Model.resolveSchemaReferenceWithoutWarning $ OAT.schema (OAT.schema (parameter :: OAT.ParameterObject) :: OAT.ParameterObjectSchema) + let name = OAT.name (parameter :: OAT.ParameterObject) + description = maybe "" (": " <>) $ OAT.description (parameter :: OAT.ParameterObject) + constraints = joinWith ", " $ Model.getConstraintDescriptionsOfSchema schema + pure $ Doc.escapeText $ name <> description <> (if T.null constraints then "" else " | Constraints: " <> constraints) + +-- | Defines the body of an Operation function +-- The Operation function calls an generall HTTP function +-- all Parameters are arguments to the function +defineOperationFunction :: + -- | Should the configuration be passed explicitly as parameter? + Bool -> + -- | How the function should be called + Name -> + -- | The parameters + [OAT.ParameterObject] -> + -- | The request path. It may contain placeholders in the form /my/{var}/path/ + Text -> + -- | HTTP Method (POST,GET,etc.) + Text -> + -- | Schema of body + Maybe RequestBodyDefinition -> + -- | An expression used to transform the response from 'B8.ByteString' to the required response type. + -- Note that the response is nested within a HTTP monad and an 'Either'. + Q Exp -> + -- | Function body definition in TH + OAM.Generator (Q Doc) +defineOperationFunction useExplicitConfiguration fnName params requestPath method bodySchema responseTransformerExp = do + paramVarNames <- mapM getParameterName params + let configArg = mkName "config" + paraPattern = varP <$> paramVarNames + fnPatterns = if useExplicitConfiguration then varP configArg : paraPattern else paraPattern + namedParameters = zip paramVarNames params + namedPathParameters = filter ((== OAT.PathParameterObjectLocation) . getInFromParameterObject . snd) namedParameters + request = generateParameterizedRequestPath namedPathParameters requestPath + namedQueryParameters = filter ((== OAT.QueryParameterObjectLocation) . getInFromParameterObject . snd) namedParameters + queryParameters = generateQueryParams namedQueryParameters + bodyName = mkName "body" + pure $ + ppr <$> case bodySchema of + Just RequestBodyDefinition {..} -> + let encodeExpr = + varE $ + case encoding of + OC.RequestBodyEncodingFormData -> 'OC.RequestBodyEncodingFormData + OC.RequestBodyEncodingJSON -> 'OC.RequestBodyEncodingJSON + in [d| + $(conP fnName $ fnPatterns <> [varP bodyName]) = + $responseTransformerExp + ( $( if useExplicitConfiguration + then [|OC.doBodyCallWithConfiguration $(varE configArg)|] + else [|OC.doBodyCallWithConfigurationM|] + ) + (T.toUpper method) + (T.pack $(request)) + $(queryParameters) + $(if required then [|Just $(varE bodyName)|] else varE bodyName) + $(encodeExpr) + ) + |] + Nothing -> + [d| + $(conP fnName fnPatterns) = + $responseTransformerExp + ( $( if useExplicitConfiguration + then [|OC.doCallWithConfiguration $(varE configArg)|] + else [|OC.doCallWithConfigurationM|] + ) + (T.toUpper method) + (T.pack $(request)) + $(queryParameters) + ) + |] + +-- | Extracts the request body schema from an operation and the encoding which should be used on the body data. +getBodySchemaFromOperation :: OAT.OperationObject -> OAM.Generator (Maybe RequestBodyDefinition) +getBodySchemaFromOperation operation = do + requestBody <- getRequestBodyObject operation + case requestBody of + Just body -> getRequestBodySchema body + Nothing -> pure Nothing + +getRequestBodyContent :: OAT.RequestBodyObject -> Map.Map Text OAT.MediaTypeObject +getRequestBodyContent = OAT.content + +getSchemaFromMedia :: OAT.MediaTypeObject -> Maybe OAT.Schema +getSchemaFromMedia = OAT.schema + +getRequestBodySchema :: OAT.RequestBodyObject -> OAM.Generator (Maybe RequestBodyDefinition) +getRequestBodySchema body = + let content = Map.lookup "application/json" $ getRequestBodyContent body + createRequestBodyDefinition encoding schema = + Just $ + RequestBodyDefinition + { schema = schema, + encoding = encoding, + required = OAT.required (body :: OAT.RequestBodyObject) + } + in case content of + Nothing -> + let formContent = Map.lookup "application/x-www-form-urlencoded" $ getRequestBodyContent body + in case formContent of + Nothing -> do + OAM.logWarning "Only content type application/json and application/x-www-form-urlencoded is supported" + pure Nothing + Just media -> + pure $ + getSchemaFromMedia media + >>= createRequestBodyDefinition OC.RequestBodyEncodingFormData + Just media -> + pure $ + getSchemaFromMedia media + >>= createRequestBodyDefinition OC.RequestBodyEncodingJSON + +getRequestBodyObject :: OAT.OperationObject -> OAM.Generator (Maybe OAT.RequestBodyObject) +getRequestBodyObject operation = + case OAT.requestBody operation of + Nothing -> pure Nothing + Just (OAT.Concrete p) -> pure $ Just p + Just (OAT.Reference ref) -> do + p <- OAM.getRequestBodyReferenceM ref + when (Maybe.isNothing p) $ OAM.logWarning $ "Reference " <> ref <> " to RequestBody could not be found and therefore will be skipped." + pure p + +-- | Extracts the response 'OAT.Schema' from a 'OAT.ResponseObject'. +-- +-- A warning is logged if the response does not contain one of the supported media types. +getResponseSchema :: OAT.ResponseObject -> OAM.Generator (Maybe OAT.Schema) +getResponseSchema response = do + let contentMap = OAT.content (response :: OAT.ResponseObject) + schema = Map.lookup "application/json" contentMap >>= getSchemaFromMedia + when (Maybe.isNothing schema && not (Map.null contentMap)) $ OAM.logWarning "Only content type application/json is supported for response bodies." + pure schema + +-- | Resolve a possibly referenced response to a concrete value. +-- +-- A warning is logged if the reference is not found. +getResponseObject :: OAT.Referencable OAT.ResponseObject -> OAM.Generator (Maybe OAT.ResponseObject) +getResponseObject (OAT.Concrete p) = pure $ Just p +getResponseObject (OAT.Reference ref) = do + p <- OAM.getResponseReferenceM ref + when (Maybe.isNothing p) $ OAM.logWarning $ "Reference " <> ref <> " to response could not be found and therefore will be skipped." + pure p + +-- | Generates query params in the form of [(Text,ByteString)] +generateQueryParams :: [(Name, OAT.ParameterObject)] -> Q Exp +generateQueryParams ((name, param) : xs) = + infixE (Just [|(queryName, $(expr))|]) (varE $ mkName ":") (Just $ generateQueryParams xs) + where + queryName = getNameFromParameter param + required = getRequiredFromParameter param + expr = + if required + then [|$(varE $ mkName "GHC.Base.Just") $ OC.stringifyModel $(varE name)|] + else [|OC.stringifyModel <$> $(varE name)|] +generateQueryParams _ = [|[]|] + +-- | Resolves placeholders in paths with dynamic expressions +-- +-- "my/{var}/path" -> "my" ++ myVar ++ "/path" +-- +-- If the placeholder is at the end or at the beginning an empty string gets appended +generateParameterizedRequestPath :: [(Name, OAT.ParameterObject)] -> Text -> Q Exp +generateParameterizedRequestPath ((paramName, param) : xs) path = + foldr1 (foldingFn paramName) partExpressiones + where + parts = Split.splitOn ("{" <> T.unpack (getNameFromParameter param) <> "}") (T.unpack path) + partExpressiones = generateParameterizedRequestPath xs . T.pack <$> parts + foldingFn :: Name -> Q Exp -> Q Exp -> Q Exp + foldingFn var a b = [|$(a) ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE var)) ++ $(b)|] +generateParameterizedRequestPath _ path = litE (stringL $ T.unpack path) + +-- | Extracts a description from an 'OAT.OperationObject'. +-- If available, the description is used, the summary otherwise. +-- If neither is available, an empty description is used. +getOperationDescription :: OAT.OperationObject -> Text +getOperationDescription operation = + Maybe.fromMaybe "" $ Maybe.listToMaybe $ + Maybe.catMaybes + [ OAT.description (operation :: OAT.OperationObject), + OAT.summary (operation :: OAT.OperationObject) + ] + +-- | Constructs the name of an operation. +-- If an 'OAT.operationId' is available, this is the primary choice. +-- If it is not available, the id is constructed based on the request path and method. +getOperationName :: Text -> Text -> OAT.OperationObject -> OAM.Generator Name +getOperationName requestPath method operation = + let operationId = OAT.operationId operation + textName = Maybe.fromMaybe (T.map Char.toLower method <> requestPath) operationId + in haskellifyNameM False textName diff --git a/src/OpenAPI/Generate/Internal/Util.hs b/src/OpenAPI/Generate/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Internal/Util.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Utility functions for the OpenAPI code generator +module OpenAPI.Generate.Internal.Util + ( haskellifyText, + haskellifyName, + haskellifyNameM, + transformToModuleName, + uppercaseFirstText, + mapMaybeM, + liftedAppend, + splitOn, + joinWithPoint, + joinWith, + ) +where + +import qualified Control.Applicative as Applicative +import qualified Data.Char as Char +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH +import qualified OpenAPI.Generate.Flags as OAF +import qualified OpenAPI.Generate.Monad as OAM + +-- | Transform an identifier to ensure it is a valid Haskell identifier +-- Additionally, this function applies style settings according to the need of the consumer. +haskellifyText :: + -- | Should the identifier be transformed to CamelCase? + Bool -> + -- | Should the first character of the identifier be uppercase? + Bool -> + -- | The identifier to transform + Text -> + -- | The resulting identifier + String +haskellifyText convertToCamelCase startWithUppercase name = + let casefn = if startWithUppercase then Char.toUpper else Char.toLower + replaceChar '.' = '\'' + replaceChar '\'' = '\'' + replaceChar a = if Char.isAlphaNum a then a else '_' + caseFirstCharCorrectly (x : xs) = casefn x : xs + caseFirstCharCorrectly x = x + nameWithoutSpecialChars a = replaceChar <$> a + toCamelCase (x : y : xs) | not (Char.isAlphaNum x) && x /= '\'' && Char.isAlpha y = Char.toUpper y : toCamelCase xs + toCamelCase (x : xs) = x : toCamelCase xs + toCamelCase xs = xs + replaceReservedWord "case" = "case'" + replaceReservedWord "class" = "class'" + replaceReservedWord "data" = "data'" + replaceReservedWord "deriving" = "deriving'" + replaceReservedWord "do" = "do'" + replaceReservedWord "else" = "else'" + replaceReservedWord "if" = "if'" + replaceReservedWord "import" = "import'" + replaceReservedWord "in" = "in'" + replaceReservedWord "infix" = "infix'" + replaceReservedWord "infixl" = "infixl'" + replaceReservedWord "infixr" = "infixr'" + replaceReservedWord "instance" = "instance'" + replaceReservedWord "let" = "let'" + replaceReservedWord "of" = "of'" + replaceReservedWord "module" = "module'" + replaceReservedWord "newtype" = "newtype'" + replaceReservedWord "then" = "then'" + replaceReservedWord "type" = "type'" + replaceReservedWord "where" = "where'" + replaceReservedWord "Configuration" = "Configuration'" + replaceReservedWord "MonadHTTP" = "MonadHTTP'" + replaceReservedWord "StringifyModel" = "StringifyModel'" + replaceReservedWord "SecurityScheme" = "SecurityScheme'" + replaceReservedWord "AnonymousSecurityScheme" = "AnonymousSecurityScheme'" + replaceReservedWord "JsonByteString" = "JsonByteString'" + replaceReservedWord "JsonDateTime" = "JsonDateTime'" + replaceReservedWord "RequestBodyEncoding" = "RequestBodyEncoding'" + replaceReservedWord ('_' : rest) = replaceReservedWord rest + replaceReservedWord a = a + replacePlus ('+' : rest) = "Plus" <> replacePlus rest + replacePlus (x : xs) = x : replacePlus xs + replacePlus a = a + in replaceReservedWord + $ caseFirstCharCorrectly + $ (if convertToCamelCase then toCamelCase else id) + $ nameWithoutSpecialChars + $ replacePlus + $ T.unpack name + +-- | The same as 'haskellifyText' but transform the result to a 'Name' +haskellifyName :: Bool -> Bool -> Text -> Name +haskellifyName convertToCamelCase startWithUppercase name = mkName $ haskellifyText convertToCamelCase startWithUppercase name + +-- | 'OAM.Generator' version of 'haskellifyName' +haskellifyNameM :: Bool -> Text -> OAM.Generator Name +haskellifyNameM startWithUppercase name = do + flags <- OAM.getFlags + pure $ haskellifyName (OAF.optConvertToCamelCase flags) startWithUppercase name + +-- | Transform a module name to ensure it is valid for file names +transformToModuleName :: Text -> Text +transformToModuleName = + let toCamelCase (x : y : xs) | not (Char.isAlphaNum x) && Char.isAlpha y = Char.toUpper y : toCamelCase xs + toCamelCase (x : xs) = x : toCamelCase xs + toCamelCase xs = xs + in T.pack + . toCamelCase + . uppercaseFirst + . T.unpack + . T.dropWhile (== '_') + . T.map (\c -> if Char.isAlphaNum c then c else '_') + +uppercaseFirst :: String -> String +uppercaseFirst (x : xs) = Char.toUpper x : xs +uppercaseFirst x = x + +-- | Uppercase the first character of a 'Text' +uppercaseFirstText :: Text -> Text +uppercaseFirstText = T.pack . uppercaseFirst . T.unpack + +-- | Concat a list of strings with a point +-- +-- >>> joinWithPoint ["a", "b", "c"] +-- "a.b.c" +joinWithPoint :: [String] -> String +joinWithPoint = joinWith "." + +-- | Concat a list of values separated by an other value +joinWith :: Monoid a => a -> [a] -> a +joinWith _ [] = mempty +joinWith separator xs = + foldr1 + ( \part1 part2 -> part1 <> separator <> part2 + ) + xs + +-- | Split a list on on a given element +splitOn :: Eq a => a -> [a] -> [[a]] +splitOn x = + foldr + ( \element (currentAcc : acc) -> + if element == x + then [] : currentAcc : acc + else (element : currentAcc) : acc + ) + [[]] + +-- | A version of 'Data.Maybe.mapMaybe' that works with a monadic predicate. +-- from https://hackage.haskell.org/package/extra-1.7.1/docs/src/Control.Monad.Extra.html#mapMaybeM copied +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM op = foldr f (pure []) + where + f x xs = do x' <- op x; case x' of { Nothing -> xs; Just x'' -> do { xs' <- xs; pure $ x'' : xs' } } + +-- | Lifted version of '<>' which can be used with 'Semigroup's inside 'Applicative's +liftedAppend :: (Applicative f, Semigroup a) => f a -> f a -> f a +liftedAppend = Applicative.liftA2 (<>) diff --git a/src/OpenAPI/Generate/Model.hs b/src/OpenAPI/Generate/Model.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Model.hs @@ -0,0 +1,671 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | Defines functionality for the generation of models from OpenAPI schemas +module OpenAPI.Generate.Model + ( getSchemaType, + resolveSchemaReferenceWithoutWarning, + getConstraintDescriptionsOfSchema, + defineModelForSchemaNamed, + defineModelForSchema, + TypeWithDeclaration, + ) +where + +import Control.Monad +import qualified Data.Aeson as Aeson +import qualified Data.Int as Int +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Scientific as Scientific +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text (Text) +import Data.Time.Calendar +import GHC.Generics +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import Language.Haskell.TH.Syntax +import qualified OpenAPI.Common as OC +import OpenAPI.Generate.Doc (appendDoc, emptyDoc) +import qualified OpenAPI.Generate.Doc as Doc +import qualified OpenAPI.Generate.Flags as OAF +import OpenAPI.Generate.Internal.Util +import qualified OpenAPI.Generate.ModelDependencies as Dep +import qualified OpenAPI.Generate.Monad as OAM +import qualified OpenAPI.Generate.Types as OAT +import qualified OpenAPI.Generate.Types.Schema as OAS +import Prelude hiding (maximum, minimum, not) + +-- | The type of a model and the declarations needed for defining it +type TypeWithDeclaration = (Q Type, Dep.ModelContentWithDependencies) + +type BangTypesSelfDefined = (Q [VarBangType], Q Doc, Dep.Models) + +data TypeAliasStrategy = CreateTypeAlias | DontCreateTypeAlias + deriving (Show, Eq, Ord) + +addDependencies :: Dep.Models -> OAM.Generator TypeWithDeclaration -> OAM.Generator TypeWithDeclaration +addDependencies dependenciesToAdd typeDef = do + (type', (content, dependencies)) <- typeDef + pure (type', (content, Set.union dependencies dependenciesToAdd)) + +-- | default derive clause for the objects +objectDeriveClause :: [Q DerivClause] +objectDeriveClause = + [ derivClause + Nothing + [ conT ''Show, + conT ''Eq + -- makes the programm compilation unusable slow + -- conT ''Generic + ] + ] + +-- | Defines all the models for a schema +defineModelForSchema :: Text -> OAS.Schema -> OAM.Generator Dep.ModelWithDependencies +defineModelForSchema schemaName schema = do + namedSchema <- defineModelForSchemaNamedWithTypeAliasStrategy CreateTypeAlias schemaName schema + pure (transformToModuleName schemaName, snd namedSchema) + +-- | Defines all the models for a schema and returns the declarations with the type of the root model +defineModelForSchemaNamed :: Text -> OAS.Schema -> OAM.Generator TypeWithDeclaration +defineModelForSchemaNamed = defineModelForSchemaNamedWithTypeAliasStrategy DontCreateTypeAlias + +-- | defines the definitions for a schema and returns a type to the "entrypoint" of the schema +defineModelForSchemaNamedWithTypeAliasStrategy :: TypeAliasStrategy -> Text -> OAS.Schema -> OAM.Generator TypeWithDeclaration +defineModelForSchemaNamedWithTypeAliasStrategy strategy schemaName schema = OAM.nested schemaName $ + case schema of + OAT.Concrete concrete -> defineModelForSchemaConcrete strategy schemaName concrete + OAT.Reference reference -> do + let originalName = T.replace "#/components/schemas/" "" reference + refName <- haskellifyNameM True originalName + OAM.logInfo $ "Reference " <> reference <> " to " <> T.pack (nameBase refName) + pure (varT refName, (emptyDoc, Set.singleton $ transformToModuleName originalName)) + +-- | Transforms a 'OAS.Schema' (either a reference or a concrete object) to @'Maybe' 'OAS.SchemaObject'@ +-- If a reference is found it is resolved. If it is not found, no log message is generated. +resolveSchemaReferenceWithoutWarning :: OAS.Schema -> OAM.Generator (Maybe OAS.SchemaObject) +resolveSchemaReferenceWithoutWarning schema = + case schema of + OAT.Concrete concrete -> pure $ Just concrete + OAT.Reference ref -> OAM.getSchemaReferenceM ref + +resolveSchemaReference :: Text -> OAS.Schema -> OAM.Generator (Maybe (OAS.SchemaObject, Dep.Models)) +resolveSchemaReference schemaName schema = + OAM.nested schemaName $ + case schema of + OAT.Concrete concrete -> pure $ Just (concrete, Set.empty) + OAT.Reference ref -> do + p <- OAM.getSchemaReferenceM ref + when (Maybe.isNothing p) $ OAM.logWarning $ + "Reference " <> ref <> " to SchemaObject from " + <> schemaName + <> " could not be found and therefore will be skipped." + pure $ (,Set.singleton $ transformToModuleName ref) <$> p + +-- | creates an alias depending on the strategy +createAlias :: Text -> Text -> TypeAliasStrategy -> OAM.Generator TypeWithDeclaration -> OAM.Generator TypeWithDeclaration +createAlias schemaName description strategy res = do + schemaName' <- haskellifyNameM True schemaName + (type', (content, dependencies)) <- res + pure $ case strategy of + CreateTypeAlias -> + ( type', + ( content + `appendDoc` ( ( Doc.generateHaddockComment + [ "Defines an alias for the schema " <> Doc.escapeText schemaName, + "", + description + ] + $$ + ) + . ppr <$> tySynD schemaName' [] type' + ), + dependencies + ) + ) + DontCreateTypeAlias -> (type', (content, dependencies)) + +-- | returns the type of a schema. Second return value is a 'Q' Monad, for the types that have to be created +defineModelForSchemaConcrete :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration +defineModelForSchemaConcrete strategy schemaName schema = + let enumValues = OAS.enum schema + in if null enumValues + then defineModelForSchemaConcreteIgnoreEnum strategy schemaName schema + else defineEnumModel strategy schemaName schema enumValues + +-- | Creates a Model, ignores enum values +defineModelForSchemaConcreteIgnoreEnum :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration +defineModelForSchemaConcreteIgnoreEnum strategy schemaName schema = do + flags <- OAM.getFlags + let schemaDescription = getDescriptionOfSchema schema + typeAliasing = createAlias schemaName schemaDescription strategy + case schema of + OAS.SchemaObject {type' = OAS.SchemaTypeArray, ..} -> defineArrayModelForSchema strategy schemaName schema + OAS.SchemaObject {type' = OAS.SchemaTypeObject, ..} -> + let allOfNull = Set.null $ OAS.allOf schema + oneOfNull = Set.null $ OAS.oneOf schema + anyOfNull = Set.null $ OAS.anyOf schema + in case (allOfNull, oneOfNull, anyOfNull) of + (False, _, _) -> defineAllOfSchema schemaName schemaDescription $ Set.toList $ OAS.allOf schema + (_, False, _) -> typeAliasing $ defineOneOfSchema schemaName schemaDescription $ Set.toList $ OAS.oneOf schema + (_, _, False) -> defineAnyOfSchema strategy schemaName schemaDescription $ Set.toList $ OAS.anyOf schema + _ -> defineObjectModelForSchema schemaName schema + _ -> + typeAliasing $ pure (varT $ getSchemaType flags schema, (emptyDoc, Set.empty)) + +defineEnumModel :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> Set.Set Aeson.Value -> OAM.Generator TypeWithDeclaration +defineEnumModel strategy schemaName schema enumValuesSet = do + OAM.logInfo (T.pack "Generate Enum " <> schemaName) + let enumValues = Set.toList enumValuesSet + let getConstructor (a, _, _) = a + let getValueInfo value = do + cname <- haskellifyNameM True (schemaName <> T.pack "Enum" <> T.replace "\"" "" (T.pack (show value))) + pure (normalC cname [], cname, value) + name <- haskellifyNameM True schemaName + (typ, (content, dependencies)) <- defineModelForSchemaConcreteIgnoreEnum strategy (schemaName <> T.pack "EnumValue") schema + constructorsInfo <- mapM getValueInfo enumValues + otherName <- haskellifyNameM True (schemaName <> T.pack "EnumOther") + typedName <- haskellifyNameM True (schemaName <> T.pack "EnumTyped") + let nameValuePairs = fmap (\(_, a, b) -> (a, b)) constructorsInfo + let toBangType t = do + ban <- bang noSourceUnpackedness noSourceStrictness + banT <- t + pure (ban, banT) + let otherC = normalC otherName [toBangType (varT ''Aeson.Value)] + let typedC = normalC typedName [toBangType typ] + let jsonImplementation = defineJsonImplementationForEnum name otherName [otherName, typedName] nameValuePairs + let newType = + ( Doc.generateHaddockComment + [ "Defines the enum schema " <> Doc.escapeText schemaName, + "", + getDescriptionOfSchema schema + ] + $$ + ) + . ppr + <$> dataD + (pure []) + name + [] + Nothing + (otherC : typedC : (getConstructor <$> constructorsInfo)) + objectDeriveClause + pure (varT name, (content `appendDoc` newType `appendDoc` jsonImplementation, dependencies)) + +defineJsonImplementationForEnum :: Name -> Name -> [Name] -> [(Name, Aeson.Value)] -> Q Doc +defineJsonImplementationForEnum name fallbackName specialCons nameValues = + -- without this function, a N long string takes up N lines, as every + -- new character starts on a new line + let nicifyValue (Aeson.String a) = [|Aeson.String $ T.pack $(litE $ stringL $ T.unpack a)|] + nicifyValue a = [|a|] + fnArgName = mkName "val" + getName = fst + getValue = snd + fromJsonCns (x : xs) = + let vl = getValue x + name' = getName x + in [|if $(varE fnArgName) == $(nicifyValue vl) then $(varE name') else $(fromJsonCns xs)|] + fromJsonCns [] = appE (varE fallbackName) (varE fnArgName) + fromJsonFn = + funD + (mkName "parseJSON") + [clause [varP fnArgName] (normalB [|pure $(fromJsonCns nameValues)|]) []] + fromJson = instanceD (pure []) (appT (varT $ mkName "Data.Aeson.FromJSON") $ varT name) [fromJsonFn] + toJsonClause (name', value) = + let jsonValue = Aeson.toJSON value + in clause [conP name' []] (normalB $ nicifyValue jsonValue) [] + toSpecialCons name' = + clause + [conP name' [varP $ mkName "patternName"]] + (normalB [|Aeson.toJSON $(varE (mkName "patternName"))|]) + [] + toJsonFn = + funD + (mkName "toJSON") + ((toSpecialCons <$> specialCons) <> (toJsonClause <$> nameValues)) + toJson = instanceD (pure []) (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT name) [toJsonFn] + in fmap ppr toJson `appendDoc` fmap ppr fromJson + +-- | defines anyOf types +-- +-- If the subschemas consist only of objects an allOf type without any required field can be generated +-- If there are differen subschema types, per schematype a oneOf is generated +defineAnyOfSchema :: TypeAliasStrategy -> Text -> Text -> [OAS.Schema] -> OAM.Generator TypeWithDeclaration +defineAnyOfSchema strategy schemaName description schemas = do + OAM.logInfo $ T.pack "defineAnyOfSchema " <> schemaName + schemasWithDependencies <- mapMaybeM (resolveSchemaReference schemaName) schemas + let concreteSchemas = fmap fst schemasWithDependencies + schemasWithoutRequired = fmap (\o -> o {OAS.required = Set.empty}) concreteSchemas + notObjectSchemas = filter (\o -> OAS.type' o /= OAS.SchemaTypeObject) concreteSchemas + newDependencies = Set.unions $ fmap snd schemasWithDependencies + if null notObjectSchemas + then addDependencies newDependencies $ defineAllOfSchema schemaName description (fmap OAT.Concrete schemasWithoutRequired) + else createAlias schemaName description strategy $ defineOneOfSchema schemaName description schemas + +-- this would be the correct implementation +-- but it generates endless loop because some implementations use anyOf as a oneOf +-- where the schema reference itself +-- let objectSchemas = filter (\o -> OAS.type' o == OAS.SchemaTypeObject) concreteSchemas +-- (propertiesCombined, _) <- fuseSchemasAllOf schemaName (fmap OAT.Concrete objectSchemas) +-- if null propertiesCombined then +-- createAlias schemaName strategy $ defineOneOfSchema schemaName schemas +-- else +-- let schemaPrototype = head objectSchemas +-- newSchema = schemaPrototype {OAS.properties = propertiesCombined, OAS.required = Set.empty} +-- in +-- createAlias schemaName strategy $ defineOneOfSchema schemaName (fmap OAT.Concrete (newSchema : notObjectSchemas)) + +-- | defines a OneOf Schema +-- +-- creates types for all the subschemas and then creates an adt with constructors for the different +-- subschemas. Constructors are numbered +defineOneOfSchema :: Text -> Text -> [OAS.Schema] -> OAM.Generator TypeWithDeclaration +defineOneOfSchema schemaName description schemas = do + if null schemas + then OAM.logWarning "schemas are empty, can not create OneOfSchemas" + else OAM.logInfo $ "define oneOf Model " <> schemaName + flags <- OAM.getFlags + let indexedSchemas = zip schemas ([1 ..] :: [Integer]) + defineIndexed schema index = defineModelForSchemaNamed (schemaName <> "OneOf" <> T.pack (show index)) schema + variants <- mapM (uncurry defineIndexed) indexedSchemas + let variantDefinitions = vcat <$> mapM (fst . snd) variants + dependencies = Set.unions $ fmap (snd . snd) variants + types = fmap fst variants + indexedTypes = zip types ([1 ..] :: [Integer]) + createTypeConstruct (typ, n) = do + t <- typ + bang' <- bang noSourceUnpackedness noSourceStrictness + let suffix = if OAF.optUseNumberedVariantConstructors flags then "Variant" <> T.pack (show n) else typeToSuffix t + haskellifiedName = haskellifyName (OAF.optConvertToCamelCase flags) True $ schemaName <> suffix + normalC haskellifiedName [pure (bang', t)] + emptyCtx = pure [] + name = haskellifyName (OAF.optConvertToCamelCase flags) True $ schemaName <> "Variants" + fromJsonFn = + funD + (mkName "parseJSON") + [ clause + [] + ( normalB + [| + Aeson.genericParseJSON Aeson.defaultOptions {Aeson.sumEncoding = Aeson.UntaggedValue} + |] + ) + [] + ] + toJsonFn = + funD + (mkName "toJSON") + [ clause + [] + ( normalB + [| + Aeson.genericToJSON Aeson.defaultOptions {Aeson.sumEncoding = Aeson.UntaggedValue} + |] + ) + [] + ] + dataDefinition = + ( Doc.generateHaddockComment + [ "Define the one-of schema " <> Doc.escapeText schemaName, + "", + description + ] + $$ + ) + . ppr + <$> dataD + emptyCtx + name + [] + Nothing + (createTypeConstruct <$> indexedTypes) + [ derivClause + Nothing + [ conT ''Show, + conT ''Eq, + -- makes the programm slow, but oneOf is not used that often + conT ''Generic + ] + ] + toJson = ppr <$> instanceD emptyCtx (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT name) [toJsonFn] + fromJson = ppr <$> instanceD emptyCtx (appT (varT $ mkName "Data.Aeson.FromJSON") $ varT name) [fromJsonFn] + innerRes = (varT name, (variantDefinitions `appendDoc` dataDefinition `appendDoc` toJson `appendDoc` fromJson, dependencies)) + pure innerRes + +typeToSuffix :: Type -> Text +typeToSuffix (ConT name') = T.pack $ nameBase name' +typeToSuffix (VarT name') = + let x = T.pack $ nameBase name' + in if x == "[]" then "List" else x +typeToSuffix (AppT type1 type2) = typeToSuffix type1 <> typeToSuffix type2 +typeToSuffix x = T.pack $ show x + +-- | combines schemas so that it is usefull for a allOf fusion +fuseSchemasAllOf :: Text -> [OAS.Schema] -> OAM.Generator (Map.Map Text OAS.Schema, Set.Set Text) +fuseSchemasAllOf schemaName schemas = do + schemasWithDependencies <- mapMaybeM (resolveSchemaReference schemaName) schemas + let concreteSchemas = fmap fst schemasWithDependencies + subSchemaInformation <- mapM (getPropertiesForAllOf schemaName) concreteSchemas + let propertiesCombined = foldl (Map.unionWith const) Map.empty (fmap fst subSchemaInformation) + let requiredCombined = foldl Set.union Set.empty (fmap snd subSchemaInformation) + pure (propertiesCombined, requiredCombined) + +-- | gets properties for an allOf merge +-- looks if subschemas define further subschemas +getPropertiesForAllOf :: Text -> OAS.SchemaObject -> OAM.Generator (Map.Map Text OAS.Schema, Set.Set Text) +getPropertiesForAllOf schemaName schema = + let allOf = OAS.allOf schema + anyOf = OAS.anyOf schema + relevantSubschemas = Set.union allOf anyOf + in if null relevantSubschemas + then pure (OAS.properties schema, OAS.required schema) + else do + (allOfProps, allOfRequired) <- fuseSchemasAllOf schemaName $ Set.toList allOf + (anyOfProps, _) <- fuseSchemasAllOf schemaName $ Set.toList anyOf + pure (Map.unionWith const allOfProps anyOfProps, allOfRequired) + +-- | defines a allOf subschema +-- Fuses the subschemas together +defineAllOfSchema :: Text -> Text -> [OAS.Schema] -> OAM.Generator TypeWithDeclaration +defineAllOfSchema schemaName description schemas = do + newDefs <- defineNewSchemaForAllOf schemaName description schemas + case newDefs of + Just (newSchema, newDependencies) -> + addDependencies newDependencies $ defineModelForSchemaConcrete DontCreateTypeAlias schemaName newSchema + Nothing -> pure (varT ''String, (emptyDoc, Set.empty)) + +-- | defines a new Schema, which properties are fused +defineNewSchemaForAllOf :: Text -> Text -> [OAS.Schema] -> OAM.Generator (Maybe (OAS.SchemaObject, Dep.Models)) +defineNewSchemaForAllOf schemaName description schemas = do + OAM.logInfo $ "define allOf Model " <> schemaName + schemasWithDependencies <- mapMaybeM (resolveSchemaReference schemaName) schemas + let concreteSchemas = fmap fst schemasWithDependencies + newDependencies = Set.unions $ fmap snd schemasWithDependencies + (propertiesCombined, requiredCombined) <- fuseSchemasAllOf schemaName schemas + if Map.null propertiesCombined + then do + OAM.logWarning "allOf schemas is empty" + pure Nothing + else + let schemaPrototype = head concreteSchemas + newSchema = schemaPrototype {OAS.properties = propertiesCombined, OAS.required = requiredCombined, OAS.description = Just description} + in pure $ Just (newSchema, newDependencies) + +-- | defines an array +defineArrayModelForSchema :: TypeAliasStrategy -> Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration +defineArrayModelForSchema strategy schemaName schema = do + (type', (content, dependencies)) <- + case OAS.items schema of + Just itemSchema -> defineModelForSchemaNamed schemaName itemSchema + -- not allowed by the spec + Nothing -> do + OAM.logWarning $ T.pack "items is empty for an array (assume string) " <> schemaName + pure (varT ''String, (emptyDoc, Set.empty)) + let arrayType = appT (varT $ mkName "[]") type' + schemaName' <- haskellifyNameM True schemaName + pure + ( arrayType, + ( content `appendDoc` case strategy of + CreateTypeAlias -> + ( Doc.generateHaddockComment + [ "Defines an alias for the schema " <> Doc.escapeText schemaName, + "", + getDescriptionOfSchema schema + ] + $$ + ) + . ppr + <$> tySynD schemaName' [] arrayType + DontCreateTypeAlias -> emptyDoc, + dependencies + ) + ) + +-- | Defines a Record +defineObjectModelForSchema :: Text -> OAS.SchemaObject -> OAM.Generator TypeWithDeclaration +defineObjectModelForSchema schemaName schema = do + flags <- OAM.getFlags + let convertToCamelCase = OAF.optConvertToCamelCase flags + name = haskellifyName convertToCamelCase True schemaName + props = Map.toList $ OAS.properties schema + propsWithNames = zip (fmap fst props) $ fmap (haskellifyName convertToCamelCase False . (schemaName <>) . uppercaseFirstText . fst) props + emptyCtx = pure [] + required = OAS.required schema + OAM.logInfo $ "define object model " <> T.pack (nameBase name) + (bangTypes, propertyContent, propertyDependencies) <- propertiesToBangTypes schemaName props required + propertyDescriptions <- getDescriptionOfProperties props + let dataDefinition :: Q Doc + dataDefinition = do + bangs <- bangTypes + let record = recC name (pure <$> bangs) + flip Doc.zipCodeAndComments propertyDescriptions + . T.lines + . T.pack + . show + . Doc.breakOnTokensWithReplacement + ( \case + "{" -> "{\n " + token -> "\n " <> token + ) + [",", "{", "}"] + . ppr <$> dataD emptyCtx name [] Nothing [record] objectDeriveClause + toJsonInstance = createToJSONImplementation name propsWithNames + fromJsonInstance = createFromJSONImplementation name propsWithNames required + pure + ( varT name, + ( pure + ( Doc.generateHaddockComment + [ "Defines the data type for the schema " <> Doc.escapeText schemaName, + "", + getDescriptionOfSchema schema + ] + ) + `appendDoc` dataDefinition + `appendDoc` toJsonInstance + `appendDoc` fromJsonInstance + `appendDoc` propertyContent, + propertyDependencies + ) + ) + +-- | create toJSON implementation for an object +createToJSONImplementation :: Name -> [(Text, Name)] -> Q Doc +createToJSONImplementation objectName recordNames = + let emptyDefs = pure [] + fnArgName = mkName "obj" + toAssertion (jsonName, hsName) = + [| + $(varE $ mkName "Data.Aeson..=") + $(litE $ stringL $ T.unpack jsonName) + ($(varE hsName) $(varE fnArgName)) + |] + toExprList :: [Q Exp] -> Q Exp + toExprList [] = [|[]|] + toExprList (x : xs) = uInfixE x (varE $ mkName ":") (toExprList xs) + toExprCombination :: [Q Exp] -> Q Exp + toExprCombination [] = [|[]|] + toExprCombination [x] = x + toExprCombination (x : xs) = [|$(x) <> $(toExprCombination xs)|] + defaultJsonImplementation :: [DecQ] + defaultJsonImplementation = + if null recordNames + then + [ funD + (mkName "toJSON") + [ clause + [varP fnArgName] + ( normalB + [| + $(varE $ mkName "Data.Aeson.object") [] + |] + ) + [] + ], + funD + (mkName "toEncoding") + [ clause + [varP fnArgName] + ( normalB + [| + $(varE $ mkName "Data.Aeson.pairs") + ($(varE $ mkName "Data.Aeson..=") "string" ("string" :: String)) + |] + ) + [] + ] + ] + else + [ funD + (mkName "toJSON") + [ clause + [varP fnArgName] + ( normalB + [| + $(varE $ mkName "Data.Aeson.object") + $(toExprList $ toAssertion <$> recordNames) + |] + ) + [] + ], + funD + (mkName "toEncoding") + [ clause + [varP fnArgName] + ( normalB + [| + $(varE $ mkName "Data.Aeson.pairs") + $(toExprCombination $ toAssertion <$> recordNames) + |] + ) + [] + ] + ] + in ppr <$> instanceD emptyDefs (appT (varT $ mkName "Data.Aeson.ToJSON") $ varT objectName) defaultJsonImplementation + +-- | create FromJSON implementation for an object +createFromJSONImplementation :: Name -> [(Text, Name)] -> Set.Set Text -> Q Doc +createFromJSONImplementation objectName recordNames required = + let fnArgName = mkName "obj" + withObjectLamda = + foldl + ( \prev (propName, _) -> + let propName' = litE $ stringL $ T.unpack propName + arg = varE fnArgName + readPropE = + if propName `elem` required + then [|$arg Aeson..: $propName'|] + else [|$arg Aeson..:? $propName'|] + in [|$prev <*> $readPropE|] + ) + [|pure $(varE objectName)|] + recordNames + in ppr + <$> instanceD + (cxt []) + [t|Aeson.FromJSON $(varT objectName)|] + [ funD + (mkName "parseJSON") + [ clause + [] + ( normalB + [|Aeson.withObject $(litE $ stringL $ show objectName) $(lam1E (varP fnArgName) withObjectLamda)|] + ) + [] + ] + ] + +-- | create "bangs" record fields for properties +propertiesToBangTypes :: Text -> [(Text, OAS.Schema)] -> Set.Set Text -> OAM.Generator BangTypesSelfDefined +propertiesToBangTypes _ [] _ = pure (pure [], emptyDoc, Set.empty) +propertiesToBangTypes schemaName props required = do + flags <- OAM.getFlags + let propertySuffix = T.pack $ OAF.optPropertyTypeSuffix flags + let createBang :: Text -> Text -> Q Type -> OAM.Generator (Q VarBangType) + createBang recordName propName myType = + let qVar :: Q VarBangType + qVar = do + bang' <- bang noSourceUnpackedness noSourceStrictness + type' <- + if recordName `elem` required + then myType + else appT (varT ''Maybe) myType + pure (haskellifyName (OAF.optConvertToCamelCase flags) False propName, bang', type') + in pure qVar + propToBangType :: (Text, OAS.Schema) -> OAM.Generator (Q VarBangType, Q Doc, Dep.Models) + propToBangType (recordName, schema) = do + let propName = schemaName <> uppercaseFirstText recordName + (myType, (content, depenencies)) <- defineModelForSchemaNamed (propName <> propertySuffix) schema + myBang <- createBang recordName propName myType + pure (myBang, content, depenencies) + foldFn :: OAM.Generator BangTypesSelfDefined -> (Text, OAS.Schema) -> OAM.Generator BangTypesSelfDefined + foldFn accHolder next = do + (varBang, content, dependencies) <- accHolder + (nextVarBang, nextContent, nextDependencies) <- propToBangType next + pure + ( varBang `liftedAppend` fmap pure nextVarBang, + content `appendDoc` nextContent, + Set.union dependencies nextDependencies + ) + foldl foldFn (pure (pure [], emptyDoc, Set.empty)) props + +getDescriptionOfSchema :: OAS.SchemaObject -> Text +getDescriptionOfSchema schema = Doc.escapeText $ Maybe.fromMaybe "" $ OAS.description schema + +getDescriptionOfProperties :: [(Text, OAS.Schema)] -> OAM.Generator [Text] +getDescriptionOfProperties = + mapM + ( \(name, schema) -> do + schema' <- resolveSchemaReferenceWithoutWarning schema + let description = maybe "" (": " <>) $ schema' >>= OAS.description + constraints = T.unlines $ ("* " <>) <$> getConstraintDescriptionsOfSchema schema' + pure $ Doc.escapeText $ name <> description <> (if T.null constraints then "" else "\n\nConstraints:\n\n" <> constraints) + ) + +-- | Extracts the constraints of a 'OAS.SchemaObject' as human readable text +getConstraintDescriptionsOfSchema :: Maybe OAS.SchemaObject -> [Text] +getConstraintDescriptionsOfSchema schema = + let showConstraint desc = showConstraintSurrounding desc "" + showConstraintSurrounding prev after = fmap $ (prev <>) . (<> after) . T.pack . show + exclusiveMaximum = maybe False OAS.exclusiveMaximum schema + exclusiveMinimum = maybe False OAS.exclusiveMinimum schema + in Maybe.catMaybes + [ showConstraint "Must be a multiple of " $ schema >>= OAS.multipleOf, + showConstraint ("Maxium " <> if exclusiveMaximum then " (exclusive)" else "" <> " of ") $ schema >>= OAS.maximum, + showConstraint ("Minimum " <> if exclusiveMinimum then " (exclusive)" else "" <> " of ") $ schema >>= OAS.minimum, + showConstraint "Maximum length of " $ schema >>= OAS.maxLength, + showConstraint "Minimum length of " $ schema >>= OAS.minLength, + ("Must match pattern '" <>) . (<> "'") <$> (schema >>= OAS.pattern'), + showConstraintSurrounding "Must have a maximum of " " items" $ schema >>= OAS.maxItems, + showConstraintSurrounding "Must have a minimum of " " items" $ schema >>= OAS.minItems, + schema + >>= ( \case + True -> Just "Must have unique items" + False -> Nothing + ) + . OAS.uniqueItems, + showConstraintSurrounding "Must have a maximum of " " properties" $ schema >>= OAS.maxProperties, + showConstraintSurrounding "Must have a minimum of " " properties" $ schema >>= OAS.minProperties + ] + +-- | Extracts the 'Name' of a 'OAS.SchemaObject' which should be used for primitive types +getSchemaType :: OAF.Flags -> OAS.SchemaObject -> Name +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int32", ..} = ''Int.Int32 +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, format = Just "int64", ..} = ''Int.Int64 +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeInteger, ..} = ''Integer +getSchemaType OAF.Flags {optUseFloatWithArbitraryPrecision = True, ..} OAS.SchemaObject {type' = OAS.SchemaTypeNumber, ..} = ''Scientific.Scientific +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "float", ..} = ''Float +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, format = Just "double", ..} = ''Double +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeNumber, ..} = ''Double +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "byte", ..} = ''OC.JsonByteString +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "binary", ..} = ''OC.JsonByteString +getSchemaType OAF.Flags {optUseDateTypesAsString = True, ..} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date", ..} = ''Day +getSchemaType OAF.Flags {optUseDateTypesAsString = True, ..} OAS.SchemaObject {type' = OAS.SchemaTypeString, format = Just "date-time", ..} = ''OC.JsonDateTime +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeString, ..} = ''String +getSchemaType _ OAS.SchemaObject {type' = OAS.SchemaTypeBool, ..} = ''Bool +getSchemaType _ OAS.SchemaObject {..} = ''String diff --git a/src/OpenAPI/Generate/ModelDependencies.hs b/src/OpenAPI/Generate/ModelDependencies.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/ModelDependencies.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Functionality to split models into multiple modules according to their dependencies +module OpenAPI.Generate.ModelDependencies + ( getModelModulesFromModelsWithDependencies, + ModuleDefinition, + Models, + ModelContentWithDependencies, + ModelWithDependencies, + ) +where + +import Data.List +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text (Text) +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import qualified OpenAPI.Generate.Doc as Doc +import OpenAPI.Generate.Internal.Util + +-- | A module definition with a name as a string list with the different module levels (e. g. [\"OpenAPI\", \"Generate\"] for "OpenAPI.Generate") +-- and the 'Doc' representing the module content +type ModuleDefinition = ([String], Doc) + +-- | A set of model names (typically used as dependency list) +type Models = Set.Set Text + +-- | A tuple containing the content and the dependencies of a model +type ModelContentWithDependencies = (Q Doc, Models) + +-- | Represents a model with a name, content and dependencies +type ModelWithDependencies = (Text, ModelContentWithDependencies) + +typesModule :: String +typesModule = "Types" + +cyclicTypesModule :: String +cyclicTypesModule = "CyclicTypes" + +-- | Analyzes the dependencies of the provided models and splits them into modules. +-- All models with cyclic dependencies (between each other or to itself) are put in a module named by @cyclicTypesModule@. +getModelModulesFromModelsWithDependencies :: String -> [ModelWithDependencies] -> Q [ModuleDefinition] +getModelModulesFromModelsWithDependencies mainModuleName = createModelModules mainModuleName . extractCyclicModuleDependentModels + +createModelModules :: String -> ([ModelWithDependencies], Q Doc) -> Q [ModuleDefinition] +createModelModules mainModuleName (models, cyclicModuleContentQ) = do + let prependTypesModule = ((typesModule <> ".") <>) . T.unpack + let prependMainModule = ((mainModuleName <> ".") <>) + cyclicModuleContent <- cyclicModuleContentQ + modules <- + mapM + ( \(modelName, (doc, dependencies)) -> + ([typesModule, T.unpack modelName],) + . Doc.addModelModuleHeader + mainModuleName + (prependTypesModule modelName) + (prependTypesModule <$> Set.toList dependencies) + ("Contains the types generated from the schema " <> T.unpack modelName) + <$> doc + ) + models + let modelModuleNames = fmap (joinWithPoint . fst) modules + pure $ + ( [typesModule], + Doc.createModuleHeaderWithReexports + (prependMainModule typesModule) + (fmap prependMainModule (cyclicTypesModule : modelModuleNames)) + "Rexports all type modules (used in the operation modules)." + ) + : ( [cyclicTypesModule], + Doc.addModelModuleHeader + mainModuleName + cyclicTypesModule + modelModuleNames + "Contains all types with cyclic dependencies (between each other or to itself)" + cyclicModuleContent + ) + : modules + +extractCyclicModuleDependentModels :: [ModelWithDependencies] -> ([ModelWithDependencies], Q Doc) +extractCyclicModuleDependentModels models = + let (cyclicModels, extractedModels) = extractUnidirectionallyDependentModels (models, []) + in (extractedModels, vcat <$> mapM (fst . snd) cyclicModels) + +extractUnidirectionallyDependentModels :: ([ModelWithDependencies], [ModelWithDependencies]) -> ([ModelWithDependencies], [ModelWithDependencies]) +extractUnidirectionallyDependentModels (rest, extractedModels) = + let extractedModelNames = Set.fromList $ fmap fst extractedModels + (newExtractedModels, notExtractedModels) = partition ((`Set.isSubsetOf` extractedModelNames) . snd . snd) rest + in if null newExtractedModels + then (rest, extractedModels) + else extractUnidirectionallyDependentModels (notExtractedModels, extractedModels <> newExtractedModels) diff --git a/src/OpenAPI/Generate/Monad.hs b/src/OpenAPI/Generate/Monad.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Monad.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module contains the 'Generator' monad and functions which deal with this monad. +-- In addition this module contains the means for logging and resolving references since they are +-- closely linked to the 'Generator' monad. +module OpenAPI.Generate.Monad where + +import qualified Control.Monad.Reader as MR +import qualified Control.Monad.Writer as MW +import Data.List +import Data.Text (Text) +import qualified OpenAPI.Generate.Flags as OAF +import qualified OpenAPI.Generate.Reference as Ref +import qualified OpenAPI.Generate.Types as OAT +import qualified OpenAPI.Generate.Types.Schema as OAS + +-- | The reader environment of the 'Generator' monad +-- +-- The 'currentPath' is updated using the 'nested' function to track the current position within the specification. +-- This is used to produce tracable log messages. +-- The 'references' map is a lookup table for references within the OpenAPI specification. +data GeneratorEnvironment + = GeneratorEnvironment + { currentPath :: [Text], + references :: Ref.ReferenceMap, + flags :: OAF.Flags + } + deriving (Show, Eq) + +-- | Data type representing the log severities +data GeneratorLogSeverity = ErrorSeverity | WarningSeverity | InfoSeverity + deriving (Show, Eq) + +-- | A log entry containing the location within the OpenAPI specification where the message was produced, a severity and the actual message. +data GeneratorLogEntry + = GeneratorLogEntry + { path :: [Text], + severity :: GeneratorLogSeverity, + message :: Text + } + deriving (Show, Eq) + +-- | The type contained in the writer of the 'Generator' used to collect log entries +type GeneratorLogs = [GeneratorLogEntry] + +-- | The 'Generator' monad is used to pass a 'MR.Reader' environment to functions in need of resolving references +-- and collects log messages. +newtype Generator a = Generator {unGenerator :: MW.WriterT GeneratorLogs (MR.Reader GeneratorEnvironment) a} + deriving (Functor, Applicative, Monad, MR.MonadReader GeneratorEnvironment, MW.MonadWriter GeneratorLogs) + +-- | Runs the generator monad within a provided environment. +runGenerator :: GeneratorEnvironment -> Generator a -> (a, GeneratorLogs) +runGenerator e (Generator g) = MR.runReader (MW.runWriterT g) e + +-- | Create an environment based on a 'Ref.ReferenceMap' and 'OAF.Flags' +createEnvironment :: OAF.Flags -> Ref.ReferenceMap -> GeneratorEnvironment +createEnvironment flags references = + GeneratorEnvironment + { currentPath = [], + references = references, + flags = flags + } + +-- | Writes a log message to a 'Generator' monad +logMessage :: GeneratorLogSeverity -> Text -> Generator () +logMessage severity message = do + path' <- MR.asks currentPath + MW.tell [GeneratorLogEntry {path = path', severity = severity, message = message}] + +-- | Writes an error to a 'Generator' monad +logError :: Text -> Generator () +logError = logMessage ErrorSeverity + +-- | Writes a warning to a 'Generator' monad +logWarning :: Text -> Generator () +logWarning = logMessage WarningSeverity + +-- | Writes an info to a 'Generator' monad +logInfo :: Text -> Generator () +logInfo = logMessage InfoSeverity + +-- | Transforms a log returned from 'runGenerator' to a list of 'Text' values for easier printing. +transformGeneratorLogs :: GeneratorLogs -> [Text] +transformGeneratorLogs = + fmap + ( \GeneratorLogEntry {..} -> + transformSeverity severity <> " (" <> transformPath path <> "): " <> message + ) + +-- | Transforms the severity to a 'Text' representation +transformSeverity :: GeneratorLogSeverity -> Text +transformSeverity ErrorSeverity = "ERROR" +transformSeverity WarningSeverity = "WARN" +transformSeverity InfoSeverity = "INFO" + +-- | Transforms the path to a 'Text' representation (parts are seperated with a dot) +transformPath :: [Text] -> Text +transformPath = mconcat . intersperse "." + +-- | This function can be used to tell the 'Generator' monad where in the OpenAPI specification the generator currently is +nested :: Text -> Generator a -> Generator a +nested pathItem = MR.local $ \g -> g {currentPath = currentPath g <> [pathItem]} + +-- | Helper function to create a lookup function for a specific type +createReferenceLookupM :: (Text -> Ref.ReferenceMap -> Maybe a) -> Text -> Generator (Maybe a) +createReferenceLookupM fn key = MR.asks $ fn key . references + +-- | Resolve a 'OAS.SchemaObject' reference from within the 'Generator' monad +getSchemaReferenceM :: Text -> Generator (Maybe OAS.SchemaObject) +getSchemaReferenceM = createReferenceLookupM Ref.getSchemaReference + +-- | Resolve a 'OAT.ResponseObject' reference from within the 'Generator' monad +getResponseReferenceM :: Text -> Generator (Maybe OAT.ResponseObject) +getResponseReferenceM = createReferenceLookupM Ref.getResponseReference + +-- | Resolve a 'OAT.ParameterObject' reference from within the 'Generator' monad +getParameterReferenceM :: Text -> Generator (Maybe OAT.ParameterObject) +getParameterReferenceM = createReferenceLookupM Ref.getParameterReference + +-- | Resolve a 'OAT.ExampleObject' reference from within the 'Generator' monad +getExampleReferenceM :: Text -> Generator (Maybe OAT.ExampleObject) +getExampleReferenceM = createReferenceLookupM Ref.getExampleReference + +-- | Resolve a 'OAT.RequestBodyObject' reference from within the 'Generator' monad +getRequestBodyReferenceM :: Text -> Generator (Maybe OAT.RequestBodyObject) +getRequestBodyReferenceM = createReferenceLookupM Ref.getRequestBodyReference + +-- | Resolve a 'OAT.HeaderObject' reference from within the 'Generator' monad +getHeaderReferenceM :: Text -> Generator (Maybe OAT.HeaderObject) +getHeaderReferenceM = createReferenceLookupM Ref.getHeaderReference + +-- | Resolve a 'OAT.SecuritySchemeObject' reference from within the 'Generator' monad +getSecuritySchemeReferenceM :: Text -> Generator (Maybe OAT.SecuritySchemeObject) +getSecuritySchemeReferenceM = createReferenceLookupM Ref.getSecuritySchemeReference + +-- | Get all flags passed to the program +getFlags :: Generator OAF.Flags +getFlags = MR.asks flags + +-- | Get a specific flag selected by @f@ +getFlag :: (OAF.Flags -> a) -> Generator a +getFlag f = MR.asks $ f . flags diff --git a/src/OpenAPI/Generate/Operation.hs b/src/OpenAPI/Generate/Operation.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Operation.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | Contains the functionality to define operation functions for path items. +module OpenAPI.Generate.Operation + ( defineOperationsForPath, + ) +where + +import qualified Data.Bifunctor as BF +import qualified Data.ByteString.Char8 as B8 +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import qualified OpenAPI.Common as OC +import qualified OpenAPI.Generate.Doc as Doc +import qualified OpenAPI.Generate.Flags as OAF +import OpenAPI.Generate.Internal.Operation +import OpenAPI.Generate.Internal.Util +import qualified OpenAPI.Generate.Model as Model +import qualified OpenAPI.Generate.ModelDependencies as Dep +import qualified OpenAPI.Generate.Monad as OAM +import qualified OpenAPI.Generate.Response as OAR +import qualified OpenAPI.Generate.Types as OAT + +-- | Defines the operations for all paths and their methods +defineOperationsForPath :: String -> Text -> OAT.PathItemObject -> OAM.Generator (Q [Dep.ModuleDefinition]) +defineOperationsForPath mainModuleName requestPath = + OAM.nested requestPath + . fmap sequence + . mapM + (uncurry (defineModuleForOperation mainModuleName requestPath)) + . ( \pathItemObject -> + filterEmptyOperations + [ ("GET", OAT.get pathItemObject), + ("PUT", OAT.put pathItemObject), + ("POST", OAT.post pathItemObject), + ("DELETE", OAT.delete pathItemObject), + ("OPTIONS", OAT.options pathItemObject), + ("HEAD", OAT.head pathItemObject), + ("PATCH", OAT.patch pathItemObject), + ("TRACE", OAT.trace pathItemObject) + ] + ) + +-- | A path may define n methods +-- This function filters out the empy not defined methods +filterEmptyOperations :: [(Text, Maybe OAT.OperationObject)] -> [(Text, OAT.OperationObject)] +filterEmptyOperations xs = [(method, operation) | (method, Just operation) <- xs] + +-- | +-- Defines an Operation for a Method and a Path +-- Uses an OperationObject +-- +-- Returns a commented function definition and implementation in a Q Monad +defineModuleForOperation :: + -- | The main module name passed via CLI options + String -> + -- | The path to the request (This is the key from the map of Operations) + -- It may contain placeholder variables in the form of /my/{var}/path/ + Text -> + -- | HTTP Method (GET,POST,etc) + Text -> + -- | The Operation Object + OAT.OperationObject -> + -- | commented function definition and implementation + OAM.Generator (Q Dep.ModuleDefinition) +defineModuleForOperation mainModuleName requestPath method operation = OAM.nested method $ do + operationIdName <- getOperationName requestPath method operation + flags <- OAM.getFlags + let operationIdNameRaw = mkName $ nameBase operationIdName <> "Raw" + operationIdNameWithMonadTransformer = mkName $ nameBase operationIdName <> "M" + operationIdNameRawWithMonadTransformer = mkName $ nameBase operationIdNameRaw <> "M" + moduleName = haskellifyText (OAF.optConvertToCamelCase flags) True (T.pack $ show operationIdName) + description = Doc.escapeText $ getOperationDescription operation + monadName = mkName "m" + securitySchemeName = mkName "s" + appendToOperationName = ((T.pack $ nameBase operationIdName) <>) + rawTransformation = [|id|] + OAM.logInfo $ "Generating operation with name: " <> T.pack (show operationIdName) + params <- getParametersFromOperationConcrete operation + bodySchema <- getBodySchemaFromOperation operation + (responseTypeName, responseTransformerExp, responseBodyDefinitions) <- OAR.getResponseDefinitions operation appendToOperationName + functionBody <- defineOperationFunction True operationIdName params requestPath method bodySchema responseTransformerExp + functionBodyRaw <- defineOperationFunction True operationIdNameRaw params requestPath method bodySchema rawTransformation + functionBodyWithMonadTransformer <- defineOperationFunction False operationIdNameWithMonadTransformer params requestPath method bodySchema responseTransformerExp + functionBodyRawWithMonadTransformer <- defineOperationFunction False operationIdNameRawWithMonadTransformer params requestPath method bodySchema rawTransformation + (bodyType, bodyDefinition) <- getBodyType bodySchema appendToOperationName + paramDescriptions <- (<> ["The request body to send" | not $ null bodyType]) <$> mapM getParameterDescription params + let types = (getParameterType flags <$> params) <> bodyType + fnType = getParametersTypeForSignature types responseTypeName monadName securitySchemeName + fnTypeRaw = getParametersTypeForSignature types ''B8.ByteString monadName securitySchemeName + fnTypeWithMonadTransformer = getParametersTypeForSignatureWithMonadTransformer types responseTypeName monadName securitySchemeName + fnTypeRawWithMonadTransformer = getParametersTypeForSignatureWithMonadTransformer types ''B8.ByteString monadName securitySchemeName + createFunSignature operationName fnType' = + ppr + <$> sigD + operationName + ( forallT + [plainTV monadName, plainTV securitySchemeName] + (cxt [appT (conT ''OC.MonadHTTP) (varT monadName), appT (conT ''OC.SecurityScheme) (varT securitySchemeName)]) + fnType' + ) + fnSignature = + createFunSignature + operationIdName + fnType + fnSignatureRaw = + createFunSignature + operationIdNameRaw + fnTypeRaw + fnSignatureWithMonadTransformer = + createFunSignature + operationIdNameWithMonadTransformer + fnTypeWithMonadTransformer + fnSignatureRawWithMonadTransformer = + createFunSignature + operationIdNameRawWithMonadTransformer + fnTypeRawWithMonadTransformer + methodAndPath = T.toUpper method <> " " <> requestPath + operationNameAsString = nameBase operationIdName + operationDescription = pure . Doc.generateHaddockComment . ("> " <> methodAndPath :) . ("" :) + pure $ + ([moduleName],) + . Doc.addOperationsModuleHeader mainModuleName moduleName operationNameAsString + . ($$ text "") + <$> ( ($$) + <$> ( vcat + <$> sequence + [ operationDescription [description], + ( `Doc.sideBySide` + Doc.sideComments + ("The configuration to use in the request" : paramDescriptions <> ["Monad containing the result of the operation"]) + ) + . Doc.breakOnTokens ["->"] + <$> fnSignature, + functionBody, + operationDescription ["The same as '" <> T.pack operationNameAsString <> "' but returns the raw 'Data.ByteString.Char8.ByteString'"], + fnSignatureRaw, + functionBodyRaw, + operationDescription ["Monadic version of '" <> T.pack operationNameAsString <> "' (use with 'OpenAPI.Common.runWithConfiguration')"], + fnSignatureWithMonadTransformer, + functionBodyWithMonadTransformer, + operationDescription ["Monadic version of '" <> T.pack (nameBase operationIdNameRaw) <> "' (use with 'OpenAPI.Common.runWithConfiguration')"], + fnSignatureRawWithMonadTransformer, + functionBodyRawWithMonadTransformer, + bodyDefinition + ] + ) + <*> responseBodyDefinitions + ) + +getBodyType :: Maybe RequestBodyDefinition -> (Text -> Text) -> OAM.Generator ([Q Type], Q Doc) +getBodyType Nothing _ = pure ([], Doc.emptyDoc) +getBodyType (Just RequestBodyDefinition {..}) appendToOperationName = do + let transformType = pure . (if required then id else appT $ varT ''Maybe) + requestBodySuffix <- OAM.getFlag $ T.pack . OAF.optRequestBodyTypeSuffix + BF.bimap transformType fst <$> Model.defineModelForSchemaNamed (appendToOperationName requestBodySuffix) schema diff --git a/src/OpenAPI/Generate/Reference.hs b/src/OpenAPI/Generate/Reference.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Reference.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Contains function to resolve references within the OpenAPI specification +module OpenAPI.Generate.Reference + ( ReferenceMap, + ComponentReference (..), + buildReferenceMap, + getSchemaReference, + getResponseReference, + getParameterReference, + getExampleReference, + getRequestBodyReference, + getHeaderReference, + getSecuritySchemeReference, + ) +where + +import Control.Monad +import qualified Data.Bifunctor as BF +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import GHC.Generics +import qualified OpenAPI.Generate.Types as OAT +import qualified OpenAPI.Generate.Types.Schema as OAS + +-- | Represents all types the 'ReferenceMap' can hold +data ComponentReference + = SchemaReference OAS.SchemaObject + | ResponseReference OAT.ResponseObject + | ParameterReference OAT.ParameterObject + | ExampleReference OAT.ExampleObject + | RequestBodyReference OAT.RequestBodyObject + | HeaderReference OAT.HeaderObject + | SecuritySchemeReference OAT.SecuritySchemeObject + deriving (Show, Eq, Generic) + +-- | A lookup table for references within the OpenAPI specification +type ReferenceMap = Map.Map Text ComponentReference + +-- | Creates a 'ReferenceMap' from an 'OAT.OpenApiSpecification' containing all elements within components. +-- It does not capture possibly referenced locations anywhere else in the specification. +buildReferenceMap :: OAT.OpenApiSpecification -> ReferenceMap +buildReferenceMap = + Map.fromList + . ( \o -> + buildReferencesForComponentType "schemas" SchemaReference (OAT.schemas o) + <> buildReferencesForComponentType "responses" ResponseReference (OAT.responses (o :: OAT.ComponentsObject)) + <> buildReferencesForComponentType "parameters" ParameterReference (OAT.parameters (o :: OAT.ComponentsObject)) + <> buildReferencesForComponentType "examples" ExampleReference (OAT.examples (o :: OAT.ComponentsObject)) + <> buildReferencesForComponentType "requestBodies" RequestBodyReference (OAT.requestBodies o) + <> buildReferencesForComponentType "headers" HeaderReference (OAT.headers (o :: OAT.ComponentsObject)) + <> buildReferencesForComponentType "securitySchemes" SecuritySchemeReference (OAT.securitySchemes o) + ) + . OAT.components + +-- | Maps the subtypes of components to the entries of the 'ReferenceMap' and filters references (the lookup table should only contain concrete values). +buildReferencesForComponentType :: + Text -> + (a -> ComponentReference) -> + Map.Map Text (OAT.Referencable a) -> + [(Text, ComponentReference)] +buildReferencesForComponentType componentName constructor = + fmap (BF.first (("#/components/" <> componentName <> "/") <>)) + . Maybe.mapMaybe (convertReferencableToReference constructor) + . Map.toList + +convertReferencableToReference :: + (a -> ComponentReference) -> + (Text, OAT.Referencable a) -> + Maybe (Text, ComponentReference) +convertReferencableToReference constructor (name', OAT.Concrete object) = Just (name', constructor object) +convertReferencableToReference _ (_, OAT.Reference _) = Nothing + +getReference :: Text -> ReferenceMap -> Maybe ComponentReference +getReference = Map.lookup + +createReferenceLookup :: (ComponentReference -> Maybe a) -> Text -> ReferenceMap -> Maybe a +createReferenceLookup conversionFn key = getReference key >=> conversionFn + +-- | Resolve a 'OAS.SchemaObject' reference from a 'ReferenceMap' +getSchemaReference :: Text -> ReferenceMap -> Maybe OAS.SchemaObject +getSchemaReference = createReferenceLookup $ \case + SchemaReference r -> Just r + _ -> Nothing + +-- | Resolve a 'OAT.ResponseObject' reference from a 'ReferenceMap' +getResponseReference :: Text -> ReferenceMap -> Maybe OAT.ResponseObject +getResponseReference = createReferenceLookup $ \case + ResponseReference r -> Just r + _ -> Nothing + +-- | Resolve a 'OAT.ParameterObject' reference from a 'ReferenceMap' +getParameterReference :: Text -> ReferenceMap -> Maybe OAT.ParameterObject +getParameterReference = createReferenceLookup $ \case + ParameterReference r -> Just r + _ -> Nothing + +-- | Resolve a 'OAT.ExampleObject' reference from a 'ReferenceMap' +getExampleReference :: Text -> ReferenceMap -> Maybe OAT.ExampleObject +getExampleReference = createReferenceLookup $ \case + ExampleReference r -> Just r + _ -> Nothing + +-- | Resolve a 'OAT.RequestBodyObject' reference from a 'ReferenceMap' +getRequestBodyReference :: Text -> ReferenceMap -> Maybe OAT.RequestBodyObject +getRequestBodyReference = createReferenceLookup $ \case + RequestBodyReference r -> Just r + _ -> Nothing + +-- | Resolve a 'OAT.HeaderObject' reference from a 'ReferenceMap' +getHeaderReference :: Text -> ReferenceMap -> Maybe OAT.HeaderObject +getHeaderReference = createReferenceLookup $ \case + HeaderReference r -> Just r + _ -> Nothing + +-- | Resolve a 'OAT.SecuritySchemeObject' reference from a 'ReferenceMap' +getSecuritySchemeReference :: Text -> ReferenceMap -> Maybe OAT.SecuritySchemeObject +getSecuritySchemeReference = createReferenceLookup $ \case + SecuritySchemeReference r -> Just r + _ -> Nothing diff --git a/src/OpenAPI/Generate/Response.hs b/src/OpenAPI/Generate/Response.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Response.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | This module contains the utilities to define the data types of the response type of an operation +module OpenAPI.Generate.Response + ( getResponseDefinitions, + ) +where + +import qualified Data.Aeson as Aeson +import qualified Data.Either as Either +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import Language.Haskell.TH.Syntax +import qualified Network.HTTP.Client as HC +import qualified Network.HTTP.Types as HT +import qualified OpenAPI.Generate.Doc as Doc +import qualified OpenAPI.Generate.Flags as OAF +import OpenAPI.Generate.Internal.Operation +import OpenAPI.Generate.Internal.Util +import qualified OpenAPI.Generate.Model as Model +import qualified OpenAPI.Generate.Monad as OAM +import qualified OpenAPI.Generate.Types as OAT + +-- | Generates a response type with a constructor for all possible response types of the operation. +-- +-- Always generates an error case which is used if no other case matches. +getResponseDefinitions :: + -- | The operation to generate the response types for + OAT.OperationObject -> + -- | A function which appends the passed 'Text' to the operation name and returns it + (Text -> Text) -> + -- | Returns the name of the reponse data type, the response transformation function and the document containing + -- the definitions of all response types. + OAM.Generator (Name, Q Exp, Q Doc) +getResponseDefinitions operation appendToOperationName = do + convertToCamelCase <- OAM.getFlag OAF.optConvertToCamelCase + responseSuffix <- OAM.getFlag $ T.pack . OAF.optResponseTypeSuffix + responseBodySuffix <- OAM.getFlag $ T.pack . OAF.optResponseBodyTypeSuffix + let responsesObject = OAT.responses (operation :: OAT.OperationObject) + createBodyName = createResponseNameAsText convertToCamelCase appendToOperationName . (responseBodySuffix <>) + createName = createResponseName convertToCamelCase appendToOperationName . (responseSuffix <>) + responseName = createName "" + responseReferenceCases = getStatusCodeResponseCases responsesObject <> getRangeResponseCases responsesObject + responseCases <- resolveResponseReferences responseReferenceCases + let responseDescriptions = getResponseDescription . (\(_, _, r) -> r) <$> responseCases + schemas <- generateResponseCaseDefinitions createBodyName responseCases + pure $ (responseName,createResponseTransformerFn createName schemas,) $ + vcat + <$> sequence + [ pure $ + Doc.generateHaddockComment + [ "Represents a response of the operation '" <> appendToOperationName "" <> "'.", + "", + "The response constructor is chosen by the status code of the response. If no case matches (no specific case for the response code, no range case, no default case), '" + <> createResponseNameAsText convertToCamelCase appendToOperationName (responseSuffix <> errorSuffix) + <> "' is used." + ], + ( `Doc.sideBySide` + (text "" $$ Doc.sideComments ("Means either no matching case available or a parse error" : responseDescriptions)) + ) + . Doc.breakOnTokensWithReplacement + ( \case + "=" -> "=\n " + token -> "\n " <> token + ) + ["=", "deriving", "|"] + . ppr + <$> dataD + (cxt []) + responseName + [] + Nothing + ( fmap + ( \(suffix, _, maybeSchema) -> + normalC + (createName suffix) + ( case maybeSchema of + Just (type', _) -> [bangType (bang noSourceUnpackedness noSourceStrictness) type'] + Nothing -> [] + ) + ) + ((errorSuffix, [||const True||], Just ([t|String|], (Doc.emptyDoc, Set.empty))) : schemas) + ) + [derivClause Nothing [conT ''Show, conT ''Eq]], + printSchemaDefinitions schemas + ] + +-- | First: suffix to append to the data constructor name +-- Second: an expression which can be used to determine if this case should be used in regard to the response status +-- Third: Reference or concrete response object +type ResponseReferenceCase = (Text, TExpQ (HT.Status -> Bool), OAT.Referencable OAT.ResponseObject) + +-- | Same as @ResponseReferenceCase@ but with resolved reference +type ResponseCase = (Text, TExpQ (HT.Status -> Bool), OAT.ResponseObject) + +-- | Same as @ResponseReferenceCase@ but with type definition +type ResponseCaseDefinition = (Text, TExpQ (HT.Status -> Bool), Maybe Model.TypeWithDeclaration) + +-- | Suffix used for the error case +errorSuffix :: Text +errorSuffix = "Error" + +-- | Create the name as 'Text' of the response type / data constructor based on a suffix +createResponseNameAsText :: Bool -> (Text -> Text) -> Text -> Text +createResponseNameAsText convertToCamelCase appendToOperationName = T.pack . haskellifyText convertToCamelCase True . appendToOperationName + +-- | Create the name as 'Name' of the response type / data constructor based on a suffix +createResponseName :: Bool -> (Text -> Text) -> Text -> Name +createResponseName convertToCamelCase appendToOperationName = mkName . T.unpack . createResponseNameAsText convertToCamelCase appendToOperationName + +-- | Generate the response cases which have a range instead of a single status code +getRangeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase] +getRangeResponseCases responsesObject = + Maybe.catMaybes + [ ("1XX",[||HT.statusIsInformational||],) <$> OAT.range1XX responsesObject, + ("2XX",[||HT.statusIsSuccessful||],) <$> OAT.range2XX responsesObject, + ("3XX",[||HT.statusIsRedirection||],) <$> OAT.range3XX responsesObject, + ("4XX",[||HT.statusIsClientError||],) <$> OAT.range4XX responsesObject, + ("5XX",[||HT.statusIsServerError||],) <$> OAT.range5XX responsesObject, + ("Default",[||const True||],) <$> OAT.default' (responsesObject :: OAT.ResponsesObject) + ] + +-- | Generate the response cases based on the available status codes +getStatusCodeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase] +getStatusCodeResponseCases = + fmap (\(code, response) -> (T.pack $ show code, [||\status -> HT.statusCode status == code||], response)) + . Map.toList + . OAT.perStatusCode + +-- | Resolve the references in response cases +-- +-- Note: Discards the unresolved references and generates a log message for them +resolveResponseReferences :: [ResponseReferenceCase] -> OAM.Generator [ResponseCase] +resolveResponseReferences = + fmap Maybe.catMaybes + . mapM + ( \(suffix, guard, response) -> + fmap (suffix,guard,) <$> OAM.nested suffix (getResponseObject response) + ) + +-- | Generate the response definitions +-- +-- If no response schema is available for a case (or with an unsupported media type), an empty data constructor is used +generateResponseCaseDefinitions :: (Text -> Text) -> [ResponseCase] -> OAM.Generator [ResponseCaseDefinition] +generateResponseCaseDefinitions createBodyName = + mapM + ( \(suffix, guard, r) -> OAM.nested suffix $ do + responseSchema <- getResponseSchema r + (suffix,guard,) <$> mapM (Model.defineModelForSchemaNamed $ createBodyName suffix) responseSchema + ) + +-- | Prints the definitions of the different response case data types in 'Q' +printSchemaDefinitions :: [ResponseCaseDefinition] -> Q Doc +printSchemaDefinitions = + fmap vcat + . sequence + . Maybe.mapMaybe (\(_, _, namedTypeDef) -> fmap (fst . snd) namedTypeDef) + +-- | Creates a function as 'Q Exp' which can be used in the generated code to transform the response +createResponseTransformerFn :: (Text -> Name) -> [ResponseCaseDefinition] -> Q Exp +createResponseTransformerFn createName schemas = + let responseArgName = mkName "response" + bodyName = mkName "body" + ifCases = + multiIfE $ + fmap + ( \(suffix, guard, maybeSchema) -> + normalGE + [|$(unTypeQ guard) (HC.responseStatus $(varE responseArgName))|] + ( case maybeSchema of + Just (type', _) -> [|$(varE $ createName suffix) <$> (Aeson.eitherDecodeStrict $(varE bodyName) :: Either String $type')|] + Nothing -> [|Right $(varE $ createName suffix)|] + ) + ) + schemas + <> [normalGE [|otherwise|] [|Left "Missing default response type"|]] + transformLambda = lamE [varP responseArgName, varP bodyName] ifCases + in [|fmap (fmap (\response -> fmap (Either.either $(varE $ createName errorSuffix) id . $transformLambda response) response))|] + +getResponseDescription :: OAT.ResponseObject -> Text +getResponseDescription response = Doc.escapeText $ OAT.description (response :: OAT.ResponseObject) diff --git a/src/OpenAPI/Generate/SecurityScheme.hs b/src/OpenAPI/Generate/SecurityScheme.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/SecurityScheme.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Provides the generation functions for the supported security schemes +module OpenAPI.Generate.SecurityScheme + ( defineSupportedSecuritySchemes, + ) +where + +import qualified Data.Bifunctor as BF +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import qualified Network.HTTP.Client as HC +import qualified Network.HTTP.Simple as HS +import qualified OpenAPI.Common as OC +import qualified OpenAPI.Generate.Doc as Doc +import qualified OpenAPI.Generate.Monad as OAM +import qualified OpenAPI.Generate.Types as OAT + +-- | Defines the security schemes which are configured in the OpenAPI specification +-- +-- Generates warnings if unsupported schemes are defined in the specification +defineSupportedSecuritySchemes :: Text -> [(Text, OAT.SecuritySchemeObject)] -> OAM.Generator (Q Doc) +defineSupportedSecuritySchemes moduleName securitySchemes = OAM.nested "securitySchemes" $ do + let securitySchemeDefinitions = fmap (BF.second $ defineSecurityScheme moduleName) securitySchemes + mapM_ + ( \(name, _) -> + OAM.nested name + $ OAM.logWarning + $ "The security scheme '" <> name <> "' is not supported (currently only http-basic and http-bearer are supported)." + ) + $ filter (Maybe.isNothing . snd) securitySchemeDefinitions + pure $ fmap vcat $ mapM (fmap ($$ text "") . snd) $ Maybe.mapMaybe sequence securitySchemeDefinitions + +-- | Defines the security scheme for one 'OAT.SecuritySchemeObject' +defineSecurityScheme :: Text -> OAT.SecuritySchemeObject -> Maybe (Q Doc) +defineSecurityScheme moduleName (OAT.HttpSecuritySchemeObject scheme) = + let description = Doc.escapeText $ Maybe.fromMaybe "" $ OAT.description (scheme :: OAT.HttpSecurityScheme) + in case OAT.scheme scheme of + "basic" -> Just $ basicAuthenticationScheme moduleName description + "bearer" -> Just $ bearerAuthenticationScheme moduleName description + _ -> Nothing +defineSecurityScheme _ _ = Nothing + +-- | The name used in the instance declaration (referencing 'OC.authenticateRequest'). +-- It is necessary because it is not possible to fully qualify the name in the instance declaration. +authenticateRequestName :: Name +authenticateRequestName = mkName "authenticateRequest" + +-- | BasicAuthentication scheme with simple username and password +basicAuthenticationScheme :: Text -> Text -> Q Doc +basicAuthenticationScheme moduleName description = + let dataName = mkName "BasicAuthenticationSecurityScheme" + usernameName = mkName "basicAuthenticationSecuritySchemeUsername" + passwordName = mkName "basicAuthenticationSecuritySchemePassword" + paramName = mkName "basicAuth" + dataDefinition = + dataD + (cxt []) + dataName + [] + Nothing + [ recC + dataName + [ varBangType usernameName $ bangType (bang noSourceUnpackedness noSourceStrictness) $ conT ''Text, + varBangType passwordName $ bangType (bang noSourceUnpackedness noSourceStrictness) $ conT ''Text + ] + ] + [derivClause Nothing [conT ''Show, conT ''Ord, conT ''Eq]] + instanceDefinition = + instanceD + (cxt []) + (appT (conT ''OC.SecurityScheme) (conT dataName)) + [ funD + authenticateRequestName + [ clause + [varP paramName] + ( normalB + [| + HC.applyBasicAuth + (OC.textToByte $ $(varE usernameName) $(varE paramName)) + (OC.textToByte $ $(varE passwordName) $(varE paramName)) + |] + ) + [] + ] + ] + in vcat + <$> sequence + [ ($$ text "") + . ( Doc.generateHaddockComment + [ "Use this security scheme to use basic authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.", + "", + description, + "", + "@", + "'" <> moduleName <> ".Configuration.defaultConfiguration'", + " { configSecurityScheme =", + " 'BasicAuthenticationSecurityScheme'", + " { 'basicAuthenticationSecuritySchemeUsername' = \"user\",", + " 'basicAuthenticationSecuritySchemePassword' = \"pw\"", + " }", + " }", + "@" + ] + $$ + ) + . ppr <$> dataDefinition, + ppr <$> instanceDefinition + ] + +-- | BearerAuthentication scheme with a bearer token +bearerAuthenticationScheme :: Text -> Text -> Q Doc +bearerAuthenticationScheme moduleName description = + let dataName = mkName "BearerAuthenticationSecurityScheme" + tokenName = mkName "token" + dataDefinition = + dataD + (cxt []) + dataName + [] + Nothing + [ normalC + dataName + [bangType (bang noSourceUnpackedness noSourceStrictness) $ conT ''Text] + ] + [derivClause Nothing [conT ''Show, conT ''Ord, conT ''Eq]] + instanceDefinition = + instanceD + (cxt []) + (appT (conT ''OC.SecurityScheme) (conT dataName)) + [ funD + authenticateRequestName + [ clause + [conP dataName [varP tokenName]] + ( normalB + [| + HS.addRequestHeader "Authorization" $ OC.textToByte $ "Bearer " <> $(varE tokenName) + |] + ) + [] + ] + ] + in vcat + <$> sequence + [ ($$ text "") + . ( Doc.generateHaddockComment + [ "Use this security scheme to use bearer authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.", + "", + description, + "", + "@", + "'" <> moduleName <> ".Configuration.defaultConfiguration'", + " { configSecurityScheme = 'BearerAuthenticationSecurityScheme' \"token\"", + " }", + "@" + ] + $$ + ) + . ppr + <$> dataDefinition, + ppr <$> instanceDefinition + ] diff --git a/src/OpenAPI/Generate/Types.hs b/src/OpenAPI/Generate/Types.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Types.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | This module specifies the data types from the OpenAPI specification 3.0.3 +-- +-- For more information see http://spec.openapis.org/oas/v3.0.3 +-- +-- All names in this module correspond to the respective OpenAPI types +module OpenAPI.Generate.Types + ( module OpenAPI.Generate.Types.ExternalDocumentation, + module OpenAPI.Generate.Types.Referencable, + module OpenAPI.Generate.Types.Schema, + module OpenAPI.Generate.Types, + ) +where + +import qualified Data.HashMap.Strict as HMap +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Yaml +import GHC.Generics +import OpenAPI.Generate.Types.ExternalDocumentation +import OpenAPI.Generate.Types.Referencable +import OpenAPI.Generate.Types.Schema (Schema) +import Text.Read (readMaybe) + +data OpenApiSpecification + = OpenApiSpecification + { openapi :: Text, + info :: InfoObject, + servers :: [ServerObject], + paths :: PathsObject, + components :: ComponentsObject, + security :: [SecurityRequirementObject], + tags :: [TagObject], + externalDocs :: Maybe ExternalDocumentationObject + } + deriving (Show, Eq, Generic) + +instance FromJSON OpenApiSpecification where + parseJSON = withObject "OpenApiSpecification" $ \o -> + OpenApiSpecification + <$> o .: "openapi" + <*> o .: "info" + <*> o .:? "servers" .!= [] + <*> o .: "paths" + <*> o .:? "components" + .!= ComponentsObject + { schemas = Map.empty, + responses = Map.empty, + parameters = Map.empty, + examples = Map.empty, + requestBodies = Map.empty, + headers = Map.empty, + securitySchemes = Map.empty + } + <*> o .:? "security" .!= [] + <*> o .:? "tags" .!= [] + <*> o .:? "externalDocs" + +data InfoObject + = InfoObject + { title :: Text, + description :: Maybe Text, + termsOfService :: Maybe Text, + contact :: Maybe ContactObject, + license :: Maybe LicenseObject, + version :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON InfoObject + +data ContactObject + = ContactObject + { name :: Maybe Text, + url :: Maybe Text, + email :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON ContactObject + +data LicenseObject + = LicenseObject + { name :: Text, + url :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON LicenseObject + +type PathsObject = Map.Map Text PathItemObject + +data PathItemObject + = PathItemObject + { ref :: Maybe Text, + summary :: Maybe Text, + description :: Maybe Text, + get :: Maybe OperationObject, + put :: Maybe OperationObject, + post :: Maybe OperationObject, + delete :: Maybe OperationObject, + options :: Maybe OperationObject, + head :: Maybe OperationObject, + patch :: Maybe OperationObject, + trace :: Maybe OperationObject, + servers :: [ServerObject], + parameters :: [Referencable ParameterObject] + } + deriving (Show, Eq, Generic) + +instance FromJSON PathItemObject where + parseJSON = withObject "PathItemObject" $ \o -> + PathItemObject + <$> o .:? "ref" + <*> o .:? "summary" + <*> o .:? "description" + <*> o .:? "get" + <*> o .:? "put" + <*> o .:? "post" + <*> o .:? "delete" + <*> o .:? "options" + <*> o .:? "head" + <*> o .:? "patch" + <*> o .:? "trace" + <*> o .:? "servers" .!= [] + <*> o .:? "parameters" .!= [] + +data OperationObject + = OperationObject + { tags :: [Text], + summary :: Maybe Text, + description :: Maybe Text, + externalDocs :: Maybe ExternalDocumentationObject, + operationId :: Maybe Text, + parameters :: [Referencable ParameterObject], + requestBody :: Maybe (Referencable RequestBodyObject), + responses :: ResponsesObject, + deprecated :: Bool, + security :: [SecurityRequirementObject], + servers :: [ServerObject] + -- callbacks (http://spec.openapis.org/oas/v3.0.3#operation-object) are omitted because they are not needed + } + deriving (Show, Eq, Generic) + +instance FromJSON OperationObject where + parseJSON = withObject "OperationObject" $ \o -> + OperationObject + <$> o .:? "tags" .!= [] + <*> o .:? "summary" + <*> o .:? "description" + <*> o .:? "externalDocs" + <*> o .:? "operationId" + <*> o .:? "parameters" .!= [] + <*> o .:? "requestBody" + <*> o .: "responses" + <*> o .:? "deprecated" .!= False + <*> o .:? "security" .!= [] + <*> o .:? "servers" .!= [] + +type SecurityRequirementObject = Map.Map Text [Text] + +data RequestBodyObject + = RequestBodyObject + { content :: Map.Map Text MediaTypeObject, + description :: Maybe Text, + required :: Bool + } + deriving (Show, Eq, Generic) + +instance FromJSON RequestBodyObject where + parseJSON = withObject "RequestBodyObject" $ \o -> + RequestBodyObject + <$> o .: "content" + <*> o .:? "description" + <*> o .:? "required" .!= False + +data MediaTypeObject + = MediaTypeObject + { schema :: Maybe Schema, + example :: Maybe Value, + examples :: Map.Map Text (Referencable ExampleObject), + encoding :: Map.Map Text EncodingObject + } + deriving (Show, Eq, Generic) + +instance FromJSON MediaTypeObject where + parseJSON = withObject "MediaTypeObject" $ \o -> + MediaTypeObject + <$> o .:? "schema" + <*> o .:? "example" + <*> o .:? "examples" .!= Map.empty + <*> o .:? "encoding" .!= Map.empty + +data ExampleObject + = ExampleObject + { summary :: Maybe Text, + description :: Maybe Text, + value :: Maybe Value, -- value and externalValue are mutually exclusive, maybe this should be encoded in this data type + externalValue :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON ExampleObject + +data EncodingObject + = EncodingObject + { contentType :: Maybe Text, + headers :: Map.Map Text (Referencable HeaderObject), + style :: Maybe Text, + explode :: Bool, + allowReserved :: Bool + } + deriving (Show, Eq, Generic) + +instance FromJSON EncodingObject where + parseJSON = withObject "EncodingObject" $ \o -> + EncodingObject + <$> o .:? "contentType" + <*> o .:? "headers" .!= Map.empty + <*> o .:? "style" + <*> o .:? "explode" .!= True + <*> o .:? "allowReserved" .!= False + +data ResponsesObject + = ResponsesObject + { default' :: Maybe (Referencable ResponseObject), + range1XX :: Maybe (Referencable ResponseObject), + range2XX :: Maybe (Referencable ResponseObject), + range3XX :: Maybe (Referencable ResponseObject), + range4XX :: Maybe (Referencable ResponseObject), + range5XX :: Maybe (Referencable ResponseObject), + perStatusCode :: Map.Map Int (Referencable ResponseObject) + } + deriving (Show, Eq, Generic) + +instance FromJSON ResponsesObject where + parseJSON = withObject "ResponsesObject" $ \o -> + ResponsesObject + <$> o .:? "default" + <*> o .:? "1XX" + <*> o .:? "2XX" + <*> o .:? "3XX" + <*> o .:? "4XX" + <*> o .:? "5XX" + <*> mapM + parseJSON + ( Map.fromList + . filter (\(code, _) -> code >= 100 && code < 600) + . Maybe.mapMaybe + ( \(code, response) -> fmap (,response) . readMaybe . T.unpack $ code + ) + $ HMap.toList o + ) + +data ResponseObject + = ResponseObject + { description :: Text, + headers :: Map.Map Text (Referencable HeaderObject), + content :: Map.Map Text MediaTypeObject + -- links (http://spec.openapis.org/oas/v3.0.3#fixed-fields-14) are omitted because they are not needed + } + deriving (Show, Eq, Generic) + +instance FromJSON ResponseObject where + parseJSON = withObject "ResponseObject" $ \o -> + ResponseObject + <$> o .: "description" + <*> o .:? "headers" .!= Map.empty + <*> o .:? "content" .!= Map.empty + +data ServerObject + = ServerObject + { url :: Text, + description :: Maybe Text, + variables :: Map.Map Text ServerVariableObject + } + deriving (Show, Eq, Generic) + +instance FromJSON ServerObject where + parseJSON = withObject "ServerObject" $ \o -> + ServerObject + <$> o .: "url" + <*> o .:? "description" + <*> o .:? "variables" .!= Map.empty + +data ServerVariableObject + = ServerVariableObject + { enum :: [Text], + default' :: Text, + description :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON ServerVariableObject where + parseJSON = withObject "ServerVariableObject" $ \o -> + ServerVariableObject + <$> o .:? "enum" .!= [] + <*> o .: "default" + <*> o .:? "description" + +data ParameterObject + = ParameterObject + { name :: Text, + in' :: ParameterObjectLocation, + description :: Maybe Text, + required :: Bool, + deprecated :: Bool, + allowEmptyValue :: Bool, + schema :: ParameterObjectSchema + } + deriving (Show, Eq, Generic) + +instance FromJSON ParameterObject where + parseJSON = withObject "ParameterObject" $ \o -> + ParameterObject + <$> o .: "name" + <*> o .: "in" + <*> o .:? "description" + <*> o .:? "required" .!= False + <*> o .:? "deprecated" .!= False + <*> o .:? "allowEmptyValue" .!= False + <*> parseJSON (Object o) + +data ParameterObjectLocation = QueryParameterObjectLocation | HeaderParameterObjectLocation | PathParameterObjectLocation | CookieParameterObjectLocation + deriving (Show, Eq, Generic) + +instance FromJSON ParameterObjectLocation where + parseJSON = withText "ParameterObjectLocation" $ \case + "query" -> pure QueryParameterObjectLocation + "header" -> pure HeaderParameterObjectLocation + "path" -> pure PathParameterObjectLocation + "cookie" -> pure CookieParameterObjectLocation + _ -> fail "A ParameterObject must have a value of 'query', 'header', 'path' or 'cookie' in the property 'in'." + +data ParameterObjectSchema + = SimpleParameterObjectSchema + { style :: Maybe Text, + explode :: Bool, + allowReserved :: Bool, + schema :: Schema, + example :: Maybe Value, + examples :: Map.Map Text (Referencable ExampleObject) + } + | ComplexParameterObjectSchema (Map.Map Text MediaTypeObject) + deriving (Show, Eq, Generic) + +instance FromJSON ParameterObjectSchema where + parseJSON = withObject "ParameterObjectSchema" $ \o -> do + maybeSchema <- o .:? "schema" + maybeContent <- o .:? "content" + case (maybeSchema, maybeContent) of + (Just schema', Nothing) -> + SimpleParameterObjectSchema + <$> o .:? "style" + <*> o .:? "explode" .!= True + <*> o .:? "allowReserved" .!= False + <*> pure schema' + <*> o .:? "example" + <*> o .:? "examples" .!= Map.empty + (Nothing, Just content') -> pure $ ComplexParameterObjectSchema content' + (Just _, Just _) -> fail "ParameterObject (http://spec.openapis.org/oas/v3.0.3#parameter-object) only allows one of the properties schema and content." + (Nothing, Nothing) -> fail "ParameterObject (http://spec.openapis.org/oas/v3.0.3#parameter-object) requires one of the properties schema and content to be present." + +newtype HeaderObject = HeaderObject ParameterObject + deriving (Show, Eq, Generic) + +instance FromJSON HeaderObject where + parseJSON = withObject "HeaderObject" $ \o -> + HeaderObject + <$> ( ParameterObject "name MUST NOT be specified, it is given in the corresponding headers map" HeaderParameterObjectLocation + <$> o .:? "description" + <*> o .:? "required" .!= False + <*> o .:? "deprecated" .!= False + <*> o .:? "allowEmptyValue" .!= False + <*> parseJSON (Object o) + ) + +data ComponentsObject + = ComponentsObject + { schemas :: Map.Map Text Schema, + responses :: Map.Map Text (Referencable ResponseObject), + parameters :: Map.Map Text (Referencable ParameterObject), + examples :: Map.Map Text (Referencable ExampleObject), + requestBodies :: Map.Map Text (Referencable RequestBodyObject), + headers :: Map.Map Text (Referencable HeaderObject), + securitySchemes :: Map.Map Text (Referencable SecuritySchemeObject) + -- links and callbacks are omitted because they are not supported in the generator + } + deriving (Show, Eq, Generic) + +instance FromJSON ComponentsObject where + parseJSON = withObject "ComponentsObject" $ \o -> + ComponentsObject + <$> o .:? "schemas" .!= Map.empty + <*> o .:? "responses" .!= Map.empty + <*> o .:? "parameters" .!= Map.empty + <*> o .:? "examples" .!= Map.empty + <*> o .:? "requestBodies" .!= Map.empty + <*> o .:? "headers" .!= Map.empty + <*> o .:? "securitySchemes" .!= Map.empty + +data SecuritySchemeObject + = ApiKeySecuritySchemeObject ApiKeySecurityScheme + | HttpSecuritySchemeObject HttpSecurityScheme + | OAuth2SecuritySchemeObject OAuth2SecurityScheme + | OpenIdConnectSecuritySchemeObject OpenIdConnectSecurityScheme + deriving (Show, Eq, Generic) + +instance FromJSON SecuritySchemeObject where + parseJSON = withObject "SecuritySchemeObject" $ \o -> do + type' <- o .: "type" + case (type' :: Text) of + "apiKey" -> ApiKeySecuritySchemeObject <$> parseJSON (Object o) + "http" -> HttpSecuritySchemeObject <$> parseJSON (Object o) + "oauth2" -> OAuth2SecuritySchemeObject <$> parseJSON (Object o) + "openIdConnect" -> OpenIdConnectSecuritySchemeObject <$> parseJSON (Object o) + _ -> fail "A SecuritySchemeObject must have a value of 'apiKey', 'http', 'oauth2' or 'openIdConnect' in the property 'type'." + +data ApiKeySecurityScheme + = ApiKeySecurityScheme + { description :: Maybe Text, + name :: Text, + in' :: ApiKeySecuritySchemeLocation + } + deriving (Show, Eq, Generic) + +instance FromJSON ApiKeySecurityScheme where + parseJSON = withObject "ApiKeySecurityScheme" $ \o -> + ApiKeySecurityScheme + <$> o .:? "description" + <*> o .: "name" + <*> o .: "in" + +data ApiKeySecuritySchemeLocation = QueryApiKeySecuritySchemeLocation | HeaderApiKeySecuritySchemeLocation | CookieApiKeySecuritySchemeLocation + deriving (Show, Eq, Generic) + +instance FromJSON ApiKeySecuritySchemeLocation where + parseJSON = withText "ApiKeySecuritySchemeLocation" $ \case + "query" -> pure QueryApiKeySecuritySchemeLocation + "header" -> pure HeaderApiKeySecuritySchemeLocation + "cookie" -> pure CookieApiKeySecuritySchemeLocation + _ -> fail "A SecuritySchemeObject with type 'apiKey' must have a value of 'query', 'header' or 'cookie' in the property 'in'." + +data HttpSecurityScheme + = HttpSecurityScheme + { description :: Maybe Text, + scheme :: Text, + bearerFormat :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON HttpSecurityScheme + +data OAuth2SecurityScheme + = OAuth2SecurityScheme + { description :: Maybe Text, + flows :: OAuthFlowsObject + } + deriving (Show, Eq, Generic) + +instance FromJSON OAuth2SecurityScheme + +data OAuthFlowsObject + = OAuthFlowsObject + { implicit :: Maybe OAuthFlowObject, + password :: Maybe OAuthFlowObject, + clientCredentials :: Maybe OAuthFlowObject, + authorizationCode :: Maybe OAuthFlowObject + } + deriving (Show, Eq, Generic) + +instance FromJSON OAuthFlowsObject + +data OAuthFlowObject + = OAuthFlowObject + { authorizationUrl :: Maybe Text, -- applies only to implicit and authorizationCode + tokenUrl :: Maybe Text, -- applies only to password, clientCredentials and authorizationCode + refreshUrl :: Maybe Text, + scopes :: Map.Map Text Text + } + deriving (Show, Eq, Generic) + +instance FromJSON OAuthFlowObject + +data OpenIdConnectSecurityScheme + = OpenIdConnectSecurityScheme + { description :: Maybe Text, + openIdConnectUrl :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON OpenIdConnectSecurityScheme + +data TagObject + = TagObject + { name :: Text, + description :: Maybe Text, + externalDocs :: Maybe ExternalDocumentationObject + } + deriving (Show, Eq, Generic) + +instance FromJSON TagObject diff --git a/src/OpenAPI/Generate/Types/ExternalDocumentation.hs b/src/OpenAPI/Generate/Types/ExternalDocumentation.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Types/ExternalDocumentation.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | For more information see http://spec.openapis.org/oas/v3.0.3#external-documentation-object +module OpenAPI.Generate.Types.ExternalDocumentation where + +import Data.Text (Text) +import Data.Yaml +import GHC.Generics + +data ExternalDocumentationObject + = ExternalDocumentationObject + { url :: Text, + description :: Maybe Text + } + deriving (Show, Ord, Eq, Generic) + +instance FromJSON ExternalDocumentationObject diff --git a/src/OpenAPI/Generate/Types/Referencable.hs b/src/OpenAPI/Generate/Types/Referencable.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Types/Referencable.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Many fields in OpenAPI can be either a reference or a concrete object. +-- This module adds this capabilities. +-- +-- For more information see http://spec.openapis.org/oas/v3.0.3#reference-object +module OpenAPI.Generate.Types.Referencable where + +import Data.Text (Text) +import Data.Yaml + +-- | Represents either a reference or a concrete value +data Referencable a + = -- | A reference with the JSON reference string pointing to the referenced target + Reference Text + | -- | A concrete value which can be used directly + Concrete a + deriving (Show, Eq, Ord) + +instance FromJSON a => FromJSON (Referencable a) where + parseJSON (Object v) = do + maybeReference <- v .:? "$ref" + case maybeReference of + (Just reference) -> pure (Reference reference) + Nothing -> Concrete <$> parseJSON (Object v) + parseJSON v = Concrete <$> parseJSON v diff --git a/src/OpenAPI/Generate/Types/Schema.hs b/src/OpenAPI/Generate/Types/Schema.hs new file mode 100644 --- /dev/null +++ b/src/OpenAPI/Generate/Types/Schema.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module specifies the data types from the OpenAPI specification 3.0.3 Schema +-- +-- For more information see http://spec.openapis.org/oas/v3.0.3 +-- and https://json-schema.org/ +-- +-- All names in this module correspond to the respective OpenAPI types +module OpenAPI.Generate.Types.Schema where + +import qualified Data.Map as Map +import qualified Data.Scientific as Scientific +import Data.Set as Set +import qualified Data.Text as T +import Data.Text (Text) +import Data.Yaml +import GHC.Generics +import OpenAPI.Generate.Types.ExternalDocumentation +import OpenAPI.Generate.Types.Referencable + +type Schema = Referencable SchemaObject + +data SchemaObject + = SchemaObject + { type' :: SchemaType, + title :: Maybe Text, + multipleOf :: Maybe Integer, + maximum :: Maybe Float, + exclusiveMaximum :: Bool, + minimum :: Maybe Float, + exclusiveMinimum :: Bool, + maxLength :: Maybe Word, + minLength :: Maybe Word, + pattern' :: Maybe Text, + maxItems :: Maybe Word, + minItems :: Maybe Word, + uniqueItems :: Bool, + maxProperties :: Maybe Word, + minProperties :: Maybe Word, + required :: Set Text, + enum :: Set Value, + allOf :: Set Schema, + oneOf :: Set Schema, + anyOf :: Set Schema, + not :: Maybe Schema, + properties :: Map.Map Text Schema, + additionalProperties :: AdditionalProperties, + description :: Maybe Text, + format :: Maybe Text, + -- default would have the same value type as restricted by + -- the schema. Stripe only uses Text default values + default' :: Maybe ConcreteValue, + nullable :: Bool, + discriminator :: Maybe DiscriminatorObject, + readOnly :: Bool, + writeOnly :: Bool, + xml :: Maybe XMLObject, + externalDocs :: Maybe ExternalDocumentationObject, + example :: Maybe Value, + deprecated :: Bool, + items :: Maybe Schema + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON SchemaObject where + parseJSON = withObject "SchemaObject" $ \o -> + SchemaObject + <$> o .:? "type" .!= SchemaTypeObject + <*> o .:? "title" + <*> o .:? "multipleOf" + <*> o .:? "maximum" + <*> o .:? "exclusiveMaximum" .!= False + <*> o .:? "minimum" + <*> o .:? "exclusiveMinimum" .!= False + <*> o .:? "maxLength" + <*> o .:? "minLength" + <*> o .:? "pattern" + <*> o .:? "maxItems" + <*> o .:? "minItems" + <*> o .:? "uniqueItems" .!= False + <*> o .:? "maxProperties" + <*> o .:? "minProperties" + <*> o .:? "required" .!= Set.empty + <*> o .:? "enum" .!= Set.empty + <*> o .:? "allOf" .!= Set.empty + <*> o .:? "oneOf" .!= Set.empty + <*> o .:? "anyOf" .!= Set.empty + <*> o .:? "not" + <*> o .:? "properties" .!= Map.empty + <*> o .:? "additionalProperties" .!= HasAdditionalProperties + <*> o .:? "description" + <*> o .:? "format" + <*> o .:? "default" + <*> o .:? "nullable" .!= False + <*> o .:? "discriminator" + <*> o .:? "readOnly" .!= False + <*> o .:? "writeOnly" .!= False + <*> o .:? "xml" + <*> o .:? "externalDocs" + <*> o .:? "example" + <*> o .:? "deprecated" .!= False + <*> o .:? "items" + +data SchemaType + = SchemaTypeString + | SchemaTypeNumber + | SchemaTypeInteger + | SchemaTypeBool + | SchemaTypeObject + | SchemaTypeArray + deriving (Show, Eq, Ord, Generic) + +instance FromJSON SchemaType where + parseJSON (String "integer") = pure SchemaTypeInteger + parseJSON (String "string") = pure SchemaTypeString + parseJSON (String "number") = pure SchemaTypeNumber + parseJSON (String "boolean") = pure SchemaTypeBool + parseJSON (String "array") = pure SchemaTypeArray + parseJSON (String "object") = pure SchemaTypeObject + parseJSON (String x) = fail $ "Only types integer, string, number, bool, array and object are supported but got: " <> T.unpack x + parseJSON _ = fail "type must be of type string" + +data DiscriminatorObject + = DiscriminatorObject + { propertyName :: Text, + mapping :: Map.Map Text Text + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON DiscriminatorObject where + parseJSON = withObject "DiscriminatorObject" $ \o -> + DiscriminatorObject + <$> o .: "propertyName" + <*> o .:? "mapping" .!= Map.empty + +-- So that Sets are possible +instance Ord Value where + (Object a) `compare` (Object b) = compare a b + (Array a) `compare` (Array b) = compare a b + (String a) `compare` (String b) = compare a b + (Number a) `compare` (Number b) = compare a b + (Bool a) `compare` (Bool b) = compare a b + Null `compare` Null = EQ + (Object _) `compare` _ = GT + _ `compare` (Object _) = LT + (Array _) `compare` _ = GT + _ `compare` (Array _) = LT + (String _) `compare` _ = GT + _ `compare` (String _) = LT + (Number _) `compare` _ = GT + _ `compare` (Number _) = LT + (Bool _) `compare` _ = GT + _ `compare` (Bool _) = LT + +data ConcreteValue + = StringDefaultValue Text + | NumericDefaultValue Scientific.Scientific + | BoolDefaultValue Bool + | OtherDefaultValue Value + deriving (Show, Eq, Ord, Generic) + +instance FromJSON ConcreteValue where + parseJSON v@(String _) = StringDefaultValue <$> parseJSON v + parseJSON v@(Number _) = NumericDefaultValue <$> parseJSON v + parseJSON v@(Bool _) = BoolDefaultValue <$> parseJSON v + parseJSON v = pure $ OtherDefaultValue v + +data AdditionalProperties + = NoAdditionalProperties + | HasAdditionalProperties + | AdditionalPropertiesWithSchema Schema + deriving (Show, Eq, Ord, Generic) + +instance FromJSON AdditionalProperties where + parseJSON (Bool False) = pure NoAdditionalProperties + parseJSON (Bool True) = pure HasAdditionalProperties + parseJSON v = AdditionalPropertiesWithSchema <$> parseJSON v + +data XMLObject + = XMLObject + { name :: Maybe Text, + namespace :: Maybe Text, + prefix :: Maybe Text, + attribute :: Bool, + wrapped :: Bool + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON XMLObject where + parseJSON = withObject "SchemaObject" $ \o -> + XMLObject + <$> o .:? "name" + <*> o .:? "namespace" + <*> o .:? "prefix" + <*> o .:? "attribute" .!= False + <*> o .:? "wrapped" .!= False diff --git a/test/OpenAPI/Generate/DocSpec.hs b/test/OpenAPI/Generate/DocSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenAPI/Generate/DocSpec.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenAPI.Generate.DocSpec where + +import GHC.Generics +import Language.Haskell.TH +import Language.Haskell.TH.PprLib +import OpenAPI.Generate.Doc +import OpenAPI.Generate.Internal.Util +import Test.Hspec +import Test.QuickCheck +import Test.Validity + +newtype MultiLineString = MultiLineString String + deriving (Eq, Show, Generic) + +instance Validity MultiLineString + +instance GenUnchecked MultiLineString where + genUnchecked = + MultiLineString + <$> genListOf + ( frequency [(9, genUnchecked :: Gen Char), (1, pure '\n')] + ) + +instance GenValid MultiLineString + +spec :: Spec +spec = do + describe "sideBySide" $ do + it "should place equally long docs" $ + show + ( sideBySide + ( text "a" $$ text "c" + ) + (text "b" $$ text "d") + ) + `shouldBe` show (text "a b" $$ text "c d") + it "should indent if right doc is longer" $ + show + ( sideBySide + ( text "a" $$ text "c" + ) + (text "b" $$ text "d" $$ text "e") + ) + `shouldBe` show (text "a b" $$ text "c d" $$ text " e") + it "should not indent if left doc is longer" $ + show + ( sideBySide + ( text "a" $$ text "c" $$ text "e" + ) + (text "b" $$ text "d") + ) + `shouldBe` show (text "a b" $$ text "c d" $$ text "e") + it "should have the length of the longer document" $ do + let numberOfLinesOfDoc = length . splitOn '\n' . show + forAllValid $ \(MultiLineString doc1, MultiLineString doc2) -> + numberOfLinesOfDoc + ( sideBySide + (text doc1) + (text doc2) + ) + == max (numberOfLinesOfDoc $ text doc1) (numberOfLinesOfDoc $ text doc2) + describe "generateHaddockComment" + $ it "should place every item on a new line and respect newline characters" + $ show (generateHaddockComment ["Line 1", "Line 2", "", "Line 3\nLine 4"]) + `shouldBe` init + ( unlines + [ "-- | Line 1", + "-- Line 2", + "-- ", + "-- Line 3", + "-- Line 4" + ] + ) + describe "sideComments" + $ it "should convert every item to a side comment and replace newlines with spaces" + $ show (sideComments ["Line 1", "Line 2", "", "Line 3\nLine 4"]) + `shouldBe` init + ( unlines + [ "-- ^ Line 1", + "-- ^ Line 2", + "-- ^ ", + "-- ^ Line 3 Line 4" + ] + ) + describe "appendDoc" + $ it "should append two docs" + $ do + content <- runQ $ pure (text "a") `appendDoc` pure (text "b") + show content `shouldBe` "a\nb" + describe "breakOnTokens" + $ it "place a line feed before the tokens and add an indentation" + $ show + ( breakOnTokens [",", "}"] $ text $ + init + ( unlines + [ "foo = {", + " a = 123, b = 321,", + " c = A", + " } deriving Foo" + ] + ) + ) + `shouldBe` init + ( unlines + [ "foo = { a = 123", + " , b = 321", + " , c = A ", + " } deriving Foo" + ] + ) + describe "zipCodeAndComments" + $ it "should intertwine code and comments" + $ show + ( zipCodeAndComments + [ "foo = {", + " a = 123", + " , b = 321", + " , c = A ", + " } deriving Foo" + ] + [ "a is foo", + "b is bar\nbut remember the line feed", + "c is A" + ] + ) + `shouldBe` init + ( unlines + [ "foo = {", + " -- | a is foo", + " a = 123", + " -- | b is bar", + " -- but remember the line feed", + " , b = 321", + " -- | c is A", + " , c = A ", + " } deriving Foo" + ] + ) diff --git a/test/OpenAPI/Generate/Internal/UtilSpec.hs b/test/OpenAPI/Generate/Internal/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenAPI/Generate/Internal/UtilSpec.hs @@ -0,0 +1,16 @@ +module OpenAPI.Generate.Internal.UtilSpec where + +import OpenAPI.Generate.Internal.Util +import Test.Hspec +import Test.Validity + +spec :: Spec +spec = + describe "splitOn" $ do + it "should split string into pieces" $ + splitOn 'a' "abcabca" `shouldBe` ["", "bc", "bc", ""] + it "should have one split more than elements to split on" + $ forAllValid + $ \(x, list) -> + length (splitOn (x :: Char) list) + == length (filter (== x) list) + 1 diff --git a/test/OpenAPI/Generate/ModelDependenciesSpec.hs b/test/OpenAPI/Generate/ModelDependenciesSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenAPI/Generate/ModelDependenciesSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenAPI.Generate.ModelDependenciesSpec where + +import Data.Bifunctor +import Data.List +import qualified Data.Set as Set +import Language.Haskell.TH +import Language.Haskell.TH.PprLib hiding ((<>)) +import OpenAPI.Generate.ModelDependencies +import Test.Hspec + +spec :: Spec +spec = + describe "getModelModulesFromModelsWithDependencies" $ do + let sut = getModelModulesFromModelsWithDependencies "OpenAPI" + t = pure . text + it "should split string into pieces" $ do + result <- + runQ $ + sut + [ ("A", (t "aToken", Set.fromList [])), + ("B", (t "bToken", Set.fromList ["A"])), + ("C", (t "cToken", Set.fromList ["A", "B"])), + ("D", (t "dToken", Set.fromList ["C"])), + ("E", (t "eToken", Set.fromList ["E"])), + ("F", (t "fToken", Set.fromList ["G"])), + ("G", (t "gToken", Set.fromList ["F"])) + ] + sortBy (\(a, _) (b, _) -> compare a b) (fmap (second show) result) + `shouldSatisfy` ( \case + [ (["CyclicTypes"], cyclicContent), + (["Types"], _), + (["Types", "A"], aContent), + (["Types", "B"], bContent), + (["Types", "C"], cContent), + (["Types", "D"], dContent) + ] -> + and + [ "aToken" `isInfixOf` aContent, + "bToken" `isInfixOf` bContent, + "cToken" `isInfixOf` cContent, + "dToken" `isInfixOf` dContent, + "eToken" `isInfixOf` cyclicContent, + "fToken" `isInfixOf` cyclicContent, + "gToken" `isInfixOf` cyclicContent + ] + _ -> False + ) diff --git a/test/OpenAPI/Generate/MonadSpec.hs b/test/OpenAPI/Generate/MonadSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenAPI/Generate/MonadSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module OpenAPI.Generate.MonadSpec where + +import Control.Monad.Reader +import Data.Bifunctor +import Data.GenValidity.Text () +import Data.List +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Validity.Text () +import qualified OpenAPI.Generate.Flags as OAF +import OpenAPI.Generate.Monad +import OpenAPI.Generate.Reference +import OpenAPI.Generate.Types as OAT +import Test.Hspec +import Test.Validity + +spec :: Spec +spec = do + let run = runGenerator (createEnvironment OAF.defaultFlags Map.empty) + describe "nested" $ do + it "should nest path correct with simple example" $ do + let (currentPath', _) = run $ nested "a" $ nested "b" $ nested "c" $ asks currentPath + currentPath' `shouldBe` ["a", "b", "c"] + it "should nest path correct with property" $ forAllValid $ \list -> do + let (currentPath', _) = run $ foldr nested (asks currentPath) list + currentPath' `shouldBe` list + it "should save path with logs" $ + let (_, logs) = run $ nested "a" $ do + logInfo "1" + nested "b" $ do + logInfo "2" + nested "c" $ logInfo "3" + logInfo "4" + logInfo "5" + in fmap (\l -> (path l, message l)) logs + `shouldBe` [ (["a"], "1"), + (["a", "b"], "2"), + (["a", "b", "c"], "3"), + (["a", "b"], "4"), + (["a"], "5") + ] + describe "logs" $ do + let msgAndLogToTupleList list logs = bimap T.unpack T.unpack <$> zip list (transformGeneratorLogs logs) + logContainsMsgPredicate = all $ uncurry isInfixOf + it "should contain all logged info messages" $ forAllValid $ \list -> do + let (_, logs) = run $ foldr ((>>) . logInfo) (pure ()) list + shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate + it "should contain all logged warn messages" $ forAllValid $ \list -> do + let (_, logs) = run $ foldr ((>>) . logWarning) (pure ()) list + shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate + it "should contain all logged error messages" $ forAllValid $ \list -> do + let (_, logs) = run $ foldr ((>>) . logError) (pure ()) list + shouldSatisfy (msgAndLogToTupleList list logs) logContainsMsgPredicate + describe "reference lookup" $ do + let e = OAT.ExampleObject (Just "foo") Nothing Nothing (Just "http://example.com") + b = OAT.RequestBodyObject Map.empty Nothing False + runWithEnv = + runGenerator + $ createEnvironment OAF.defaultFlags + $ Map.fromList + [ ("#/components/examples/example1", ExampleReference e), + ("#/components/requestBodies/body1", RequestBodyReference b) + ] + it "should find existing reference to example" $ do + let (maybeExample, _) = runWithEnv $ getExampleReferenceM "#/components/examples/example1" + maybeExample `shouldBe` Just e + it "should find existing reference to request body" $ do + let (maybeBody, _) = runWithEnv $ getRequestBodyReferenceM "#/components/requestBodies/body1" + maybeBody `shouldBe` Just b + it "should not find existing reference with wrong type" $ do + let (maybeExample, _) = runWithEnv $ getExampleReferenceM "#/components/requestBodies/body1" + maybeExample `shouldBe` Nothing + it "should not find non-existing reference" $ do + let (maybeExample, _) = runWithEnv $ getExampleReferenceM "#/components/examples/example99" + maybeExample `shouldBe` Nothing diff --git a/test/OpenAPI/Generate/OperationGetOperationDescriptionSpec.hs b/test/OpenAPI/Generate/OperationGetOperationDescriptionSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenAPI/Generate/OperationGetOperationDescriptionSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenAPI.Generate.OperationGetOperationDescriptionSpec where + +import qualified Data.Map as Map +import OpenAPI.Generate.Internal.Operation +import OpenAPI.Generate.Types as OAT +import Test.Hspec + +spec :: Spec +spec = + let emptyResponseObject = + OAT.ResponsesObject + { default' = Nothing, + range1XX = Nothing, + range2XX = Nothing, + range3XX = Nothing, + range4XX = Nothing, + range5XX = Nothing, + perStatusCode = Map.empty + } + testOperation = + OAT.OperationObject + { tags = [], + summary = Nothing, + description = Nothing, + externalDocs = Nothing, + operationId = Nothing, + parameters = [], + requestBody = Nothing, + responses = emptyResponseObject, + deprecated = False, + security = [], + servers = [] + } + testOperation2 = + testOperation + { summary = Just "my summary" + } :: + OAT.OperationObject + testOperation3 = + testOperation + { description = Just "my description" + } :: + OAT.OperationObject + testOperation4 = + testOperation + { summary = Just "my summary", + description = Just "my description" + } :: + OAT.OperationObject + in describe "getOperationDesciption" $ do + it + "should return an empty string" + (getOperationDescription testOperation `shouldBe` "") + it + "should return description" + (getOperationDescription testOperation2 `shouldBe` "my summary") + it + "should return summary" + (getOperationDescription testOperation3 `shouldBe` "my description") + it + "should return description" + (getOperationDescription testOperation4 `shouldBe` "my description") diff --git a/test/OpenAPI/Generate/OperationTHSpec.hs b/test/OpenAPI/Generate/OperationTHSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenAPI/Generate/OperationTHSpec.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module OpenAPI.Generate.OperationTHSpec where + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Text as T +import Data.Yaml +import Language.Haskell.TH +import qualified Network.HTTP.Simple as HS +import qualified Network.HTTP.Types as HT +import qualified OpenAPI.Common as OC +import OpenAPI.Generate.Internal.Operation +import OpenAPI.Generate.Types as OAT +import OpenAPI.Generate.Types.Schema as OAS +import Test.Hspec + +spec :: Spec +spec = + let singleTestTH desc should is = + it desc $ do + expected <- runQ should + res <- runQ is + expected `shouldBe` res + schemaObject = Maybe.fromJust $ decodeThrow "{}" :: OAS.SchemaObject + testParameterSchema = OAT.SimpleParameterObjectSchema Nothing False False (OAT.Concrete schemaObject) Nothing Map.empty + testParameter = OAT.ParameterObject "testName" OAT.QueryParameterObjectLocation Nothing True False True testParameterSchema + testParameterOtherName = OAT.ParameterObject "testName2" OAT.QueryParameterObjectLocation Nothing True False True testParameterSchema + testTHName = mkName "myTestName" + testTHE = [|B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE testTHName))|] + monadName = mkName "m" + securitySchemeName = mkName "s" + in do + describe "generateQueryParams" $ + singleTestTH + "should generate empty list" + (generateQueryParams []) + [|[]|] + describe "generateParameterizedRequestPath" $ do + singleTestTH + "should not change empty path without arguments" + (generateParameterizedRequestPath [] (T.pack "")) + [|""|] + singleTestTH + "should not change path without arguments" + (generateParameterizedRequestPath [] (T.pack "/my/path/")) + [|"/my/path/"|] + singleTestTH + "should ignore params not names" + (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/my/path/")) + [|"/my/path/"|] + singleTestTH + "should replace one occurences at the end" + (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/my/path/{testName}")) + [|"/my/path/" ++ $(testTHE) ++ ""|] + singleTestTH + "should replace one occurences at the end" + (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/my/path/{testName}/")) + [|"/my/path/" ++ $(testTHE) ++ "/"|] + singleTestTH + "should replace one occurences at the beginning" + (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "{testName}/my/path/")) + [|"" ++ $(testTHE) ++ "/my/path/"|] + singleTestTH + "should replace one occurences at the beginning" + (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/{testName}/my/path/")) + [|"/" ++ $(testTHE) ++ "/my/path/"|] + singleTestTH + "should replace one occurences in the middle" + (generateParameterizedRequestPath [(mkName "myTestName", testParameter)] (T.pack "/another/test/{testName}/my/path/")) + [|"/another/test/" ++ $(testTHE) ++ "/my/path/"|] + singleTestTH + "should ignore names not given" + (generateParameterizedRequestPath [] (T.pack "/another/test/{testName}/my/path/")) + [|"/another/test/{testName}/my/path/"|] + singleTestTH + "should replace two occurences" + ( generateParameterizedRequestPath + [(mkName "myTestName", testParameter), (mkName "myTestName2", testParameterOtherName)] + (T.pack "/{testName2}/my//test/{testName}/my/path/") + ) + [|("/" ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE $ mkName "myTestName2")) ++ "/my//test/") ++ $(testTHE) ++ "/my/path/"|] + singleTestTH + "should replace one variable twice in the path" + ( generateParameterizedRequestPath + [(mkName "myTestName", testParameter)] + (T.pack "/{testName}/my//test/{testName}/my/path/") + ) + [|"/" ++ $(testTHE) ++ "/my//test/" ++ $(testTHE) ++ "/my/path/"|] + describe "getParametersTypeForSignature" $ do + let responseTypeName = mkName "Test" + responseType = [t|$(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|] + singleTestTH + "no parameters" + (getParametersTypeForSignature [] responseTypeName monadName securitySchemeName) + [t|OC.Configuration $(varT securitySchemeName) -> $(responseType)|] + singleTestTH + "One parameters" + (getParametersTypeForSignature [conT ''Int] responseTypeName monadName securitySchemeName) + [t|OC.Configuration $(varT securitySchemeName) -> Int -> $(responseType)|] + singleTestTH + "Optional parameters" + (getParametersTypeForSignature [[t|Maybe Int|]] responseTypeName monadName securitySchemeName) + [t|OC.Configuration $(varT securitySchemeName) -> Maybe Int -> $(responseType)|] + singleTestTH + "Two parameters" + (getParametersTypeForSignature [conT ''Int, conT ''String] responseTypeName monadName securitySchemeName) + [t|OC.Configuration $(varT securitySchemeName) -> Int -> String -> $(responseType)|] diff --git a/test/OpenAPI/Generate/ReferenceSpec.hs b/test/OpenAPI/Generate/ReferenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenAPI/Generate/ReferenceSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenAPI.Generate.ReferenceSpec where + +import qualified Data.Map as Map +import OpenAPI.Generate.Reference +import OpenAPI.Generate.Types as OAT +import Test.Hspec + +spec :: Spec +spec = do + let i = + OAT.InfoObject + { title = "", + description = Nothing, + termsOfService = Nothing, + contact = Nothing, + license = Nothing, + version = "0.0.1" + } + e = OAT.ExampleObject {summary = Just "foo", description = Nothing, value = Nothing, externalValue = Just "http://example.com"} + c = + OAT.ComponentsObject + { schemas = Map.empty, + responses = Map.empty, + parameters = Map.empty, + examples = + Map.fromList + [ ("example1", OAT.Concrete e), + ("example2", OAT.Reference "#/components/examples/example1") + ], + requestBodies = Map.empty, + headers = Map.empty, + securitySchemes = Map.empty + } + openApiSpec = + OAT.OpenApiSpecification + { openapi = "3.0.3", + info = i, + servers = [], + paths = Map.empty, + components = c, + security = [], + tags = [], + externalDocs = Nothing + } + describe "buildReferenceMap" $ do + it "should find reference" $ + getExampleReference "#/components/examples/example1" (buildReferenceMap openApiSpec) + `shouldBe` Just e + it "should not find reference pointing to other reference" $ + getExampleReference "#/components/examples/example2" (buildReferenceMap openApiSpec) `shouldBe` Nothing + it "should not find unexisting reference" $ + getExampleReference "#/components/examples/example99" (buildReferenceMap openApiSpec) `shouldBe` Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}