diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,11 @@ Unreleased ===== +0.3 +=== + +* Added support for `openapi3` by implementing necessary instances. + 0.2 ===== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -78,10 +78,10 @@ ```haskell type GetBooks - :> SortingParams + = SortingParams ["isbn" ?: Isbn, "name" ?: Text, "author" ?: Text] '["isbn" ?: 'Asc Isbn] - = Get '[JSON] [Book] + :> Get '[JSON] [Book] ``` @@ -134,8 +134,8 @@ ["isbn" ?: Asc Isbn] type GetBooks - :> SortingParamsOf Book -- same as the definition at the section's top - = Get '[JSON] [Book] + = SortingParamsOf Book -- same as the definition at the section's top + :> Get '[JSON] [Book] ``` @@ -157,8 +157,8 @@ ```haskell type GetBooks - :> FilteringParams ["isbn" ?: 'AutoFilter Isbn, "name" ?: 'AutoFilter Text] - = Get '[JSON] [Book] + = FilteringParams ["isbn" ?: 'AutoFilter Isbn, "name" ?: 'AutoFilter Text] + :> Get '[JSON] [Book] ``` @@ -196,8 +196,8 @@ ```haskell type GetBooks - :> FilteringParams ["hasLongName" ?: ManualFilter Bool] - = Get '[JSON] [Book] + = FilteringParams ["hasLongName" ?: ManualFilter Bool] + :> Get '[JSON] [Book] ``` @@ -244,8 +244,8 @@ import Servant.Util.Dummy (paginate) type GetBooks - :> PaginationParams - = Get '[JSON] [Book] + = PaginationParams + :> Get '[JSON] [Book] getBooks :: ToServer GetBooks getBooks pagination = paginate pagination <$> getAllBooks diff --git a/examples/BooksOpenApi.hs b/examples/BooksOpenApi.hs new file mode 100644 --- /dev/null +++ b/examples/BooksOpenApi.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} + +module BooksOpenApi where + +import Universum + +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.OpenApi (OpenApi, ToParamSchema, ToSchema) +import Fmt (Buildable (..), (+|), (|+)) +import qualified Network.Wai.Handler.Warp as Warp +import Servant (FromHttpApiData, Get, JSON, PostCreated, QueryParam, ReqBody, Server, serve, + (:<|>) (..), (:>)) +import Servant.OpenApi (toOpenApi) +import Servant.Swagger.UI (SwaggerSchemaUI, swaggerSchemaUIServer) + +import Servant.Util + +newtype Isbn = Isbn Word64 + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromJSON, ToSchema, ToParamSchema, FromHttpApiData) + +type instance SupportedFilters Isbn = '[FilterMatching, FilterComparing] + +type instance ParamDescription Isbn = "ISBN of a book" +type instance ParamDescription Text = "Text" + +data Book = Book + { isbn :: Isbn + , bookName :: Text + , author :: Text + } + deriving (Generic) + deriving anyclass (ToSchema) + +deriveJSON defaultOptions 'Book + +newtype Password = Password Text + deriving stock (Generic) + deriving newtype (FromHttpApiData, ToParamSchema) + +type GetBooks + = SortingParams + '["isbn" ?: Isbn, "name" ?: Text, "author" ?: Text] + '["isbn" ?: 'Asc Isbn] + :> FilteringParams ["isbn" ?: 'AutoFilter Isbn, "name" ?: 'AutoFilter Text] + :> PaginationParams ('DefPageSize 20) + :> Get '[JSON] [Book] + +type AddBook + = QueryParam "password" Password + :> ReqBody '[JSON] Book + :> PostCreated '[JSON] Isbn + +type BooksAPI = "books" :> ( + GetBooks :<|> + AddBook + ) + +openapi :: OpenApi +openapi = toOpenApi @BooksAPI Proxy + +booksHandlers :: Server BooksAPI +booksHandlers = + (\_sorting _filtering _pagination -> return []) + :<|> + (\_ book -> return (isbn book)) + +warpSettings :: Warp.Settings +warpSettings = Warp.defaultSettings + & Warp.setHost "127.0.0.1" + & Warp.setPort 8090 + +instance Buildable Isbn where + build (Isbn i) = "isbn:" <> build i + +instance Buildable Password where + build _ = "" + +instance Buildable Book where + build Book{..} = + "{ isbn = " +| isbn |+ + ", title = " +| bookName |+ + ", author = " +| author |+ + "}" + +instance Buildable (ForResponseLog Isbn) where + build = buildForResponse + +instance Buildable (ForResponseLog Book) where + build = buildForResponse + +instance Buildable (ForResponseLog [Book]) where + build = buildListForResponse (take 5) + +serveBooksServer :: IO () +serveBooksServer = + Warp.runSettings warpSettings $ + serverWithLogging loggingConfig (Proxy @BooksAPI) $ \(Proxy :: Proxy api) -> + serve @(SwaggerSchemaUI "swagger-ui" "swagger.json" :<|> api) Proxy + (swaggerSchemaUIServer openapi :<|> booksHandlers) + where + loggingConfig = ServantLogConfig $ \_ -> putTextLn diff --git a/servant-util.cabal b/servant-util.cabal --- a/servant-util.cabal +++ b/servant-util.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack -- --- hash: 936cf3a2b61cfa35f3cca3316f3946e3e890066234f3e915b0190b1b41bb84a6 +-- hash: f0ae0577e7cde4002a074bd5fada6d918ea3dc45baee134d38fa8e002ad66d9f name: servant-util -version: 0.2 +version: 0.3 synopsis: Servant servers utilities. description: Basement for common Servant combinators like filtering, sorting, pagination and semantical logging. category: Servant, Web @@ -73,7 +73,39 @@ Paths_servant_util hs-source-dirs: src - default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications + default-extensions: + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveGeneric + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + OverloadedLabels + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + TypeApplications ghc-options: -Wall build-depends: QuickCheck @@ -88,6 +120,7 @@ , lens , megaparsec , mtl + , openapi3 , pretty-terminal , reflection , regex-posix @@ -95,6 +128,7 @@ , servant , servant-client , servant-client-core + , servant-openapi3 , servant-server , servant-swagger , servant-swagger-ui @@ -111,10 +145,43 @@ main-is: Main.hs other-modules: Books + BooksOpenApi Paths_servant_util hs-source-dirs: examples - default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications + default-extensions: + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveGeneric + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + OverloadedLabels + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + TypeApplications ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 build-depends: QuickCheck @@ -129,6 +196,7 @@ , lens , megaparsec , mtl + , openapi3 , pretty-terminal , reflection , regex-posix @@ -136,6 +204,7 @@ , servant , servant-client , servant-client-core + , servant-openapi3 , servant-server , servant-swagger , servant-swagger-ui @@ -166,7 +235,39 @@ Paths_servant_util hs-source-dirs: tests - default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications + default-extensions: + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveGeneric + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + OverloadedLabels + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + TypeApplications ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover @@ -186,6 +287,7 @@ , lens , megaparsec , mtl + , openapi3 , pretty-terminal , reflection , regex-posix @@ -193,6 +295,7 @@ , servant , servant-client , servant-client-core + , servant-openapi3 , servant-server , servant-swagger , servant-swagger-ui diff --git a/src/Servant/Util/Combinators/ErrorResponses.hs b/src/Servant/Util/Combinators/ErrorResponses.hs --- a/src/Servant/Util/Combinators/ErrorResponses.hs +++ b/src/Servant/Util/Combinators/ErrorResponses.hs @@ -10,11 +10,13 @@ import Universum import Control.Lens (at, (<>~), (?~)) +import qualified Data.OpenApi as O import qualified Data.Swagger as S -import Data.Swagger.Declare (runDeclare) +import qualified Data.Swagger.Declare as S (runDeclare) import GHC.TypeLits (KnownSymbol, Symbol) import Servant (HasServer (..), (:>)) import Servant.Client (HasClient (..)) +import Servant.OpenApi (HasOpenApi (..)) import Servant.Swagger (HasSwagger (..)) import Servant.Util.Combinators.Logging @@ -87,6 +89,7 @@ routeWithLog = inRouteServer @(ErrorResponses errors :> LoggingApiRec config lcontext subApi) route id +-- Swagger instances class KnownErrorCodes (errors :: [ErrorDesc]) where errorCodesToSwagger :: S.Swagger -> S.Swagger @@ -102,7 +105,7 @@ where code = fromIntegral (natVal @code Proxy) desc = symbolValT @desc - (defs, excSchema) = runDeclare (S.declareSchemaRef (Proxy @exc)) mempty + (defs, excSchema) = S.runDeclare (S.declareSchemaRef (Proxy @exc)) mempty response = mempty & S.description .~ desc & S.schema ?~ excSchema @@ -111,6 +114,30 @@ , KnownErrorCodes errors ) => HasSwagger (ErrorResponses errors :> subApi) where toSwagger _ = toSwagger (Proxy @subApi) & errorCodesToSwagger @errors + +-- OpenApi instances +class KnownErrorCodesOpenApi (errors :: [ErrorDesc]) where + errorCodesToOpenApi :: O.OpenApi -> O.OpenApi + +instance KnownErrorCodesOpenApi '[] where + errorCodesToOpenApi = id + +instance (KnownNat code, KnownSymbol desc, O.ToSchema exc, KnownErrorCodesOpenApi es) => + KnownErrorCodesOpenApi ('ErrorDesc code exc desc ': es) where + -- In the absence of a media type we cannot insert a response schema. + errorCodesToOpenApi openapi = openapi + & O.allOperations . O.responses . O.responses . at code ?~ O.Inline response + & errorCodesToOpenApi @es + where + code = fromIntegral (natVal @code Proxy) + desc = symbolValT @desc + response = mempty + & O.description .~ desc + +instance ( HasOpenApi subApi + , KnownErrorCodesOpenApi errors + ) => HasOpenApi (ErrorResponses errors :> subApi) where + toOpenApi _ = toOpenApi (Proxy @subApi) & errorCodesToOpenApi @errors --------------------------------------------------------------------------- -- Helpers diff --git a/src/Servant/Util/Combinators/Filtering/Swagger.hs b/src/Servant/Util/Combinators/Filtering/Swagger.hs --- a/src/Servant/Util/Combinators/Filtering/Swagger.hs +++ b/src/Servant/Util/Combinators/Filtering/Swagger.hs @@ -6,10 +6,13 @@ import Universum import Control.Lens ((<>~)) +import qualified Data.HashMap.Strict.InsOrd as HM +import qualified Data.OpenApi as O import qualified Data.Swagger as S import qualified Data.Text as T import GHC.TypeLits (KnownSymbol) import Servant.API ((:>)) +import Servant.OpenApi (HasOpenApi (..)) import Servant.Swagger (HasSwagger (..)) import Servant.Util.Combinators.Filtering.Base @@ -30,6 +33,25 @@ } } +-- | Make a 'O.Param' for a filtering query parameter. +filterOpenApiParam :: forall a. O.ToParamSchema a => Text -> Text -> O.Param +filterOpenApiParam name desc = + O.Param + { O._paramName = name + , O._paramDescription = Just desc + , O._paramRequired = Just False + , O._paramDeprecated = Just False + , O._paramIn = O.ParamQuery + , O._paramAllowEmptyValue = Just True + , O._paramAllowReserved = Nothing + , O._paramStyle = Just O.StyleDeepObject + , O._paramExample = Nothing + , O._paramExamples = HM.empty + , O._paramExplode = Just True + , O._paramSchema = Just . O.Inline $ O.toParamSchema (Proxy @a) + } + + parenValueDesc :: forall a. KnownSymbol (ParamDescription a) => Text parenValueDesc = "(" <> stripTrailingDot (symbolValT @(ParamDescription a)) <> ")" where @@ -82,15 +104,28 @@ class FilterKindHasSwagger (fk :: FilterKind Type) where filterKindSwagger :: Text -> S.Param -instance DescribedParam a => FilterKindHasSwagger ('ManualFilter a) where +instance DescribedSwaggerParam a => FilterKindHasSwagger ('ManualFilter a) where filterKindSwagger name = filterSwaggerParam @a name (manualFilterDesc @a) -instance (DescribedParam a, AutoFiltersOpsDesc (SupportedFilters a)) => +instance (DescribedSwaggerParam a, AutoFiltersOpsDesc (SupportedFilters a)) => FilterKindHasSwagger ('AutoFilter a) where filterKindSwagger name = filterSwaggerParam @a name (autoFilterDesc @a ops) where ops = autoFiltersOpsDesc @(SupportedFilters a) +-- | Get documentation for the given filter kind. +class FilterKindHasOpenApi (fk :: FilterKind Type) where + filterKindOpenApi :: Text -> O.Param + +instance DescribedOpenApiParam a => FilterKindHasOpenApi ('ManualFilter a) where + filterKindOpenApi name = filterOpenApiParam @a name (manualFilterDesc @a) + +instance (DescribedOpenApiParam a, AutoFiltersOpsDesc (SupportedFilters a)) => + FilterKindHasOpenApi ('AutoFilter a) where + filterKindOpenApi name = filterOpenApiParam @a name (autoFilterDesc @a ops) + where + ops = autoFiltersOpsDesc @(SupportedFilters a) + -- | Get documentation for given filtering params. class FilterParamsHaveSwagger (params :: [TyNamedFilter]) where filterParamsSwagger :: [S.Param] @@ -109,3 +144,22 @@ HasSwagger (FilteringParams params :> api) where toSwagger _ = toSwagger (Proxy @api) & S.allOperations . S.parameters <>~ map S.Inline (filterParamsSwagger @params) + +-- | Get documentation for given filtering params. +class FilterParamsHaveOpenApi (params :: [TyNamedFilter]) where + filterParamsOpenApi :: [O.Param] + +instance FilterParamsHaveOpenApi '[] where + filterParamsOpenApi = mempty + +instance ( KnownSymbol name, FilterKindHasOpenApi fk + , FilterParamsHaveOpenApi params + ) => + FilterParamsHaveOpenApi ('TyNamedParam name fk ': params) where + filterParamsOpenApi = + filterKindOpenApi @fk (symbolValT @name) : filterParamsOpenApi @params + +instance (HasOpenApi api, ReifyParamsNames params, FilterParamsHaveOpenApi params) => + HasOpenApi (FilteringParams params :> api) where + toOpenApi _ = toOpenApi (Proxy @api) + & O.allOperations . O.parameters <>~ map O.Inline (filterParamsOpenApi @params) diff --git a/src/Servant/Util/Combinators/Logging.hs b/src/Servant/Util/Combinators/Logging.hs --- a/src/Servant/Util/Combinators/Logging.hs +++ b/src/Servant/Util/Combinators/Logging.hs @@ -31,6 +31,7 @@ import Control.Monad.Error.Class (catchError, throwError) import Data.Constraint (Dict (..)) import Data.Default (Default (..)) +import Data.OpenApi (OpenApi) import Data.Reflection (Reifies (..), reify) import Data.Swagger (Swagger) import Data.Time.Clock.POSIX (getPOSIXTime) @@ -41,6 +42,7 @@ ReflectMethod (..), ReqBody, SBoolI, Summary, Verb, (:<|>) (..), (:>)) import Servant.API.Modifiers (FoldRequired, foldRequiredArgument) import Servant.Client (HasClient (..)) +import Servant.OpenApi (HasOpenApi (..)) import Servant.Server (Handler (..), HasServer (..), Server, ServerError (..)) import Servant.Swagger (HasSwagger (..)) import Servant.Swagger.UI.Core (SwaggerUiHtml) @@ -544,6 +546,9 @@ instance Buildable (ForResponseLog Swagger) where build _ = "Swagger specification" +instance Buildable (ForResponseLog OpenApi) where + build _ = "OpenApi specification" + instance Buildable (ForResponseLog (SwaggerUiHtml dir api)) where build _ = "Accessed documentation UI" @@ -562,6 +567,10 @@ instance HasSwagger api => HasSwagger (LoggingMod mod :> api) where toSwagger _ = toSwagger (Proxy @api) + +instance HasOpenApi api => + HasOpenApi (LoggingMod mod :> api) where + toOpenApi _ = toOpenApi (Proxy @api) -- | Apply logging to the given server. serverWithLogging diff --git a/src/Servant/Util/Combinators/Pagination.hs b/src/Servant/Util/Combinators/Pagination.hs --- a/src/Servant/Util/Combinators/Pagination.hs +++ b/src/Servant/Util/Combinators/Pagination.hs @@ -14,11 +14,13 @@ import Control.Lens ((<>~), (?~)) import Data.Default (Default (..)) +import qualified Data.OpenApi as O import qualified Data.Swagger as S import qualified Data.Text as T import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, HasServer (..), QueryParam, (:>)) import Servant.Client (HasClient (..)) +import Servant.OpenApi (HasOpenApi (..)) import Servant.Swagger (HasSwagger (..)) import Servant.Server.Internal.Context (type (.++)) @@ -144,6 +146,7 @@ hoistClientMonad pm _ hst subCli = hoistClientMonad pm (Proxy @subApi) hst . subCli +-- Swagger instance instance (HasSwagger api, KnownPaginationPageSize settings) => HasSwagger (PaginationParams settings :> api) where toSwagger _ = toSwagger (Proxy @api) @@ -179,6 +182,42 @@ & S.type_ ?~ S.SwaggerInteger & S.format ?~ "int32" & S.pattern ?~ "^\\d*[1-9]\\d*$" + defaultPageSizeDesc = case settingDefPageSize @settings of + Nothing -> "By default, no limit will be applied." + Just s -> "Defaults to " <> show (unPositive s) <> "." + +-- OpenApi instance +instance (HasOpenApi api, KnownPaginationPageSize settings) => + HasOpenApi (PaginationParams settings :> api) where + toOpenApi _ = toOpenApi (Proxy @api) + & O.allOperations . O.parameters <>~ [O.Inline offsetParam, O.Inline limitParam] + where + offsetParam :: O.Param + limitParam :: O.Param + offsetParam = mempty + & O.name .~ "offset" + & O.description ?~ + "Pagination parameter. How many items to skip from the beginning." + & O.required ?~ False + & O.in_ .~ O.ParamQuery + & O.schema ?~ O.Inline offsetParamSchema + offsetParamSchema = mempty + & O.type_ ?~ O.OpenApiInteger + & O.format ?~ "int32" + + limitParam = mempty + & O.name .~ "limit" + & O.description ?~ mconcat + [ "Pagination parameter. Maximum number of items to return.\n" + , defaultPageSizeDesc + ] + & O.required ?~ False + & O.in_ .~ O.ParamQuery + & O.schema ?~ O.Inline limitParamSchema + limitParamSchema = mempty + & O.type_ ?~ O.OpenApiInteger + & O.format ?~ "int32" + & O.pattern ?~ "^\\d*[1-9]\\d*$" defaultPageSizeDesc = case settingDefPageSize @settings of Nothing -> "By default, no limit will be applied." Just s -> "Defaults to " <> show (unPositive s) <> "." diff --git a/src/Servant/Util/Combinators/Sorting/Swagger.hs b/src/Servant/Util/Combinators/Sorting/Swagger.hs --- a/src/Servant/Util/Combinators/Sorting/Swagger.hs +++ b/src/Servant/Util/Combinators/Sorting/Swagger.hs @@ -6,15 +6,18 @@ import Universum import Control.Lens ((<>~), (?~)) +import qualified Data.OpenApi as O import qualified Data.Swagger as S import qualified Data.Text as T import Fmt (build, fmt, unlinesF) import Servant.API ((:>)) +import Servant.OpenApi (HasOpenApi (..)) import Servant.Swagger (HasSwagger (..)) import Servant.Util.Combinators.Sorting.Base import Servant.Util.Common +-- Swagger instance instance (HasSwagger api, ReifySortingItems base, ReifyParamsNames provided) => HasSwagger (SortingParams provided base :> api) where toSwagger _ = toSwagger (Proxy @api) @@ -41,6 +44,51 @@ paramSchema = mempty & S.type_ ?~ S.SwaggerString & S.pattern ?~ "^" <> fieldPattern <> "(," <> fieldPattern <> ")*" <> "$" + fieldPattern = + "(" <> "[+-](" <> allowedFieldsPattern <> ")+" <> "|" <> + "(asc|desc)\\((" <> allowedFieldsPattern <> ")+\\))" + allowedFields = reifyParamsNames @provided + allowedFieldsDesc = mconcat + [ " Fields allowed for this endpoint: " + , mconcat . intersperse ", " $ + map ((<> "`") . ("`" <>) . build) allowedFields + ] + allowedFieldsPattern = T.intercalate "|" allowedFields + baseFields = reifySortingItems @base + baseFieldsDesc + | null baseFields = "" + | otherwise = mconcat + [ " Base sorting (always applied, lexicographically last): " + , "`" + , mconcat . intersperse ", " $ map build baseFields + , "`" + ] + +-- OpenApi instance +instance (HasOpenApi api, ReifySortingItems base, ReifyParamsNames provided) => + HasOpenApi (SortingParams provided base :> api) where + toOpenApi _ = toOpenApi (Proxy @api) + & O.allOperations . O.parameters <>~ [O.Inline param] + where + param = mempty + & O.name .~ "sortBy" + & O.description ?~ fmt do + unlinesF + [ "Allows lexicographical sorting on fields." + , "General format is one of:" + , " * `+field1,-field2`" + , " * `asc(field1),desc(field2)`" + , "" + , allowedFieldsDesc + , baseFieldsDesc + , " " + ] + & O.required ?~ False + & O.in_ .~ O.ParamQuery + & O.schema ?~ O.Inline paramSchema + paramSchema = mempty + & O.type_ ?~ O.OpenApiString + & O.pattern ?~ "^" <> fieldPattern <> "(," <> fieldPattern <> ")*" <> "$" fieldPattern = "(" <> "[+-](" <> allowedFieldsPattern <> ")+" <> "|" <> "(asc|desc)\\((" <> allowedFieldsPattern <> ")+\\))" diff --git a/src/Servant/Util/Combinators/Tag.hs b/src/Servant/Util/Combinators/Tag.hs --- a/src/Servant/Util/Combinators/Tag.hs +++ b/src/Servant/Util/Combinators/Tag.hs @@ -8,10 +8,12 @@ import Control.Lens (at, (?~)) import qualified Data.HashSet.InsOrd as HS +import qualified Data.OpenApi as O import qualified Data.Swagger as S import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError) import Servant (HasServer (..), StdMethod, Verb, (:<|>), (:>)) import Servant.Client (HasClient (..)) +import Servant.OpenApi (HasOpenApi (..)) import Servant.Swagger (HasSwagger (..)) import Servant.Util.Combinators.Logging @@ -35,6 +37,7 @@ HasLoggingServer config lcontext (Tag name :> subApi) ctx where routeWithLog = inRouteServer @(Tag name :> LoggingApiRec config lcontext subApi) route id +-- Swagger instance instance (HasSwagger subApi, KnownSymbol name) => HasSwagger (Tag name :> subApi) where toSwagger _ = toSwagger (Proxy @subApi) @@ -42,6 +45,14 @@ where name = symbolValT @name +-- OpenApi instance +instance (HasOpenApi subApi, KnownSymbol name) => + HasOpenApi (Tag name :> subApi) where + toOpenApi _ = toOpenApi (Proxy @subApi) + & O.allOperations . O.tags . at name ?~ () + where + name = symbolValT @name + -- | Whether to enable some type-level checks for 'Tag's and 'TagsDescription's -- correspondence. data TagsVerification @@ -82,6 +93,7 @@ AllApiTags (api1 :<|> api2) = AllApiTags api1 `UnionSorted` AllApiTags api2 AllApiTags (Verb (method :: StdMethod) (code :: Nat) ctx a) = '[] +-- Swagger instances -- | Extract tags defined by this mapping. class ReifyTagsFromMapping (mapping :: [TyNamedParam Symbol]) where reifyTagsFromMapping :: HS.InsOrdHashSet S.Tag @@ -125,3 +137,48 @@ HasSwagger (TagDescriptions 'VerifyTags mapping :> api) where toSwagger _ = toSwagger (Proxy @api) & S.tags .~ reifyTagsFromMapping @mapping + +-- OpenApi instances +-- | Extract tags defined by this mapping. +class ReifyTagsFromMapping' (mapping :: [TyNamedParam Symbol]) where + reifyTagsFromMapping' :: HS.InsOrdHashSet O.Tag + +instance ReifyTagsFromMapping' '[] where + reifyTagsFromMapping' = mempty + +instance ( KnownSymbol name, KnownSymbol desc + , ReifyTagsFromMapping' mapping + , ParamsContainNoName mapping name + ) => + ReifyTagsFromMapping' ('TyNamedParam name desc ': mapping) where + reifyTagsFromMapping' = + O.Tag + { O._tagName = symbolValT @name + , O._tagDescription = Just $ symbolValT @desc + , O._tagExternalDocs = Nothing + } `HS.insert` reifyTagsFromMapping' @mapping + +instance ( HasOpenApi api + , ReifyTagsFromMapping' mapping + ) => + HasOpenApi (TagDescriptions 'NoVerifyTags mapping :> api) where + toOpenApi _ = toOpenApi (Proxy @api) + & O.tags .~ reifyTagsFromMapping' @mapping + +instance ( HasOpenApi api + , ReifyTagsFromMapping' mapping + , missingMapping ~ (AllApiTags api // TyNamedParamsNames mapping) + , If (missingMapping == '[]) + (() :: Constraint) + (TypeError ('Text "Following tags have no mapping specified in \ + \TagDescriptions: " ':<>: 'ShowType missingMapping)) + , extraMapping ~ (TyNamedParamsNames mapping // AllApiTags api) + , If (extraMapping == '[]) + (() :: Constraint) + (TypeError ('Text "Mappings for the following names specified in \ + \TagDescriptions are unused: " + ':<>: 'ShowType extraMapping)) + ) => + HasOpenApi (TagDescriptions 'VerifyTags mapping :> api) where + toOpenApi _ = toOpenApi (Proxy @api) + & O.tags .~ reifyTagsFromMapping' @mapping diff --git a/src/Servant/Util/Swagger.hs b/src/Servant/Util/Swagger.hs --- a/src/Servant/Util/Swagger.hs +++ b/src/Servant/Util/Swagger.hs @@ -1,6 +1,7 @@ module Servant.Util.Swagger ( ParamDescription - , DescribedParam + , DescribedOpenApiParam + , DescribedSwaggerParam , paramDescription , QueryFlagDescription @@ -9,34 +10,38 @@ ) where import Universum +import qualified Data.OpenApi.Lens as OT +import qualified Data.Swagger.Lens as ST import Control.Exception (assert) -import Control.Lens (_head, ix, makePrisms, zoom, (?=)) +import Control.Lens (_head, ix, zoom, (?=)) +import qualified Data.OpenApi as O import qualified Data.Swagger as S import GHC.TypeLits (KnownSymbol, Symbol) import Servant (Capture', Description, EmptyAPI, NoContent, QueryFlag, QueryParam', Raw, StdMethod, Verb, (:<|>), (:>)) +import Servant.OpenApi (HasOpenApi (..)) import Servant.Swagger (HasSwagger (..)) import Servant.Util.Common -makePrisms ''S.Referenced - ---------------------------------------------------------------------------- -- Parameter description ---------------------------------------------------------------------------- -- | Description of parameter. -- --- Unfortunatelly, @servant-swagger@ package, when deriving description of +-- Unfortunately, @servant-swagger@ package, when deriving description of -- an endpoint parameter, fills its description for you and makes you implement -- just 'ParamSchema' which has no description field. -- To circumvent that you can define description in instance of this type family -- and later override swagger derivation accordingly. type family ParamDescription a :: Symbol -type DescribedParam a = (S.ToParamSchema a, KnownSymbol (ParamDescription a)) +type DescribedSwaggerParam a = (S.ToParamSchema a, KnownSymbol (ParamDescription a)) +type DescribedOpenApiParam a = (O.ToParamSchema a, KnownSymbol (ParamDescription a)) + -- | Set description according to 'ParamDescription' definition. paramDescription :: forall a proxy. @@ -62,9 +67,20 @@ where desc404L :: Traversal' S.Swagger Text desc404L = S.allOperations . S.responses . S.responses . - ix 404 . _Inline . S.description + ix 404 . ST._Inline . S.description pureDesc404 = toSwagger (Proxy @api) ^? desc404L +instance (HasOpenApi (Capture' mods sym a :> api), HasOpenApi api) => + HasOpenApi (SwaggerCapture mods sym a :> api) where + toOpenApi _ = + toOpenApi (Proxy @(Capture' mods sym a :> api)) + & desc404L .~ fromMaybe "" pureDesc404 + where + desc404L :: Traversal' O.OpenApi Text + desc404L = O.allOperations . O.responses . O.responses . + ix 404 . OT._Inline . O.description + pureDesc404 = toOpenApi (Proxy @api) ^? desc404L + ---------------------------------------------------------------------------- -- QueryParam description ---------------------------------------------------------------------------- @@ -82,9 +98,20 @@ where desc404L :: Traversal' S.Swagger Text desc404L = S.allOperations . S.responses . S.responses . - ix 404 . _Inline . S.description + ix 404 . ST._Inline . S.description pureDesc404 = toSwagger (Proxy @api) ^? desc404L +instance (HasOpenApi (QueryParam' mods sym a :> api), HasOpenApi api) => + HasOpenApi (SwaggerQueryParam mods sym a :> api) where + toOpenApi _ = + toOpenApi (Proxy @(QueryParam' mods sym a :> api)) + & desc404L .~ fromMaybe "" pureDesc404 + where + desc404L :: Traversal' O.OpenApi Text + desc404L = O.allOperations . O.responses . O.responses . + ix 404 . OT._Inline . O.description + pureDesc404 = toOpenApi (Proxy @api) ^? desc404L + ---------------------------------------------------------------------------- -- Query flag description ---------------------------------------------------------------------------- @@ -101,13 +128,25 @@ instance (HasSwagger subApi, KnownSymbol name, KnownSymbol (QueryFlagDescription name)) => HasSwagger (SwaggerQueryFlag name :> subApi) where toSwagger _ = toSwagger (Proxy @(QueryFlag name :> subApi)) `executingState` do - zoom (S.allOperations . S.parameters . _head . _Inline) $ do + zoom (S.allOperations . S.parameters . _head . ST._Inline) $ do paramName <- use S.name assert (name == paramName) pass S.description ?= desc where name = symbolValT @name desc = symbolValT @(QueryFlagDescription name) + +instance (HasOpenApi subApi, KnownSymbol name, KnownSymbol (QueryFlagDescription name)) => + HasOpenApi (SwaggerQueryFlag name :> subApi) where + toOpenApi _ = toOpenApi (Proxy @(QueryFlag name :> subApi)) `executingState` do + zoom (O.allOperations . O.parameters . _head . OT._Inline) $ do + paramName <- use O.name + assert (name == paramName) pass + O.description ?= desc + where + name = symbolValT @name + desc = symbolValT @(QueryFlagDescription name) + ---------------------------------------------------------------------------- -- Global diff --git a/tests/Test/Servant/Filtering/ImplSpec.hs b/tests/Test/Servant/Filtering/ImplSpec.hs --- a/tests/Test/Servant/Filtering/ImplSpec.hs +++ b/tests/Test/Servant/Filtering/ImplSpec.hs @@ -6,12 +6,14 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.TH as Aeson -import Data.Swagger (ToSchema) +import qualified Data.OpenApi as O (ToSchema) +import qualified Data.Swagger as S (ToSchema) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import Data.Time.Clock (UTCTime (..)) import Servant.API (Get, JSON, (:>)) import Servant.API.Generic (ToServantApi, (:-)) import Servant.Server.Generic (AsServer) +import Servant.OpenApi (toOpenApi) import Servant.Swagger (toSwagger) import Test.Hspec (Spec, aroundAll, describe, it) @@ -28,7 +30,8 @@ newtype Isbn = Isbn Word64 deriving (Show, Eq, Ord, Generic) -instance ToSchema Isbn +instance O.ToSchema Isbn +instance S.ToSchema Isbn Aeson.deriveJSON Aeson.defaultOptions ''Isbn @@ -39,7 +42,8 @@ , createdAt :: UTCTime } deriving (Show, Eq, Generic) -instance ToSchema Book +instance O.ToSchema Book +instance S.ToSchema Book Aeson.deriveJSON Aeson.defaultOptions ''Book @@ -119,6 +123,16 @@ writeFile "filter-test-swagger.json" $ decodeUtf8 . Aeson.encode $ toSwagger $ Proxy @(ToServantApi ApiMethods) + +-- OpenApi +--------------------------------------------------------------------------- + +-- You can try this with ghci +printFilterOpenApi :: IO () +printFilterOpenApi = + writeFile "filter-test-openapi.json" $ + decodeUtf8 . Aeson.encode $ + toOpenApi $ Proxy @(ToServantApi ApiMethods) -- Tests --------------------------------------------------------------------------- diff --git a/tests/Test/Servant/Pagination/ImplSpec.hs b/tests/Test/Servant/Pagination/ImplSpec.hs --- a/tests/Test/Servant/Pagination/ImplSpec.hs +++ b/tests/Test/Servant/Pagination/ImplSpec.hs @@ -8,6 +8,7 @@ import Servant.API (Get, JSON, (:>)) import Servant.API.Generic (ToServantApi, (:-)) import Servant.Server.Generic (AsServer) +import Servant.OpenApi (toOpenApi) import Servant.Swagger (toSwagger) import Test.Hspec (Spec, aroundAll, describe, it) @@ -54,6 +55,16 @@ writeFile "pagination-test-swagger.json" $ decodeUtf8 . Aeson.encode $ toSwagger $ Proxy @(ToServantApi ApiMethods) + +-- OpenApi +--------------------------------------------------------------------------- + +-- You can try this with ghci +printPaginationOpenApi :: IO () +printPaginationOpenApi = + writeFile "pagination-test-openapi.json" $ + decodeUtf8 . Aeson.encode $ + toOpenApi $ Proxy @(ToServantApi ApiMethods) -- Tests ---------------------------------------------------------------------------