diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ ## [Unreleased] +## [1.3.0] - 2024-06-13 + +### Changed +- Simplify core API (breaking change) (#47) +- Reimplement Swagger/OpenAPI internals (#45) + ## [1.2.0] - 2024-03-18 ### Added @@ -52,7 +58,8 @@ ### Added - First version of webgear-openapi -[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.2.0...HEAD +[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.3.0...HEAD +[1.3.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.0 [1.2.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.2.0 [1.1.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.1 [1.1.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.0 diff --git a/src/WebGear/OpenApi/Handler.hs b/src/WebGear/OpenApi/Handler.hs --- a/src/WebGear/OpenApi/Handler.hs +++ b/src/WebGear/OpenApi/Handler.hs @@ -1,13 +1,15 @@ {-# LANGUAGE CPP #-} + {- | An implementation of `Handler` to generate `OpenApi` documentation from WebGear API specifications. -} module WebGear.OpenApi.Handler ( OpenApiHandler (..), - DocNode (..), - Tree, - singletonNode, - nullNode, + Documentation (..), + consumeDescription, + consumeSummary, + addRouteDocumentation, + addRootPath, toOpenApi, ) where @@ -15,332 +17,187 @@ import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowPlus (..), ArrowZero (..)) import Control.Arrow.Operations (ArrowError (..)) import qualified Control.Category as Cat -import Control.Lens (at, (%~), (&), (.~), (<>~), (?~)) +import Control.Lens (at, (%~), (&), (.~), (?~), (^.)) +import Control.Monad ((<=<)) +import Control.Monad.State.Strict (MonadState, State, evalState, state) +import Data.Coerce (coerce) import qualified Data.HashMap.Strict.InsOrd as Map -import Data.OpenApi -import Data.OpenApi.Internal.Utils (swaggerMappend) -import Data.Text (Text) -import qualified Data.Text as Text -import Network.HTTP.Media.MediaType (MediaType) -import qualified Network.HTTP.Types as HTTP -import WebGear.Core.Handler (Description (..), Handler (..), RouteMismatch, RoutePath (..), Summary (..)) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import Data.OpenApi ( + OpenApi, + Operation, + PathItem, + Referenced (..), + Response, + allOperations, + delete, + description, + externalDocs, + get, + head_, + options, + parameters, + patch, + paths, + post, + put, + servers, + summary, + trace, + ) +import WebGear.Core.Handler ( + Description (..), + Handler (..), + RouteMismatch, + RoutePath (..), + Summary (..), + ) --- | A tree where internal nodes have one or two children. -data Tree a - = NullNode - | SingleNode a (Tree a) - | BinaryNode (Tree a) (Tree a) - deriving stock (Show) +-- | A handler that captures `OpenApi` documentation of API specifications. +newtype OpenApiHandler m a b = OpenApiHandler (OpenApi -> State Documentation OpenApi) --- | Different types of documentation elements captured by the handler -data DocNode - = DocSecurityScheme Text SecurityScheme - | DocRequestBody (Definitions Schema) RequestBody - | DocResponseBody (Definitions Schema) (InsOrdHashMap MediaType MediaTypeObject) - | DocRequestHeader Param - | DocResponseHeader HeaderName Header - | DocMethod HTTP.StdMethod - | DocPathElem Text - | DocPathVar Param - | DocQueryParam Param - | DocStatus HTTP.Status - | DocSummary Summary - | DocDescription Description - deriving stock (Show) +data Documentation = Documentation !(Maybe Description) !(Maybe Summary) --- | Documentation elements after compaction -data CompactDocNode - = CDocSecurityScheme Text SecurityScheme - | CDocRequestBody (Definitions Schema) RequestBody - | CDocResponseBody (Definitions Schema) (InsOrdHashMap MediaType MediaTypeObject) - | CDocRequestHeader Param - | CDocResponseHeader HeaderName Header - | CDocMethod HTTP.StdMethod - | CDocPathElem Text - | CDocPathVar Param - | CDocRouteDoc (Maybe Summary) (Maybe Description) - | CDocQueryParam Param - | CDocStatus HTTP.Status (Maybe Description) - deriving stock (Show) +consumeDescription :: (MonadState Documentation m) => m (Maybe Description) +consumeDescription = state $ \(Documentation d s) -> (d, Documentation Nothing s) --- | Generate a tree with a single node -singletonNode :: a -> Tree a -singletonNode a = SingleNode a NullNode +consumeSummary :: (MonadState Documentation m) => m (Maybe Summary) +consumeSummary = state $ \(Documentation d s) -> (s, Documentation d Nothing) --- | Generate an empty tree -nullNode :: Tree a -nullNode = NullNode +addRouteDocumentation :: (MonadState Documentation m) => OpenApi -> m OpenApi +addRouteDocumentation doc = do + desc <- consumeDescription + summ <- consumeSummary + pure $ + doc + -- keep any existing documentation + & allOperations . summary %~ (<|> fmap getSummary summ) + & allOperations . description %~ (<|> fmap getDescription desc) -{- | A handler that captured `OpenApi` documentation of API - specifications. --} -newtype OpenApiHandler m a b = OpenApiHandler - {openApiDoc :: Tree DocNode} +addRootPath :: OpenApi -> OpenApi +addRootPath doc = doc & paths .~ [("/", rootPathItem)] + where + rootPathItem :: PathItem + rootPathItem = + mempty @PathItem + & delete ?~ opr + & get ?~ opr + & head_ ?~ opr + & options ?~ opr + & patch ?~ opr + & post ?~ opr + & put ?~ opr + & trace ?~ opr + opr :: Operation + opr = mempty @Operation & at 0 ?~ Inline (mempty @Response) + instance Cat.Category (OpenApiHandler m) where + {-# INLINE id #-} id :: OpenApiHandler m a a - id = OpenApiHandler{openApiDoc = NullNode} + id = OpenApiHandler pure + {-# INLINE (.) #-} (.) :: OpenApiHandler m b c -> OpenApiHandler m a b -> OpenApiHandler m a c - OpenApiHandler doc2 . OpenApiHandler doc1 = OpenApiHandler $ insertAsLeaf doc1 doc2 - where - insertAsLeaf :: Tree DocNode -> Tree DocNode -> Tree DocNode - insertAsLeaf parent child = case parent of - NullNode -> child - SingleNode doc next -> SingleNode doc (insertAsLeaf next child) - BinaryNode b1 b2 -> BinaryNode (insertAsLeaf b1 child) (insertAsLeaf b2 child) + OpenApiHandler g . OpenApiHandler f = OpenApiHandler $ f <=< g instance Arrow (OpenApiHandler m) where + {-# INLINE arr #-} arr :: (a -> b) -> OpenApiHandler m a b - arr _ = OpenApiHandler{openApiDoc = NullNode} + arr _ = OpenApiHandler pure + {-# INLINE first #-} first :: OpenApiHandler m b c -> OpenApiHandler m (b, d) (c, d) - first (OpenApiHandler doc) = OpenApiHandler doc + first = coerce + {-# INLINE second #-} second :: OpenApiHandler m b c -> OpenApiHandler m (d, b) (d, c) - second (OpenApiHandler doc) = OpenApiHandler doc + second = coerce instance ArrowZero (OpenApiHandler m) where + {-# INLINE zeroArrow #-} zeroArrow :: OpenApiHandler m b c - zeroArrow = OpenApiHandler{openApiDoc = NullNode} + zeroArrow = OpenApiHandler pure +newtype MergeOpenApi = MergeOpenApi (OpenApi -> State Documentation OpenApi) + +instance Semigroup MergeOpenApi where + MergeOpenApi f <> MergeOpenApi g = + MergeOpenApi $ \doc -> do + a <- f doc + b <- g doc + pure $ + (a <> b) + & paths .~ Map.unionWith mergePathItem (a ^. paths) (b ^. paths) + & externalDocs .~ (a ^. externalDocs <|> b ^. externalDocs) + where + mergePathItem :: PathItem -> PathItem -> PathItem + mergePathItem x y = + mempty @PathItem + & delete .~ x ^. delete <> y ^. delete + & get .~ x ^. get <> y ^. get + & head_ .~ x ^. head_ <> y ^. head_ + & options .~ x ^. options <> y ^. options + & patch .~ x ^. patch <> y ^. patch + & post .~ x ^. post <> y ^. post + & put .~ x ^. put <> y ^. put + & trace .~ x ^. trace <> y ^. trace + & summary .~ (x ^. summary <|> y ^. summary) + & description .~ (x ^. description <|> y ^. description) + & parameters .~ (x ^. parameters <> y ^. parameters) + & servers .~ (x ^. servers <> y ^. servers) + instance ArrowPlus (OpenApiHandler m) where + {-# INLINE (<+>) #-} (<+>) :: OpenApiHandler m b c -> OpenApiHandler m b c -> OpenApiHandler m b c - OpenApiHandler NullNode <+> OpenApiHandler doc = OpenApiHandler doc - OpenApiHandler doc <+> OpenApiHandler NullNode = OpenApiHandler doc - OpenApiHandler doc1 <+> OpenApiHandler doc2 = OpenApiHandler $ BinaryNode doc1 doc2 + OpenApiHandler f <+> OpenApiHandler g = coerce $ MergeOpenApi f <> MergeOpenApi g instance ArrowChoice (OpenApiHandler m) where + {-# INLINE left #-} left :: OpenApiHandler m b c -> OpenApiHandler m (Either b d) (Either c d) left (OpenApiHandler doc) = OpenApiHandler doc + {-# INLINE right #-} right :: OpenApiHandler m b c -> OpenApiHandler m (Either d b) (Either d c) right (OpenApiHandler doc) = OpenApiHandler doc + {-# INLINE (+++) #-} (+++) :: OpenApiHandler m b c -> OpenApiHandler m b' c' -> OpenApiHandler m (Either b b') (Either c c') - OpenApiHandler doc +++ OpenApiHandler NullNode = OpenApiHandler doc - OpenApiHandler NullNode +++ OpenApiHandler doc = OpenApiHandler doc - OpenApiHandler doc1 +++ OpenApiHandler doc2 = OpenApiHandler $ BinaryNode doc1 doc2 + OpenApiHandler f +++ OpenApiHandler g = coerce $ MergeOpenApi f <> MergeOpenApi g + {-# INLINE (|||) #-} (|||) :: OpenApiHandler m b d -> OpenApiHandler m c d -> OpenApiHandler m (Either b c) d - OpenApiHandler doc ||| OpenApiHandler NullNode = OpenApiHandler doc - OpenApiHandler NullNode ||| OpenApiHandler doc = OpenApiHandler doc - OpenApiHandler doc1 ||| OpenApiHandler doc2 = OpenApiHandler $ BinaryNode doc1 doc2 + OpenApiHandler f ||| OpenApiHandler g = coerce $ MergeOpenApi f <> MergeOpenApi g instance ArrowError RouteMismatch (OpenApiHandler m) where {-# INLINE raise #-} - raise = OpenApiHandler{openApiDoc = NullNode} + raise = OpenApiHandler pure {-# INLINE handle #-} - OpenApiHandler doc1 `handle` OpenApiHandler doc2 = OpenApiHandler $ BinaryNode doc1 doc2 + OpenApiHandler f `handle` OpenApiHandler g = coerce $ MergeOpenApi f <> MergeOpenApi g {-# INLINE tryInUnless #-} - tryInUnless (OpenApiHandler doc1) (OpenApiHandler doc2) (OpenApiHandler doc3) = - OpenApiHandler $ BinaryNode (BinaryNode doc1 doc2) doc3 + tryInUnless (OpenApiHandler f) (OpenApiHandler g) (OpenApiHandler h) = + coerce $ MergeOpenApi f <> MergeOpenApi g <> MergeOpenApi h -instance Monad m => Handler (OpenApiHandler m) m where +instance (Monad m) => Handler (OpenApiHandler m) m where {-# INLINE arrM #-} arrM :: (a -> m b) -> OpenApiHandler m a b - arrM _ = OpenApiHandler{openApiDoc = NullNode} + arrM _ = OpenApiHandler pure {-# INLINE consumeRoute #-} consumeRoute :: OpenApiHandler m RoutePath a -> OpenApiHandler m () a - consumeRoute (OpenApiHandler doc) = OpenApiHandler doc + consumeRoute (OpenApiHandler f) = OpenApiHandler f {-# INLINE setDescription #-} setDescription :: Description -> OpenApiHandler m a a - setDescription = OpenApiHandler . singletonNode . DocDescription + setDescription d = OpenApiHandler $ \doc -> + state $ \(Documentation _ s) -> (doc, Documentation (Just d) s) {-# INLINE setSummary #-} setSummary :: Summary -> OpenApiHandler m a a - setSummary = OpenApiHandler . singletonNode . DocSummary + setSummary s = OpenApiHandler $ \doc -> + state $ \(Documentation d _) -> (doc, Documentation d (Just s)) -- | Generate OpenApi documentation from a handler toOpenApi :: OpenApiHandler m a b -> OpenApi -toOpenApi = go . compact . openApiDoc - where - go t = case t of - NullNode -> mempty - SingleNode parent child -> mergeDoc parent child mempty - BinaryNode t1 t2 -> go t1 `combineOpenApi` go t2 - -compact :: Tree DocNode -> Tree CompactDocNode -compact t = let (_, _, t') = go t in t' - where - go = \case - NullNode -> (Nothing, Nothing, NullNode) - BinaryNode t1 t2 -> - let (descr1, summ1, t1') = go t1 - (descr2, summ2, t2') = go t2 - in (descr1 <|> descr2, summ1 <|> summ2, BinaryNode t1' t2') - SingleNode node child -> compactDoc node child - - compactDoc :: DocNode -> Tree DocNode -> (Maybe Description, Maybe Summary, Tree CompactDocNode) - compactDoc (DocSecurityScheme schemeName scheme) child = - let (descr, summ, child') = go child - scheme' = scheme & description .~ fmap getDescription descr - in (Nothing, summ, SingleNode (CDocSecurityScheme schemeName scheme') child') - compactDoc (DocRequestBody defs body) child = - let (descr, summ, child') = go child - body' = body & description .~ fmap getDescription descr - in (Nothing, summ, SingleNode (CDocRequestBody defs body') child') - compactDoc (DocResponseBody defs mediaTypes) child = - SingleNode (CDocResponseBody defs mediaTypes) <$> go child - compactDoc (DocRequestHeader param) child = - let (descr, summ, child') = go child - param' = param & description .~ fmap getDescription descr - in (Nothing, summ, SingleNode (CDocRequestHeader param') child') - compactDoc (DocResponseHeader headerName header) child = - let (descr, summ, child') = go child - header' = header & description .~ fmap getDescription descr - in (Nothing, summ, SingleNode (CDocResponseHeader headerName header') child') - compactDoc (DocMethod m) child = - (Nothing, Nothing, addRouteDoc (CDocMethod m) child) - compactDoc (DocPathElem path) child = - (Nothing, Nothing, addRouteDoc (CDocPathElem path) child) - compactDoc (DocPathVar param) child = - (Nothing, Nothing, addRouteDoc (CDocPathVar param) child) - compactDoc (DocQueryParam param) child = - let (descr, summ, child') = go child - param' = param & description .~ fmap getDescription descr - in (Nothing, summ, SingleNode (CDocQueryParam param') child') - compactDoc (DocStatus status) child = - let (descr, summ, child') = go child - in (Nothing, summ, SingleNode (CDocStatus status descr) child') - compactDoc (DocSummary summ) child = - let (descr, _, child') = go child - in (descr, Just summ, child') - compactDoc (DocDescription descr) child = - let (_, summ, child') = go child - in (Just descr, summ, child') - - addRouteDoc :: CompactDocNode -> Tree DocNode -> Tree CompactDocNode - addRouteDoc node child = case go child of - (Nothing, Nothing, child') -> SingleNode node child' - (descr, summ, child') -> SingleNode (CDocRouteDoc summ descr) (SingleNode node child') - -postOrder :: Tree CompactDocNode -> OpenApi -> (OpenApi -> OpenApi) -> OpenApi -postOrder NullNode doc f = f doc -postOrder (SingleNode node child) doc f = f $ mergeDoc node child doc -postOrder (BinaryNode t1 t2) doc f = - f $ postOrder t1 doc id `combineOpenApi` postOrder t2 doc id - -preOrder :: Tree CompactDocNode -> OpenApi -> (OpenApi -> OpenApi) -> OpenApi -preOrder NullNode doc f = f doc -preOrder (SingleNode node child) doc f = mergeDoc node child (f doc) -preOrder (BinaryNode t1 t2) doc f = - let doc' = f doc - in postOrder t1 doc' id `combineOpenApi` postOrder t2 doc' id - -combinePathItem :: PathItem -> PathItem -> PathItem -combinePathItem s t = - PathItem - { _pathItemGet = _pathItemGet s <> _pathItemGet t - , _pathItemPut = _pathItemPut s <> _pathItemPut t - , _pathItemPost = _pathItemPost s <> _pathItemPost t - , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t - , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t - , _pathItemHead = _pathItemHead s <> _pathItemHead t - , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t - , _pathItemTrace = _pathItemTrace s <> _pathItemTrace t - , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t - , _pathItemSummary = _pathItemSummary s <|> _pathItemSummary t - , _pathItemDescription = _pathItemDescription s <|> _pathItemDescription t - , _pathItemServers = _pathItemServers s <> _pathItemServers t - } - -combineOpenApi :: OpenApi -> OpenApi -> OpenApi -combineOpenApi s t = - (mempty @OpenApi) - { _openApiInfo = _openApiInfo s <> _openApiInfo t - , _openApiServers = _openApiServers s <> _openApiServers t - , _openApiPaths = Map.unionWith combinePathItem (_openApiPaths s) (_openApiPaths t) - , _openApiComponents = _openApiComponents s <> _openApiComponents t - , _openApiSecurity = _openApiSecurity s <> _openApiSecurity t - , _openApiTags = _openApiTags s <> _openApiTags t - , _openApiExternalDocs = _openApiExternalDocs s <|> _openApiExternalDocs t - } - -mergeDoc :: CompactDocNode -> Tree CompactDocNode -> OpenApi -> OpenApi -mergeDoc (CDocSecurityScheme schemeName scheme) child doc = - let -#if MIN_VERSION_openapi3(3, 2, 0) - secSchemes = SecurityDefinitions [(schemeName, scheme)] -#else - secSchemes = [(schemeName, scheme)] :: Definitions SecurityScheme -#endif - secReqs = [SecurityRequirement [(schemeName, [])]] :: [SecurityRequirement] - in postOrder child doc $ \doc' -> - doc' - & components . securitySchemes <>~ secSchemes - & allOperations . security <>~ secReqs -mergeDoc (CDocRequestBody defs body) child doc = - postOrder child doc $ \doc' -> - doc' - & allOperations . requestBody ?~ Inline body - & components . schemas %~ (<> defs) -mergeDoc (CDocRequestHeader param) child doc = - postOrder child doc $ \doc' -> - doc' & allOperations . parameters <>~ [Inline param] -mergeDoc (CDocMethod m) child doc = - postOrder child doc $ \doc' -> - doc' & paths %~ Map.map (removeOtherMethods m) -mergeDoc (CDocPathElem path) child doc = - postOrder child doc $ prependPath (Text.unpack path) -mergeDoc (CDocPathVar param) child doc = - postOrder child doc $ \doc' -> - prependPath ("{" <> Text.unpack (_paramName param) <> "}") doc' - & allOperations . parameters <>~ [Inline param] -mergeDoc (CDocRouteDoc summ descr) child doc = - postOrder child doc $ \doc' -> - doc' - -- keep any existing documentation - & allOperations . summary %~ (<|> fmap getSummary summ) - & allOperations . description %~ (<|> fmap getDescription descr) -mergeDoc (CDocQueryParam param) child doc = - postOrder child doc $ \doc' -> - doc' & allOperations . parameters <>~ [Inline param] -mergeDoc (CDocStatus status descr) child doc = - preOrder child doc $ \doc' -> - let resp = - mempty @Response - & description .~ maybe "" getDescription descr - opr = - mempty @Operation - & at (HTTP.statusCode status) ?~ Inline resp - pathItem = - mempty @PathItem - & get ?~ opr - & put ?~ opr - & post ?~ opr - & delete ?~ opr - & options ?~ opr - & head_ ?~ opr - & patch ?~ opr - & trace ?~ opr - in doc' & paths <>~ [("/", pathItem)] -mergeDoc (CDocResponseBody defs mediaTypes) child doc = - postOrder child doc $ \doc' -> - let resp = mempty @Response & content <>~ mediaTypes - in doc' - & allOperations . responses . responses %~ Map.map (`swaggerMappend` Inline resp) - & components . schemas %~ (<> defs) -mergeDoc (CDocResponseHeader headerName header) child doc = - postOrder child doc $ \doc' -> - let resp = mempty @Response & headers <>~ [(headerName, Inline header)] - in doc' & allOperations . responses . responses %~ Map.map (`swaggerMappend` Inline resp) - -removeOtherMethods :: HTTP.StdMethod -> PathItem -> PathItem -removeOtherMethods method PathItem{..} = - case method of - HTTP.GET -> mempty{_pathItemGet, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - HTTP.PUT -> mempty{_pathItemPut, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - HTTP.POST -> mempty{_pathItemPost, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - HTTP.DELETE -> mempty{_pathItemDelete, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - HTTP.HEAD -> mempty{_pathItemHead, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - HTTP.TRACE -> mempty{_pathItemTrace, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - HTTP.OPTIONS -> mempty{_pathItemOptions, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - HTTP.PATCH -> mempty{_pathItemPatch, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} - -- OpenApi does not support CONNECT - HTTP.CONNECT -> mempty{_pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} +toOpenApi (OpenApiHandler f) = evalState (f mempty) (Documentation Nothing Nothing) diff --git a/src/WebGear/OpenApi/Trait/Auth.hs b/src/WebGear/OpenApi/Trait/Auth.hs --- a/src/WebGear/OpenApi/Trait/Auth.hs +++ b/src/WebGear/OpenApi/Trait/Auth.hs @@ -1,26 +1,44 @@ {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -- | Functions and instances for authentication -module WebGear.OpenApi.Trait.Auth () where +module WebGear.OpenApi.Trait.Auth (addSecurityScheme) where -import Control.Lens ((?~)) -import Data.Function ((&)) +import Control.Lens ((&), (.~), (<>~)) +import Control.Monad.State.Strict (MonadState) import Data.OpenApi ( Definitions, - HasType (type_), NamedSchema, + OpenApi, Schema, - ToParamSchema (..), + SecurityDefinitions (..), + SecurityRequirement (..), + SecurityScheme, ToSchema (..), - paramSchemaToSchema, + allOperations, + components, + description, + security, + securitySchemes, ) import Data.OpenApi.Declare (Declare) -import Data.OpenApi.Internal.Schema (plain) import Data.Proxy (Proxy (..)) +import Data.Text (Text) import GHC.TypeLits (KnownSymbol) +import WebGear.Core.Handler (Description (..)) import WebGear.Core.Trait.Auth.Common (AuthToken) +import WebGear.OpenApi.Handler (Documentation (..), consumeDescription) instance (KnownSymbol scheme) => ToSchema (AuthToken scheme) where declareNamedSchema :: Proxy (AuthToken scheme) -> Declare (Definitions Schema) NamedSchema declareNamedSchema _ = declareNamedSchema $ Proxy @String + +addSecurityScheme :: (MonadState Documentation m) => Text -> SecurityScheme -> OpenApi -> m OpenApi +addSecurityScheme schemeName scheme doc = do + desc <- consumeDescription + let scheme' = scheme & description .~ fmap getDescription desc + secSchemes = SecurityDefinitions [(schemeName, scheme')] + secReqs = [SecurityRequirement [(schemeName, [])]] :: [SecurityRequirement] + pure $ + doc + & components . securitySchemes <>~ secSchemes + & allOperations . security <>~ secReqs diff --git a/src/WebGear/OpenApi/Trait/Auth/Basic.hs b/src/WebGear/OpenApi/Trait/Auth/Basic.hs --- a/src/WebGear/OpenApi/Trait/Auth/Basic.hs +++ b/src/WebGear/OpenApi/Trait/Auth/Basic.hs @@ -8,20 +8,21 @@ import Data.String (fromString) import GHC.TypeLits (KnownSymbol, symbolVal) import WebGear.Core.Request (Request) -import WebGear.Core.Trait (Attribute, Get (..), TraitAbsence (Absence), With) +import WebGear.Core.Trait (Absence, Attribute, Get (..), With) import WebGear.Core.Trait.Auth.Basic (BasicAuth' (..)) -import WebGear.OpenApi.Handler (DocNode (DocSecurityScheme), OpenApiHandler (..), singletonNode) +import WebGear.OpenApi.Handler (OpenApiHandler (..)) +import WebGear.OpenApi.Trait.Auth (addSecurityScheme) -instance (TraitAbsence (BasicAuth' x scheme m e a) Request, KnownSymbol scheme) => Get (OpenApiHandler m) (BasicAuth' x scheme m e a) Request where +instance (KnownSymbol scheme) => Get (OpenApiHandler m) (BasicAuth' x scheme m e a) where {-# INLINE getTrait #-} getTrait :: BasicAuth' x scheme m e a -> - OpenApiHandler m (Request `With` ts) (Either (Absence (BasicAuth' x scheme m e a) Request) (Attribute (BasicAuth' x scheme m e a) Request)) + OpenApiHandler m (Request `With` ts) (Either (Absence (BasicAuth' x scheme m e a)) (Attribute (BasicAuth' x scheme m e a) Request)) getTrait _ = let schemeName = "http" <> fromString (symbolVal (Proxy @scheme)) - securityScheme = + scheme = SecurityScheme { _securitySchemeType = SecuritySchemeHttp HttpSchemeBasic , _securitySchemeDescription = Nothing } - in OpenApiHandler $ singletonNode (DocSecurityScheme schemeName securityScheme) + in OpenApiHandler $ addSecurityScheme schemeName scheme diff --git a/src/WebGear/OpenApi/Trait/Auth/JWT.hs b/src/WebGear/OpenApi/Trait/Auth/JWT.hs --- a/src/WebGear/OpenApi/Trait/Auth/JWT.hs +++ b/src/WebGear/OpenApi/Trait/Auth/JWT.hs @@ -8,23 +8,21 @@ import Data.Typeable (Proxy (..)) import GHC.TypeLits (KnownSymbol, symbolVal) import WebGear.Core.Request (Request) -import WebGear.Core.Trait (Attribute, Get (..), TraitAbsence (..), With) +import WebGear.Core.Trait (Absence, Attribute, Get (..), With) import WebGear.Core.Trait.Auth.JWT (JWTAuth' (..)) -import WebGear.OpenApi.Handler (DocNode (DocSecurityScheme), OpenApiHandler (..), singletonNode) +import WebGear.OpenApi.Handler (OpenApiHandler (..)) +import WebGear.OpenApi.Trait.Auth (addSecurityScheme) -instance - (TraitAbsence (JWTAuth' x scheme m e a) Request, KnownSymbol scheme) => - Get (OpenApiHandler m) (JWTAuth' x scheme m e a) Request - where +instance (KnownSymbol scheme) => Get (OpenApiHandler m) (JWTAuth' x scheme m e a) where {-# INLINE getTrait #-} getTrait :: JWTAuth' x scheme m e a -> - OpenApiHandler m (Request `With` ts) (Either (Absence (JWTAuth' x scheme m e a) Request) (Attribute (JWTAuth' x scheme m e a) Request)) + OpenApiHandler m (Request `With` ts) (Either (Absence (JWTAuth' x scheme m e a)) (Attribute (JWTAuth' x scheme m e a) Request)) getTrait _ = let schemeName = "http" <> fromString (symbolVal (Proxy @scheme)) - securityScheme = + scheme = SecurityScheme { _securitySchemeType = SecuritySchemeHttp (HttpSchemeBearer (Just "JWT")) , _securitySchemeDescription = Nothing } - in OpenApiHandler $ singletonNode (DocSecurityScheme schemeName securityScheme) + in OpenApiHandler $ addSecurityScheme schemeName scheme diff --git a/src/WebGear/OpenApi/Trait/Body.hs b/src/WebGear/OpenApi/Trait/Body.hs --- a/src/WebGear/OpenApi/Trait/Body.hs +++ b/src/WebGear/OpenApi/Trait/Body.hs @@ -3,50 +3,105 @@ -- | OpenApi implementation of 'Body' trait. module WebGear.OpenApi.Trait.Body where -import Control.Lens ((&), (.~), (?~)) -import Data.OpenApi hiding (Response, contentType) +import Control.Lens ((%~), (&), (.~), (<>~), (?~), (^.)) +import Control.Monad.State.Strict (MonadState) +import qualified Data.HashMap.Strict.InsOrd as Map +import Data.OpenApi ( + Definitions, + MediaTypeObject, + OpenApi, + Referenced (..), + RequestBody, + Response, + Schema, + ToSchema, + allOperations, + components, + content, + declareSchemaRef, + description, + paths, + requestBody, + responses, + schema, + schemas, + ) import Data.OpenApi.Declare (runDeclare) +import Data.OpenApi.Internal.Utils (swaggerMappend) import Data.Proxy (Proxy (..)) import Data.Text (Text) import GHC.Exts (fromList) +import Network.HTTP.Media.MediaType (MediaType) +import WebGear.Core.Handler (Description (..)) import WebGear.Core.MIMETypes (MIMEType (..)) import WebGear.Core.Request (Request) -import WebGear.Core.Response (Response (..), ResponseBody) +import qualified WebGear.Core.Response as WG import WebGear.Core.Trait (Get (..), Set (..), With) import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..)) import WebGear.OpenApi.Handler ( - DocNode (DocRequestBody, DocResponseBody), + Documentation (..), OpenApiHandler (..), - singletonNode, + addRootPath, + consumeDescription, ) -instance (ToSchema val, MIMEType mt) => Get (OpenApiHandler m) (Body mt val) Request where +instance (ToSchema val, MIMEType mt) => Get (OpenApiHandler m) (Body mt val) where {-# INLINE getTrait #-} getTrait :: Body mt val -> OpenApiHandler m (Request `With` ts) (Either Text val) getTrait (Body mt) = - let mediaType = mimeType mt - (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty - body = - (mempty @RequestBody) - & content .~ fromList [(mediaType, mempty @MediaTypeObject & schema ?~ ref)] - in OpenApiHandler $ singletonNode (DocRequestBody defs body) + OpenApiHandler $ \doc -> do + desc <- consumeDescription + let mediaType = mimeType mt + (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty + body = + (mempty @RequestBody) + & content .~ fromList [(mediaType, mempty @MediaTypeObject & schema ?~ ref)] + & description .~ fmap getDescription desc + pure $ + doc + & allOperations . requestBody ?~ Inline body + & components . schemas %~ (<> defs) -instance (ToSchema val, MIMEType mt) => Set (OpenApiHandler m) (Body mt val) Response where +instance (ToSchema val, MIMEType mt) => Set (OpenApiHandler m) (Body mt val) where {-# INLINE setTrait #-} setTrait :: Body mt val -> - (Response `With` ts -> Response -> val -> Response `With` (Body mt val : ts)) -> - OpenApiHandler m (Response `With` ts, val) (Response `With` (Body mt val : ts)) + (WG.Response `With` ts -> WG.Response -> val -> WG.Response `With` (Body mt val : ts)) -> + OpenApiHandler m (WG.Response `With` ts, val) (WG.Response `With` (Body mt val : ts)) setTrait (Body mt) _ = let mediaType = mimeType mt (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty body = mempty @MediaTypeObject & schema ?~ ref - in OpenApiHandler $ singletonNode (DocResponseBody defs $ fromList [(mediaType, body)]) + in OpenApiHandler $ addResponseBody defs (fromList [(mediaType, body)]) -instance Set (OpenApiHandler m) UnknownContentBody Response where +instance Set (OpenApiHandler m) UnknownContentBody where {-# INLINE setTrait #-} setTrait :: UnknownContentBody -> - (Response `With` ts -> Response -> ResponseBody -> Response `With` (UnknownContentBody : ts)) -> - OpenApiHandler m (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts)) - setTrait UnknownContentBody _ = OpenApiHandler $ singletonNode (DocResponseBody mempty mempty) + (WG.Response `With` ts -> WG.Response -> WG.ResponseBody -> WG.Response `With` (UnknownContentBody : ts)) -> + OpenApiHandler m (WG.Response `With` ts, WG.ResponseBody) (WG.Response `With` (UnknownContentBody : ts)) + setTrait UnknownContentBody _ = OpenApiHandler $ addResponseBody mempty mempty + +addResponseBody :: + (MonadState Documentation m) => + Definitions Schema -> + Map.InsOrdHashMap MediaType MediaTypeObject -> + OpenApi -> + m OpenApi +addResponseBody defs mediaTypes doc = do + desc <- consumeDescription + + let addDescription :: Referenced Response -> Referenced Response + addDescription (Ref r) = Ref r + addDescription (Inline r) = + case desc of + Nothing -> Inline r + Just (Description d) -> Inline (r & description .~ d) + + let resp = mempty @Response & content <>~ mediaTypes + doc' = if Map.null (doc ^. paths) then addRootPath doc else doc + + pure $ + doc' + & allOperations . responses . responses %~ Map.map (addDescription . (`swaggerMappend` Inline resp)) + & components . schemas %~ (<> defs) diff --git a/src/WebGear/OpenApi/Trait/Cookie.hs b/src/WebGear/OpenApi/Trait/Cookie.hs --- a/src/WebGear/OpenApi/Trait/Cookie.hs +++ b/src/WebGear/OpenApi/Trait/Cookie.hs @@ -8,16 +8,15 @@ import Data.String (fromString) import Data.Text (Text) import GHC.TypeLits (KnownSymbol, symbolVal) -import WebGear.Core.Request (Request) -import WebGear.Core.Response (Response) -import WebGear.Core.Trait (Get (..), Set (..), Trait, TraitAbsence) +import WebGear.Core.Trait (Get (..), Set (..)) import qualified WebGear.Core.Trait.Cookie as WG -import WebGear.OpenApi.Handler (DocNode (..), OpenApiHandler (..), nullNode, singletonNode) +import WebGear.OpenApi.Handler (OpenApiHandler (..)) +import WebGear.OpenApi.Trait.Auth (addSecurityScheme) -instance (KnownSymbol name, TraitAbsence (WG.Cookie e name val) Request) => Get (OpenApiHandler m) (WG.Cookie e name val) Request where +instance (KnownSymbol name) => Get (OpenApiHandler m) (WG.Cookie e name val) where {-# INLINE getTrait #-} getTrait WG.Cookie = - OpenApiHandler $ singletonNode $ DocSecurityScheme cookieName securityScheme + OpenApiHandler $ addSecurityScheme cookieName securityScheme where cookieName = fromString @Text $ symbolVal $ Proxy @name @@ -35,6 +34,6 @@ -- Response cookie information is not captured by OpenAPI -instance (Trait (WG.SetCookie e name) Response) => Set (OpenApiHandler m) (WG.SetCookie e name) Response where +instance Set (OpenApiHandler m) (WG.SetCookie e name) where {-# INLINE setTrait #-} - setTrait WG.SetCookie _ = OpenApiHandler nullNode + setTrait WG.SetCookie _ = OpenApiHandler pure diff --git a/src/WebGear/OpenApi/Trait/Header.hs b/src/WebGear/OpenApi/Trait/Header.hs --- a/src/WebGear/OpenApi/Trait/Header.hs +++ b/src/WebGear/OpenApi/Trait/Header.hs @@ -3,61 +3,93 @@ -- | OpenApi implementation of 'Header' trait. module WebGear.OpenApi.Trait.Header () where -import Control.Lens ((&), (.~), (?~)) -import Data.OpenApi hiding (Response) +import Control.Lens ((%~), (&), (.~), (<>~), (?~)) +import Control.Monad.State.Strict (MonadState) +import qualified Data.HashMap.Strict.InsOrd as Map +import Data.OpenApi ( + Header, + HeaderName, + OpenApi, + Param, + ParamLocation (..), + Referenced (..), + Response, + ToSchema, + allOperations, + description, + headers, + in_, + name, + parameters, + required, + responses, + schema, + toSchema, + ) +import Data.OpenApi.Internal.Utils (swaggerMappend) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.Text (Text) import GHC.TypeLits (KnownSymbol, symbolVal) +import WebGear.Core.Handler (Description (..)) import WebGear.Core.Modifiers (Existence (..)) -import WebGear.Core.Request (Request) -import WebGear.Core.Response (Response) -import WebGear.Core.Trait (Get (..), Set (..), TraitAbsence) +import WebGear.Core.Trait (Get (..), Set (..)) import qualified WebGear.Core.Trait.Header as WG -import WebGear.OpenApi.Handler (DocNode (..), OpenApiHandler (..), nullNode, singletonNode) - -mkParam :: - forall name val. - (KnownSymbol name, ToSchema val) => - Proxy name -> - Proxy val -> - Bool -> - Param -mkParam _ _ isRequired = - (mempty :: Param) - & name .~ fromString @Text (symbolVal $ Proxy @name) - & in_ .~ ParamHeader - & required ?~ isRequired - & schema ?~ Inline (toSchema $ Proxy @val) +import WebGear.OpenApi.Handler (Documentation, OpenApiHandler (..), consumeDescription) -instance (KnownSymbol name, ToSchema val, TraitAbsence (WG.RequestHeader Required ps name val) Request) => Get (OpenApiHandler m) (WG.RequestHeader Required ps name val) Request where +instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (WG.RequestHeader Required ps name val) where {-# INLINE getTrait #-} - getTrait WG.RequestHeader = - OpenApiHandler $ singletonNode (DocRequestHeader $ mkParam (Proxy @name) (Proxy @val) True) + getTrait WG.RequestHeader = OpenApiHandler $ addRequestHeader (Proxy @name) (Proxy @val) True -instance (KnownSymbol name, ToSchema val, TraitAbsence (WG.RequestHeader Optional ps name val) Request) => Get (OpenApiHandler m) (WG.RequestHeader Optional ps name val) Request where +instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (WG.RequestHeader Optional ps name val) where {-# INLINE getTrait #-} - getTrait WG.RequestHeader = - OpenApiHandler $ singletonNode (DocRequestHeader $ mkParam (Proxy @name) (Proxy @val) False) + getTrait WG.RequestHeader = OpenApiHandler $ addRequestHeader (Proxy @name) (Proxy @val) False -instance (KnownSymbol name, ToSchema val) => Set (OpenApiHandler m) (WG.ResponseHeader Required name val) Response where +instance (KnownSymbol name, ToSchema val) => Set (OpenApiHandler m) (WG.ResponseHeader Required name val) where {-# INLINE setTrait #-} - setTrait WG.ResponseHeader _ = - let headerName = fromString $ symbolVal $ Proxy @name - header = - mempty @Header - & required ?~ True - & schema ?~ Inline (toSchema $ Proxy @val) - in if headerName == "Content-Type" - then OpenApiHandler nullNode - else OpenApiHandler $ singletonNode (DocResponseHeader headerName header) + setTrait WG.ResponseHeader _ = OpenApiHandler $ addResponseHeader (Proxy @name) (Proxy @val) True -instance (KnownSymbol name, ToSchema val) => Set (OpenApiHandler m) (WG.ResponseHeader Optional name val) Response where +instance (KnownSymbol name, ToSchema val) => Set (OpenApiHandler m) (WG.ResponseHeader Optional name val) where {-# INLINE setTrait #-} - setTrait WG.ResponseHeader _ = - let headerName = fromString $ symbolVal $ Proxy @name - header = - mempty @Header - & required ?~ True - & schema ?~ Inline (toSchema $ Proxy @val) - in OpenApiHandler $ singletonNode (DocResponseHeader headerName header) + setTrait WG.ResponseHeader _ = OpenApiHandler $ addResponseHeader (Proxy @name) (Proxy @val) False + +addRequestHeader :: + forall name val m. + (KnownSymbol name, ToSchema val, MonadState Documentation m) => + Proxy name -> + Proxy val -> + Bool -> + OpenApi -> + m OpenApi +addRequestHeader _ _ isRequired doc = do + desc <- consumeDescription + let param = + (mempty :: Param) + & name .~ fromString @Text (symbolVal $ Proxy @name) + & in_ .~ ParamHeader + & required ?~ isRequired + & schema ?~ Inline (toSchema $ Proxy @val) + & description .~ fmap getDescription desc + pure $ doc & allOperations . parameters <>~ [Inline param] + +addResponseHeader :: + forall name val m. + (KnownSymbol name, ToSchema val, MonadState Documentation m) => + Proxy name -> + Proxy val -> + Bool -> + OpenApi -> + m OpenApi +addResponseHeader _ _ isRequired doc = do + desc <- consumeDescription + let headerName = fromString @HeaderName $ symbolVal $ Proxy @name + header = + mempty @Header + & required ?~ isRequired + & schema ?~ Inline (toSchema $ Proxy @val) + & description .~ fmap getDescription desc + resp = mempty @Response & headers <>~ [(headerName, Inline header)] + pure $ + if headerName == "Content-Type" + then doc + else doc & allOperations . responses . responses %~ Map.map (`swaggerMappend` Inline resp) diff --git a/src/WebGear/OpenApi/Trait/Method.hs b/src/WebGear/OpenApi/Trait/Method.hs --- a/src/WebGear/OpenApi/Trait/Method.hs +++ b/src/WebGear/OpenApi/Trait/Method.hs @@ -3,11 +3,29 @@ -- | OpenApi implementation of 'Method' trait. module WebGear.OpenApi.Trait.Method where -import WebGear.Core.Request (Request) +import Control.Lens ((%~), (&)) +import qualified Data.HashMap.Strict.InsOrd as Map +import Data.OpenApi (PathItem (..), paths) +import Network.HTTP.Types (StdMethod (..)) import WebGear.Core.Trait (Get (..)) import WebGear.Core.Trait.Method (Method (..)) -import WebGear.OpenApi.Handler (DocNode (DocMethod), OpenApiHandler (OpenApiHandler), singletonNode) +import WebGear.OpenApi.Handler (OpenApiHandler (..), addRouteDocumentation) -instance Get (OpenApiHandler m) Method Request where +instance Get (OpenApiHandler m) Method where {-# INLINE getTrait #-} - getTrait (Method method) = OpenApiHandler $ singletonNode (DocMethod method) + getTrait (Method method) = OpenApiHandler $ \doc -> do + addRouteDocumentation $ doc & paths %~ Map.map (removeOtherMethods method) + +removeOtherMethods :: StdMethod -> PathItem -> PathItem +removeOtherMethods method PathItem{..} = + case method of + GET -> mempty{_pathItemGet, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + PUT -> mempty{_pathItemPut, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + POST -> mempty{_pathItemPost, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + DELETE -> mempty{_pathItemDelete, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + HEAD -> mempty{_pathItemHead, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + TRACE -> mempty{_pathItemTrace, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + OPTIONS -> mempty{_pathItemOptions, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + PATCH -> mempty{_pathItemPatch, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} + -- OpenApi does not support CONNECT + CONNECT -> mempty{_pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} diff --git a/src/WebGear/OpenApi/Trait/Path.hs b/src/WebGear/OpenApi/Trait/Path.hs --- a/src/WebGear/OpenApi/Trait/Path.hs +++ b/src/WebGear/OpenApi/Trait/Path.hs @@ -3,38 +3,49 @@ -- | OpenApi implementation of path traits. module WebGear.OpenApi.Trait.Path where +import Control.Lens ((&), (<>~)) import Data.Data (Proxy (Proxy)) -import Data.OpenApi (Param (..), ParamLocation (ParamPath), Referenced (Inline), ToSchema, toSchema) +import Data.OpenApi ( + Param (..), + ParamLocation (ParamPath), + Referenced (Inline), + ToSchema, + allOperations, + parameters, + prependPath, + toSchema, + ) import Data.String (fromString) +import Data.Text (unpack) import GHC.TypeLits (KnownSymbol, symbolVal) import WebGear.Core.Request (Request) import WebGear.Core.Trait (Get (..), With) import WebGear.Core.Trait.Path (Path (..), PathEnd (..), PathVar (..), PathVarError (..)) -import WebGear.OpenApi.Handler ( - DocNode (DocPathElem, DocPathVar), - OpenApiHandler (..), - singletonNode, - ) +import WebGear.OpenApi.Handler (OpenApiHandler (..), addRouteDocumentation) -instance Get (OpenApiHandler m) Path Request where +instance Get (OpenApiHandler m) Path where {-# INLINE getTrait #-} getTrait :: Path -> OpenApiHandler m (Request `With` ts) (Either () ()) - getTrait (Path p) = OpenApiHandler $ singletonNode (DocPathElem p) + getTrait (Path p) = OpenApiHandler $ addRouteDocumentation . prependPath (unpack p) -instance (KnownSymbol tag, ToSchema val) => Get (OpenApiHandler m) (PathVar tag val) Request where +instance (KnownSymbol tag, ToSchema val) => Get (OpenApiHandler m) (PathVar tag val) where {-# INLINE getTrait #-} getTrait :: PathVar tag val -> OpenApiHandler m (Request `With` ts) (Either PathVarError val) getTrait PathVar = - let param = + let paramName = symbolVal $ Proxy @tag + param = (mempty :: Param) - { _paramName = fromString $ symbolVal $ Proxy @tag + { _paramName = fromString paramName , _paramIn = ParamPath , _paramRequired = Just True , _paramSchema = Just $ Inline $ toSchema $ Proxy @val } - in OpenApiHandler $ singletonNode (DocPathVar param) + in OpenApiHandler $ \doc -> + addRouteDocumentation $ + prependPath ("{" <> paramName <> "}") doc + & allOperations . parameters <>~ [Inline param] -instance Get (OpenApiHandler m) PathEnd Request where +instance Get (OpenApiHandler m) PathEnd where {-# INLINE getTrait #-} getTrait :: PathEnd -> OpenApiHandler m (Request `With` ts) (Either () ()) - getTrait PathEnd = OpenApiHandler $ singletonNode (DocPathElem "/") + getTrait PathEnd = OpenApiHandler $ addRouteDocumentation . prependPath "/" diff --git a/src/WebGear/OpenApi/Trait/QueryParam.hs b/src/WebGear/OpenApi/Trait/QueryParam.hs --- a/src/WebGear/OpenApi/Trait/QueryParam.hs +++ b/src/WebGear/OpenApi/Trait/QueryParam.hs @@ -3,23 +3,29 @@ -- | OpenApi implementation of 'QueryParam' trait. module WebGear.OpenApi.Trait.QueryParam where +import Control.Lens ((&), (.~), (<>~)) +import Control.Monad.State.Strict (MonadState) import Data.OpenApi ( + OpenApi, Param (..), ParamLocation (ParamQuery), Referenced (Inline), ToSchema, + allOperations, + description, + parameters, toSchema, ) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import GHC.TypeLits (KnownSymbol, symbolVal) -import WebGear.Core.Modifiers -import WebGear.Core.Request (Request) -import WebGear.Core.Trait (Get (..), TraitAbsence) +import WebGear.Core.Handler (Description (..)) +import WebGear.Core.Modifiers (Existence (..)) +import WebGear.Core.Trait (Get (..)) import WebGear.Core.Trait.QueryParam (QueryParam (..)) -import WebGear.OpenApi.Handler (DocNode (DocQueryParam), OpenApiHandler (..), singletonNode) +import WebGear.OpenApi.Handler (Documentation (..), OpenApiHandler (..), consumeDescription) -instance (KnownSymbol name, ToSchema val, TraitAbsence (QueryParam Required ps name val) Request) => Get (OpenApiHandler m) (QueryParam Required ps name val) Request where +instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (QueryParam Required ps name val) where {-# INLINE getTrait #-} getTrait _ = let param = @@ -29,9 +35,9 @@ , _paramRequired = Just True , _paramSchema = Just $ Inline $ toSchema $ Proxy @val } - in OpenApiHandler $ singletonNode (DocQueryParam param) + in OpenApiHandler $ addParam param -instance (KnownSymbol name, ToSchema val, TraitAbsence (QueryParam Optional ps name val) Request) => Get (OpenApiHandler m) (QueryParam Optional ps name val) Request where +instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (QueryParam Optional ps name val) where {-# INLINE getTrait #-} getTrait _ = let param = @@ -41,4 +47,10 @@ , _paramRequired = Just False , _paramSchema = Just $ Inline $ toSchema $ Proxy @val } - in OpenApiHandler $ singletonNode (DocQueryParam param) + in OpenApiHandler $ addParam param + +addParam :: (MonadState Documentation m) => Param -> OpenApi -> m OpenApi +addParam param doc = do + desc <- consumeDescription + let param' = param & description .~ fmap getDescription desc + pure $ doc & allOperations . parameters <>~ [Inline param'] diff --git a/src/WebGear/OpenApi/Trait/Status.hs b/src/WebGear/OpenApi/Trait/Status.hs --- a/src/WebGear/OpenApi/Trait/Status.hs +++ b/src/WebGear/OpenApi/Trait/Status.hs @@ -3,16 +3,71 @@ -- | OpenApi implementation of 'Status' trait. module WebGear.OpenApi.Trait.Status where +import Control.Applicative ((<|>)) +import Control.Lens (at, mapped, (%~), (&), (.~), (?~), (^.)) +import qualified Data.HashMap.Strict.InsOrd as Map +import Data.Maybe (fromMaybe) +import Data.OpenApi ( + Operation, + PathItem, + Referenced (..), + Response, + delete, + description, + get, + head_, + options, + patch, + paths, + post, + put, + responses, + trace, + ) import qualified Network.HTTP.Types as HTTP -import WebGear.Core.Response (Response) +import WebGear.Core.Handler (Description (..)) +import qualified WebGear.Core.Response as WG import WebGear.Core.Trait (Set, With, setTrait) import WebGear.Core.Trait.Status (Status (..)) -import WebGear.OpenApi.Handler (DocNode (DocStatus), OpenApiHandler (..), singletonNode) +import WebGear.OpenApi.Handler (OpenApiHandler (..), addRootPath, consumeDescription) -instance Set (OpenApiHandler m) Status Response where +instance Set (OpenApiHandler m) Status where {-# INLINE setTrait #-} setTrait :: Status -> - (Response `With` ts -> Response -> HTTP.Status -> Response `With` (Status : ts)) -> - OpenApiHandler m (Response `With` ts, HTTP.Status) (Response `With` (Status : ts)) - setTrait (Status status) _ = OpenApiHandler $ singletonNode (DocStatus status) + (WG.Response `With` ts -> WG.Response -> HTTP.Status -> WG.Response `With` (Status : ts)) -> + OpenApiHandler m (WG.Response `With` ts, HTTP.Status) (WG.Response `With` (Status : ts)) + setTrait status _ = OpenApiHandler $ \doc -> do + desc <- consumeDescription + let doc' = if Map.null (doc ^. paths) then addRootPath doc else doc + pure $ doc' & paths . mapped %~ setOperation desc status + +setOperation :: Maybe Description -> Status -> PathItem -> PathItem +setOperation desc (Status status) item = + item + & delete %~ updateOperation + & get %~ updateOperation + & head_ %~ updateOperation + & options %~ updateOperation + & patch %~ updateOperation + & post %~ updateOperation + & put %~ updateOperation + & trace %~ updateOperation + where + httpCode = HTTP.statusCode status + + updateOperation :: Maybe Operation -> Maybe Operation + updateOperation Nothing = Just $ mempty @Operation & at httpCode ?~ addDescription emptyResp + updateOperation (Just op) = + let resp = addDescription $ fromMaybe emptyResp $ (op ^. at httpCode) <|> (op ^. at 0) + in Just $ op & responses . responses %~ Map.insert httpCode resp . Map.delete 0 + + emptyResp :: Referenced Response + emptyResp = Inline mempty + + addDescription :: Referenced Response -> Referenced Response + addDescription (Ref r) = Ref r + addDescription (Inline r) = + case desc of + Nothing -> Inline r + Just (Description d) -> Inline (r & description .~ d) diff --git a/webgear-openapi.cabal b/webgear-openapi.cabal --- a/webgear-openapi.cabal +++ b/webgear-openapi.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: webgear-openapi -version: 1.2.0 +version: 1.3.0 synopsis: Composable, type-safe library to build HTTP API servers description: WebGear is a library to for building composable, type-safe HTTP API servers. @@ -75,9 +75,10 @@ , http-types ==0.12.* , insert-ordered-containers ==0.2.* , lens >=4.18.1 && <5.3 + , mtl >=2.2 && <2.4 , openapi3 >=3.1.0 && <3.3 , text >=1.2.0.0 && <2.2 - , webgear-core ^>=1.2.0 + , webgear-core ^>=1.3.0 ghc-options: -Wall -Wno-unticked-promoted-constructors -Wcompat