From e4b24905714f5ab2f749e4b60459750f4d1e58b9 Mon Sep 17 00:00:00 2001 From: David Vollbracht Date: Wed, 3 Dec 2025 12:19:18 -0600 Subject: [PATCH] Improves OpenAPI spec names and types and error reporting This uses the new `json-fleece` API to improve the names and types given to OpenAPI specs. This includes a change that restricts the characters allowed in the name of an OpenAPI spec. This default is to allow alphanumeric characters, plus '.' and '_'. The list of allowed characters can be specified both via the various functions that build OpenAPI specs and the default command line generation command. This also improves the error reporting when schemas have conflicts or bad names to try to provide context of where the offending spec is contained within the spec definitions so that the developer can more easily locate the offending specs within the code. --- .helix/languages.toml | 8 + orb.cabal | 3 +- package.yaml | 2 +- src/Orb/Main.hs | 137 +++++++- src/Orb/OpenApi.hs | 593 ++++++++++++++++++++++---------- src/Orb/SwaggerUI.hs | 48 ++- stack-ghc-9.10.yaml | 2 +- stack-ghc-9.10.yaml.lock | 28 +- stack-ghc-9.6.yaml | 2 +- stack-ghc-9.6.yaml.lock | 28 +- stack-ghc-9.8.yaml | 2 +- stack-ghc-9.8.yaml.lock | 28 +- stack.yaml.lock | 26 +- test/Fixtures.hs | 1 + test/Fixtures/TaggedUnion.hs | 88 +++++ test/Fixtures/Union.hs | 15 +- test/OpenApi.hs | 78 ++++- test/SwaggerUI.hs | 5 +- test/examples/tagged-union.json | 102 ++++++ test/examples/union.json | 24 +- 20 files changed, 920 insertions(+), 300 deletions(-) create mode 100644 .helix/languages.toml create mode 100644 test/Fixtures/TaggedUnion.hs create mode 100644 test/examples/tagged-union.json diff --git a/.helix/languages.toml b/.helix/languages.toml new file mode 100644 index 0000000..32c85ec --- /dev/null +++ b/.helix/languages.toml @@ -0,0 +1,8 @@ +[language-server.haskell-language-server] +command = "docker" +args = ["compose", "run", "--rm", "-T", "dev", "haskell-language-server-wrapper", "--lsp"] + +[language-server.haskell-language-server.config] +haskell.formattingProvider = "fourmolu" +haskell.plugin.hlint.globalOn = false + diff --git a/orb.cabal b/orb.cabal index fc54939..e789d23 100644 --- a/orb.cabal +++ b/orb.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: orb -version: 0.5.0.2 +version: 0.6.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/orb#readme bug-reports: https://github.com/flipstone/orb/issues @@ -127,6 +127,7 @@ test-suite orb-test Fixtures.OpenApiSubset Fixtures.SimpleGet Fixtures.SimplePost + Fixtures.TaggedUnion Fixtures.Union Handler OpenApi diff --git a/package.yaml b/package.yaml index e79d17d..62a1ddc 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: orb -version: 0.5.0.2 +version: 0.6.0.0 github: "flipstone/orb" license: MIT author: "Flipstone Technology Partners, Inc" diff --git a/src/Orb/Main.hs b/src/Orb/Main.hs index 2887a3a..36ebb51 100644 --- a/src/Orb/Main.hs +++ b/src/Orb/Main.hs @@ -1,8 +1,10 @@ module Orb.Main ( main + , mainWithOptions , mainParserInfo , mainParser , mainParserWithCommands + , openApiOptionsParser , openApiLabelArgument , generateOpenApiCommand , generateOpenApiMain @@ -10,7 +12,9 @@ module Orb.Main import Data.Aeson.Encode.Pretty qualified as AesonPretty import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (traverse_) import Data.List qualified as List +import Data.Set qualified as Set import Options.Applicative qualified as Opt import System.Exit qualified as Exit import System.IO qualified as IO @@ -30,25 +34,64 @@ import Orb.OpenApi qualified as OpenApi of the labeled routes as JSON to stdout. -} main :: OpenApi.OpenApiRouter a -> IO () -> IO () -main routes appMain = do - io <- Opt.customExecParser parserPrefs (mainParserInfo appMain routes) +main = + mainWithOptions OpenApi.defaultOpenApiOptions + +{- | + Constructs a main function that parses the command line arguments and + provides two subcommands in the executable: + + - @api@ - runs the IO action provided as the main. Presumably this + invokes some form of 'Orb.Wai.runOrb' (or otherwise runs a way server) + that serves an application handling the routes provided to this function. + + - @generate-open-api@ - accepts a argument matching one of the labels + provided to 'OpenApi.provideOpenApi' and prints an OpenApi description + of the labeled routes as JSON to stdout. + + + A version of 'main' takes an 'OpenApi.OpenApiOptions' + value to use as the default options to the @generate-open-api@ + command. If you use this function, you probably also want + to use 'Orb.SwaggerUI.swaggerUIRoutesWithOptions' instead of + 'Orb.SwaggerUI.swaggerUIRoutes' and specify the same options that + you're passing to this function. +-} +mainWithOptions :: OpenApi.OpenApiOptions -> OpenApi.OpenApiRouter a -> IO () -> IO () +mainWithOptions defaultOptions routes appMain = do + io <- Opt.customExecParser parserPrefs (mainParserInfo defaultOptions appMain routes) io {- | Constructs a 'Opt.ParserInfo' that will execute as description in 'main', but can be used as an argument to 'Opt.command' to use it as a subcommand. + + The options passed will be used as the default values for when no options + are specified on the command line. -} -mainParserInfo :: IO () -> OpenApi.OpenApiRouter a -> Opt.ParserInfo (IO ()) -mainParserInfo apiMain routes = - Opt.info (mainParser apiMain routes) mempty +mainParserInfo :: + OpenApi.OpenApiOptions -> + IO () -> + OpenApi.OpenApiRouter a -> + Opt.ParserInfo (IO ()) +mainParserInfo defaultOptions apiMain routes = + Opt.info (mainParser defaultOptions apiMain routes) mempty {- | Constructs a 'Opt.Parser' that will execute as description in 'main', but can be used directly in other option parsers. + + The options passed will be used as the default values for when no options + are specified on the command line. -} -mainParser :: IO () -> OpenApi.OpenApiRouter a -> Opt.Parser (IO ()) -mainParser apiMain = +mainParser :: + OpenApi.OpenApiOptions -> + IO () -> + OpenApi.OpenApiRouter a -> + Opt.Parser (IO ()) +mainParser defaultOptions apiMain = mainParserWithCommands + defaultOptions [ Opt.command "api" (Opt.info (pure apiMain) mempty) ] @@ -57,15 +100,19 @@ mainParser apiMain = the 'main' function along with the other commands passed. In this case no @api@ command is added by orb. It is up to the application to passed whatever set of other commands it desires. + + The options passed will be used as the default values for when no options + are specified on the command line. -} mainParserWithCommands :: + OpenApi.OpenApiOptions -> [Opt.Mod Opt.CommandFields (IO ())] -> OpenApi.OpenApiRouter a -> Opt.Parser (IO ()) -mainParserWithCommands commands routes = +mainParserWithCommands defaultOptions commands routes = Opt.hsubparser $ mconcat - ( generateOpenApiCommand routes + ( generateOpenApiCommandWithOptions defaultOptions routes : commands ) @@ -74,9 +121,67 @@ mainParserWithCommands commands routes = can be used along with 'Opt.hsubparser' include the command wherever the user chooses in their options parsing. -} -generateOpenApiCommand :: OpenApi.OpenApiRouter a -> Opt.Mod Opt.CommandFields (IO ()) +generateOpenApiCommand :: + OpenApi.OpenApiRouter a -> + Opt.Mod Opt.CommandFields (IO ()) generateOpenApiCommand routes = - Opt.command "generate-open-api" (Opt.info (generateOpenApiMain routes <$> openApiLabelArgument routes) mempty) + let + parser = + generateOpenApiMain + <$> openApiOptionsParser OpenApi.defaultOpenApiOptions + <*> pure routes + <*> openApiLabelArgument routes + in + Opt.command "generate-open-api" (Opt.info parser mempty) + +{- | + Constructs an 'Opt.command' modifier for the @generate-open-api@ command that + can be used along with 'Opt.hsubparser' include the command wherever the user + chooses in their options parsing. + + The options passed will be used as the default values for when no options + are specified on the command line. + + A version of 'generateOpenApiCommand' that takes the options argument. +-} +generateOpenApiCommandWithOptions :: + OpenApi.OpenApiOptions -> + OpenApi.OpenApiRouter a -> + Opt.Mod Opt.CommandFields (IO ()) +generateOpenApiCommandWithOptions defaultOptions routes = + let + parser = + generateOpenApiMain + <$> openApiOptionsParser defaultOptions + <*> pure routes + <*> openApiLabelArgument routes + in + Opt.command "generate-open-api" (Opt.info parser mempty) + +{- | + Constructs a 'Opt.Parser' that will parse command line options to control + how the OpenApi spec is generated. + + The options passed will be used as the default values for when no options + are specified on the command line. +-} +openApiOptionsParser :: OpenApi.OpenApiOptions -> Opt.Parser OpenApi.OpenApiOptions +openApiOptionsParser defaultOptions = + let + mkOpts allowedChars = + OpenApi.defaultOpenApiOptions + { OpenApi.openApiAllowedSchemaNameChars = Set.fromList allowedChars + } + in + mkOpts + <$> Opt.option + Opt.str + ( Opt.long "allowed-chars" + <> Opt.metavar "CHARS" + <> Opt.help "e.g. abcdefg12345" + <> Opt.value (Set.toList (OpenApi.openApiAllowedSchemaNameChars defaultOptions)) + <> Opt.showDefault + ) {- | Constructs a 'Opt.Parser' than will parse an argument representing one @@ -110,12 +215,12 @@ parserPrefs = the @generate-open-api@ command in their own main functions without using @optparse-applicative@. -} -generateOpenApiMain :: OpenApi.OpenApiRouter a -> String -> IO () -generateOpenApiMain routes label = - case OpenApi.mkOpenApi routes label of - Left err -> do +generateOpenApiMain :: OpenApi.OpenApiOptions -> OpenApi.OpenApiRouter a -> String -> IO () +generateOpenApiMain options routes label = + case OpenApi.mkOpenApi options routes label of + Left errs -> do IO.hPutStrLn IO.stderr ("Unable to generate OpenApi Spec for " <> label <> "!") - IO.hPutStrLn IO.stderr err + traverse_ (IO.hPutStrLn IO.stderr . OpenApi.renderOpenApiError) errs Exit.exitWith (Exit.ExitFailure 1) Right openApi -> LBS.putStr (AesonPretty.encodePretty openApi) diff --git a/src/Orb/OpenApi.hs b/src/Orb/OpenApi.hs index e5276bb..76f8f91 100644 --- a/src/Orb/OpenApi.hs +++ b/src/Orb/OpenApi.hs @@ -1,12 +1,19 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Orb.OpenApi ( mkOpenApi , mkAllOpenApis + , OpenApiError + , renderOpenApiError , openApiLabels + , OpenApiOptions (openApiAllowedSchemaNameChars) + , defaultOpenApiOptions , OpenApiProvider (provideOpenApi) , OpenApiRouter , FleeceOpenApi @@ -17,8 +24,11 @@ module Orb.OpenApi import Beeline.Params qualified as BP import Beeline.Routing qualified as R import Control.Monad qualified as Monad +import Control.Monad.Reader qualified as Reader +import Control.Monad.Trans qualified as Trans import Data.Aeson qualified as Aeson import Data.Align qualified as Align +import Data.Bifunctor qualified as Bifunctor import Data.ByteString.Char8 qualified as BS8 import Data.DList qualified as DList import Data.HashMap.Strict.InsOrd qualified as IOHM @@ -27,6 +37,8 @@ import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Maybe qualified as Maybe import Data.OpenApi qualified as OpenApi +import Data.Semialign.Indexed qualified as IAlign +import Data.Set qualified as Set import Data.Text qualified as T import Data.These qualified as These import Fleece.Core qualified as FC @@ -66,11 +78,11 @@ openApiLabels (OpenApiRouter builders) = Returns all the 'OpenApi.OpenApi' descriptions that have been labeled in the specified router. If any of them return an error, it will be returned. -} -mkAllOpenApis :: OpenApiRouter a -> Either String (Map.Map String OpenApi.OpenApi) -mkAllOpenApis router = +mkAllOpenApis :: OpenApiOptions -> OpenApiRouter a -> Either [OpenApiError] (Map.Map String OpenApi.OpenApi) +mkAllOpenApis options router = let mkLabeledApi label = do - api <- mkOpenApi router label + api <- mkOpenApi options router label pure (label, api) in Map.fromList <$> traverse mkLabeledApi (openApiLabels router) @@ -81,38 +93,59 @@ mkAllOpenApis router = no section with the label can be found or if an error occurs while generating the OpenApi description, an error will be returned. -} -mkOpenApi :: OpenApiRouter a -> String -> Either String OpenApi.OpenApi -mkOpenApi (OpenApiRouter builders) label = do - builder <- - case Map.lookup label (labeledBuilders builders) of - Nothing -> Left ("No OpenApi definition found with label " <> label <> ".") - Just builder -> Right builder - - apiInfo <- - runOpenApiBuilder builder $ - PathInfo - { pathInfoPath = "" - , pathInfoParams = [] - } - - let - paths = - toIOHM . apiPaths $ apiInfo - - componentsSchemas = - toIOHM - . fmap openApiSchema - . apiSchemaComponents - $ apiInfo +mkOpenApi :: OpenApiOptions -> OpenApiRouter a -> String -> Either [OpenApiError] OpenApi.OpenApi +mkOpenApi options (OpenApiRouter builders) label = + runOpenApiGen options $ do + builder <- + case Map.lookup label (labeledBuilders builders) of + Nothing -> failOpenApiGenOne (NoDefinitionForLabel label) + Just builder -> pure builder + + apiInfo <- + runOpenApiBuilder builder $ + PathInfo + { pathInfoPath = "" + , pathInfoParams = [] + } - pure $ - mempty - { OpenApi._openApiPaths = paths - , OpenApi._openApiComponents = + case DList.toList (lintApiInfo options apiInfo) of + someErrors@(_ : _) -> + failOpenApiGenMany someErrors + [] -> do + let + paths = + toIOHM . apiPaths $ apiInfo + + componentsSchemas = + toIOHM + . fmap openApiSchema + . apiSchemaComponents + $ apiInfo + + pure $ mempty - { OpenApi._componentsSchemas = componentsSchemas + { OpenApi._openApiPaths = paths + , OpenApi._openApiComponents = + mempty + { OpenApi._componentsSchemas = componentsSchemas + } } - } + +lintApiInfo :: OpenApiOptions -> ApiInfo -> DList.DList OpenApiError +lintApiInfo options apiInfo = + Map.foldMapWithKey + (checkSchemaComponentEntry options) + (apiSchemaComponents apiInfo) + +checkSchemaComponentEntry :: OpenApiOptions -> T.Text -> SchemaInfo -> DList.DList OpenApiError +checkSchemaComponentEntry options schemaName schemaInfo = + let + allowedChars = + openApiAllowedSchemaNameChars options + in + if T.all (flip Set.member allowedChars) schemaName + then DList.empty + else DList.singleton (InvalidSchemaName schemaName schemaInfo allowedChars) toIOHM :: Hashable k => Map.Map k v -> IOHM.InsOrdHashMap k v toIOHM = @@ -130,12 +163,13 @@ emptyApiInfo = , apiSchemaComponents = Map.empty } -combineApiInfo :: ApiInfo -> ApiInfo -> Either String ApiInfo +combineApiInfo :: ApiInfo -> ApiInfo -> OpenApiGen ApiInfo combineApiInfo left right = do components <- - combineSchemaComponents - (apiSchemaComponents left) - (apiSchemaComponents right) + eitherToOpenApiGen $ + combineSchemaComponents + (apiSchemaComponents left) + (apiSchemaComponents right) pure $ ApiInfo { apiPaths = @@ -158,32 +192,29 @@ combinePathItems left right = combineSchemaComponents :: Map.Map T.Text SchemaInfo -> Map.Map T.Text SchemaInfo -> - Either String (Map.Map T.Text SchemaInfo) + Either OpenApiError (Map.Map T.Text SchemaInfo) combineSchemaComponents left right = let - checkForConflict theseSchemas = + checkForConflict :: + T.Text -> + These.These SchemaInfo SchemaInfo -> + Either OpenApiError SchemaInfo + checkForConflict key theseSchemas = case theseSchemas of These.This this -> Right this These.That that -> Right that These.These this that -> - if isSameSchemaInfo this that - then Right this - else + case DList.toList (schemaConflicts this that) of + [] -> pure this + conflicts -> Left $ - "Conflicting schema definitions found " - <> FC.nameToString (fleeceName this) - <> " and " - <> FC.nameToString (fleeceName that) - - addKeyToError :: T.Text -> Either String a -> Either String a - addKeyToError key errOrSchemaInfo = - case errOrSchemaInfo of - Left err -> Left (T.unpack key <> ": " <> err) - Right schemaInfo -> Right schemaInfo + SchemaConflict + key + this + that + conflicts in - Map.traverseWithKey - addKeyToError - (Align.alignWith checkForConflict left right) + sequence (IAlign.ialignWith checkForConflict left right) singletonApiInfo :: Map.Map T.Text SchemaInfo -> @@ -196,10 +227,105 @@ singletonApiInfo components pathInfo pathItem = , apiSchemaComponents = components } +{- | + Options can be specified to 'mkOpenApi' and 'mkAllOpenApis' to control the + OpenApi construction. This type is exported without it's constructor. Use + 'defaultOpenApiOptions' to construct a value and use record update syntax + to update whichever options you wish. + + See the record members below. +-} +data OpenApiOptions + = OpenApiOptions + { openApiAllowedSchemaNameChars :: Set.Set Char + {- ^ Controls which characters are allowed in the names of schemas in the + generated OpenAPI spec. By default this is set to @0-9A-Z_.a-z@ as this + promotes better names in code that is from from the resulting OpenAPI spec + -} + } + +{- | + Sensible default options for generating OpenAPI specs. See the descriptions of + each record field fold the default values. +-} +defaultOpenApiOptions :: OpenApiOptions +defaultOpenApiOptions = + OpenApiOptions + { openApiAllowedSchemaNameChars = + Set.fromList + ( -- Update the docs for openApiAllowedSchemaNameChars if you change this + ['0' .. '9'] ++ ['A' .. 'Z'] ++ "_." ++ ['a' .. 'z'] + ) + } + +newtype OpenApiGen a + = OpenApiGen (Reader.ReaderT OpenApiOptions (Either [OpenApiError]) a) + deriving newtype (Functor, Applicative, Monad) + +failOpenApiGenOne :: OpenApiError -> OpenApiGen a +failOpenApiGenOne = + failOpenApiGenMany . pure + +failOpenApiGenMany :: [OpenApiError] -> OpenApiGen a +failOpenApiGenMany = + OpenApiGen . Trans.lift . Left + +data OpenApiError + = InternalError String + | NoDefinitionForLabel String + | BeelineMethodUsed HTTPTypes.StdMethod PathInfo + | UnsupportedMethod HTTPTypes.StdMethod PathInfo + | InvalidSchemaName T.Text SchemaInfo (Set.Set Char) + | SchemaConflict T.Text SchemaInfo SchemaInfo [String] + +instance Show OpenApiError where + show = renderOpenApiError + +renderOpenApiError :: OpenApiError -> String +renderOpenApiError err = + case err of + InternalError msg -> + "Internal Error: " <> msg + NoDefinitionForLabel label -> + "No OpenApi definition found with label " <> label <> "." + BeelineMethodUsed method pathInfo -> + "Unable to make OpenAPI description for router defined using standard Beeline 'method' (or helpers such as 'get'): " + <> BS8.unpack (HTTPTypes.renderStdMethod method) + <> " " + <> pathInfoPath pathInfo + UnsupportedMethod method pathInfo -> + "Unable to create OpenAPI for description of " + <> pathInfoPath pathInfo + <> " due to use of HTTP Method: " + <> BS8.unpack (HTTPTypes.renderStdMethod method) + InvalidSchemaName schemaName schemaInfo allowedChars -> + "Invalid Schema Name: " + <> show schemaName + <> " only the following characters are allowed, " + <> show (Set.toList allowedChars) + <> ".\n" + <> renderPath (schemaPath schemaInfo) + SchemaConflict key this that conflicts -> + unlines $ + ("Conflicting schema definitions found for " <> T.unpack key) + : "========= Left Side" + : renderPath (schemaPath this) + : "========= Right side" + : renderPath (schemaPath that) + : "========= Conflicts" + : conflicts + +runOpenApiGen :: OpenApiOptions -> OpenApiGen a -> Either [OpenApiError] a +runOpenApiGen options (OpenApiGen reader) = + Reader.runReaderT reader options + +eitherToOpenApiGen :: Either OpenApiError a -> OpenApiGen a +eitherToOpenApiGen = OpenApiGen . Trans.lift . Bifunctor.first pure + newtype OpenApiBuilder - = OpenApiBuilder (PathInfo -> Either String ApiInfo) + = OpenApiBuilder (PathInfo -> OpenApiGen ApiInfo) -runOpenApiBuilder :: OpenApiBuilder -> PathInfo -> Either String ApiInfo +runOpenApiBuilder :: OpenApiBuilder -> PathInfo -> OpenApiGen ApiInfo runOpenApiBuilder (OpenApiBuilder f) = f @@ -212,7 +338,7 @@ modifyOpenApiBuilderPathInfo f (OpenApiBuilder mkApiInfo) = emptyOpenApiBuilder :: OpenApiBuilder emptyOpenApiBuilder = - OpenApiBuilder (const (Right emptyApiInfo)) + OpenApiBuilder (const (pure emptyApiInfo)) combineOpenApiBuilder :: OpenApiBuilder -> @@ -289,7 +415,7 @@ instance Handler.ServerRouter OpenApiRouter where let builder = OpenApiBuilder $ \parentContext -> do - mbRequestBody <- mkRequestBody handler + mbRequestBody <- eitherToOpenApiGen $ mkRequestBody handler let (mbReqBody, reqComponents) = @@ -297,8 +423,10 @@ instance Handler.ServerRouter OpenApiRouter where Nothing -> (Nothing, Map.empty) Just (reqBody, reqComps) -> (Just reqBody, reqComps) - (responses, responseComponents) <- mkResponses handler - allComponents <- combineSchemaComponents reqComponents responseComponents + (responses, responseComponents) <- eitherToOpenApiGen $ mkResponses handler + allComponents <- + eitherToOpenApiGen $ + combineSchemaComponents reqComponents responseComponents let operation = @@ -317,11 +445,7 @@ instance Handler.ServerRouter OpenApiRouter where case mbPathItem of Nothing -> - Left $ - "Unable to create OpenAPI for description of " - <> pathInfoPath pathInfo - <> " due to use of HTTP Method: " - <> BS8.unpack (HTTPTypes.renderStdMethod method) + failOpenApiGenOne (UnsupportedMethod method pathInfo) Just pathItem -> do pure $ singletonApiInfo allComponents pathInfo pathItem in @@ -382,12 +506,7 @@ instance R.Router OpenApiRouter where pathInfo = mkRoute parentContext in - Left - ( "Unable to make OpenAPI description for router defined using standard Beeline 'method' (or helpers such as 'get'): " - <> BS8.unpack (HTTPTypes.renderStdMethod method) - <> " " - <> pathInfoPath pathInfo - ) + failOpenApiGenOne (BeelineMethodUsed method pathInfo) in OpenApiRouter $ emptyOpenApiBuilders @@ -437,11 +556,11 @@ mkPathItem method pathInfo operation = mkRequestBody :: Handler.Handler route -> - Either String (Maybe (OpenApi.Referenced OpenApi.RequestBody, Map.Map T.Text SchemaInfo)) + Either OpenApiError (Maybe (OpenApi.Referenced OpenApi.RequestBody, Map.Map T.Text SchemaInfo)) mkRequestBody handler = case Handler.requestBody handler of - Handler.SchemaRequestBody (FleeceOpenApi errOrSchemaInfo) -> do - schemaInfo <- fmap rewriteSchemaInfo errOrSchemaInfo + Handler.SchemaRequestBody (FleeceOpenApi mkErrOrSchemaInfo) -> do + schemaInfo <- mkErrOrSchemaInfo [] let schemaRef = @@ -558,7 +677,7 @@ instance BP.HeaderSchema OpenApiParams where mkResponses :: Handler.Handler router -> - Either String (OpenApi.Responses, Map.Map T.Text SchemaInfo) + Either OpenApiError (OpenApi.Responses, Map.Map T.Text SchemaInfo) mkResponses handler = let schemas = @@ -568,7 +687,7 @@ mkResponses handler = mbSchemaInfo <- case responseSchema of Response.NoSchemaResponseBody _mbContentType -> pure Nothing - Response.SchemaResponseBody (FleeceOpenApi info) -> fmap Just info + Response.SchemaResponseBody (FleeceOpenApi mkInfo) -> fmap Just (mkInfo []) Response.EmptyResponseBody -> pure Nothing let mkResponseContent schemaRef = @@ -696,7 +815,7 @@ mkParamSchema param = description of the schema. -} newtype FleeceOpenApi a = FleeceOpenApi - { unFleeceOpenApi :: Either String SchemaInfo + { unFleeceOpenApi :: Path -> Either OpenApiError SchemaInfo } {- | @@ -714,7 +833,7 @@ data SchemaWithComponents = SchemaWithComponents Fleece schema. If an error occurs during construction (e.g. conflicting definitions of the same component), an error will be returned. -} -schemaWithComponents :: FleeceOpenApi a -> Either String SchemaWithComponents +schemaWithComponents :: FleeceOpenApi a -> Either OpenApiError SchemaWithComponents schemaWithComponents = fmap ( \schemaInfo -> @@ -726,40 +845,96 @@ schemaWithComponents = (schemaComponents schemaInfo) } ) + . ($ []) . unFleeceOpenApi +data PathEntry + = PathSchema FC.Name + | PathField FC.Name String + deriving (Show) + +renderPathEntry :: PathEntry -> String +renderPathEntry pathEntry = + case pathEntry of + PathSchema schemaName -> "Schema " <> FC.nameToString schemaName + PathField schemaName field -> FC.nameToString schemaName <> "." <> field + +type Path = [PathEntry] + +addSchemaToPath :: FC.Name -> Path -> Path +addSchemaToPath = + (:) . PathSchema + +addFieldToPath :: String -> Path -> Path +addFieldToPath field path = + case path of + [] -> [PathField topLevelDummySchemaName field] + (PathSchema schemaName : rest) -> PathField schemaName field : rest + (PathField schemaName oldField : rest) -> PathField schemaName (oldField <> "." <> field) : rest + +topLevelDummySchemaName :: FC.Name +topLevelDummySchemaName = FC.unqualifiedName "<>" + +renderPath :: Path -> String +renderPath path = + case path of + [] -> renderPath [PathSchema topLevelDummySchemaName] + (first : rest) -> + let + render :: String -> PathEntry -> String + render label pathEntry = + " - " <> label <> ": " <> renderPathEntry pathEntry + in + unlines $ + (render "Found at" first) + : map (render "Within") rest + data SchemaInfo = SchemaInfo { fleeceName :: FC.Name + , schemaPath :: Path , schemaIsPrimitive :: Bool , openApiKey :: Maybe T.Text , openApiNullable :: Bool , openApiSchema :: OpenApi.Schema , schemaComponents :: Map.Map T.Text SchemaInfo } + deriving (Show) isArraySchemaInfo :: SchemaInfo -> Bool isArraySchemaInfo = (== Just OpenApi.OpenApiArray) . OpenApi._schemaType . openApiSchema -isSameSchemaInfo :: SchemaInfo -> SchemaInfo -> Bool -isSameSchemaInfo - (SchemaInfo fleeceName1 schemaIsPrimitive1 openApiKey1 _ openApiNullable1 schemaComponents1) - (SchemaInfo fleeceName2 schemaIsPrimitive2 openApiKey2 _ openApiNullable2 schemaComponents2) = - fleeceName1 == fleeceName2 - && schemaIsPrimitive1 == schemaIsPrimitive2 - && openApiKey1 == openApiKey2 - && openApiNullable1 == openApiNullable2 - && and +schemaConflicts :: SchemaInfo -> SchemaInfo -> DList.DList String +schemaConflicts + (SchemaInfo fleeceName1 _path1 schemaIsPrimitive1 openApiKey1 _nullable1 openApiSchema1 schemaComponents1) + (SchemaInfo fleeceName2 _path2 schemaIsPrimitive2 openApiKey2 _nullable2 openApiSchema2 schemaComponents2) = + eqConflict "Fleece Name" fleeceName1 fleeceName2 + <> eqConflict "Is Primitive" schemaIsPrimitive1 schemaIsPrimitive2 + <> eqConflict "OpenAPI Key" openApiKey1 openApiKey2 + <> eqConflict "OpenAPI Schema" openApiSchema1 openApiSchema2 + <> foldMap + id ( Align.alignWith ( These.these - (const False) - (const False) - isSameSchemaInfo + (\leftSchema -> DList.singleton (show (fleeceName leftSchema) <> " only present in first")) + (\rightSchema -> DList.singleton (show (fleeceName rightSchema) <> " only present in second")) + schemaConflicts ) schemaComponents1 schemaComponents2 ) +eqConflict :: + (Eq a, Show a) => + String -> + a -> + a -> + DList.DList String +eqConflict name left right = + if left == right + then DList.empty + else DList.singleton (name <> ": " <> show left <> " /= " <> show right) + setSchemaInfoFormat :: T.Text -> SchemaInfo -> SchemaInfo setSchemaInfoFormat fmt info = info @@ -769,7 +944,19 @@ setSchemaInfoFormat fmt info = } } -collectComponents :: [SchemaInfo] -> Either String (Map.Map T.Text SchemaInfo) +setOpenApiType :: OpenApi.OpenApiType -> FleeceOpenApi a -> FleeceOpenApi a +setOpenApiType typ (FleeceOpenApi mkErrOrSchemaInfo) = do + FleeceOpenApi $ \path -> do + schemaInfo <- mkErrOrSchemaInfo path + pure + schemaInfo + { openApiSchema = + (openApiSchema schemaInfo) + { OpenApi._schemaType = Just typ + } + } + +collectComponents :: [SchemaInfo] -> Either OpenApiError (Map.Map T.Text SchemaInfo) collectComponents schemaInfos = let mkTopLevel schemaInfo = @@ -811,10 +998,12 @@ mkSchemaRef schema = mkPrimitiveSchema :: String -> OpenApi.OpenApiType -> + Path -> SchemaInfo -mkPrimitiveSchema name openApiType = +mkPrimitiveSchema name openApiType path = SchemaInfo { fleeceName = FC.unqualifiedName name + , schemaPath = path , schemaIsPrimitive = True , openApiKey = Nothing , openApiNullable = False @@ -833,40 +1022,55 @@ data FieldInfo = FieldInfo instance FC.Fleece FleeceOpenApi where data Object FleeceOpenApi _object _constructor - = Object (Either String [FieldInfo]) + = Object (Path -> Either OpenApiError [FieldInfo]) data Field FleeceOpenApi _object _field - = Field (Either String FieldInfo) + = Field (Path -> Either OpenApiError FieldInfo) data AdditionalFields FleeceOpenApi _object _field = AdditionalFields data UnionMembers FleeceOpenApi _allTypes _handledTypes - = UnionMembers (Either String [SchemaInfo]) + = UnionMembers (Path -> Either OpenApiError [SchemaInfo]) data TaggedUnionMembers FleeceOpenApi _allTags _handledTags - = TaggedUnionMembers (FieldInfo -> String -> Either String [(T.Text, SchemaInfo)]) - - schemaName (FleeceOpenApi errOrSchemaInfo) = - case errOrSchemaInfo of - Left err -> FC.unqualifiedName ("Unable to get schema name:" <> err) + = TaggedUnionMembers (Path -> FieldInfo -> String -> Either OpenApiError [(T.Text, SchemaInfo)]) + + schemaName (FleeceOpenApi mkErrOrSchemaInfo) = + -- We might not be able to make a name here because 'mkErrOrSchemaInfo' might + -- return an error. 'schemaName' cannot return an error, however, so we are + -- forced to reflect the error in the name of the schema. This is not ideal, + -- but the error raised by the schema will almost certainly be raised elsewhere + -- as part of the OpenApi spec generation, so it will get reported as an error + -- elsewhere in addition to in the name of this schema. + case mkErrOrSchemaInfo [] of + Left err -> + let + shortErr = + takeWhile (/= '\n') (renderOpenApiError err) + in + FC.unqualifiedName ("Unable to get schema name:" <> shortErr) Right schemaInfo -> fleeceName schemaInfo + format formatString (FleeceOpenApi mkErrOrSchemaInfo) = + FleeceOpenApi $ \path -> + fmap (setSchemaInfoFormat (T.pack formatString)) (mkErrOrSchemaInfo path) + number = - FleeceOpenApi . Right $ mkPrimitiveSchema "number" OpenApi.OpenApiNumber + FleeceOpenApi $ Right . mkPrimitiveSchema "number" OpenApi.OpenApiNumber text = - FleeceOpenApi . Right $ mkPrimitiveSchema "text" OpenApi.OpenApiString + FleeceOpenApi $ Right . mkPrimitiveSchema "text" OpenApi.OpenApiString boolean = - FleeceOpenApi . Right $ mkPrimitiveSchema "boolean" OpenApi.OpenApiBoolean + FleeceOpenApi $ Right . mkPrimitiveSchema "boolean" OpenApi.OpenApiBoolean null = - FleeceOpenApi . Right $ mkPrimitiveSchema "null" OpenApi.OpenApiNull + FleeceOpenApi $ Right . mkPrimitiveSchema "null" OpenApi.OpenApiNull - array (FleeceOpenApi errOrItemSchemaInfo) = - FleeceOpenApi $ do - itemSchemaInfo <- errOrItemSchemaInfo + array (FleeceOpenApi mkErrOrItemSchemaInfo) = + FleeceOpenApi $ \path -> do + itemSchemaInfo <- mkErrOrItemSchemaInfo path components <- collectComponents [itemSchemaInfo] let @@ -876,6 +1080,7 @@ instance FC.Fleece FleeceOpenApi where pure $ SchemaInfo { fleeceName = FC.annotateName (fleeceName itemSchemaInfo) "array" + , schemaPath = path , schemaIsPrimitive = False , openApiKey = Nothing , openApiNullable = False @@ -887,9 +1092,9 @@ instance FC.Fleece FleeceOpenApi where , schemaComponents = components } - nullable (FleeceOpenApi errOrSchemaInfo) = - FleeceOpenApi $ do - schemaInfo <- fmap rewriteSchemaInfo errOrSchemaInfo + nullable (FleeceOpenApi mkErrOrSchemaInfo) = + FleeceOpenApi $ \path -> do + schemaInfo <- mkErrOrSchemaInfo path let innerSchemaShouldBeNullable = (schemaIsPrimitive schemaInfo || isArraySchemaInfo schemaInfo) @@ -898,6 +1103,7 @@ instance FC.Fleece FleeceOpenApi where pure $ SchemaInfo { fleeceName = fleeceName schemaInfo + , schemaPath = path , schemaIsPrimitive = schemaIsPrimitive schemaInfo , openApiKey = openApiKey schemaInfo , openApiNullable = True @@ -911,9 +1117,9 @@ instance FC.Fleece FleeceOpenApi where , schemaComponents = schemaComponents schemaInfo } - required name _accessor (FleeceOpenApi errOrSchemaInfo) = - Field $ do - schemaInfo <- fmap rewriteSchemaInfo errOrSchemaInfo + required name _accessor (FleeceOpenApi mkErrOrSchemaInfo) = + Field $ \path -> do + schemaInfo <- mkErrOrSchemaInfo (addFieldToPath name path) pure $ FieldInfo { fieldName = T.pack name @@ -921,9 +1127,9 @@ instance FC.Fleece FleeceOpenApi where , fieldSchemaInfo = schemaInfo } - optional name _accessor (FleeceOpenApi errOrSchemaInfo) = - Field $ do - schemaInfo <- fmap rewriteSchemaInfo errOrSchemaInfo + optional name _accessor (FleeceOpenApi mkErrOrSchemaInfo) = + Field $ \path -> do + schemaInfo <- mkErrOrSchemaInfo (addFieldToPath name path) pure $ FieldInfo { fieldName = T.pack name @@ -937,21 +1143,23 @@ instance FC.Fleece FleeceOpenApi where additionalFields _accessor _schema = AdditionalFields - objectNamed name (Object errOrFieldsInReverse) = - FleeceOpenApi (mkObjectForFields name =<< errOrFieldsInReverse) + objectNamed name (Object mkErrOrFieldsInReverse) = + FleeceOpenApi $ \path -> + mkObjectForFields path name =<< mkErrOrFieldsInReverse (addSchemaToPath name path) constructor _cons = - Object (Right []) + Object . const . Right $ [] - field (Object fieldInfos) (Field newFieldInfo) = - Object (liftA2 (:) newFieldInfo fieldInfos) + field (Object mkFieldInfos) (Field mkNewFieldInfo) = + Object (\path -> liftA2 (:) (mkNewFieldInfo path) (mkFieldInfos path)) additional (Object _fields) _additional = - Object (Left "Fleece additional fields not currently support for OpenAPI") + Object . const . Left . InternalError $ + "Fleece additional fields not currently support for OpenAPI" - validateNamed name _uncheck _check (FleeceOpenApi errOrSchemaInfo) = do - FleeceOpenApi $ do - schemaInfo <- fmap rewriteSchemaInfo errOrSchemaInfo + validateNamed name _uncheck _check (FleeceOpenApi mkErrOrSchemaInfo) = do + FleeceOpenApi $ \path -> do + schemaInfo <- mkErrOrSchemaInfo (addSchemaToPath name path) if schemaIsPrimitive schemaInfo then do @@ -963,7 +1171,15 @@ instance FC.Fleece FleeceOpenApi where , openApiNullable = False , schemaComponents = components } - else pure schemaInfo + else + pure $ + schemaInfo + { fleeceName = name + , openApiKey = Just . fleeceNameToOpenApiKey $ name + } + + validateAnonymous _uncheck _check (FleeceOpenApi errOrSchemaInfo) = do + FleeceOpenApi errOrSchemaInfo boundedEnumNamed name toText = let @@ -972,32 +1188,34 @@ instance FC.Fleece FleeceOpenApi where (Aeson.toJSON . toText) [minBound .. maxBound] in - FleeceOpenApi - . Right - $ SchemaInfo - { fleeceName = name - , schemaIsPrimitive = False - , openApiKey = Just . fleeceNameToOpenApiKey $ name - , openApiNullable = False - , openApiSchema = - mempty - { OpenApi._schemaType = Just OpenApi.OpenApiString - , OpenApi._schemaEnum = Just enumValues - } - , schemaComponents = Map.empty - } + FleeceOpenApi $ \path -> + Right $ + SchemaInfo + { fleeceName = name + , schemaPath = path + , schemaIsPrimitive = False + , openApiKey = Just . fleeceNameToOpenApiKey $ name + , openApiNullable = False + , openApiSchema = + mempty + { OpenApi._schemaType = Just OpenApi.OpenApiString + , OpenApi._schemaEnum = Just enumValues + } + , schemaComponents = Map.empty + } - unionNamed name (UnionMembers errOrMembers) = - FleeceOpenApi $ do + unionNamed name (UnionMembers mkErrOrMembers) = + FleeceOpenApi $ \path -> do let key = Just $ fleeceNameToOpenApiKey name - members <- errOrMembers + members <- mkErrOrMembers (PathSchema name : path) components <- collectComponents members pure $ SchemaInfo { fleeceName = name + , schemaPath = path , schemaIsPrimitive = False , openApiKey = key , openApiNullable = False @@ -1012,16 +1230,18 @@ instance FC.Fleece FleeceOpenApi where , schemaComponents = components } - unionMemberWithIndex _idx (FleeceOpenApi errOrSchemaInfo) = - UnionMembers $ do - schemaInfo <- errOrSchemaInfo - pure [rewriteSchemaInfo schemaInfo] + unionMemberWithIndex _idx (FleeceOpenApi mkErrOrSchemaInfo) = + UnionMembers $ \path -> do + schemaInfo <- mkErrOrSchemaInfo path + pure [schemaInfo] unionCombine (UnionMembers left) (UnionMembers right) = - UnionMembers $ liftA2 (<>) left right + -- Don't change this to '<>' or we might get bitten by accidental + -- polymorphism + UnionMembers $ \path -> liftA2 (++) (left path) (right path) taggedUnionNamed name tagPropertyString (TaggedUnionMembers mkMembers) = - FleeceOpenApi $ do + FleeceOpenApi $ \path -> do let tagProperty = T.pack tagPropertyString @@ -1029,8 +1249,8 @@ instance FC.Fleece FleeceOpenApi where memberKeyPrefix = FC.nameUnqualified name <> "." - FleeceOpenApi errOrStringSchema = - FC.text + errOrStringSchema = + unFleeceOpenApi FC.text (PathSchema name : path) mkTagField tagSchema = FieldInfo @@ -1043,14 +1263,14 @@ instance FC.Fleece FleeceOpenApi where case openApiKey schemaInfo of Just key -> Right (tagValue, componentsPrefix <> key) Nothing -> - Left $ + Left . InternalError $ "No Schema Key found for member " <> T.unpack tagValue <> " of union " <> FC.nameToString name stringSchema <- errOrStringSchema - members <- mkMembers (mkTagField stringSchema) memberKeyPrefix + members <- mkMembers (PathSchema name : path) (mkTagField stringSchema) memberKeyPrefix components <- collectComponents (fmap snd members) @@ -1072,6 +1292,7 @@ instance FC.Fleece FleeceOpenApi where pure $ SchemaInfo { fleeceName = name + , schemaPath = path , schemaIsPrimitive = False , openApiKey = key , openApiNullable = False @@ -1085,43 +1306,73 @@ instance FC.Fleece FleeceOpenApi where , schemaComponents = components } - taggedUnionMemberWithTag tag (Object errOrFieldsInReverse) = - TaggedUnionMembers $ \tagField memberKeyPrefix -> do + taggedUnionMemberWithTag tag (Object mkErrOrFieldsInReverse) = + TaggedUnionMembers $ \path tagField memberKeyPrefix -> do let tagValue = symbolVal tag - -- TODO: come up with better name memberName = FC.unqualifiedName (memberKeyPrefix <> tagValue) - -- TODO: add tag property to schema - fieldsInReverse <- errOrFieldsInReverse + fieldsInReverse <- mkErrOrFieldsInReverse path let fieldsInReverseWithTag = fieldsInReverse <> [tagField] - objectSchema <- mkObjectForFields memberName fieldsInReverseWithTag + objectSchema <- mkObjectForFields path memberName fieldsInReverseWithTag pure [(T.pack tagValue, objectSchema)] taggedUnionCombine (TaggedUnionMembers mkLeft) (TaggedUnionMembers mkRight) = - TaggedUnionMembers $ \tagProperty memberKeyPrefix -> do - left <- mkLeft tagProperty memberKeyPrefix - right <- mkRight tagProperty memberKeyPrefix - pure (left <> right) + TaggedUnionMembers $ \path tagProperty memberKeyPrefix -> do + left <- mkLeft path tagProperty memberKeyPrefix + right <- mkRight path tagProperty memberKeyPrefix + -- Don't change this to '<>' or we might get bitten by accidental + -- polymorphism + pure (left ++ right) jsonString (FleeceOpenApi _schemaInfo) = FleeceOpenApi + . const . Left + . InternalError $ "Fleece jsonString is not currently implemented for OpenApi" + -- + -- Default implementations we override to get OpenAPI specific behavior. + -- Unfortunately this requires that we duplicate the default implementations + -- of these members from the class implementations in json-fleece because + -- we have no way to access and call the defaults. + -- + + int = setOpenApiType OpenApi.OpenApiInteger $ FC.boundedIntegralNumberAnonymous + + int8 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int8" FC.boundedIntegralNumberAnonymous + + int16 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int16" FC.boundedIntegralNumberAnonymous + + int32 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int32" FC.boundedIntegralNumberAnonymous + + int64 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int64" FC.boundedIntegralNumberAnonymous + + word = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word" FC.boundedIntegralNumberAnonymous + + word8 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word8" FC.boundedIntegralNumberAnonymous + + word16 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word16" FC.boundedIntegralNumberAnonymous + + word32 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word32" FC.boundedIntegralNumberAnonymous + + word64 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word64" FC.boundedIntegralNumberAnonymous + mkObjectForFields :: + Path -> FC.Name -> [FieldInfo] -> - Either String SchemaInfo -mkObjectForFields name fieldsInReverse = do + Either OpenApiError SchemaInfo +mkObjectForFields path name fieldsInReverse = do let key = Just $ fleeceNameToOpenApiKey name @@ -1135,6 +1386,7 @@ mkObjectForFields name fieldsInReverse = do pure $ SchemaInfo { fleeceName = name + , schemaPath = path , schemaIsPrimitive = False , openApiKey = key , openApiNullable = False @@ -1152,17 +1404,6 @@ fleeceNameToOpenApiKey :: FC.Name -> T.Text fleeceNameToOpenApiKey = T.pack . FC.nameUnqualified --- TODO this is a hack pending a better solution in json-fleece. -rewriteSchemaInfo :: SchemaInfo -> SchemaInfo -rewriteSchemaInfo schemaInfo = - case FC.nameUnqualified $ fleeceName schemaInfo of - "Int" -> mkPrimitiveSchema "integer" OpenApi.OpenApiInteger - "Int64" -> setSchemaInfoFormat "int64" $ mkPrimitiveSchema "integer" OpenApi.OpenApiInteger - "Int32" -> setSchemaInfoFormat "int32" $ mkPrimitiveSchema "integer" OpenApi.OpenApiInteger - "UTCTime" -> setSchemaInfoFormat "date-time" $ mkPrimitiveSchema "string" OpenApi.OpenApiString - "Day" -> setSchemaInfoFormat "date" $ mkPrimitiveSchema "string" OpenApi.OpenApiString - _ -> schemaInfo - componentsPrefix :: T.Text componentsPrefix = "#/components/schemas/" diff --git a/src/Orb/SwaggerUI.hs b/src/Orb/SwaggerUI.hs index 162a073..0c01d95 100644 --- a/src/Orb/SwaggerUI.hs +++ b/src/Orb/SwaggerUI.hs @@ -7,6 +7,7 @@ module Orb.SwaggerUI ( swaggerUIRoutes + , swaggerUIRoutesWithOptions , SwaggerUIRoute (SwaggerUIRoute, swaggerOpenApis, swaggerApiLabel, swaggerUIPath) , dispatchSwaggerUIRoute , SwaggerUIPath @@ -54,8 +55,39 @@ import Orb.Response qualified as Response @/@ under whatever path you choose to include 'swaggerUIRoutes' within your application's routes. -} -swaggerUIRoutes :: R.Router r => OrbOpenApi.OpenApiRouter a -> r SwaggerUIRoute -swaggerUIRoutes openApiRouter = +swaggerUIRoutes :: + R.Router r => + OrbOpenApi.OpenApiRouter a -> + r SwaggerUIRoute +swaggerUIRoutes = + swaggerUIRoutesWithOptions OrbOpenApi.defaultOpenApiOptions + +{- | + These routes can be included in your application routes to provide an + auto-generate SwaggerUI for any OpenAPI specs defined by the router passed + in. The provided router should have the root-level routing of the APIs so + that they can be invoked successfully via the paths found in the generated + OpenAPI specs. The 'SwaggerUIRoute' type has a 'Dispatchable' instance, so + requests can be handled via 'Orb.dispatch', which will be done automatically + if the routes are in a Shrubbery union using Orbs automatic dispatching for + unions. + + A separate SwaggerUI will be offered for each of the APIs labeled via + 'OrbOpenApi.provideOpenApi' in the provided router. These can be accessed via + @/@ under whatever path you choose to include 'swaggerUIRoutes' + within your application's routes. + + A version of 'swaggerUIRoutes' that takes an 'OrbOpenApi.OpenApiOptions' + value. If you use this function, you probably also want to use + 'Orb.Main.mainWithDefaultOptions' instead of 'Orb.Main.main' and specify the + same options that you're passing to this function. +-} +swaggerUIRoutesWithOptions :: + R.Router r => + OrbOpenApi.OpenApiOptions -> + OrbOpenApi.OpenApiRouter a -> + r SwaggerUIRoute +swaggerUIRoutesWithOptions options openApiRouter = let pathRouter = R.routeList $ @@ -65,7 +97,7 @@ swaggerUIRoutes openApiRouter = /: R.get (R.make SwaggerUIResource /+ R.Param fileNameParam swaggerUIResourcePath) /: R.emptyRoutes in - R.make (SwaggerUIRoute (OrbOpenApi.mkAllOpenApis openApiRouter)) + R.make (SwaggerUIRoute (OrbOpenApi.mkAllOpenApis options openApiRouter)) /+ R.Param apiLabelParam swaggerApiLabel /> R.Subrouter pathRouter swaggerUIPath @@ -86,7 +118,7 @@ fileNameParam = the browser. -} data SwaggerUIRoute = SwaggerUIRoute - { swaggerOpenApis :: Either String (Map.Map String OpenApi.OpenApi) + { swaggerOpenApis :: Either [OrbOpenApi.OpenApiError] (Map.Map String OpenApi.OpenApi) , swaggerApiLabel :: T.Text , swaggerUIPath :: SwaggerUIPath } @@ -140,14 +172,14 @@ dispatchSwaggerUIRoute :: (HasRespond.HasRespond m, HasRequest.HasRequest m, MIO.MonadIO m) => SwaggerUIRoute -> m Wai.ResponseReceived -dispatchSwaggerUIRoute (SwaggerUIRoute errOrOpenApis apiLabel apiPath) = - case errOrOpenApis of - Left err -> +dispatchSwaggerUIRoute (SwaggerUIRoute errsOrOpenApis apiLabel apiPath) = + case errsOrOpenApis of + Left errs -> Response.respondWith $ Wai.responseLBS HTTP.status500 [("Content-Type", Response.textPlain)] - (LBS8.pack err) + (LBS8.pack . unlines . map OrbOpenApi.renderOpenApiError $ errs) Right allOpenApis -> case Map.lookup (T.unpack apiLabel) allOpenApis of Nothing -> Response.respondWith notFoundResponse diff --git a/stack-ghc-9.10.yaml b/stack-ghc-9.10.yaml index b68274a..b09ea70 100644 --- a/stack-ghc-9.10.yaml +++ b/stack-ghc-9.10.yaml @@ -11,7 +11,7 @@ extra-deps: - github: flipstone/shrubbery commit: a064ede07e01b753a6eb310fc24d9fd8da1ad826 - github: flipstone/json-fleece - commit: 68e248c9bf1e2033358505d86d1cbc75506777ce + commit: 2064e681d594a603fcbaf2e58105c64ee53156a1 subdirs: - json-fleece-aeson - json-fleece-core diff --git a/stack-ghc-9.10.yaml.lock b/stack-ghc-9.10.yaml.lock index 3693a70..6a32957 100644 --- a/stack-ghc-9.10.yaml.lock +++ b/stack-ghc-9.10.yaml.lock @@ -57,29 +57,29 @@ packages: - completed: name: json-fleece-aeson pantry-tree: - sha256: b033b89cb2b953a6243cd653d40739b512aa347956345409d3569f28b4d3da76 - size: 581 - sha256: c6984319a1e66edd5b6a18b3610b5bfa95f507870f6885f26cb3751e0b2f7ff7 - size: 3067241 + sha256: d687b890f3727930fba309980fdb2b7f099e3c6092006940867c7fed3c19bd64 + size: 628 + sha256: d37000c263116c1f30d69dde80ece99f2a0037a5f07a378537cb282c3ac5debf + size: 3073901 subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz - version: 0.3.7.2 + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz + version: 0.3.8.0 original: subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz - completed: name: json-fleece-core pantry-tree: - sha256: 83cbd3f3b1548883235d80473bea1c44170524cde37f799433643632e0571992 - size: 443 - sha256: c6984319a1e66edd5b6a18b3610b5bfa95f507870f6885f26cb3751e0b2f7ff7 - size: 3067241 + sha256: 5adc2bf8c045e936eeb32d4388ee1dcd44cb4557e078b485c9a7415b98a9387f + size: 491 + sha256: d37000c263116c1f30d69dde80ece99f2a0037a5f07a378537cb282c3ac5debf + size: 3073901 subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz - version: 0.7.1.2 + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz + version: 0.8.0.0 original: subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz snapshots: - completed: sha256: 0d0bb681dd5be9b930c8fc070d717aae757b9aed176ae6047d87624b46406816 diff --git a/stack-ghc-9.6.yaml b/stack-ghc-9.6.yaml index d42a423..41b78e0 100644 --- a/stack-ghc-9.6.yaml +++ b/stack-ghc-9.6.yaml @@ -11,7 +11,7 @@ extra-deps: - github: flipstone/shrubbery commit: a064ede07e01b753a6eb310fc24d9fd8da1ad826 - github: flipstone/json-fleece - commit: 68e248c9bf1e2033358505d86d1cbc75506777ce + commit: 2064e681d594a603fcbaf2e58105c64ee53156a1 subdirs: - json-fleece-aeson - json-fleece-core diff --git a/stack-ghc-9.6.yaml.lock b/stack-ghc-9.6.yaml.lock index 68d5636..fbec44b 100644 --- a/stack-ghc-9.6.yaml.lock +++ b/stack-ghc-9.6.yaml.lock @@ -57,29 +57,29 @@ packages: - completed: name: json-fleece-aeson pantry-tree: - sha256: b033b89cb2b953a6243cd653d40739b512aa347956345409d3569f28b4d3da76 - size: 581 - sha256: c6984319a1e66edd5b6a18b3610b5bfa95f507870f6885f26cb3751e0b2f7ff7 - size: 3067241 + sha256: d687b890f3727930fba309980fdb2b7f099e3c6092006940867c7fed3c19bd64 + size: 628 + sha256: d37000c263116c1f30d69dde80ece99f2a0037a5f07a378537cb282c3ac5debf + size: 3073901 subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz - version: 0.3.7.2 + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz + version: 0.3.8.0 original: subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz - completed: name: json-fleece-core pantry-tree: - sha256: 83cbd3f3b1548883235d80473bea1c44170524cde37f799433643632e0571992 - size: 443 - sha256: c6984319a1e66edd5b6a18b3610b5bfa95f507870f6885f26cb3751e0b2f7ff7 - size: 3067241 + sha256: 5adc2bf8c045e936eeb32d4388ee1dcd44cb4557e078b485c9a7415b98a9387f + size: 491 + sha256: d37000c263116c1f30d69dde80ece99f2a0037a5f07a378537cb282c3ac5debf + size: 3073901 subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz - version: 0.7.1.2 + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz + version: 0.8.0.0 original: subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz snapshots: - completed: sha256: 238fa745b64f91184f9aa518fe04bdde6552533d169b0da5256670df83a0f1a9 diff --git a/stack-ghc-9.8.yaml b/stack-ghc-9.8.yaml index 843dc4e..93a0073 100644 --- a/stack-ghc-9.8.yaml +++ b/stack-ghc-9.8.yaml @@ -11,7 +11,7 @@ extra-deps: - github: flipstone/shrubbery commit: a064ede07e01b753a6eb310fc24d9fd8da1ad826 - github: flipstone/json-fleece - commit: 68e248c9bf1e2033358505d86d1cbc75506777ce + commit: 2064e681d594a603fcbaf2e58105c64ee53156a1 subdirs: - json-fleece-aeson - json-fleece-core diff --git a/stack-ghc-9.8.yaml.lock b/stack-ghc-9.8.yaml.lock index 912452c..2e0d38b 100644 --- a/stack-ghc-9.8.yaml.lock +++ b/stack-ghc-9.8.yaml.lock @@ -57,29 +57,29 @@ packages: - completed: name: json-fleece-aeson pantry-tree: - sha256: b033b89cb2b953a6243cd653d40739b512aa347956345409d3569f28b4d3da76 - size: 581 - sha256: c6984319a1e66edd5b6a18b3610b5bfa95f507870f6885f26cb3751e0b2f7ff7 - size: 3067241 + sha256: d687b890f3727930fba309980fdb2b7f099e3c6092006940867c7fed3c19bd64 + size: 628 + sha256: d37000c263116c1f30d69dde80ece99f2a0037a5f07a378537cb282c3ac5debf + size: 3073901 subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz - version: 0.3.7.2 + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz + version: 0.3.8.0 original: subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz - completed: name: json-fleece-core pantry-tree: - sha256: 83cbd3f3b1548883235d80473bea1c44170524cde37f799433643632e0571992 - size: 443 - sha256: c6984319a1e66edd5b6a18b3610b5bfa95f507870f6885f26cb3751e0b2f7ff7 - size: 3067241 + sha256: 5adc2bf8c045e936eeb32d4388ee1dcd44cb4557e078b485c9a7415b98a9387f + size: 491 + sha256: d37000c263116c1f30d69dde80ece99f2a0037a5f07a378537cb282c3ac5debf + size: 3073901 subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz - version: 0.7.1.2 + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz + version: 0.8.0.0 original: subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/68e248c9bf1e2033358505d86d1cbc75506777ce.tar.gz + url: https://github.com/flipstone/json-fleece/archive/2064e681d594a603fcbaf2e58105c64ee53156a1.tar.gz snapshots: - completed: sha256: 7e724f347d5969cb5e8dde9f9aae30996e3231c29d1dafd45f21f1700d4c4fcb diff --git a/stack.yaml.lock b/stack.yaml.lock index 300f507..d5c5a56 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -57,29 +57,29 @@ packages: - completed: name: json-fleece-aeson pantry-tree: - sha256: b033b89cb2b953a6243cd653d40739b512aa347956345409d3569f28b4d3da76 + sha256: 4821f2305b6a4a38fea102375dce74a3f9296cb804aaa009fead93d07b73e51d size: 581 - sha256: 4aca3a1480ecdf5aac9f4873ce17aacaa34bb8d9862c10a9740e9eb470a93c33 - size: 3047689 + sha256: f39c90b9e0dd1efbc362fd4f012ca9d0475bba7982b97964b97b8a598f3165d7 + size: 3068986 subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/36b958bce2399c3f7a79bbc126a7f269781c30ab.tar.gz - version: 0.3.7.2 + url: https://github.com/flipstone/json-fleece/archive/4dcf90fc0c24abe28dfa029db74adc32dbb6b027.tar.gz + version: 0.3.8.0 original: subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/36b958bce2399c3f7a79bbc126a7f269781c30ab.tar.gz + url: https://github.com/flipstone/json-fleece/archive/4dcf90fc0c24abe28dfa029db74adc32dbb6b027.tar.gz - completed: name: json-fleece-core pantry-tree: - sha256: 83cbd3f3b1548883235d80473bea1c44170524cde37f799433643632e0571992 - size: 443 - sha256: 4aca3a1480ecdf5aac9f4873ce17aacaa34bb8d9862c10a9740e9eb470a93c33 - size: 3047689 + sha256: 4f1b4f4684155abec72fe865975865e0caa94a01440c0281e38f864afb052c02 + size: 444 + sha256: f39c90b9e0dd1efbc362fd4f012ca9d0475bba7982b97964b97b8a598f3165d7 + size: 3068986 subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/36b958bce2399c3f7a79bbc126a7f269781c30ab.tar.gz - version: 0.7.1.2 + url: https://github.com/flipstone/json-fleece/archive/4dcf90fc0c24abe28dfa029db74adc32dbb6b027.tar.gz + version: 0.8.0.0 original: subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/36b958bce2399c3f7a79bbc126a7f269781c30ab.tar.gz + url: https://github.com/flipstone/json-fleece/archive/4dcf90fc0c24abe28dfa029db74adc32dbb6b027.tar.gz snapshots: - completed: sha256: 0d0bb681dd5be9b930c8fc070d717aae757b9aed176ae6047d87624b46406816 diff --git a/test/Fixtures.hs b/test/Fixtures.hs index a34ef90..ad344be 100644 --- a/test/Fixtures.hs +++ b/test/Fixtures.hs @@ -11,4 +11,5 @@ import Fixtures.NullableRefCollectComponents as Export import Fixtures.OpenApiSubset as Export import Fixtures.SimpleGet as Export import Fixtures.SimplePost as Export +import Fixtures.TaggedUnion as Export import Fixtures.Union as Export diff --git a/test/Fixtures/TaggedUnion.hs b/test/Fixtures/TaggedUnion.hs new file mode 100644 index 0000000..5bed60b --- /dev/null +++ b/test/Fixtures/TaggedUnion.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Fixtures.TaggedUnion + ( TaggedUnion (..) + , taggedUnionOpenApiRouter + ) where + +import Beeline.Routing ((/-), (/:)) +import Beeline.Routing qualified as R +import Data.Text qualified as T +import Fleece.Core ((#+), (#@)) +import Fleece.Core qualified as FC +import Shrubbery (type (@=)) +import Shrubbery qualified as S + +import Fixtures.NoPermissions (NoPermissions (NoPermissions)) +import Orb qualified +import TestDispatchM qualified as TDM + +taggedUnionOpenApiRouter :: Orb.OpenApiProvider r => r (S.Union '[TaggedUnion]) +taggedUnionOpenApiRouter = + Orb.provideOpenApi "tagged-union" + . R.routeList + $ (Orb.get (R.make TaggedUnion /- "tagged-union")) + /: R.emptyRoutes + +data TaggedUnion = TaggedUnion + +instance Orb.HasHandler TaggedUnion where + type HandlerResponses TaggedUnion = TaggedUnionResponses + type HandlerPermissionAction TaggedUnion = NoPermissions + type HandlerMonad TaggedUnion = TDM.TestDispatchM + routeHandler = + Orb.Handler + { Orb.handlerId = "TaggedUnionHandler" + , Orb.requestBody = Orb.EmptyRequestBody + , Orb.requestQuery = Orb.EmptyRequestQuery + , Orb.requestHeaders = Orb.EmptyRequestHeaders + , Orb.handlerResponseBodies = + Orb.responseBodies + . Orb.addResponseSchema200 unionResponseSchema + . Orb.addResponseSchema500 Orb.internalServerErrorSchema + $ Orb.noResponseBodies + , Orb.mkPermissionAction = + \_request -> NoPermissions + , Orb.handleRequest = + \_request () -> + Orb.return200 (S.unifyTaggedUnion @"foo" (Foo True)) + } + +type TaggedUnionResponses = + [ Orb.Response200 TaggedUnionResponse + , Orb.Response500 Orb.InternalServerError + ] + +type TaggedUnionResponse = + S.TaggedUnion + [ "foo" @= Foo + , "bar" @= Bar + ] + +unionResponseSchema :: FC.Fleece schema => schema TaggedUnionResponse +unionResponseSchema = + FC.taggedUnionNamed "TaggedUnionResponse" "type" $ + FC.taggedUnionMember @"foo" fooObjectSchema + #@ FC.taggedUnionMember @"bar" barObjectSchema + +data Foo = Foo + { fooField :: Bool + } + +fooObjectSchema :: FC.Fleece schema => FC.Object schema Foo Foo +fooObjectSchema = + FC.constructor Foo + #+ FC.required "fooField" fooField FC.boolean + +data Bar = Bar + { barField :: T.Text + } + +barObjectSchema :: FC.Fleece schema => FC.Object schema Bar Bar +barObjectSchema = + FC.constructor Bar + #+ FC.required "barField" barField FC.text diff --git a/test/Fixtures/Union.hs b/test/Fixtures/Union.hs index 71da03a..746384b 100644 --- a/test/Fixtures/Union.hs +++ b/test/Fixtures/Union.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Fixtures.Union @@ -10,7 +11,7 @@ module Fixtures.Union import Beeline.Routing ((/-), (/:)) import Beeline.Routing qualified as R import Data.Text qualified as T -import Fleece.Core ((#+)) +import Fleece.Core ((#+), (#|)) import Fleece.Core qualified as FC import Shrubbery qualified as S @@ -46,7 +47,7 @@ instance Orb.HasHandler Union where \_request -> NoPermissions , Orb.handleRequest = \_request () -> - Orb.return200 (UnionResponse (Left 42)) + Orb.return200 (S.unify @Int 42) } type UnionResponses = @@ -54,15 +55,13 @@ type UnionResponses = , Orb.Response500 Orb.InternalServerError ] -newtype UnionResponse = UnionResponse (Either Int RandomObject) +type UnionResponse = S.Union [Int, RandomObject] unionResponseSchema :: FC.Fleece schema => schema UnionResponse unionResponseSchema = - FC.coerceSchema intOrObjectSchema - -intOrObjectSchema :: FC.Fleece schema => schema (Either Int RandomObject) -intOrObjectSchema = - FC.eitherOfNamed "IntOrObject" FC.int randomObjectSchema + FC.unionNamed "UnionResponse" $ + FC.unionMember FC.int + #| FC.unionMember randomObjectSchema data RandomObject = RandomObject { randomBool :: Bool diff --git a/test/OpenApi.hs b/test/OpenApi.hs index a0312a9..19ab706 100644 --- a/test/OpenApi.hs +++ b/test/OpenApi.hs @@ -3,8 +3,9 @@ module OpenApi ) where import Data.Aeson.Encode.Pretty qualified as AesonPretty -import Data.ByteString.Lazy as LBS +import Data.ByteString.Lazy qualified as LBS import Data.OpenApi qualified as OpenApi +import Data.Set qualified as Set import Hedgehog ((===)) import Hedgehog qualified as HH import Test.Tasty qualified as Tasty @@ -18,7 +19,8 @@ testGroup :: Tasty.TestTree testGroup = Tasty.testGroup "OpenApi" - [ TastyHH.testProperty "cannot generate an unknown open api" prop_openApiUnknownLabel + [ test_openApiUnknownLabel + , test_rejectsSchemaNamesWithUnallowedCharacters , test_simpleGet , test_simplePost , test_getWithQuery @@ -27,88 +29,126 @@ testGroup = , test_openApiSubset , test_nullableRefOpenApi , test_unionOpenApi + , test_taggedUnionOpenApi , test_nullableRefCollectComponentsOpenApi ] -prop_openApiUnknownLabel :: HH.Property -prop_openApiUnknownLabel = HH.withTests 1 . HH.property $ do - case Orb.mkOpenApi Fixtures.simpleGetOpenApiRouter "unknown-open-api" of - Right _ -> fail "Should not have returned an OpenApi for an unknown label" - Left msg -> msg === "No OpenApi definition found with label unknown-open-api." +test_openApiUnknownLabel :: Tasty.TestTree +test_openApiUnknownLabel = + TastyHH.testProperty "cannot generate an unknown open api" . HH.withTests 1 . HH.property $ + case mkTestOpenApi Fixtures.simpleGetOpenApiRouter "unknown-open-api" of + Right _ -> fail "Should not have returned an OpenApi for an unknown label" + Left msg -> + fmap Orb.renderOpenApiError msg + === ["No OpenApi definition found with label unknown-open-api."] + +test_rejectsSchemaNamesWithUnallowedCharacters :: Tasty.TestTree +test_rejectsSchemaNamesWithUnallowedCharacters = + TastyHH.testProperty "Rejects schema names with unallowed characters" . HH.withTests 1 . HH.property $ + let + options = + Orb.defaultOpenApiOptions + { Orb.openApiAllowedSchemaNameChars = Set.fromList "" + } + in + case Orb.mkOpenApi options Fixtures.simpleGetOpenApiRouter "simple-get" of + Right _ -> fail "Should not have returned an OpenApi for an unknown label" + Left errs -> + fmap Orb.renderOpenApiError errs + === [ "Invalid Schema Name: \"InternalServerError\" only the following characters are allowed, \"\".\n\ + \ - Found at: Schema <>\n" + , "Invalid Schema Name: \"SuccessMessage\" only the following characters are allowed, \"\".\n\ + \ - Found at: Schema <>\n" + ] test_simpleGet :: Tasty.TestTree test_simpleGet = mkGoldenTest "Generates the correct OpenAPI JSON for a simple get" "test/examples/simple-get.json" - $ Orb.mkOpenApi Fixtures.simpleGetOpenApiRouter "simple-get" + $ mkTestOpenApi Fixtures.simpleGetOpenApiRouter "simple-get" test_simplePost :: Tasty.TestTree test_simplePost = mkGoldenTest "Generates the correct OpenAPI JSON for a simple post" "test/examples/simple-post.json" - $ Orb.mkOpenApi Fixtures.simplePostOpenApiRouter "simple-post" + $ mkTestOpenApi Fixtures.simplePostOpenApiRouter "simple-post" test_getWithQuery :: Tasty.TestTree test_getWithQuery = mkGoldenTest "Generates the correct OpenAPI JSON for a get with query params" "test/examples/get-with-query.json" - $ Orb.mkOpenApi Fixtures.getWithQueryOpenApiRouter "get-with-query" + $ mkTestOpenApi Fixtures.getWithQueryOpenApiRouter "get-with-query" test_getWithHeaders :: Tasty.TestTree test_getWithHeaders = mkGoldenTest "Generates the correct OpenAPI JSON for a get with header params" "test/examples/get-with-headers.json" - $ Orb.mkOpenApi Fixtures.getWithHeadersOpenApiRouter "get-with-headers" + $ mkTestOpenApi Fixtures.getWithHeadersOpenApiRouter "get-with-headers" test_getWithCookies :: Tasty.TestTree test_getWithCookies = mkGoldenTest "Generates the correct OpenAPI JSON for a get with header params" "test/examples/get-with-cookies.json" - $ Orb.mkOpenApi Fixtures.getWithCookiesOpenApiRouter "get-with-cookies" + $ mkTestOpenApi Fixtures.getWithCookiesOpenApiRouter "get-with-cookies" test_openApiSubset :: Tasty.TestTree test_openApiSubset = mkGoldenTest "Generates the correct OpenAPI JSON for a subset of routes" "test/examples/open-api-subset.json" - $ Orb.mkOpenApi Fixtures.openApiSubsetRouter "open-api-subset" + $ mkTestOpenApi Fixtures.openApiSubsetRouter "open-api-subset" test_nullableRefOpenApi :: Tasty.TestTree test_nullableRefOpenApi = mkGoldenTest "Generates the correct OpenAPI JSON for a nullable schema" "test/examples/nullable-ref.json" - $ Orb.mkOpenApi Fixtures.nullableRefOpenApiRouter "nullable-ref" + $ mkTestOpenApi Fixtures.nullableRefOpenApiRouter "nullable-ref" test_unionOpenApi :: Tasty.TestTree test_unionOpenApi = mkGoldenTest "Generates the correct OpenAPI JSON for a union schema" "test/examples/union.json" - $ Orb.mkOpenApi Fixtures.unionOpenApiRouter "union" + $ mkTestOpenApi Fixtures.unionOpenApiRouter "union" + +test_taggedUnionOpenApi :: Tasty.TestTree +test_taggedUnionOpenApi = + mkGoldenTest + "Generates the correct OpenAPI JSON for a tagged union schema" + "test/examples/tagged-union.json" + $ mkTestOpenApi Fixtures.taggedUnionOpenApiRouter "tagged-union" test_nullableRefCollectComponentsOpenApi :: Tasty.TestTree test_nullableRefCollectComponentsOpenApi = mkGoldenTest "Generates the correct OpenAPI JSON for a nullable schema with an inner object schema" "test/examples/nullable-ref-collect-components.json" - $ Orb.mkOpenApi Fixtures.nullableRefCollectComponentsOpenApiRouter "nullable-ref-collect-components" + $ mkTestOpenApi Fixtures.nullableRefCollectComponentsOpenApiRouter "nullable-ref-collect-components" + +mkTestOpenApi :: Orb.OpenApiRouter a -> String -> Either [Orb.OpenApiError] OpenApi.OpenApi +mkTestOpenApi = + Orb.mkOpenApi Orb.defaultOpenApiOptions mkGoldenTest :: Tasty.TestName -> FilePath -> - Either String OpenApi.OpenApi -> + Either [Orb.OpenApiError] OpenApi.OpenApi -> Tasty.TestTree -mkGoldenTest testName goldenPath eopenApi = do +mkGoldenTest testName goldenPath errOrOpenApi = do -- Using VsStringDiff instead of VsString because the output for failing -- tests is better goldenVsStringDiff testName (\ref new -> ["diff", "-u", ref, new]) goldenPath $ do - openApi <- either fail pure eopenApi + openApi <- + either + (fail . unlines . fmap Orb.renderOpenApiError) + pure + errOrOpenApi -- Aeson Pretty doesn't emit a newline at the end, but some text editors -- like to add it. So we explicitly add it. pure $ AesonPretty.encodePretty openApi <> LBS.pack [10] diff --git a/test/SwaggerUI.hs b/test/SwaggerUI.hs index d0187e8..453f675 100644 --- a/test/SwaggerUI.hs +++ b/test/SwaggerUI.hs @@ -61,7 +61,10 @@ prop_swaggerUIOpenApi = HH.withTests 1 . HH.property $ do expectedJSON <- HH.evalEither ( AesonPretty.encodePretty - <$> Orb.mkOpenApi Fixtures.simpleGetOpenApiRouter "simple-get" + <$> Orb.mkOpenApi + Orb.defaultOpenApiOptions + Fixtures.simpleGetOpenApiRouter + "simple-get" ) response <- HH.evalIO . WaiTest.withSession swaggerUIApp $ do diff --git a/test/examples/tagged-union.json b/test/examples/tagged-union.json new file mode 100644 index 0000000..601c765 --- /dev/null +++ b/test/examples/tagged-union.json @@ -0,0 +1,102 @@ +{ + "components": { + "schemas": { + "InternalServerError": { + "properties": { + "internal_server_error": { + "type": "string" + } + }, + "required": [ + "internal_server_error" + ], + "title": "InternalServerError", + "type": "object" + }, + "TaggedUnionResponse": { + "discriminator": { + "mapping": { + "bar": "#/components/schemas/TaggedUnionResponse.bar", + "foo": "#/components/schemas/TaggedUnionResponse.foo" + }, + "propertyName": "type" + }, + "oneOf": [ + { + "$ref": "#/components/schemas/TaggedUnionResponse.foo" + }, + { + "$ref": "#/components/schemas/TaggedUnionResponse.bar" + } + ], + "title": "TaggedUnionResponse" + }, + "TaggedUnionResponse.bar": { + "properties": { + "barField": { + "type": "string" + }, + "type": { + "type": "string" + } + }, + "required": [ + "type", + "barField" + ], + "title": "TaggedUnionResponse.bar", + "type": "object" + }, + "TaggedUnionResponse.foo": { + "properties": { + "fooField": { + "type": "boolean" + }, + "type": { + "type": "string" + } + }, + "required": [ + "type", + "fooField" + ], + "title": "TaggedUnionResponse.foo", + "type": "object" + } + } + }, + "info": { + "title": "", + "version": "" + }, + "openapi": "3.0.0", + "paths": { + "/tagged-union": { + "get": { + "operationId": "TaggedUnionHandler", + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/TaggedUnionResponse" + } + } + }, + "description": "" + }, + "500": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/InternalServerError" + } + } + }, + "description": "" + } + } + } + } + } +} diff --git a/test/examples/union.json b/test/examples/union.json index eb3ca1a..ea357c7 100644 --- a/test/examples/union.json +++ b/test/examples/union.json @@ -1,17 +1,6 @@ { "components": { "schemas": { - "IntOrObject": { - "oneOf": [ - { - "type": "integer" - }, - { - "$ref": "#/components/schemas/RandomObject" - } - ], - "title": "IntOrObject" - }, "InternalServerError": { "properties": { "internal_server_error": { @@ -39,6 +28,17 @@ ], "title": "RandomObject", "type": "object" + }, + "UnionResponse": { + "oneOf": [ + { + "type": "integer" + }, + { + "$ref": "#/components/schemas/RandomObject" + } + ], + "title": "UnionResponse" } } }, @@ -56,7 +56,7 @@ "content": { "application/json": { "schema": { - "$ref": "#/components/schemas/IntOrObject" + "$ref": "#/components/schemas/UnionResponse" } } },