From 7aa1cc63531331c6ae8021dd26897b9de845f41a Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 15 Feb 2022 10:58:16 +0100 Subject: [PATCH] Initial commit --- .gitignore | 2 + CHANGELOG.md | 5 + src/Tie.hs | 217 ++++++++++++++++++ src/Tie/Codegen/Cabal.hs | 40 ++++ src/Tie/Codegen/Imports.hs | 77 +++++++ src/Tie/Codegen/Operation.hs | 253 +++++++++++++++++++++ src/Tie/Codegen/Response.hs | 102 +++++++++ src/Tie/Codegen/Schema.hs | 324 ++++++++++++++++++++++++++ src/Tie/Name.hs | 198 ++++++++++++++++ src/Tie/Operation.hs | 330 +++++++++++++++++++++++++++ src/Tie/Resolve.hs | 71 ++++++ src/Tie/Type.hs | 410 +++++++++++++++++++++++++++++++++ src/Tie/Writer.hs | 57 +++++ test/Main.hs | 1 + test/Test/Tie/Golden.hs | 26 +++ test/Test/Tie/Operation.hs | 16 ++ test/golden/lists.yaml | 47 ++++ test/golden/lists.yaml.out | 233 +++++++++++++++++++ test/golden/oneof.yaml | 32 +++ test/golden/oneof.yaml.out | 201 +++++++++++++++++ test/golden/test1.yaml | 145 ++++++++++++ test/golden/test1.yaml.out | 427 +++++++++++++++++++++++++++++++++++ tie.cabal | 113 +++++++++ 23 files changed, 3327 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 src/Tie.hs create mode 100644 src/Tie/Codegen/Cabal.hs create mode 100644 src/Tie/Codegen/Imports.hs create mode 100644 src/Tie/Codegen/Operation.hs create mode 100644 src/Tie/Codegen/Response.hs create mode 100644 src/Tie/Codegen/Schema.hs create mode 100644 src/Tie/Name.hs create mode 100644 src/Tie/Operation.hs create mode 100644 src/Tie/Resolve.hs create mode 100644 src/Tie/Type.hs create mode 100644 src/Tie/Writer.hs create mode 100644 test/Main.hs create mode 100644 test/Test/Tie/Golden.hs create mode 100644 test/Test/Tie/Operation.hs create mode 100644 test/golden/lists.yaml create mode 100644 test/golden/lists.yaml.out create mode 100644 test/golden/oneof.yaml create mode 100644 test/golden/oneof.yaml.out create mode 100644 test/golden/test1.yaml create mode 100644 test/golden/test1.yaml.out create mode 100644 tie.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..80e4cdf --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist-newstyle/ +.DS_Store \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..8bf24e2 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for openapi3-server-gen + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/src/Tie.hs b/src/Tie.hs new file mode 100644 index 0000000..1f9f1fb --- /dev/null +++ b/src/Tie.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Tie + ( generate, + Writer, + fileWriter, + withTestWriter, + ) +where + +import qualified Data.HashMap.Strict.InsOrd as InsOrd +import qualified Data.OpenApi as OpenApi +import qualified Data.Set as Set +import Data.Yaml (decodeFileThrow) +import Prettyprinter (Doc, vsep) +import Tie.Codegen.Cabal (codegenCabalFile) +import Tie.Codegen.Imports + ( codegenExtraApiModuleDependencies, + codegenModuleHeader, + codegenResponseDependencies, + codegenSchemaDependencies, + ) +import Tie.Codegen.Operation + ( codegenOperation, + codegenOperations, + ) +import Tie.Codegen.Response (codegenResponseAuxFile, codegenResponses) +import Tie.Codegen.Schema (codegenSchema) +import Tie.Name + ( Name, + apiHaskellFileName, + apiHaskellModuleName, + cabalFileName, + fromText, + responseHaskellFileName, + responseHaskellModuleName, + toOperationHaskellFileName, + toResponseHaskellFileName, + toResponseHaskellModuleName, + toSchemaHaskellFileName, + toSchemaHaskellModuleName, + ) +import Tie.Operation + ( Operation (..), + errors, + operationResponseDependencies, + operationSchemaDependencies, + pathItemsToOperation, + ) +import Tie.Resolve (newResolver) +import Tie.Type + ( Named, + Type, + namedTypeDependencies, + schemaToType, + transitiveDependencies, + typeDependencies, + ) +import Tie.Writer (Writer, fileWriter, withTestWriter) +import Prelude hiding (Type) + +-- | Our own version of nubOrd that both nubs and sorts +nubOrd :: Ord a => [a] -> [a] +nubOrd = Set.toList . Set.fromList + +-- | Read an OpenAPI spec. Throws in case it can not +-- be read or deserialized. +readOpenApiSpec :: + MonadIO m => + FilePath -> + m OpenApi.OpenApi +readOpenApiSpec filePath = + liftIO (decodeFileThrow filePath) + +-- | Extracts all the schemas form an 'OpenApi.OpenApi'. +specSchemas :: OpenApi.OpenApi -> [(Text, OpenApi.Schema)] +specSchemas = + InsOrd.toList . OpenApi._componentsSchemas . OpenApi._openApiComponents + +specPaths :: OpenApi.OpenApi -> [(FilePath, OpenApi.PathItem)] +specPaths = + InsOrd.toList . OpenApi._openApiPaths + +specComponents :: OpenApi.OpenApi -> OpenApi.Components +specComponents = + OpenApi._openApiComponents + +generate :: MonadIO m => Writer m -> FilePath -> m () +generate write inputFile = do + -- TODO make configurable + let apiName = "OpenAPI" + packageName = "open-api" + + openApi <- readOpenApiSpec inputFile + + -- Helper to resolve components in the spec. + let resolver = + newResolver + (specComponents openApi) + (\_ -> error "could not resolve reference") + + -- Extract all the Operations from the spec + operations <- + pathItemsToOperation + resolver + errors + (specPaths openApi) + + -- Only extract the direct, shallow dependencies. This is used to get a precise + -- import list for the api and schema modules. + let shallow :: Named Type -> [Name] + shallow = + namedTypeDependencies + + -- Deeply traverse a type and extracts all dependencies. Used to get a list + -- of all the things we have to generate. + let transitive :: Named Type -> [Name] + transitive = + transitiveDependencies + + -- Transitive closure of all the referenced Schemas + let allReferencedSchemas :: [Name] + allReferencedSchemas = + foldMap (operationSchemaDependencies transitive) operations + + -- Walk through all the available Schemas and generate code for the + -- referenced ones. + for_ (specSchemas openApi) $ \(name, schema) -> do + let name' = fromText name + path = toSchemaHaskellFileName apiName name' + header = codegenModuleHeader (toSchemaHaskellModuleName apiName name') + when (name' `elem` allReferencedSchemas) $ do + type_ <- schemaToType resolver schema + let dependencyCode = + codegenSchemaDependencies apiName $ + nubOrd (typeDependencies shallow type_) + output <- codegenSchema name' type_ + write path $ + vsep + [ header, + mempty, + dependencyCode, + mempty, + output + ] + + -- For each Operation, generate data types for the responses. + for_ operations $ \operation@Operation {name} -> do + let path = toResponseHaskellFileName apiName name + header = codegenModuleHeader (toResponseHaskellModuleName apiName name) + + dependencyCode = + codegenSchemaDependencies apiName $ + nubOrd (operationSchemaDependencies shallow operation) + responsesCode <- codegenResponses resolver operation + write path $ + vsep + [ header, + mempty, + dependencyCode, + mempty, + responsesCode + ] + + -- Generate auxiliary definitions in Response.hs + let path = responseHaskellFileName apiName + header = codegenModuleHeader (responseHaskellModuleName apiName) + + write path $ + vsep + [ header, + mempty, + codegenResponseAuxFile + ] + + -- Generate a single Api.hs module containing the server for the api + operationsCode <- codegenOperations resolver operations + let path = apiHaskellFileName apiName + + header = + codegenModuleHeader (apiHaskellModuleName apiName) + schemaDependencyCode = + map + (codegenSchemaDependencies apiName . nubOrd . operationSchemaDependencies shallow) + operations + responseDependencyCode = + map + (codegenResponseDependencies apiName . nubOrd . operationResponseDependencies) + operations + + write path $ + vsep + [ header, + mempty, + codegenExtraApiModuleDependencies apiName, + mempty, + vsep schemaDependencyCode, + mempty, + vsep responseDependencyCode, + mempty, + operationsCode + ] + + -- Last but not least, generate the Cabal file + let allReferencedModules :: [Text] + allReferencedModules = + nubOrd $ + map (toSchemaHaskellModuleName apiName) allReferencedSchemas + ++ foldMap (map (toResponseHaskellModuleName apiName) . operationResponseDependencies) operations + ++ [ apiHaskellModuleName apiName, + responseHaskellModuleName apiName + ] + + path = cabalFileName packageName + write path (codegenCabalFile packageName allReferencedModules) diff --git a/src/Tie/Codegen/Cabal.hs b/src/Tie/Codegen/Cabal.hs new file mode 100644 index 0000000..e2bbe40 --- /dev/null +++ b/src/Tie/Codegen/Cabal.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tie.Codegen.Cabal (codegenCabalFile) where + +import Prettyprinter (Doc, (<+>)) +import qualified Prettyprinter as PP + +codegenCabalFile :: Text -> [Text] -> Doc ann +codegenCabalFile packageName exposedModules = + PP.vsep + [ "cabal-version:" <+> "3.0", + "name:" <+> PP.pretty packageName, + "version:" <+> "0.1.0.0", + "library" <> PP.line + <> PP.indent + 2 + ( PP.vsep + [ "build-depends:" <> PP.line + <> PP.indent + 2 + ( PP.vsep + [ "," <+> "aeson", + "," <+> "attoparsec", + "," <+> "base", + "," <+> "ghc-prim", + "," <+> "http-api-data", + "," <+> "http-types", + "," <+> "text", + "," <+> "wai" + ] + ), + "exposed-modules:" <> PP.line + <> PP.indent + 2 + ( PP.vsep + (map PP.pretty exposedModules) + ) + ] + ) + ] diff --git a/src/Tie/Codegen/Imports.hs b/src/Tie/Codegen/Imports.hs new file mode 100644 index 0000000..f3f1814 --- /dev/null +++ b/src/Tie/Codegen/Imports.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Tie.Codegen.Imports + ( codegenModuleHeader, + codegenSchemaDependencies, + codegenResponseDependencies, + codegenExtraApiModuleDependencies, + ) +where + +import Prettyprinter (Doc, (<+>)) +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Text as PP +import Tie.Name + ( ApiName, + Name, + responseHaskellModuleName, + toResponseHaskellModuleName, + toSchemaHaskellModuleName, + ) + +codegenModuleHeader :: Text -> Doc ann +codegenModuleHeader moduleName = + "{-#" <+> "LANGUAGE" <+> "DuplicateRecordFields" <+> "#-}" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "OverloadedStrings" <+> "#-}" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "RankNTypes" <+> "#-}" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "RecordWildCards" <+> "#-}" + <> PP.line + <> "module" <+> PP.pretty moduleName <+> "where" + <> PP.line + <> PP.line + <> "import" <+> "qualified" <+> "Control.Applicative" + <> PP.line + <> "import" <+> "qualified" <+> "Control.Monad.IO.Class" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Aeson" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Aeson.Parser" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Aeson.Types" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Attoparsec.ByteString" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Maybe" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Text" + <> PP.line + <> "import" <+> "qualified" <+> "GHC.Types" + <> PP.line + <> "import" <+> "qualified" <+> "Network.HTTP.Types" + <> PP.line + <> "import" <+> "qualified" <+> "Network.Wai" + <> PP.line + <> "import" <+> "qualified" <+> "Web.HttpApiData" + +codegenExtraApiModuleDependencies :: ApiName -> Doc ann +codegenExtraApiModuleDependencies apiName = + "import" <+> PP.pretty (responseHaskellModuleName apiName) + +codegenSchemaDependencies :: ApiName -> [Name] -> Doc ann +codegenSchemaDependencies apiName dependencies = + PP.vsep + [ "import" <+> PP.pretty (toSchemaHaskellModuleName apiName dependency) + | dependency <- dependencies + ] + +codegenResponseDependencies :: ApiName -> [Name] -> Doc ann +codegenResponseDependencies apiName dependencies = + PP.vsep + [ "import" <+> PP.pretty (toResponseHaskellModuleName apiName dependency) + | dependency <- dependencies + ] diff --git a/src/Tie/Codegen/Operation.hs b/src/Tie/Codegen/Operation.hs new file mode 100644 index 0000000..56e0ad8 --- /dev/null +++ b/src/Tie/Codegen/Operation.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Tie.Codegen.Operation + ( codegenOperation, + codegenOperations, + ) +where + +import Prettyprinter (Doc, (<+>)) +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Text as PP +import Tie.Codegen.Response (codegenResponses) +import Tie.Codegen.Schema (codegenFieldType, codegenParamSchema) +import Tie.Name + ( Name, + toApiMemberName, + toApiResponseTypeName, + toParamBinder, + toParamName, + ) +import Tie.Operation + ( Operation (..), + Param (..), + Path, + PathSegment (..), + RequestBody (..), + Response (..), + ) +import Tie.Resolve (Resolver) + +codegenOperations :: Monad m => Resolver m -> [Operation] -> m (PP.Doc ann) +codegenOperations resolver operations = do + dataApiDecl <- codegenApiType resolver operations + operationsCode <- traverse (codegenOperation resolver) operations + let apiDecl = + -- TODO instead of "application" take name from openapi spec + "application" <+> "::" <+> "(" <> "Control.Monad.IO.Class.MonadIO" <+> "m" <> ")" <+> "=>" <+> "(" <> "forall" <+> "a" <+> "." <+> "Network.Wai.Request" <+> "->" <+> "m" + <+> "a" + <+> "->" + <+> "IO" + <+> "a" <> ")" + <+> "->" + <+> "Api" + <+> "m" + <+> "->" + <+> "Network.Wai.Application" + <+> "->" + <+> "Network.Wai.Application" <> PP.line + <> "application" + <+> "run" + <+> "api" + <+> "notFound" + <+> "request" + <+> "respond" + <+> "=" <> PP.line + <> PP.indent + 4 + ( "case" <+> "Network.Wai.pathInfo" <+> "request" <+> "of" <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <> PP.line <> PP.line <> y) + ( operationsCode + ++ [ "_" <+> "->" <> PP.line + <> PP.indent 4 ("notFound" <+> "request" <+> "respond") + ] + ) + ) + <> PP.line + <> "where" + <> PP.line + <> PP.indent + 4 + ( "unsupportedMethod" <+> "_" <+> "=" <> PP.line + <> PP.indent + 4 + ( "respond" <+> "(" <> "Network.Wai.responseBuilder" + <+> "(" <> "toEnum" + <+> "405" <> ")" + <+> "[]" + <+> "mempty" <> ")" + ) + <> PP.line + <> "invalidRequest" <+> "_" <+> "=" + <> PP.line + <> PP.indent + 4 + ( "respond" <+> "(" <> "Network.Wai.responseBuilder" + <+> "(" <> "toEnum" + <+> "401" <> ")" + <+> "[]" + <+> "mempty" <> ")" + ) + ) + ) + + pure (dataApiDecl <> PP.line <> PP.line <> apiDecl) + +codegenApiType :: Monad m => Resolver m -> [Operation] -> m (PP.Doc ann) +codegenApiType resolver operations = do + operationsFieldsCode <- traverse (codegenApiTypeOperation resolver) operations + let fieldsCode = + PP.concatWith (\x y -> x <> "," <> PP.line <> y) operationsFieldsCode + + dataDecl = + "data" <+> "Api" <+> "m" <+> "=" <+> "Api" <+> "{" <> PP.line + <> PP.indent 4 fieldsCode + <> PP.line + <> "}" + pure dataDecl + +codegenApiTypeOperation :: Monad m => Resolver m -> Operation -> m (PP.Doc ann) +codegenApiTypeOperation resolver Operation {..} = do + paramsCode <- + sequence + [ codegenParamSchema name schema + | VariableSegment Param {name, schema} <- path + ] + pure $ + toApiMemberName name <+> "::" + <+> PP.concatWith + (\x y -> x <+> "->" <+> y) + ( paramsCode + ++ [ codegenFieldType jsonRequestBodyContent + | Just RequestBody {jsonRequestBodyContent} <- [requestBody] + ] + ++ ["m" <+> toApiResponseTypeName name] + ) + +codegenOperation :: Monad m => Resolver m -> Operation -> m (PP.Doc ann) +codegenOperation resolver operation@Operation {..} = do + pure $ + codegenPathGuard path $ + codegenMethodGuard + [ ( method, + codegenRequestBodyGuard + requestBody + ( codegenCallApiMember name path requestBody + ) + ) + ] + +codegenCallApiMember :: Name -> Path -> Maybe RequestBody -> PP.Doc ann +codegenCallApiMember operationName path requestBody = + "run" <+> "request" <+> "$" <+> "do" <> PP.line + <> PP.indent + 4 + ( "response" <+> "<-" <+> toApiMemberName operationName + <+> "api" + <+> PP.hsep [toParamBinder name | VariableSegment Param {name} <- path] + <+> (maybe mempty (\_ -> "body") requestBody) + <> PP.line + <> "Control.Monad.IO.Class.liftIO" + <+> "(" <> "respond" + <+> "(" <> "toResponse" + <+> "response" <> ")" <> ")" + ) + +codegenPath :: Monad m => Resolver m -> Path -> m (PP.Doc ann) +codegenPath resolver path = do + segments <- traverse (codegenSegment resolver) path + pure (PP.concatWith (\x y -> x <+> ":>" <+> y) segments) + +-- | Codegen a 'PathSegment'. +codegenSegment :: Monad m => Resolver m -> PathSegment Param -> m (PP.Doc ann) +codegenSegment _resolver segment = case segment of + StaticSegment literal -> + pure ("\"" <> PP.pretty literal <> "\"") + VariableSegment Param {name, schema} -> do + code <- codegenParamSchema name schema + let capture = + "Capture" <+> "\"" <> toParamName name <> "\"" <+> code + pure capture + +codegenPathGuard :: Path -> PP.Doc ann -> PP.Doc ann +codegenPathGuard path continuation = + codegenPathPattern path <+> "->" <> PP.line + <> PP.indent + 4 + ( foldr + ($) + continuation + [codegenParamGuard param | VariableSegment param <- path] + ) + +codegenParamGuard :: Param -> PP.Doc ann -> PP.Doc ann +codegenParamGuard Param {name} continuation = + "case" <+> "Web.HttpApiData.parseUrlPiece" <+> toParamBinder name <+> "of" <> PP.line + <> PP.indent + 4 + ( "Left" <+> "_" <+> "->" <+> "invalidRequest" <+> "\"" <> toParamName name <> "\"" <> PP.line + <> "Right" <+> toParamBinder name <+> "->" + <> PP.line + <> PP.indent 4 continuation + ) + +codegenPathPattern :: Path -> PP.Doc ann +codegenPathPattern path = + "[" + <+> PP.concatWith + (\x y -> x <> "," <+> y) + (map codegenPathSegmentPattern path) + <+> "]" + +codegenPathSegmentPattern :: PathSegment Param -> PP.Doc ann +codegenPathSegmentPattern segment = case segment of + StaticSegment literal -> + "\"" <> PP.pretty literal <> "\"" + VariableSegment Param {name} -> + toParamBinder name + +codegenMethodGuard :: [(Text, PP.Doc ann)] -> PP.Doc ann +codegenMethodGuard methodBodies = + "case" <+> "Network.Wai.requestMethod" <+> "request" <+> "of" <> PP.line + <> PP.indent + 4 + ( PP.vsep $ + [ "\"" <> PP.pretty method <> "\"" <+> "->" <> PP.line <> PP.indent 4 body + | (method, body) <- methodBodies + ] + ++ [ "x" <+> "->" <> PP.line <> PP.indent 4 ("unsupportedMethod" <+> "x") + ] + ) + +codegenRequestBodyGuard :: Maybe RequestBody -> PP.Doc ann -> PP.Doc ann +codegenRequestBodyGuard requestBody continuation = case requestBody of + Nothing -> continuation + Just _body -> + "do" + <+> PP.align + ( "result" <+> "<-" <+> "Data.Attoparsec.ByteString.parseWith" <+> "(" <> "Network.Wai.getRequestBodyChunk" <+> "request" <> ")" <+> "Data.Aeson.Parser.json'" <+> "mempty" <> PP.line + <> "case" <+> "Data.Attoparsec.ByteString.eitherResult" <+> "result" <+> "of" + <> PP.line + <> PP.indent + 4 + ( "Left" <+> "_err" <+> "->" <+> "undefined" <> PP.line + <> "Right" <+> "bodyValue" <+> "->" + <> PP.line + <> PP.indent + 4 + ( "case" <+> "Data.Aeson.Types.parseEither" <+> "Data.Aeson.parseJSON" <+> "bodyValue" <+> "of" <> PP.line + <> PP.indent + 4 + ( "Left" <+> "_err" <+> "->" <+> "undefined" <> PP.line + <> "Right" <+> "body" <+> "->" + <> PP.line + <> PP.indent 4 continuation + ) + ) + ) + ) diff --git a/src/Tie/Codegen/Response.hs b/src/Tie/Codegen/Response.hs new file mode 100644 index 0000000..df8d4e1 --- /dev/null +++ b/src/Tie/Codegen/Response.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Tie.Codegen.Response + ( codegenResponses, + codegenResponseAuxFile, + ) +where + +import Prettyprinter (Doc, (<+>)) +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Text as PP +import Tie.Codegen.Schema (codegenFieldType, codegenParamSchema) +import Tie.Name + ( Name, + toApiDefaultResponseConstructorName, + toApiMemberName, + toApiResponseConstructorName, + toApiResponseTypeName, + toParamBinder, + toParamName, + ) +import Tie.Operation + ( Operation (..), + Param (..), + Path, + PathSegment (..), + RequestBody (..), + Response (..), + ) +import Tie.Resolve (Resolver) + +-- | Generate code for the responses of an 'Operation'. +codegenResponses :: Monad m => Resolver m -> Operation -> m (Doc ann) +codegenResponses resolver Operation {..} = do + let decl = + "data" <+> toApiResponseTypeName name <> PP.line + <> PP.indent + 4 + ( PP.vsep $ + [ op <+> toApiResponseConstructorName name statusCode <+> codegenFieldType jsonResponseContent + | (op, (statusCode, Response {jsonResponseContent})) <- zip ("=" : repeat "|") responses + ] + ++ [ "|" <+> toApiDefaultResponseConstructorName name + <+> "Network.HTTP.Types.Status" + <+> codegenFieldType jsonResponseContent + | Just Response {jsonResponseContent} <- [defaultResponse] + ] + ) + instances = + codegenToResponses name responses defaultResponse + + pure (PP.vsep [decl, mempty, instances]) + +codegenToResponses :: Name -> [(Int, Response)] -> Maybe Response -> Doc ann +codegenToResponses operationName responses defaultResponse = + let decl = + "instance" <+> "ToResponse" <+> toApiResponseTypeName operationName <+> "where" <> PP.line + <> PP.indent + 4 + ( PP.vsep $ + [ "toResponse" <+> "(" <> toApiResponseConstructorName operationName statusCode <+> "x" <> ")" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( "Network.Wai.responseBuilder" <+> "(" <> "toEnum" <+> PP.pretty statusCode <> ")" + <+> "[(Network.HTTP.Types.hContentType, \"application/json\")]" + <+> "(" <> "Data.Aeson.fromEncoding" + <+> "(" <> "Data.Aeson.toEncoding" + <+> "x" <> ")" <> ")" + ) + | (statusCode, _response) <- responses + ] + ++ [ "toResponse" <+> "(" <> toApiDefaultResponseConstructorName operationName <+> "status" <+> "x" <> ")" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( "Network.Wai.responseBuilder" <+> "status" + <+> "[(Network.HTTP.Types.hContentType, \"application/json\")]" + <+> "(" <> "Data.Aeson.fromEncoding" + <+> "(" <> "Data.Aeson.toEncoding" + <+> "x" <> ")" <> ")" + ) + | Just Response {jsonResponseContent} <- [defaultResponse] + ] + ) + in decl + +codegenResponseAuxFile :: Doc ann +codegenResponseAuxFile = + "class" + <+> "ToResponse" + <+> "a" + <+> "where" + <> PP.line + <> PP.indent + 4 + ( "toResponse" <+> "::" <+> "a" <+> "->" <+> "Network.Wai.Response" + ) diff --git a/src/Tie/Codegen/Schema.hs b/src/Tie/Codegen/Schema.hs new file mode 100644 index 0000000..deabe78 --- /dev/null +++ b/src/Tie/Codegen/Schema.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Tie.Codegen.Schema + ( codegenSchema, + codegenParamSchema, + codegenFieldType, + ) +where + +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import Prettyprinter (Doc, (<+>)) +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Text as PP +import Tie.Name + ( inlineObjectTypeName, + inlineVariantTypeName, + toConstructorName, + toDataTypeName, + toFieldName, + toFunctionName, + toJsonFieldName, + toOneOfConstructorName, + toOneOfDataTypeName, + ) +import Tie.Type + ( BasicType (..), + Enumeration (..), + Name, + Named (..), + ObjectType (..), + Type (..), + isArrayType, + isBasicType, + isEnumType, + isObjectType, + isOneOfType, + namedType, + normalizeObjectType, + normalizeVariants, + ) +import Prelude hiding (Type) + +-- | Generate code for a parameter type. +codegenParamSchema :: Monad m => Name -> Named Type -> m (Doc ann) +codegenParamSchema _paramName typ = case typ of + Named {} -> + -- We are named, just defer to codegenFieldType + pure (codegenFieldType typ) + Unnamed typ + | Just _enumeration <- isEnumType typ -> + error "TODO enumeration params" + | Just basicType <- isBasicType typ -> + pure (codegenFieldType (Unnamed typ)) + | Just objectType <- isObjectType typ -> + error "Invariant broken: ruled out by pathToPath" + | otherwise -> + undefined + +-- | Generate code for a schema. +codegenSchema :: Monad m => Name -> Type -> m (Doc ann) +codegenSchema typName typ + | Just Enumeration {alternatives, includeNull} <- isEnumType typ = + pure (codegenEnumeration typName alternatives includeNull) + | Just basicType <- isBasicType typ = + pure (codegenBasicType typName basicType) + | Just alternatives <- isOneOfType typ = + codegenOneOfType typName alternatives + | Just objectType <- isObjectType typ = + codegenObjectType typName objectType + | Just elemType <- isArrayType typ = + codegenArrayType typName elemType + | otherwise = + undefined + +-- | Generate code for basic, primitive types +codegenBasicType :: Name -> BasicType -> Doc ann +codegenBasicType typName basicType = + let typ = case basicType of + TyString {} -> + "Data.Text.Text" + TyEnum {} -> + error "Impossible: Enumerations are handled by codegenEnumeration" + TyNumber -> + "GHC.Types.Double" + TyInteger -> + "GHC.Types.Int" + TyBoolean -> + "GHC.Types.Bool" + in "type" <+> toDataTypeName typName <+> "=" <+> typ + +codegenArrayType :: Monad m => Name -> Named Type -> m (Doc ann) +codegenArrayType name typ = pure mempty + +codegenOneOfType :: Monad m => Name -> [Named Type] -> m (Doc ann) +codegenOneOfType typName variants = do + -- Extract the inline dependencies, we will codegen them into the same file. + (variants, inlineDependencies) <- + normalizeVariants + ( \ith _variantType -> + pure (inlineVariantTypeName typName ith) + ) + variants + + -- Generate code for inline dependencies inplace + codeForInlineDependencies <- + traverse (uncurry codegenSchema) inlineDependencies + + let -- We derive the constructor names upfront. For unnamed types - which can still + -- exists after normalization for e.g. basic types - we generate an inline variant + -- type name. + variantConstructors = + [ (name, variant) + | (ith, variant) <- zip [1 ..] variants, + let name = case variant of + Named variantName _ -> + toOneOfConstructorName typName variantName + Unnamed typ -> + toOneOfConstructorName typName (inlineVariantTypeName typName ith) + ] + + decl = + "data" <+> toOneOfDataTypeName typName <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ op + <+> variantName + <+> codegenFieldType variantType + | (op, (variantName, variantType)) <- zip ("=" : repeat "|") variantConstructors + ] + ) + + toJson = + "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ "toJSON" <+> "(" <> variantName <+> "x" <> ")" <+> "=" + <+> "Data.Aeson.toJSON" + <+> "x" + | (variantName, _) <- variantConstructors + ] + ) + + fromJson = + "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" <> PP.line + <> PP.indent + 4 + ( "parseJSON" <+> "x" <+> "=" <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <+> "Control.Applicative.<|>" <> PP.line <> y) + [ "(" <> variantName <+> "<$>" <+> "Data.Aeson.parseJSON" <+> "x" <> ")" + | (variantName, variantType) <- variantConstructors + ] + ) + ) + + pure $ + PP.vsep + ( (map (<> PP.line) codeForInlineDependencies) + ++ [decl, mempty, toJson, mempty, fromJson] + ) + +codegenObjectType :: Monad m => Name -> ObjectType (Named Type) -> m (Doc ann) +codegenObjectType typName inputObjectType = do + -- Extract the inline dependencies, we will codegen them into the same file. + (ObjectType {..}, inlineDependencies) <- + normalizeObjectType + ( \fieldName _inlineObjectType -> + pure (inlineObjectTypeName typName fieldName) + ) + inputObjectType + + -- Generate code for inline dependencies inplace + codeForInlineDependencies <- + traverse (uncurry codegenSchema) inlineDependencies + + -- Now generate for the object itself + let orderedProperties = + sortOn fst (HashMap.toList properties) + + dataOrNewtype = case orderedProperties of + [_] -> "newtype" + _ -> "data" + + decl = + dataOrNewtype <+> toDataTypeName typName <+> "=" <+> toConstructorName typName <> PP.line + <> PP.indent + 4 + ( "{" <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <> "," <> PP.line <> y) + [ toFieldName field <+> "::" + <+> codegenRequiredOptionalFieldType + (HashSet.member field requiredProperties) + (codegenFieldType fieldType) + | (field, fieldType) <- orderedProperties + ] + ) + <> PP.line + <> "}" + ) + + toJson = + "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" <> PP.line + <> PP.indent + 4 + ( "toJSON" <+> toConstructorName typName <+> "{..}" <+> "=" <+> "Data.Aeson.object" <> PP.line + <> PP.indent + 4 + ( "[" <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <> "," <> PP.line <> y) + [ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName field + | (field, _) <- orderedProperties + ] + ) + <> PP.line + <> "]" + ) + ) + + fromOptOrReq field + | HashSet.member field requiredProperties = "Data.Aeson..:" + | otherwise = "Data.Aeson..:?" + + fromJson = + "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" <> PP.line + <> PP.indent + 4 + ( "parseJSON" <+> "=" <+> "Data.Aeson.withObject" <+> "\"" <> toDataTypeName typName <> "\"" <+> "$" <+> "\\" <> "o" <+> "->" <> PP.line + <> PP.indent + 4 + ( toConstructorName typName <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ op <+> "o" <+> fromOptOrReq fieldName <+> "\"" <> toJsonFieldName fieldName <> "\"" + | (op, (fieldName, _)) <- zip ("<$>" : repeat "<*>") orderedProperties + ] + ) + ) + ) + in pure $ + PP.vsep + ( (map (<> PP.line) codeForInlineDependencies) + ++ [decl, mempty, toJson, mempty, fromJson] + ) + +codegenRequiredOptionalFieldType :: Bool -> Doc ann -> Doc ann +codegenRequiredOptionalFieldType True doc = doc +codegenRequiredOptionalFieldType False doc = "Data.Maybe.Maybe" <+> "(" <> doc <> ")" + +codegenFieldType :: Named Type -> Doc ann +codegenFieldType namedType = case namedType of + Named name _ -> toDataTypeName name + Unnamed typ -> case typ of + AllOf {} -> "error: allOf" + AnyOf {} -> "error: anyOf" + OneOf {} -> "error: oneOf" + Not {} -> "error: not" + Basic basicType -> case basicType of + TyString {} -> "Data.Text.Text" + TyEnum {} -> "error: Enum" + TyNumber -> "GHC.Types.Double" + TyInteger -> "GHC.Types.Int" + TyBoolean -> "GHC.Types.Bool" + Object objectType -> "Data.Aeson.Value" + Array elemType -> "[" <+> codegenFieldType elemType <+> "]" + +-- | Generate the Haskell code for enumeration types +codegenEnumeration :: Name -> [Text] -> Bool -> Doc ann +codegenEnumeration typName alternatives _includeNull = + let dataDecl = + "data" + <+> toDataTypeName typName + <> PP.line + <> PP.indent + 4 + ( "=" + <+> PP.concatWith + (\x y -> x <> PP.line <> "|" <+> y) + (map PP.pretty alternatives) + <> PP.line + <> "deriving" + <+> "(" <> "Eq" <> "," + <+> "Show" <> ")" + ) + toJSON = + "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" <> PP.line + <> PP.indent + 4 + ( "toJSON" <+> "x" <+> "=" <+> "case" <+> "x" <+> "of" <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ PP.pretty alt <+> "->" <+> "\"" <+> PP.pretty alt <+> "\"" + | alt <- alternatives + ] + ) + ) + fromJSON = + "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" <> PP.line + <> PP.indent + 4 + ( "parseJSON" <+> "=" <+> "withText" <+> "\"" <+> toDataTypeName typName <+> "\"" <+> "$" <+> "\\" <+> "s" <+> "->" <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> PP.pretty alt + | alt <- alternatives + ] + ) + ) + in PP.vsep [dataDecl, PP.line, toJSON, PP.line, fromJSON] diff --git a/src/Tie/Name.hs b/src/Tie/Name.hs new file mode 100644 index 0000000..cc8acb7 --- /dev/null +++ b/src/Tie/Name.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tie.Name + ( PackageName, + ApiName, + Name, + fromText, + cabalFileName, + toDataTypeName, + toOneOfDataTypeName, + toOneOfConstructorName, + toFunctionName, + toConstructorName, + toFieldName, + toJsonFieldName, + toParamName, + toParamBinder, + toApiTypeName, + toSchemaHaskellFileName, + toSchemaHaskellModuleName, + toOperationHaskellFileName, + toOperationHaskellModuleName, + toResponseHaskellFileName, + toResponseHaskellModuleName, + apiHaskellModuleName, + apiHaskellFileName, + responseHaskellModuleName, + responseHaskellFileName, + inlineObjectTypeName, + inlineVariantTypeName, + toApiResponseTypeName, + toApiResponseConstructorName, + toApiDefaultResponseConstructorName, + toApiMemberName, + ) +where + +import Data.Char (toLower, toUpper) +import qualified Data.Text as Text +import qualified Prettyprinter as PP + +-- | Name of the API to generate code for +type ApiName = Text + +-- | Cabal package name +type PackageName = Text + +-- | Names identify things in the OpenApi universe. Name's are coming directly +-- from the OpenApi spec. +newtype Name = Name {unName :: Text} + deriving (IsString, Eq, Ord, Show, Hashable) + +fromText :: Text -> Name +fromText = Name + +cabalFileName :: PackageName -> FilePath +cabalFileName packageName = + Text.unpack packageName <> ".cabal" + +apiHaskellModuleName :: ApiName -> Text +apiHaskellModuleName apiName = + apiName <> ".Api" + +apiHaskellFileName :: ApiName -> FilePath +apiHaskellFileName apiName = + Text.unpack apiName <> "/Api.hs" + +responseHaskellModuleName :: ApiName -> Text +responseHaskellModuleName apiName = + apiName <> ".Response" + +responseHaskellFileName :: ApiName -> FilePath +responseHaskellFileName apiName = + Text.unpack apiName <> "/Response.hs" + +toSchemaHaskellModuleName :: ApiName -> Name -> Text +toSchemaHaskellModuleName apiName (Name name) = + Text.pack $ Text.unpack apiName <> ".Schemas." <> capitalizeFirstLetter (Text.unpack name) + +toSchemaHaskellFileName :: ApiName -> Name -> FilePath +toSchemaHaskellFileName apiName (Name name) = + Text.unpack apiName <> "/Schemas/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs" + +toOperationHaskellModuleName :: ApiName -> Name -> Text +toOperationHaskellModuleName apiName (Name name) = + Text.pack $ Text.unpack apiName <> ".Api." <> capitalizeFirstLetter (Text.unpack name) + +toOperationHaskellFileName :: ApiName -> Name -> FilePath +toOperationHaskellFileName apiName (Name name) = + Text.unpack apiName <> "/Api/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs" + +toResponseHaskellModuleName :: ApiName -> Name -> Text +toResponseHaskellModuleName apiName (Name name) = + Text.pack $ Text.unpack apiName <> ".Response." <> capitalizeFirstLetter (Text.unpack name) + +toResponseHaskellFileName :: ApiName -> Name -> FilePath +toResponseHaskellFileName apiName (Name name) = + Text.unpack apiName <> "/Response/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs" + +toApiTypeName :: Name -> PP.Doc ann +toApiTypeName = + toDataTypeName + +toJsonFieldName :: Name -> PP.Doc ann +toJsonFieldName = PP.pretty . unName + +toDataTypeName :: Name -> PP.Doc ann +toDataTypeName = + PP.pretty . Text.pack . capitalizeFirstLetter . Text.unpack . unName + +toOneOfDataTypeName :: Name -> PP.Doc ann +toOneOfDataTypeName = + PP.pretty . Text.pack . capitalizeFirstLetter . Text.unpack . unName + +toOneOfConstructorName :: Name -> Name -> PP.Doc ann +toOneOfConstructorName (Name oneOfType) (Name variant) = + PP.pretty $ + Text.pack $ + escapeKeyword $ + capitalizeFirstLetter (Text.unpack oneOfType) + <> capitalizeFirstLetter (Text.unpack variant) + +toConstructorName :: Name -> PP.Doc ann +toConstructorName = toDataTypeName + +toFunctionName :: Name -> PP.Doc ann +toFunctionName = + PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName + +toFieldName :: Name -> PP.Doc ann +toFieldName = + PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName + +toParamName :: Name -> PP.Doc ann +toParamName = + PP.pretty . unName + +toParamBinder :: Name -> PP.Doc ann +toParamBinder = + PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName + +toApiMemberName :: Name -> PP.Doc ann +toApiMemberName = + PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName + +toApiResponseTypeName :: Name -> PP.Doc ann +toApiResponseTypeName = + PP.pretty . Text.pack . escapeKeyword . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName + +toApiResponseConstructorName :: Name -> Int -> PP.Doc ann +toApiResponseConstructorName name statusCode = + PP.pretty . Text.pack . escapeKeyword . (<> show statusCode) . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName $ name + +toApiDefaultResponseConstructorName :: Name -> PP.Doc ann +toApiDefaultResponseConstructorName name = + PP.pretty . Text.pack . escapeKeyword . (<> "DefaultResponse") . capitalizeFirstLetter . Text.unpack . unName $ name + +-- | Constructs a name for an object defined inline. Based on the containing data +-- type as well as the field name. +inlineObjectTypeName :: Name -> Name -> Name +inlineObjectTypeName (Name parentType) (Name fieldName) = + Name $ + Text.pack $ + escapeKeyword $ + capitalizeFirstLetter (Text.unpack parentType) + <> capitalizeFirstLetter (Text.unpack fieldName) + +-- | Construct a name for an inline type in a oneOf. +inlineVariantTypeName :: Name -> Int -> Name +inlineVariantTypeName (Name parentType) ith = + Name $ + Text.pack $ + escapeKeyword $ + capitalizeFirstLetter (Text.unpack parentType) <> "OneOf" <> show ith + +lowerFirstLetter :: String -> String +lowerFirstLetter [] = [] +lowerFirstLetter (x : xs) = toLower x : xs + +capitalizeFirstLetter :: String -> String +capitalizeFirstLetter [] = [] +capitalizeFirstLetter (x : xs) = toUpper x : xs + +escapeKeyword :: String -> String +escapeKeyword input = case input of + "type" -> "type'" + "class" -> "class'" + "where" -> "where'" + "case" -> "case'" + "of" -> "of'" + "data" -> "data'" + "import" -> "import'" + "qualified" -> "qualified'" + "as" -> "as'" + "instance" -> "instance'" + "module" -> "module'" + _ -> input diff --git a/src/Tie/Operation.hs b/src/Tie/Operation.hs new file mode 100644 index 0000000..9bdcde5 --- /dev/null +++ b/src/Tie/Operation.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Tie.Operation + ( StatusCode, + Param (..), + RequestBody (..), + Response (..), + Operation (..), + pathItemsToOperation, + operationToOperation, + + -- * Errors + Errors (..), + errors, + + -- * Path + Path, + PathSegment (..), + parsePath, + + -- * Dependencies + operationSchemaDependencies, + operationResponseDependencies, + ) +where + +import qualified Data.HashMap.Strict.InsOrd as InsOrd +import qualified Data.OpenApi as OpenApi +import qualified Data.Text as Text +import Tie.Name (Name, fromText) +import Tie.Resolve (Resolver, resolve) +import Tie.Type + ( Named, + Type, + isBasicType, + namedType, + namedTypeDependencies, + schemaRefToType, + ) +import Prelude hiding (Type) + +-- | HTTP Status code type +type StatusCode = Int + +-- | Request body descriptor +data RequestBody = RequestBody + { jsonRequestBodyContent :: Named Type + } + +-- | Response descriptor +data Response = Response + { -- | JSON schema of the response + jsonResponseContent :: Named Type + } + +-- | Internal representation of a path. +data PathSegment variable + = StaticSegment Text + | VariableSegment variable + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | Internal representation of a Path +type Path = [PathSegment Param] + +data ParamIn + = InPath + | InQuery + | InHeader + | InCookie + deriving (Eq, Ord, Show) + +data Param = Param + { name :: Name, + paramIn :: ParamIn, + schema :: Named Type, + required :: Bool + } + +-- | Internal representation for an 'OpenApi.Operation'. +data Operation = Operation + { -- | Name of the operation. Used for identifiers. + name :: Name, + -- | Path + path :: Path, + -- | HTTP method for this operation (Get, Post, Put, Delete) + method :: Text, + -- | Type of the request body (if any) for this 'Operation'. + requestBody :: Maybe RequestBody, + -- | Default response. + defaultResponse :: Maybe Response, + -- | Responses + responses :: [(StatusCode, Response)] + } + +data Errors m = Errors + { missingOperationId :: forall a. m a, + unsupportedMediaType :: forall a. m a, + requestBodyMissingSchema :: forall a. m a, + unknownParameter :: forall a. Text -> m a, + paramMissingSchema :: forall a. m a, + paramNotInPath :: forall a. m a, + paramNotBasicType :: forall a. m a + } + +errors :: Errors m +errors = + Errors + { missingOperationId = + error "missing operation id", + unsupportedMediaType = + error "unsupported media type", + requestBodyMissingSchema = + error "request body missing media type", + unknownParameter = + error "unknown parameter", + paramMissingSchema = + error "param missing schema", + paramNotInPath = + error "param not 'in path' type", + paramNotBasicType = + error "only basic types are supported for parameters" + } + +-- | Returns the dependencies on schemas of an operation. Parameterized so +-- that shallow vs. all transitive dependencies can be extracted. +operationSchemaDependencies :: (Named Type -> [Name]) -> Operation -> [Name] +operationSchemaDependencies getDependencies Operation {..} = + concat $ + [ getDependencies jsonRequestBodyContent + | Just RequestBody {jsonRequestBodyContent} <- [requestBody] + ] + ++ [ getDependencies jsonResponseContent + | Just Response {jsonResponseContent} <- [defaultResponse] + ] + ++ [ getDependencies jsonResponseContent + | (_, Response {jsonResponseContent}) <- responses + ] + +-- | Dependencies in the Response.* modules. +operationResponseDependencies :: Operation -> [Name] +operationResponseDependencies Operation {name} = [name] + +pathItemsToOperation :: + Monad m => + Resolver m -> + -- | Conversion error cases + Errors m -> + -- | URLs + [(FilePath, OpenApi.PathItem)] -> + m [Operation] +pathItemsToOperation resolver errors@Errors {..} pathInfos = do + items <- forM pathInfos $ \(path, OpenApi.PathItem {..}) -> do + get <- + forM _pathItemGet (operationToOperation resolver errors "GET" path _pathItemParameters) + put <- + forM _pathItemPut (operationToOperation resolver errors "PUT" path _pathItemParameters) + post <- + forM _pathItemPost (operationToOperation resolver errors "POST" path _pathItemParameters) + delete <- + forM _pathItemDelete (operationToOperation resolver errors "DELETE" path _pathItemParameters) + options <- + forM _pathItemOptions (operationToOperation resolver errors "OPTIONS" path _pathItemParameters) + head <- + forM _pathItemHead (operationToOperation resolver errors "HEAD" path _pathItemParameters) + patch <- + forM _pathItemPatch (operationToOperation resolver errors "PATCH" path _pathItemParameters) + trace <- + forM _pathItemTrace (operationToOperation resolver errors "TRACE" path _pathItemParameters) + pure (catMaybes [get, put, post, delete, options, head, patch, trace]) + pure (concat items) + +-- TODO name +operationToOperation :: + Monad m => + Resolver m -> + -- | Conversion error cases + Errors m -> + -- | HTTP Method + Text -> + -- | Path + FilePath -> + -- | Params defined at the PathItem level + [OpenApi.Referenced OpenApi.Param] -> + OpenApi.Operation -> + m Operation +operationToOperation resolver errors@Errors {..} method path params OpenApi.Operation {..} = do + operationId <- + whenNothing _operationOperationId missingOperationId + path <- + pathToPath + resolver + errors + path + -- Operations override pathItem params + (_operationParameters ++ params) + requestBody <- forM _operationRequestBody $ \referencedRequestBody -> do + requestBody <- resolve resolver referencedRequestBody + requestBodyToRequestBody resolver errors requestBody + defaultResponse <- forM (OpenApi._responsesDefault _operationResponses) $ \referencedResponse -> do + response <- resolve resolver referencedResponse + responseToResponse resolver errors response + responses <- forM (InsOrd.toList (OpenApi._responsesResponses _operationResponses)) $ \(statusCode, referencedResponse) -> do + response <- resolve resolver referencedResponse + (,) <$> pure statusCode <*> responseToResponse resolver errors response + pure + Operation + { name = fromText operationId, + .. + } + +requestBodyToRequestBody :: + Monad m => + Resolver m -> + Errors m -> + OpenApi.RequestBody -> + m RequestBody +requestBodyToRequestBody resolver Errors {..} requestBody = do + -- TODO support form inputs as well + OpenApi.MediaTypeObject {..} <- + whenNothing + (InsOrd.lookup "application/json" (OpenApi._requestBodyContent requestBody)) + unsupportedMediaType + referencedSchema <- + whenNothing + _mediaTypeObjectSchema + requestBodyMissingSchema + type_ <- + schemaRefToType resolver referencedSchema + pure + RequestBody + { jsonRequestBodyContent = type_ + } + +responseToResponse :: + Monad m => + Resolver m -> + Errors m -> + OpenApi.Response -> + m Response +responseToResponse resolver Errors {..} response = do + OpenApi.MediaTypeObject {..} <- + whenNothing + (InsOrd.lookup "application/json" (OpenApi._responseContent response)) + unsupportedMediaType + -- TODO take care of headers + referencedSchema <- + whenNothing + _mediaTypeObjectSchema + requestBodyMissingSchema + type_ <- + schemaRefToType resolver referencedSchema + pure + Response + { jsonResponseContent = type_ + } + +parsePath :: FilePath -> [PathSegment Text] +parsePath path = + let toPathSegment s + | Just s <- Text.stripPrefix "{" s, + Just s <- Text.stripSuffix "}" s = + VariableSegment s + | otherwise = + StaticSegment s + in case Text.splitOn "/" (toText path) of + -- leading / results in a leading empty string after split + "" : segments -> + map toPathSegment segments + segments -> + -- TODO this is probably an error + map toPathSegment segments + +paramToParam :: + Monad m => + Resolver m -> + Errors m -> + OpenApi.Param -> + m Param +paramToParam resolver Errors {..} OpenApi.Param {..} = do + schema <- whenNothing _paramSchema paramMissingSchema + typ <- schemaRefToType resolver schema + pure + Param + { name = fromText _paramName, + paramIn = case _paramIn of + OpenApi.ParamQuery -> InQuery + OpenApi.ParamHeader -> InHeader + OpenApi.ParamPath -> InPath + OpenApi.ParamCookie -> InCookie, + required = fromMaybe False _paramRequired, + schema = typ + } + +pathToPath :: + Monad m => + Resolver m -> + Errors m -> + -- | URL Path + FilePath -> + -- | Available 'OpenApi.Param's + [OpenApi.Referenced OpenApi.Param] -> + m Path +pathToPath resolver errors@Errors {..} textualPath availableParams = do + let path = parsePath textualPath + params <- traverse (resolve resolver) availableParams + forM path $ \segment -> + forM segment $ \paramName -> do + param <- + whenNothing + ( find + (\x -> OpenApi._paramName x == paramName) + params + ) + (unknownParameter paramName) + param <- paramToParam resolver errors param + when + (paramIn param /= InPath) + paramNotInPath + _ <- + whenNothing + (isBasicType (namedType (schema param))) + paramNotBasicType + pure param diff --git a/src/Tie/Resolve.hs b/src/Tie/Resolve.hs new file mode 100644 index 0000000..b455c8a --- /dev/null +++ b/src/Tie/Resolve.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Tie.Resolve + ( Resolvable, + Resolver, + newResolver, + resolve, + ) +where + +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashMap.Strict.InsOrd as InsOrd +import qualified Data.OpenApi as OpenApi +import qualified Data.Text as Text + +-- | Resolve an 'OpenApi.Reference' to the underlying component. +newtype Resolver m = Resolver + { resolve :: forall a. Resolvable a => OpenApi.Referenced a -> m a + } + +newResolver :: Applicative m => OpenApi.Components -> (forall a. OpenApi.Reference -> m a) -> Resolver m +newResolver components notFound = + Resolver (resolveComponent components notFound) + +type ComponentName = Text + +resolveComponent :: + (Applicative m, Resolvable a) => + -- | Inventory of components we can resolve to + OpenApi.Components -> + -- | What to do in case a 'OpenApi.Reference' is not found + (OpenApi.Reference -> m a) -> + -- | 'OpenApi.Reference' to resolve + OpenApi.Referenced a -> + m a +resolveComponent components notFound = \referenced -> do + let (componentType, resolveComponent) = resolvables + case referenced of + OpenApi.Inline a -> + pure a + OpenApi.Ref reference + | Just a <- + InsOrd.lookup + (OpenApi.getReference reference) + (resolveComponent components) -> + pure a + | otherwise -> + notFound reference + +-- | Helper class helping to dispatch from 'OpenApi.Referenced' to component type @a@. +class Resolvable a where + -- | Resolves the `OpenApi.Components` to the given corresponding `Definitions`. + resolvables :: (Text.Text, OpenApi.Components -> OpenApi.Definitions a) + +instance Resolvable OpenApi.Schema where + resolvables = ("schemas", OpenApi._componentsSchemas) + +instance Resolvable OpenApi.Response where + resolvables = ("responses", OpenApi._componentsResponses) + +instance Resolvable OpenApi.Param where + resolvables = ("parameters", OpenApi._componentsParameters) + +instance Resolvable OpenApi.Example where + resolvables = ("examples", OpenApi._componentsExamples) + +instance Resolvable OpenApi.RequestBody where + resolvables = ("requestBodies", OpenApi._componentsRequestBodies) diff --git a/src/Tie/Type.hs b/src/Tie/Type.hs new file mode 100644 index 0000000..e3193f2 --- /dev/null +++ b/src/Tie/Type.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Tie.Type + ( StringFormat (..), + BasicType (..), + ObjectType (..), + Type (..), + Enumeration (..), + Name, + Named (..), + namedType, + + -- * Conversion from 'OpenApi.Schema' to 'Type'. + schemaToType, + schemaRefToType, + + -- * Accessors and operators working with 'Type' + isBasicType, + isEnumType, + isArrayType, + isObjectType, + isOneOfType, + + -- * Normalize types + normalizeObjectType, + normalizeVariants, + + -- * Dependencies + namedTypeDependencies, + transitiveDependencies, + typeDependencies, + ) +where + +import Control.Monad.Writer (runWriterT, tell) +import qualified Data.Aeson as Aeson +import Data.Foldable (foldr1) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashMap.Strict.InsOrd as InsOrd +import qualified Data.HashSet as HashSet +import qualified Data.OpenApi as OpenApi +import qualified Data.Text as Text +import Tie.Name (Name, fromText) +import Tie.Resolve (Resolver, resolve) +import Prelude hiding (Type) + +-- | Formats a String can have +data StringFormat + = -- | Default for when there is no format defined in the type declaration. + FormatDefault + | -- | Full-date notation as defined by RFC 3339, section 5.6, for example, 2017-07-21 + FormatDate + | -- | The date-time notation as defined by RFC 3339, section 5.6, for example, 2017-07-21T17:32:28Z + FormatDateTime + | -- | A hint to UIs to mask the input + FormatPassword + | -- | base64-encoded characters, for example, U3dhZ2dlciByb2Nrcw== + FormatByte + | -- | binary data, used to describe files + FormatBinary + deriving (Eq, Show) + +-- | Represents an OpenAPI enumeration. +data Enumeration = Enumeration + { -- | The allowed values for this 'Enum'. + alternatives :: [Text], + -- | Whether 'null' is a valid 'Enum' value. + includeNull :: Bool + } + deriving (Eq, Show) + +-- | Basic types OpenAPI data types. +data BasicType + = TyString {format :: StringFormat} + | TyEnum Enumeration + | TyNumber + | TyInteger + | TyBoolean + deriving (Eq, Show) + +-- | An object is a collection of property/value pairs. +data ObjectType ty = ObjectType + { properties :: HashMap Name ty, + requiredProperties :: HashSet Name, + freeFormObjectType :: Bool + } + deriving (Eq, Show) + +-- | Our own version of 'OpenApi.Referenced'. +data Named ty + = Named Name ty + | Unnamed ty + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +namedType :: Named ty -> ty +namedType named = case named of + Named _ ty -> ty + Unnamed ty -> ty + +-- | This is our internal representation for 'OpenApi.Schema'. From 'Type' we derive +-- the Haskell data types as well as the serialization code. +data Type + = -- | OpenApi's allOf + AllOf [Named Type] + | -- | OpenApi's anyOf + AnyOf [Named Type] + | -- | OpenApi's oneOf + OneOf [Named Type] + | -- | OpenApi's not + Not (Named Type) + | -- | Basic, primitive types + Basic BasicType + | -- | Objects and it's properties + Object (ObjectType (Named Type)) + | -- | Arrays of elements + Array (Named Type) + deriving (Eq, Show) + +-- | Casts a 'Type' to a 'BasicType' if possible. +isBasicType :: Type -> Maybe BasicType +isBasicType typ = case typ of + AllOf [x] -> isBasicType (namedType x) + AllOf {} -> Nothing + AnyOf [x] -> isBasicType (namedType x) + AnyOf {} -> Nothing + OneOf [x] -> isBasicType (namedType x) + OneOf {} -> Nothing + Not {} -> Nothing + Basic basicType -> Just basicType + Object {} -> Nothing + Array {} -> Nothing + +-- | Casts a 'Type' to an 'Enumeration' if possible. +isEnumType :: Type -> Maybe Enumeration +isEnumType typ + | Just (TyEnum enum) <- isBasicType typ = + Just enum + | otherwise = + Nothing + +schemaRefToType :: + Monad m => + Resolver m -> + OpenApi.Referenced OpenApi.Schema -> + m (Named Type) +schemaRefToType resolver referencedSchema = do + schema <- resolve resolver referencedSchema + case referencedSchema of + OpenApi.Ref reference -> + Named (fromText (OpenApi.getReference reference)) + <$> schemaToType resolver schema + OpenApi.Inline schema -> do + Unnamed <$> schemaToType resolver schema + +-- | Converts an 'OpenApi.Schema' to our internal 'Type' representation. +-- An optional 'ComponentName' indicates the name of component. +schemaToType :: Monad m => Resolver m -> OpenApi.Schema -> m Type +schemaToType resolver schema + | Just allOfsRefs <- OpenApi._schemaAllOf schema = do + AllOf <$> traverse (schemaRefToType resolver) allOfsRefs + | Just oneOfsRefs <- OpenApi._schemaOneOf schema = + OneOf <$> traverse (schemaRefToType resolver) oneOfsRefs + | Just anyOfRefs <- OpenApi._schemaAnyOf schema = + AnyOf <$> traverse (schemaRefToType resolver) anyOfRefs + | Just notOfRef <- OpenApi._schemaNot schema = + Not <$> schemaRefToType resolver notOfRef + | Just schemaType <- OpenApi._schemaType schema = + case schemaType of + OpenApi.OpenApiString -> + pure (Basic (schemaToStringyType schema)) + OpenApi.OpenApiNumber -> + pure (Basic TyNumber) + OpenApi.OpenApiInteger -> + pure (Basic TyInteger) + OpenApi.OpenApiBoolean -> + pure (Basic TyBoolean) + OpenApi.OpenApiArray + | Just items <- OpenApi._schemaItems schema -> + case items of + OpenApi.OpenApiItemsObject itemsSchemaRef -> + Array <$> schemaRefToType resolver itemsSchemaRef + OpenApi.OpenApiItemsArray _itemsSchemaRefs -> + undefined -- TODO find out what tuple schemas are + | otherwise -> + undefined -- TODO array type without items + OpenApi.OpenApiNull -> + undefined -- TODO need a BasicType for that + OpenApi.OpenApiObject -> + Object <$> schemaToObjectType resolver schema + -- Heuristic: if the 'OpenApi.Schema' has properties attached + -- treat it as object. + | not (InsOrd.null (OpenApi._schemaProperties schema)) = + Object <$> schemaToObjectType resolver schema + -- It's an enum but without explicit "type: string" + | Just _enum <- OpenApi._schemaEnum schema = + pure (Basic (schemaToStringyType schema)) + | otherwise = + traceShow schema undefined + +-- | Resolves an 'OpenApi.Schema' to an 'ObjectType'. In case the the 'OpenApi.Schema' is an +-- allOf-schema. This function doesn't do any additional type checking. +schemaToObjectType :: + Monad m => + Resolver m -> + OpenApi.Schema -> + m (ObjectType (Named Type)) +schemaToObjectType resolver schema = do + properties <- + traverse + (schemaRefToType resolver) + (InsOrd.toHashMap (OpenApi._schemaProperties schema)) + freeFormObjectType <- case OpenApi._schemaAdditionalProperties schema of + Nothing -> pure False + Just (OpenApi.AdditionalPropertiesAllowed allowed) -> pure allowed + Just (OpenApi.AdditionalPropertiesSchema schema) -> undefined -- TODO what exactly is this? + pure $ + ObjectType + { freeFormObjectType, + properties = HashMap.mapKeys fromText properties, + requiredProperties = + HashSet.fromList (map fromText (OpenApi._schemaRequired schema)) + } + +-- | Treat an 'OpenApi.Schema' as stringy. Accounts for enumerations +-- as well. This function doesn't do any additional type checking. +schemaToStringyType :: OpenApi.Schema -> BasicType +schemaToStringyType schema + | Just enum <- OpenApi._schemaEnum schema = do + TyEnum $ + Enumeration + { alternatives = [alt | Aeson.String alt <- enum], + includeNull = Aeson.Null `elem` enum + } + | otherwise = + TyString + { format = FormatDefault -- TODO + } + +-- | Extracts the shallow dependencies of a 'Type' by traversing the 'Type' and +-- until we hit a 'Named' type. +typeDependencies :: (Named Type -> [Name]) -> Type -> [Name] +typeDependencies getDependencies ty = + -- For allOf, anyOf, oneOf look through all the dependencies - similar to what + -- we do in 'isObjectType'. + case ty of + AllOf allOfs -> + concatMap getDependencies allOfs + AnyOf anyOfs -> + concatMap getDependencies anyOfs + OneOf oneOfs -> + concatMap getDependencies oneOfs + Not not -> + typeDependencies getDependencies (namedType not) + Basic {} -> + [] + Object objectType -> + objectTypeDependencies getDependencies objectType + Array elemType -> + getDependencies elemType + +-- | Dependencies of a 'Named Type'. This doesn't return transitive +-- dependencies. +namedTypeDependencies :: Named Type -> [Name] +namedTypeDependencies named = case named of + Named name _elem -> + -- This is key: We don't want to descend into elem's type. + [name] + Unnamed elem -> + typeDependencies namedTypeDependencies elem + +-- | Extract all the transitive dependencies form a 'Named Type'. +transitiveDependencies :: Named Type -> [Name] +transitiveDependencies named = case named of + Named name typ -> + name : typeDependencies transitiveDependencies typ + Unnamed typ -> + typeDependencies transitiveDependencies typ + +-- | Dependencies of an 'ObjectType'. +objectTypeDependencies :: (Named Type -> [Name]) -> ObjectType (Named Type) -> [Name] +objectTypeDependencies getDependencies objectType = + concatMap getDependencies (toList (properties objectType)) + +-- | Casting a 'Type' to the set of types it could be. +isOneOfType :: Type -> Maybe [Named Type] +isOneOfType ty = case ty of + OneOf oneOfs -> + Just oneOfs + _ -> + Nothing + +isArrayType :: Type -> Maybe (Named Type) +isArrayType ty = case ty of + Array elem -> Just elem + _ -> Nothing + +-- | Casting a 'Type' to an 'ObjectType', if possible. `isObjectType` looks through +-- allOf, oneOf, anyOf to ensure +isObjectType :: Type -> Maybe (ObjectType (Named Type)) +isObjectType ty = case ty of + AllOf allOfs -> do + -- We have the choice: we could use traverse instead and fail + -- everything in case any subtype is not an Object. For now, + -- we ignore "type errors" and collect everything we get. I + -- found other code generators for OpenApi that behave that way. + let objects = catMaybes (map (isObjectType . namedType) allOfs) + pure (combine objects) + AnyOf anyOfs -> do + -- Look through all the objects, mark all of the properties optional + let objects = + [ object {requiredProperties = HashSet.empty} + | object <- catMaybes (map (isObjectType . namedType) anyOfs) + ] + pure (combine objects) + OneOf oneOfs -> do + -- Look through all the objects, mark all of the properties optional + let objects = + [ object {requiredProperties = HashSet.empty} + | object <- catMaybes (map (isObjectType . namedType) oneOfs) + ] + pure (combine objects) + Not {} -> Nothing + Basic {} -> Nothing + Object obj -> Just obj + Array {} -> Nothing + where + -- In principle this is Semigroup and Monoid instance. But it's too + -- early in the design to rely on that. + combine xs = case nonEmpty xs of + Nothing -> emptyObject + Just os -> foldr1 combineObjects os -- TODO make strict + emptyObject = + ObjectType + { properties = mempty, + requiredProperties = mempty, + freeFormObjectType = False + } + + -- Combine two ObjectTypes. Doesn't report common fields! + combineObjects o1 o2 = + ObjectType + { properties = properties o1 <> properties o2, + requiredProperties = requiredProperties o1 <> requiredProperties o2, + freeFormObjectType = freeFormObjectType o1 || freeFormObjectType o2 + } + +-- | OpenApi allows defining objects "inline". This function extracts inline objects +-- and assigns names to them. +-- +-- Invariant: The returned 'ObjectType' doesn't contain unnamed dependencies. +normalizeObjectType :: + Monad m => + (Name -> ObjectType (Named Type) -> m Name) -> + ObjectType (Named Type) -> + m (ObjectType (Named Type), [(Name, Type)]) +normalizeObjectType assignName objectType@ObjectType {..} = do + (properties, newTypes) <- runWriterT $ + flip HashMap.traverseWithKey properties $ \fieldName fieldType -> + -- TODO we will probably have to handle enums here as well + case fieldType of + Unnamed typ + | Just objectType <- isObjectType typ -> do + name <- lift (assignName fieldName objectType) + tell [(name, Object objectType)] + pure (Named name (Object objectType)) + -- TODO we need to recurse, otherwise we only support + -- one level deep arrays. + | Array (Unnamed elemType) <- typ, + Just objectType <- isObjectType elemType -> do + name <- lift (assignName fieldName objectType) + tell [(name, Object objectType)] + pure (Named name (Object objectType)) + _ -> + pure fieldType + pure (objectType {properties}, newTypes) + +-- | Walk through the variants of a oneOf type. This function extracts inline objects +-- and assigns names to them. +-- +-- Invariant: The returned variants don't contain unnamed dependencies. +normalizeVariants :: + Monad m => + (Int -> Type -> m Name) -> + [Named Type] -> + m ([Named Type], [(Name, Type)]) +normalizeVariants assignName variants = runWriterT $ + forM (zip [1 ..] variants) $ \(i, variant) -> do + -- TODO we will probably have to handle enums here as well + case variant of + Unnamed typ + | Just objectType <- isObjectType typ -> do + let typ = Object objectType + name <- lift (assignName i typ) + tell [(name, typ)] + pure (Named name typ) + -- TODO we need to recurse, otherwise we only support + -- one level deep arrays. + | Array (Unnamed elemType) <- typ, + Just objectType <- isObjectType elemType -> do + let typ = Object objectType + name <- lift (assignName i typ) + tell [(name, typ)] + pure (Named name typ) + _ -> + pure variant diff --git a/src/Tie/Writer.hs b/src/Tie/Writer.hs new file mode 100644 index 0000000..e3d5d8d --- /dev/null +++ b/src/Tie/Writer.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Tie.Writer + ( Writer, + fileWriter, + withTestWriter, + ) +where + +import Data.ByteString.Builder (Builder, writeFile) +import Data.Text.Lazy.Encoding (encodeUtf8Builder) +import Prettyprinter (Doc, (<+>)) +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Text as PP +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory, ()) + +-- | Abstraction for storing generated code on disk. +type Writer m = forall ann. FilePath -> Doc ann -> m () + +-- | Renders a 'Doc' to a 'Builder' - ready to be written to disk. +-- TODO move somewhere else +render :: Doc ann -> Builder +render = + encodeUtf8Builder . PP.renderLazy . PP.layoutPretty PP.defaultLayoutOptions + +-- | Renders 'Doc's to a file just as you would expect. Writes files relative +-- to the given output directory. +fileWriter :: MonadIO m => FilePath -> Writer m +fileWriter outputDirectory path doc = liftIO $ do + let fullPath = outputDirectory path + createDirectoryIfMissing True (takeDirectory fullPath) + Data.ByteString.Builder.writeFile fullPath (render doc) + +-- | Collects all the FilePath and Doc pairs and returns them concatenated +-- in one output +withTestWriter :: MonadIO m => (Writer m -> m a) -> m (a, Builder) +withTestWriter action = do + ref <- liftIO (newIORef []) + result <- action $ \file doc -> + liftIO (modifyIORef' ref ((file, PP.unAnnotate doc) :)) + docs <- liftIO (readIORef ref) + pure (result, renderOneBigFile (sortOn fst docs)) + where + renderOneBigFile docs = + render $ + PP.concatWith + (\x y -> x <> PP.line <> "---------------------" <> PP.line <> y) + [ PP.vsep + [ PP.pretty (toText file), + mempty, + doc + ] + | (file, doc) <- docs + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..327adf4 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/test/Test/Tie/Golden.hs b/test/Test/Tie/Golden.hs new file mode 100644 index 0000000..838ff0c --- /dev/null +++ b/test/Test/Tie/Golden.hs @@ -0,0 +1,26 @@ +module Test.Tie.Golden (test_Golden_tests) where + +import Data.ByteString.Builder (toLazyByteString) +import Paths_tie (getDataDir) +import System.FilePath (normalise, replaceExtension, ()) +import Test.Tasty (TestTree) +import Test.Tasty.Golden (findByExtension, goldenVsStringDiff) +import Tie (generate, withTestWriter) + +test_Golden_tests :: IO [TestTree] +test_Golden_tests = do + dataDir <- getDataDir + inputs <- findByExtension [".yaml"] (dataDir "test" "golden") + pure + [ goldenVsStringDiff + ("Test " <> input) + (\ref new -> ["diff", "-u", ref, new]) + (replaceExtension input ".yaml.out") + ( do + (_, output) <- withTestWriter $ \writer -> + generate writer input + pure (toLazyByteString output) + ) + | input' <- inputs, + let input = normalise input' + ] diff --git a/test/Test/Tie/Operation.hs b/test/Test/Tie/Operation.hs new file mode 100644 index 0000000..b220c3b --- /dev/null +++ b/test/Test/Tie/Operation.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Tie.Operation where + +import Test.Hspec (Spec, context, it, shouldBe) +import Test.Tasty.Hspec +import Tie.Operation (PathSegment (..), parsePath) + +spec_parsePath :: Spec +spec_parsePath = do + it "parses /users/create" $ + parsePath "/users/create" `shouldBe` [StaticSegment "users", StaticSegment "create"] + it "parses /users/{id}" $ + parsePath "/users/{id}" `shouldBe` [StaticSegment "users", VariableSegment "id"] + it "parses /users/{id}/address" $ + parsePath "/users/{id}/address" `shouldBe` [StaticSegment "users", VariableSegment "id", StaticSegment "address"] diff --git a/test/golden/lists.yaml b/test/golden/lists.yaml new file mode 100644 index 0000000..6addfbb --- /dev/null +++ b/test/golden/lists.yaml @@ -0,0 +1,47 @@ +openapi: "3.0.0" +info: + version: 1.0.0 + title: Scarf + license: + name: AllRightsReserved +servers: + - url: https://scarf.sh/api/v1 +paths: + /packages: + get: + summary: List all packages + operationId: listPackages + tags: + - packages + responses: + '200': + description: An array of packages + content: + application/json: + schema: + $ref: "#/components/schemas/Packages" + /packages2: + get: + summary: List all packages + operationId: listPackages2 + tags: + - packages + responses: + '200': + description: An inline array of packages + content: + application/json: + schema: + type: array + items: + $ref: "#/components/schemas/Package" +components: + schemas: + Package: + properties: + name: + type: string + Packages: + type: array + items: + $ref: "#/components/schemas/Package" diff --git a/test/golden/lists.yaml.out b/test/golden/lists.yaml.out new file mode 100644 index 0000000..50a1838 --- /dev/null +++ b/test/golden/lists.yaml.out @@ -0,0 +1,233 @@ +OpenAPI/Api.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Api where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Response + +import OpenAPI.Schemas.Packages +import OpenAPI.Schemas.Package + +import OpenAPI.Response.ListPackages +import OpenAPI.Response.ListPackages2 + +data Api m = Api { + listPackages :: m ListPackagesResponse, + listPackages2 :: m ListPackages2Response +} + +application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application +application run api notFound request respond = + case Network.Wai.pathInfo request of + [ "packages" ] -> + case Network.Wai.requestMethod request of + "GET" -> + run request $ do + response <- listPackages api + Control.Monad.IO.Class.liftIO (respond (toResponse response)) + x -> + unsupportedMethod x + + [ "packages2" ] -> + case Network.Wai.requestMethod request of + "GET" -> + run request $ do + response <- listPackages2 api + Control.Monad.IO.Class.liftIO (respond (toResponse response)) + x -> + unsupportedMethod x + + _ -> + notFound request respond + where + unsupportedMethod _ = + respond (Network.Wai.responseBuilder (toEnum 405) [] mempty) + invalidRequest _ = + respond (Network.Wai.responseBuilder (toEnum 401) [] mempty) +--------------------- +OpenAPI/Response.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Response where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +class ToResponse a where + toResponse :: a -> Network.Wai.Response +--------------------- +OpenAPI/Response/ListPackages.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Response.ListPackages where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Packages + +data ListPackagesResponse + = ListPackagesResponse200 Packages + +instance ToResponse ListPackagesResponse where + toResponse (ListPackagesResponse200 x) = + Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) +--------------------- +OpenAPI/Response/ListPackages2.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Response.ListPackages2 where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Package + +data ListPackages2Response + = ListPackages2Response200 [ Package ] + +instance ToResponse ListPackages2Response where + toResponse (ListPackages2Response200 x) = + Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) +--------------------- +OpenAPI/Schemas/Package.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.Package where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + + + +newtype Package = Package + { + name :: Data.Maybe.Maybe (Data.Text.Text) + } + +instance Data.Aeson.ToJSON Package where + toJSON Package {..} = Data.Aeson.object + [ + "name" Data.Aeson..= name + ] + +instance Data.Aeson.FromJSON Package where + parseJSON = Data.Aeson.withObject "Package" $ \o -> + Package + <$> o Data.Aeson..:? "name" +--------------------- +OpenAPI/Schemas/Packages.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.Packages where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Package + + +--------------------- +open-api.cabal + +cabal-version: 3.0 +name: open-api +version: 0.1.0.0 +library + build-depends: + , aeson + , attoparsec + , base + , ghc-prim + , http-api-data + , http-types + , text + , wai + exposed-modules: + OpenAPI.Api + OpenAPI.Response + OpenAPI.Response.ListPackages + OpenAPI.Response.ListPackages2 + OpenAPI.Schemas.Package + OpenAPI.Schemas.Packages \ No newline at end of file diff --git a/test/golden/oneof.yaml b/test/golden/oneof.yaml new file mode 100644 index 0000000..2be9b7e --- /dev/null +++ b/test/golden/oneof.yaml @@ -0,0 +1,32 @@ +openapi: "3.0.0" +info: + version: 1.0.0 + title: Scarf + license: + name: AllRightsReserved +servers: + - url: https://scarf.sh/api/v1 +paths: + /packages: + get: + summary: List all packages + operationId: listPackages + tags: + - packages + responses: + '200': + description: An array of packages + content: + application/json: + schema: + $ref: "#/components/schemas/Packages" +components: + schemas: + Package: + properties: + name: + type: string + Packages: + oneOf: + - $ref: "#/components/schemas/Package" + - $ref: "#/components/schemas/Package" \ No newline at end of file diff --git a/test/golden/oneof.yaml.out b/test/golden/oneof.yaml.out new file mode 100644 index 0000000..d94fed5 --- /dev/null +++ b/test/golden/oneof.yaml.out @@ -0,0 +1,201 @@ +OpenAPI/Api.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Api where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Response + +import OpenAPI.Schemas.Packages + +import OpenAPI.Response.ListPackages + +data Api m = Api { + listPackages :: m ListPackagesResponse +} + +application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application +application run api notFound request respond = + case Network.Wai.pathInfo request of + [ "packages" ] -> + case Network.Wai.requestMethod request of + "GET" -> + run request $ do + response <- listPackages api + Control.Monad.IO.Class.liftIO (respond (toResponse response)) + x -> + unsupportedMethod x + + _ -> + notFound request respond + where + unsupportedMethod _ = + respond (Network.Wai.responseBuilder (toEnum 405) [] mempty) + invalidRequest _ = + respond (Network.Wai.responseBuilder (toEnum 401) [] mempty) +--------------------- +OpenAPI/Response.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Response where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +class ToResponse a where + toResponse :: a -> Network.Wai.Response +--------------------- +OpenAPI/Response/ListPackages.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Response.ListPackages where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Packages + +data ListPackagesResponse + = ListPackagesResponse200 Packages + +instance ToResponse ListPackagesResponse where + toResponse (ListPackagesResponse200 x) = + Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) +--------------------- +OpenAPI/Schemas/Package.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.Package where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + + + +newtype Package = Package + { + name :: Data.Maybe.Maybe (Data.Text.Text) + } + +instance Data.Aeson.ToJSON Package where + toJSON Package {..} = Data.Aeson.object + [ + "name" Data.Aeson..= name + ] + +instance Data.Aeson.FromJSON Package where + parseJSON = Data.Aeson.withObject "Package" $ \o -> + Package + <$> o Data.Aeson..:? "name" +--------------------- +OpenAPI/Schemas/Packages.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.Packages where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Package + +data Packages + = PackagesPackage Package + | PackagesPackage Package + +instance Data.Aeson.ToJSON Packages where + toJSON (PackagesPackage x) = Data.Aeson.toJSON x + toJSON (PackagesPackage x) = Data.Aeson.toJSON x + +instance Data.Aeson.FromJSON Packages where + parseJSON x = + (PackagesPackage <$> Data.Aeson.parseJSON x) Control.Applicative.<|> + (PackagesPackage <$> Data.Aeson.parseJSON x) +--------------------- +open-api.cabal + +cabal-version: 3.0 +name: open-api +version: 0.1.0.0 +library + build-depends: + , aeson + , attoparsec + , base + , ghc-prim + , http-api-data + , http-types + , text + , wai + exposed-modules: + OpenAPI.Api + OpenAPI.Response + OpenAPI.Response.ListPackages + OpenAPI.Schemas.Package + OpenAPI.Schemas.Packages \ No newline at end of file diff --git a/test/golden/test1.yaml b/test/golden/test1.yaml new file mode 100644 index 0000000..28b711d --- /dev/null +++ b/test/golden/test1.yaml @@ -0,0 +1,145 @@ +openapi: "3.0.0" +info: + version: 1.0.0 + title: simple_violation_bool + license: + name: MIT + description: | + Simple violation in simple_violation_bool module +servers: + - url: https://swagger.io/specification/ +paths: + /users/{id}/create/{name}: + parameters: + - in: path + name: id + schema: + type: integer + required: true + - in: path + name: name + schema: + type: string + required: true + post: + operationId: getUsers + summary: Adds a new user + requestBody: + content: + application/json: + schema: # Request body contents + $ref: "#/components/schemas/NISE" + responses: + '200': + description: xxxx + content: + application/json: + schema: # Request body contents + $ref: "#/components/schemas/Vehicle" +components: + schemas: + Vehicle: + type: object + required: + - id + - type + properties: + id: + type: integer + type: + type: string + model: + type: string + name: + type: string + + Car: + allOf: + - $ref: "#/components/schemas/Vehicle" + - type: object + properties: + type: + enum: + - car + has_4_wheel_drive: + type: boolean + + Plane: + anyOf: + - $ref: "#/components/schemas/Vehicle" + - type: object + properties: + type: + enum: + - plane + car: + $ref: "#/components/schemas/Car" + has_reactor: + type: boolean + nb_passengers: + type: integer + + Error: + required: + - code + - message + properties: + code: + type: integer + format: int32 + message: + type: string + + PackageId: + oneOf: + - $ref: "#/components/schemas/Plane" + - $ref: "#/components/schemas/Car" + - type: integer + - properties: + name: + type: string + + NISE: + type: object + title: The Root Schema + required: + - description + - id + - name + - ports + properties: + description: + $ref: "#/components/schemas/PackageId" + id: + type: integer + title: The Id Schema + default: 0 + format: int64 + schema: + $ref: './violation_schema.yaml#/NISE' + name: + type: string + title: The Name Schema + schema: + $ref: './violation_schema.yaml#/NISE' + ports: + type: array + title: The Ports Schema + schema: + $ref: './violation_schema.yaml#/NISE' + items: + type: integer + title: The items Schema + default: 0 + schema: + $ref: './violation_schema.yaml#/NISE' + value: + type: object + title: The Value Schema + properties: + name: + type: string + schema: + $ref: './violation_schema.yaml#/NISE' + + diff --git a/test/golden/test1.yaml.out b/test/golden/test1.yaml.out new file mode 100644 index 0000000..28f6a00 --- /dev/null +++ b/test/golden/test1.yaml.out @@ -0,0 +1,427 @@ +OpenAPI/Api.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Api where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Response + +import OpenAPI.Schemas.NISE +import OpenAPI.Schemas.Vehicle + +import OpenAPI.Response.GetUsers + +data Api m = Api { + getUsers :: GHC.Types.Int -> Data.Text.Text -> NISE -> m GetUsersResponse +} + +application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application +application run api notFound request respond = + case Network.Wai.pathInfo request of + [ "users", id, "create", name ] -> + case Web.HttpApiData.parseUrlPiece id of + Left _ -> invalidRequest "id" + Right id -> + case Web.HttpApiData.parseUrlPiece name of + Left _ -> invalidRequest "name" + Right name -> + case Network.Wai.requestMethod request of + "POST" -> + do result <- Data.Attoparsec.ByteString.parseWith (Network.Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty + case Data.Attoparsec.ByteString.eitherResult result of + Left _err -> undefined + Right bodyValue -> + case Data.Aeson.Types.parseEither Data.Aeson.parseJSON bodyValue of + Left _err -> undefined + Right body -> + run request $ do + response <- getUsers api id name body + Control.Monad.IO.Class.liftIO (respond (toResponse response)) + x -> + unsupportedMethod x + + _ -> + notFound request respond + where + unsupportedMethod _ = + respond (Network.Wai.responseBuilder (toEnum 405) [] mempty) + invalidRequest _ = + respond (Network.Wai.responseBuilder (toEnum 401) [] mempty) +--------------------- +OpenAPI/Response.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Response where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +class ToResponse a where + toResponse :: a -> Network.Wai.Response +--------------------- +OpenAPI/Response/GetUsers.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Response.GetUsers where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.NISE +import OpenAPI.Schemas.Vehicle + +data GetUsersResponse + = GetUsersResponse200 Vehicle + +instance ToResponse GetUsersResponse where + toResponse (GetUsersResponse200 x) = + Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) +--------------------- +OpenAPI/Schemas/Car.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.Car where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Vehicle + +data Car = Car + { + has_4_wheel_drive :: Data.Maybe.Maybe (GHC.Types.Bool), + id :: GHC.Types.Int, + model :: Data.Maybe.Maybe (Data.Text.Text), + name :: Data.Maybe.Maybe (Data.Text.Text), + type' :: Data.Text.Text + } + +instance Data.Aeson.ToJSON Car where + toJSON Car {..} = Data.Aeson.object + [ + "has_4_wheel_drive" Data.Aeson..= has_4_wheel_drive, + "id" Data.Aeson..= id, + "model" Data.Aeson..= model, + "name" Data.Aeson..= name, + "type" Data.Aeson..= type' + ] + +instance Data.Aeson.FromJSON Car where + parseJSON = Data.Aeson.withObject "Car" $ \o -> + Car + <$> o Data.Aeson..:? "has_4_wheel_drive" + <*> o Data.Aeson..: "id" + <*> o Data.Aeson..:? "model" + <*> o Data.Aeson..:? "name" + <*> o Data.Aeson..: "type" +--------------------- +OpenAPI/Schemas/NISE.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.NISE where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.PackageId + +newtype NISEValue = NISEValue + { + name :: Data.Maybe.Maybe (Data.Text.Text) + } + +instance Data.Aeson.ToJSON NISEValue where + toJSON NISEValue {..} = Data.Aeson.object + [ + "name" Data.Aeson..= name + ] + +instance Data.Aeson.FromJSON NISEValue where + parseJSON = Data.Aeson.withObject "NISEValue" $ \o -> + NISEValue + <$> o Data.Aeson..:? "name" + +data NISE = NISE + { + description :: PackageId, + id :: GHC.Types.Int, + name :: Data.Text.Text, + ports :: [ GHC.Types.Int ], + value :: Data.Maybe.Maybe (NISEValue) + } + +instance Data.Aeson.ToJSON NISE where + toJSON NISE {..} = Data.Aeson.object + [ + "description" Data.Aeson..= description, + "id" Data.Aeson..= id, + "name" Data.Aeson..= name, + "ports" Data.Aeson..= ports, + "value" Data.Aeson..= value + ] + +instance Data.Aeson.FromJSON NISE where + parseJSON = Data.Aeson.withObject "NISE" $ \o -> + NISE + <$> o Data.Aeson..: "description" + <*> o Data.Aeson..: "id" + <*> o Data.Aeson..: "name" + <*> o Data.Aeson..: "ports" + <*> o Data.Aeson..:? "value" +--------------------- +OpenAPI/Schemas/PackageId.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.PackageId where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Car +import OpenAPI.Schemas.Plane + +newtype PackageIdOneOf4 = PackageIdOneOf4 + { + name :: Data.Maybe.Maybe (Data.Text.Text) + } + +instance Data.Aeson.ToJSON PackageIdOneOf4 where + toJSON PackageIdOneOf4 {..} = Data.Aeson.object + [ + "name" Data.Aeson..= name + ] + +instance Data.Aeson.FromJSON PackageIdOneOf4 where + parseJSON = Data.Aeson.withObject "PackageIdOneOf4" $ \o -> + PackageIdOneOf4 + <$> o Data.Aeson..:? "name" + +data PackageId + = PackageIdPlane Plane + | PackageIdCar Car + | PackageIdPackageIdOneOf3 GHC.Types.Int + | PackageIdPackageIdOneOf4 PackageIdOneOf4 + +instance Data.Aeson.ToJSON PackageId where + toJSON (PackageIdPlane x) = Data.Aeson.toJSON x + toJSON (PackageIdCar x) = Data.Aeson.toJSON x + toJSON (PackageIdPackageIdOneOf3 x) = Data.Aeson.toJSON x + toJSON (PackageIdPackageIdOneOf4 x) = Data.Aeson.toJSON x + +instance Data.Aeson.FromJSON PackageId where + parseJSON x = + (PackageIdPlane <$> Data.Aeson.parseJSON x) Control.Applicative.<|> + (PackageIdCar <$> Data.Aeson.parseJSON x) Control.Applicative.<|> + (PackageIdPackageIdOneOf3 <$> Data.Aeson.parseJSON x) Control.Applicative.<|> + (PackageIdPackageIdOneOf4 <$> Data.Aeson.parseJSON x) +--------------------- +OpenAPI/Schemas/Plane.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.Plane where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import OpenAPI.Schemas.Car +import OpenAPI.Schemas.Vehicle + +data Plane = Plane + { + car :: Data.Maybe.Maybe (Car), + has_reactor :: Data.Maybe.Maybe (GHC.Types.Bool), + id :: Data.Maybe.Maybe (GHC.Types.Int), + model :: Data.Maybe.Maybe (Data.Text.Text), + name :: Data.Maybe.Maybe (Data.Text.Text), + nb_passengers :: Data.Maybe.Maybe (GHC.Types.Int), + type' :: Data.Maybe.Maybe (Data.Text.Text) + } + +instance Data.Aeson.ToJSON Plane where + toJSON Plane {..} = Data.Aeson.object + [ + "car" Data.Aeson..= car, + "has_reactor" Data.Aeson..= has_reactor, + "id" Data.Aeson..= id, + "model" Data.Aeson..= model, + "name" Data.Aeson..= name, + "nb_passengers" Data.Aeson..= nb_passengers, + "type" Data.Aeson..= type' + ] + +instance Data.Aeson.FromJSON Plane where + parseJSON = Data.Aeson.withObject "Plane" $ \o -> + Plane + <$> o Data.Aeson..:? "car" + <*> o Data.Aeson..:? "has_reactor" + <*> o Data.Aeson..:? "id" + <*> o Data.Aeson..:? "model" + <*> o Data.Aeson..:? "name" + <*> o Data.Aeson..:? "nb_passengers" + <*> o Data.Aeson..:? "type" +--------------------- +OpenAPI/Schemas/Vehicle.hs + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module OpenAPI.Schemas.Vehicle where + +import qualified Control.Applicative +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Parser +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.Maybe +import qualified Data.Text +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + + + +data Vehicle = Vehicle + { + id :: GHC.Types.Int, + model :: Data.Maybe.Maybe (Data.Text.Text), + name :: Data.Maybe.Maybe (Data.Text.Text), + type' :: Data.Text.Text + } + +instance Data.Aeson.ToJSON Vehicle where + toJSON Vehicle {..} = Data.Aeson.object + [ + "id" Data.Aeson..= id, + "model" Data.Aeson..= model, + "name" Data.Aeson..= name, + "type" Data.Aeson..= type' + ] + +instance Data.Aeson.FromJSON Vehicle where + parseJSON = Data.Aeson.withObject "Vehicle" $ \o -> + Vehicle + <$> o Data.Aeson..: "id" + <*> o Data.Aeson..:? "model" + <*> o Data.Aeson..:? "name" + <*> o Data.Aeson..: "type" +--------------------- +open-api.cabal + +cabal-version: 3.0 +name: open-api +version: 0.1.0.0 +library + build-depends: + , aeson + , attoparsec + , base + , ghc-prim + , http-api-data + , http-types + , text + , wai + exposed-modules: + OpenAPI.Api + OpenAPI.Response + OpenAPI.Response.GetUsers + OpenAPI.Schemas.Car + OpenAPI.Schemas.NISE + OpenAPI.Schemas.PackageId + OpenAPI.Schemas.Plane + OpenAPI.Schemas.Vehicle \ No newline at end of file diff --git a/tie.cabal b/tie.cabal new file mode 100644 index 0000000..d919d63 --- /dev/null +++ b/tie.cabal @@ -0,0 +1,113 @@ +cabal-version: 3.6 +name: tie +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: + +-- The package author(s). +-- author: + +-- An email address to which users can send suggestions, bug reports, and patches. +-- maintainer: + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +data-files: + test/golden/**/*.yaml + test/golden/**/*.out + +library + exposed-modules: Tie + Tie.Resolve + Tie.Type + Tie.Operation + Tie.Codegen.Imports + Tie.Codegen.Operation + Tie.Codegen.Response + Tie.Codegen.Schema + Tie.Name + Tie.Codegen.Cabal + Tie.Writer + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: aeson, + base, + bytestring >= 0.11.2.0, + containers, + text, + directory, + filepath, + lens, + mtl, + openapi3, + unordered-containers, + insert-ordered-containers, + prettyprinter, + yaml, + relude + + mixins: + base hiding (Prelude), + relude (Relude as Prelude), + relude + + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tie-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + + autogen-modules: + Paths_tie + + other-modules: + Paths_tie + + other-modules: + Test.Tie.Golden + Test.Tie.Operation + + build-depends: + , aeson + , base + , bytestring + , containers + , filepath + , hspec + , tasty-hspec + , tasty + , tasty-golden + , openapi3 + , tasty-hunit + , tie + , text + , prettyprinter + , relude + , insert-ordered-containers + , yaml + + mixins: + base hiding (Prelude), + relude (Relude as Prelude), + relude + + build-tool-depends: tasty-discover:tasty-discover + hs-source-dirs: test \ No newline at end of file