packages feed

webgear-openapi 1.2.0 → 1.3.0

raw patch · 13 files changed

+469/−405 lines, 13 filesdep +mtldep ~lensdep ~webgear-core

Dependencies added: mtl

Dependency ranges changed: lens, webgear-core

Files

CHANGELOG.md view
@@ -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
src/WebGear/OpenApi/Handler.hs view
@@ -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)
src/WebGear/OpenApi/Trait/Auth.hs view
@@ -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
src/WebGear/OpenApi/Trait/Auth/Basic.hs view
@@ -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
src/WebGear/OpenApi/Trait/Auth/JWT.hs view
@@ -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
src/WebGear/OpenApi/Trait/Body.hs view
@@ -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)
src/WebGear/OpenApi/Trait/Cookie.hs view
@@ -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
src/WebGear/OpenApi/Trait/Header.hs view
@@ -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)
src/WebGear/OpenApi/Trait/Method.hs view
@@ -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}
src/WebGear/OpenApi/Trait/Path.hs view
@@ -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 "/"
src/WebGear/OpenApi/Trait/QueryParam.hs view
@@ -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']
src/WebGear/OpenApi/Trait/Status.hs view
@@ -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)
webgear-openapi.cabal view
@@ -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