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" } } },