webgear-swagger 1.2.0 → 1.3.0

raw patch · 13 files changed

+477/−436 lines, 13 filesdep +mtldep ~lensdep ~webgear-corePVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

Dependency ranges changed: lens, webgear-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−1
• src/WebGear/Swagger/Handler.hs +125/−294
• src/WebGear/Swagger/Trait/Auth.hs +25/−1
• src/WebGear/Swagger/Trait/Auth/Basic.hs +8/−7
• src/WebGear/Swagger/Trait/Auth/JWT.hs +7/−9
• src/WebGear/Swagger/Trait/Body.hs +90/−22
• src/WebGear/Swagger/Trait/Cookie.hs +9/−19
• src/WebGear/Swagger/Trait/Header.hs +77/−46
• src/WebGear/Swagger/Trait/Method.hs +22/−4
• src/WebGear/Swagger/Trait/Path.hs +21/−15
• src/WebGear/Swagger/Trait/QueryParam.hs +23/−10
• src/WebGear/Swagger/Trait/Status.hs +59/−6
• webgear-swagger.cabal +3/−2

@@ -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@@ -20,7 +26,8 @@ - Support file uploads (#32) - First version of webgear-swagger -[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

@@ -1,12 +1,15 @@+{-# LANGUAGE CPP #-}+ {- | An implementation of `Handler` to generate `Swagger` documentation  from WebGear API specifications. -} module WebGear.Swagger.Handler (   SwaggerHandler (..),-  DocNode (..),-  Tree,-  singletonNode,-  nullNode,+  Documentation (..),+  consumeDescription,+  consumeSummary,+  addRouteDocumentation,+  addRootPath,   toSwagger, ) where @@ -14,352 +17,180 @@ 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.List (nub)-import Data.Swagger-import Data.Swagger.Internal.Utils (swaggerMappend)-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Network.HTTP.Types as HTTP-import WebGear.Core.Handler (Description (..), Handler (..), RouteMismatch, RoutePath (..), Summary (..))+import Data.Swagger (+  Operation,+  PathItem,+  Referenced (..),+  Response,+  Swagger,+  allOperations,+  delete,+  description,+  externalDocs,+  get,+  head_,+  options,+  parameters,+  patch,+  paths,+  post,+  put,+  summary,+ )+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 `Swagger` documentation of API specifications.+newtype SwaggerHandler m a b = SwaggerHandler (Swagger -> State Documentation Swagger) --- | Different types of documentation elements captured by the handler-data DocNode-  = DocSecurityScheme Text SecurityScheme-  | DocRequestBody (Definitions Schema) MimeList Param-  | DocResponseBody (Definitions Schema) MimeList (Maybe (Referenced Schema))-  | 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) MimeList Param-  | CDocResponseBody (Definitions Schema) MimeList (Maybe (Referenced Schema))-  | 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) => Swagger -> m Swagger+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 `Swagger` documentation of API- specifications.--}-newtype SwaggerHandler m a b = SwaggerHandler-  {swaggerDoc :: Tree DocNode}+addRootPath :: Swagger -> Swagger+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 +    opr :: Operation+    opr = mempty @Operation & at 0 ?~ Inline (mempty @Response)+ instance Cat.Category (SwaggerHandler m) where+  {-# INLINE id #-}   id :: SwaggerHandler m a a-  id = SwaggerHandler{swaggerDoc = NullNode}+  id = SwaggerHandler pure +  {-# INLINE (.) #-}   (.) :: SwaggerHandler m b c -> SwaggerHandler m a b -> SwaggerHandler m a c-  SwaggerHandler doc2 . SwaggerHandler doc1 = SwaggerHandler $ 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)+  SwaggerHandler g . SwaggerHandler f = SwaggerHandler $ f <=< g  instance Arrow (SwaggerHandler m) where+  {-# INLINE arr #-}   arr :: (a -> b) -> SwaggerHandler m a b-  arr _ = SwaggerHandler{swaggerDoc = NullNode}+  arr _ = SwaggerHandler pure +  {-# INLINE first #-}   first :: SwaggerHandler m b c -> SwaggerHandler m (b, d) (c, d)-  first (SwaggerHandler doc) = SwaggerHandler doc+  first = coerce +  {-# INLINE second #-}   second :: SwaggerHandler m b c -> SwaggerHandler m (d, b) (d, c)-  second (SwaggerHandler doc) = SwaggerHandler doc+  second = coerce  instance ArrowZero (SwaggerHandler m) where+  {-# INLINE zeroArrow #-}   zeroArrow :: SwaggerHandler m b c-  zeroArrow = SwaggerHandler{swaggerDoc = NullNode}+  zeroArrow = SwaggerHandler pure +newtype MergeSwagger = MergeSwagger (Swagger -> State Documentation Swagger)++instance Semigroup MergeSwagger where+  MergeSwagger f <> MergeSwagger g =+    MergeSwagger $ \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+          & parameters .~ (x ^. parameters <> y ^. parameters)+ instance ArrowPlus (SwaggerHandler m) where+  {-# INLINE (<+>) #-}   (<+>) :: SwaggerHandler m b c -> SwaggerHandler m b c -> SwaggerHandler m b c-  SwaggerHandler NullNode <+> SwaggerHandler doc = SwaggerHandler doc-  SwaggerHandler doc <+> SwaggerHandler NullNode = SwaggerHandler doc-  SwaggerHandler doc1 <+> SwaggerHandler doc2 = SwaggerHandler $ BinaryNode doc1 doc2+  SwaggerHandler f <+> SwaggerHandler g = coerce $ MergeSwagger f <> MergeSwagger g  instance ArrowChoice (SwaggerHandler m) where+  {-# INLINE left #-}   left :: SwaggerHandler m b c -> SwaggerHandler m (Either b d) (Either c d)   left (SwaggerHandler doc) = SwaggerHandler doc +  {-# INLINE right #-}   right :: SwaggerHandler m b c -> SwaggerHandler m (Either d b) (Either d c)   right (SwaggerHandler doc) = SwaggerHandler doc +  {-# INLINE (+++) #-}   (+++) :: SwaggerHandler m b c -> SwaggerHandler m b' c' -> SwaggerHandler m (Either b b') (Either c c')-  SwaggerHandler doc +++ SwaggerHandler NullNode = SwaggerHandler doc-  SwaggerHandler NullNode +++ SwaggerHandler doc = SwaggerHandler doc-  SwaggerHandler doc1 +++ SwaggerHandler doc2 = SwaggerHandler $ BinaryNode doc1 doc2+  SwaggerHandler f +++ SwaggerHandler g = coerce $ MergeSwagger f <> MergeSwagger g +  {-# INLINE (|||) #-}   (|||) :: SwaggerHandler m b d -> SwaggerHandler m c d -> SwaggerHandler m (Either b c) d-  SwaggerHandler doc ||| SwaggerHandler NullNode = SwaggerHandler doc-  SwaggerHandler NullNode ||| SwaggerHandler doc = SwaggerHandler doc-  SwaggerHandler doc1 ||| SwaggerHandler doc2 = SwaggerHandler $ BinaryNode doc1 doc2+  SwaggerHandler f ||| SwaggerHandler g = coerce $ MergeSwagger f <> MergeSwagger g  instance ArrowError RouteMismatch (SwaggerHandler m) where   {-# INLINE raise #-}-  raise = SwaggerHandler{swaggerDoc = NullNode}+  raise = SwaggerHandler pure    {-# INLINE handle #-}-  SwaggerHandler doc1 `handle` SwaggerHandler doc2 = SwaggerHandler $ BinaryNode doc1 doc2+  SwaggerHandler f `handle` SwaggerHandler g = coerce $ MergeSwagger f <> MergeSwagger g    {-# INLINE tryInUnless #-}-  tryInUnless (SwaggerHandler doc1) (SwaggerHandler doc2) (SwaggerHandler doc3) =-    SwaggerHandler $ BinaryNode (BinaryNode doc1 doc2) doc3+  tryInUnless (SwaggerHandler f) (SwaggerHandler g) (SwaggerHandler h) =+    coerce $ MergeSwagger f <> MergeSwagger g <> MergeSwagger h  instance (Monad m) => Handler (SwaggerHandler m) m where   {-# INLINE arrM #-}   arrM :: (a -> m b) -> SwaggerHandler m a b-  arrM _ = SwaggerHandler{swaggerDoc = NullNode}+  arrM _ = SwaggerHandler pure    {-# INLINE consumeRoute #-}   consumeRoute :: SwaggerHandler m RoutePath a -> SwaggerHandler m () a-  consumeRoute (SwaggerHandler doc) = SwaggerHandler doc+  consumeRoute (SwaggerHandler f) = SwaggerHandler f    {-# INLINE setDescription #-}   setDescription :: Description -> SwaggerHandler m a a-  setDescription = SwaggerHandler . singletonNode . DocDescription+  setDescription d = SwaggerHandler $ \doc ->+    state $ \(Documentation _ s) -> (doc, Documentation (Just d) s)    {-# INLINE setSummary #-}   setSummary :: Summary -> SwaggerHandler m a a-  setSummary = SwaggerHandler . singletonNode . DocSummary+  setSummary s = SwaggerHandler $ \doc ->+    state $ \(Documentation d _) -> (doc, Documentation d (Just s))  -- | Generate Swagger documentation from a handler toSwagger :: SwaggerHandler m a b -> Swagger-toSwagger = go . compact . swaggerDoc-  where-    go t = case t of-      NullNode -> mempty-      SingleNode parent child -> mergeDoc parent child mempty-      BinaryNode t1 t2 -> go t1 `combineSwagger` 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 mimeList bodyParam) child =-      let (descr, summ, child') = go child-          bodyParam' = bodyParam & description .~ fmap getDescription descr-       in (Nothing, summ, SingleNode (CDocRequestBody defs mimeList bodyParam') child')-    compactDoc (DocResponseBody defs mimeList responseSchema) child =-      SingleNode (CDocResponseBody defs mimeList responseSchema) <$> 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 -> Swagger -> (Swagger -> Swagger) -> Swagger-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 `combineSwagger` postOrder t2 doc id--preOrder :: Tree CompactDocNode -> Swagger -> (Swagger -> Swagger) -> Swagger-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 `combineSwagger` postOrder t2 doc' id--newtype WHOperation = WHOperation {getOperation :: Operation}--instance Semigroup WHOperation where-  WHOperation op1 <> WHOperation op2 =-    let nubMimeList = fmap (\(MimeList xs) -> MimeList $ nub xs)-     in WHOperation $ (op1 <> op2)-          & consumes .~ nubMimeList ((op1 ^. consumes) <> (op2 ^. consumes))-          & produces .~ nubMimeList ((op1 ^. produces) <> (op2 ^. produces))--combineOperation :: Maybe Operation -> Maybe Operation -> Maybe Operation-combineOperation op1 op2 = getOperation <$> (WHOperation <$> op1) <> (WHOperation <$> op2)--combinePathItem :: PathItem -> PathItem -> PathItem-combinePathItem s t =-  PathItem-    { _pathItemGet = _pathItemGet s `combineOperation` _pathItemGet t-    , _pathItemPut = _pathItemPut s `combineOperation` _pathItemPut t-    , _pathItemPost = _pathItemPost s `combineOperation` _pathItemPost t-    , _pathItemDelete = _pathItemDelete s `combineOperation` _pathItemDelete t-    , _pathItemOptions = _pathItemOptions s `combineOperation` _pathItemOptions t-    , _pathItemHead = _pathItemHead s `combineOperation` _pathItemHead t-    , _pathItemPatch = _pathItemPatch s `combineOperation` _pathItemPatch t-    , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t-    }--combineSwagger :: Swagger -> Swagger -> Swagger-combineSwagger s t =-  Swagger-    { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t-    , _swaggerHost = _swaggerHost s <|> _swaggerHost t-    , _swaggerBasePath = _swaggerBasePath s <> _swaggerBasePath t-    , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t-    , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t-    , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t-    , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t-    , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t-    , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t-    , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t-    , _swaggerPaths = Map.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)-    , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t-    , _swaggerTags = _swaggerTags s <> _swaggerTags t-    , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t-    }--mergeDoc :: CompactDocNode -> Tree CompactDocNode -> Swagger -> Swagger-mergeDoc (CDocSecurityScheme schemeName scheme) child doc =-  let-    secSchemes = [(schemeName, scheme)] :: Definitions SecurityScheme-    secReqs = [SecurityRequirement [(schemeName, [])]] :: [SecurityRequirement]-   in-    postOrder child doc $ \doc' ->-      doc'-        & securityDefinitions <>~ SecurityDefinitions secSchemes-        & allOperations . security <>~ secReqs-mergeDoc (CDocRequestBody defs mimeList bodyParam) child doc =-  postOrder child doc $ \doc' ->-    doc'-      & allOperations-        %~ ( \op ->-              op-                & parameters %~ (Inline bodyParam :)-                & consumes %~ Just . maybe mimeList (<> mimeList)-           )-      & definitions %~ (<> 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-     in doc' & paths <>~ [("/", pathItem)]-mergeDoc (CDocResponseBody defs mimeList responseSchema) child doc =-  postOrder child doc $ \doc' ->-    let resp = mempty @Response & schema .~ responseSchema-     in doc'-          & allOperations-            %~ ( \op ->-                  op-                    & responses . responses %~ Map.map (`swaggerMappend` Inline resp)-                    & produces %~ Just . maybe mimeList (`swaggerMappend` mimeList)-               )-          & definitions %~ (<> defs)-mergeDoc (CDocResponseHeader headerName header) child doc =-  postOrder child doc $ \doc' ->-    let resp = mempty @Response & headers <>~ [(headerName, 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, _pathItemParameters}-    HTTP.PUT -> mempty{_pathItemPut, _pathItemParameters}-    HTTP.POST -> mempty{_pathItemPost, _pathItemParameters}-    HTTP.DELETE -> mempty{_pathItemDelete, _pathItemParameters}-    HTTP.HEAD -> mempty{_pathItemHead, _pathItemParameters}-    HTTP.OPTIONS -> mempty{_pathItemOptions, _pathItemParameters}-    HTTP.PATCH -> mempty{_pathItemPatch, _pathItemParameters}-    -- Swagger does not support CONNECT and TRACE-    HTTP.CONNECT -> mempty{_pathItemParameters}-    HTTP.TRACE -> mempty{_pathItemParameters}+toSwagger (SwaggerHandler f) = evalState (f mempty) (Documentation Nothing Nothing)

@@ -1,18 +1,42 @@ {-# OPTIONS_GHC -Wno-orphans #-}  -- | Functions and instances for authentication-module WebGear.Swagger.Trait.Auth () where+module WebGear.Swagger.Trait.Auth (addSecurityScheme) where +import Control.Lens ((&), (.~), (<>~))+import Control.Monad.State.Strict (MonadState) import Data.Proxy (Proxy (..)) import Data.Swagger (   Definitions,   NamedSchema,   Schema,+  SecurityDefinitions (..),+  SecurityRequirement (..),+  SecurityScheme,+  Swagger,   ToSchema (..),+  allOperations,+  description,+  security,+  securityDefinitions,  ) import Data.Swagger.Declare (Declare)+import Data.Text (Text)+import WebGear.Core.Handler (Description (..)) import WebGear.Core.Trait.Auth.Common (AuthToken)+import WebGear.Swagger.Handler (Documentation (..), consumeDescription)  instance ToSchema (AuthToken scheme) where   declareNamedSchema :: Proxy (AuthToken scheme) -> Declare (Definitions Schema) NamedSchema   declareNamedSchema _ = declareNamedSchema $ Proxy @String++addSecurityScheme :: (MonadState Documentation m) => Text -> SecurityScheme -> Swagger -> m Swagger+addSecurityScheme schemeName scheme doc = do+  desc <- consumeDescription+  let scheme' = scheme & description .~ fmap getDescription desc+      secDefs = SecurityDefinitions [(schemeName, scheme')]+      secReqs = [SecurityRequirement [(schemeName, [])]] :: [SecurityRequirement]+  pure $+    doc+      & securityDefinitions <>~ secDefs+      & allOperations . security <>~ secReqs

@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} --- | Swagger implementation of 'BasicAuth'' trait.+-- | Swagger implementation of `BasicAuth'` trait. module WebGear.Swagger.Trait.Auth.Basic where  import Data.Proxy (Proxy (..))@@ -8,20 +8,21 @@ import Data.Swagger 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.Swagger.Handler (DocNode (DocSecurityScheme), SwaggerHandler (..), singletonNode)+import WebGear.Swagger.Handler (SwaggerHandler (..))+import WebGear.Swagger.Trait.Auth (addSecurityScheme) -instance (TraitAbsence (BasicAuth' x scheme m e a) Request, KnownSymbol scheme) => Get (SwaggerHandler m) (BasicAuth' x scheme m e a) Request where+instance (KnownSymbol scheme) => Get (SwaggerHandler m) (BasicAuth' x scheme m e a) where   {-# INLINE getTrait #-}   getTrait ::     BasicAuth' x scheme m e a ->-    SwaggerHandler m (Request `With` ts) (Either (Absence (BasicAuth' x scheme m e a) Request) (Attribute (BasicAuth' x scheme m e a) Request))+    SwaggerHandler 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 = SecuritySchemeBasic             , _securitySchemeDescription = Nothing             }-     in SwaggerHandler $ singletonNode (DocSecurityScheme schemeName securityScheme)+     in SwaggerHandler $ addSecurityScheme schemeName scheme

@@ -8,22 +8,20 @@ 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.Swagger.Handler (DocNode (DocSecurityScheme), SwaggerHandler (..), singletonNode)+import WebGear.Swagger.Handler (SwaggerHandler (..))+import WebGear.Swagger.Trait.Auth (addSecurityScheme) -instance-  (TraitAbsence (JWTAuth' x scheme m e a) Request, KnownSymbol scheme) =>-  Get (SwaggerHandler m) (JWTAuth' x scheme m e a) Request-  where+instance (KnownSymbol scheme) => Get (SwaggerHandler m) (JWTAuth' x scheme m e a) where   {-# INLINE getTrait #-}   getTrait ::     JWTAuth' x scheme m e a ->-    SwaggerHandler m (Request `With` ts) (Either (Absence (JWTAuth' x scheme m e a) Request) (Attribute (JWTAuth' x scheme m e a) Request))+    SwaggerHandler m (Request `With` ts) (Either (Absence (JWTAuth' x scheme m e a)) (Attribute (JWTAuth' x scheme m e a) Request))   getTrait _ =     let schemeName = fromString (symbolVal (Proxy @scheme))         -- Swagger 2.0 does not support JWT: https://stackoverflow.com/a/32995636-        securityScheme =+        scheme =           SecurityScheme             { _securitySchemeType =                 SecuritySchemeApiKey@@ -34,4 +32,4 @@                   )             , _securitySchemeDescription = Just ("Enter the token with the `" <> schemeName <> ": ` prefix")             }-     in SwaggerHandler $ singletonNode (DocSecurityScheme schemeName securityScheme)+     in SwaggerHandler $ addSecurityScheme schemeName scheme

@@ -3,50 +3,118 @@ -- | Swagger implementation of 'Body' trait. module WebGear.Swagger.Trait.Body where -import Control.Lens ((&), (.~), (?~))+import Control.Lens ((%~), (&), (.~), (?~), (^.))+import Control.Monad.State.Strict (MonadState)+import qualified Data.HashMap.Strict.InsOrd as Map import Data.Proxy (Proxy (..))-import Data.Swagger hiding (Response)+import Data.Swagger (+  Definitions,+  MimeList (..),+  Param,+  ParamAnySchema (..),+  Referenced (..),+  Response,+  Schema,+  Swagger,+  ToSchema,+  allOperations,+  consumes,+  declareSchemaRef,+  definitions,+  description,+  name,+  parameters,+  paths,+  produces,+  required,+  responses,+  schema,+ ) import Data.Swagger.Declare (runDeclare)+import Data.Swagger.Internal.Utils (swaggerMappend) import Data.Text (Text)+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.Swagger.Handler (-  DocNode (DocRequestBody, DocResponseBody),+  Documentation (..),   SwaggerHandler (..),-  singletonNode,+  addRootPath,+  consumeDescription,  ) -instance (ToSchema val, MIMEType mt) => Get (SwaggerHandler m) (Body mt val) Request where+instance (ToSchema val, MIMEType mt) => Get (SwaggerHandler m) (Body mt val) where   {-# INLINE getTrait #-}   getTrait :: Body mt val -> SwaggerHandler m (Request `With` ts) (Either Text val)   getTrait (Body mt) =-    let mimeList = MimeList [mimeType mt]-        (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty-        body =-          mempty @Param-            & schema .~ ParamBody ref-            & required ?~ True-            & name .~ "body"-     in SwaggerHandler $ singletonNode (DocRequestBody defs mimeList body)+    SwaggerHandler $ \doc -> do+      desc <- consumeDescription+      let mimeList = MimeList [mimeType mt]+          (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty+          body =+            (mempty @Param)+              & schema .~ ParamBody ref+              & required ?~ True+              & name .~ "body"+              & description .~ fmap getDescription desc+      pure $+        doc+          & allOperations+            %~ ( \op ->+                  op+                    & parameters %~ (Inline body :)+                    & consumes %~ Just . maybe mimeList (<> mimeList)+               )+          & definitions %~ (<> defs) -instance (ToSchema val, MIMEType mt) => Set (SwaggerHandler m) (Body mt val) Response where+instance (ToSchema val, MIMEType mt) => Set (SwaggerHandler m) (Body mt val) where   {-# INLINE setTrait #-}   setTrait ::     Body mt val ->-    (Response `With` ts -> Response -> val -> Response `With` (Body mt val : ts)) ->-    SwaggerHandler 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)) ->+    SwaggerHandler m (WG.Response `With` ts, val) (WG.Response `With` (Body mt val : ts))   setTrait (Body mt) _ =     let mimeList = MimeList [mimeType mt]         (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty-     in SwaggerHandler $ singletonNode (DocResponseBody defs mimeList (Just ref))+     in SwaggerHandler $ addResponseBody defs mimeList (Just ref) -instance Set (SwaggerHandler m) UnknownContentBody Response where+instance Set (SwaggerHandler m) UnknownContentBody where   {-# INLINE setTrait #-}   setTrait ::     UnknownContentBody ->-    (Response `With` ts -> Response -> ResponseBody -> Response `With` (UnknownContentBody : ts)) ->-    SwaggerHandler m (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts))-  setTrait UnknownContentBody _ = SwaggerHandler $ singletonNode (DocResponseBody mempty mempty Nothing)+    (WG.Response `With` ts -> WG.Response -> WG.ResponseBody -> WG.Response `With` (UnknownContentBody : ts)) ->+    SwaggerHandler m (WG.Response `With` ts, WG.ResponseBody) (WG.Response `With` (UnknownContentBody : ts))+  setTrait UnknownContentBody _ = SwaggerHandler $ addResponseBody mempty mempty Nothing++addResponseBody ::+  (MonadState Documentation m) =>+  Definitions Schema ->+  MimeList ->+  Maybe (Referenced Schema) ->+  Swagger ->+  m Swagger+addResponseBody defs mimeList respSchema 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 & schema .~ respSchema+      doc' = if Map.null (doc ^. paths) then addRootPath doc else doc++  pure $+    doc'+      & allOperations+        %~ ( \op ->+              op+                & responses . responses %~ Map.map (addDescription . (`swaggerMappend` Inline resp))+                & produces %~ Just . maybe mimeList (`swaggerMappend` mimeList)+           )+      & definitions %~ (<> defs)

@@ -1,28 +1,18 @@ {-# OPTIONS_GHC -Wno-orphans #-} -{- | Swagger implementation of 'WG.Cookie' and 'WG.SetCookie' traits.--Swagger 2.0 does not support cookie authentication. So these-implementations are no-ops.--}+-- | Swagger implementation of 'WG.Cookie' and 'WG.SetCookie' traits. module WebGear.Swagger.Trait.Cookie () where -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.Swagger.Handler (SwaggerHandler (..), nullNode)+import WebGear.Swagger.Handler (SwaggerHandler (..)) -instance-  (TraitAbsence (WG.Cookie e name val) Request) =>-  Get (SwaggerHandler m) (WG.Cookie e name val) Request-  where+-- Cookie information is not captured by Swagger++instance Get (SwaggerHandler m) (WG.Cookie e name val) where   {-# INLINE getTrait #-}-  getTrait WG.Cookie = SwaggerHandler nullNode+  getTrait WG.Cookie = SwaggerHandler pure -instance-  (Trait (WG.SetCookie e name) Response) =>-  Set (SwaggerHandler m) (WG.SetCookie e name) Response-  where+instance Set (SwaggerHandler m) (WG.SetCookie e name) where   {-# INLINE setTrait #-}-  setTrait WG.SetCookie _ = SwaggerHandler nullNode+  setTrait WG.SetCookie _ = SwaggerHandler pure

@@ -3,73 +3,104 @@ -- | Swagger implementation of 'Header' trait. module WebGear.Swagger.Trait.Header () where -import Control.Lens ((&), (.~), (?~))+import Control.Lens ((%~), (&), (.~), (<>~), (?~))+import Control.Monad.State.Strict (MonadState)+import qualified Data.HashMap.Strict.InsOrd as Map import Data.Proxy (Proxy (Proxy)) import Data.String (fromString)-import Data.Swagger hiding (Response)+import Data.Swagger (+  Header,+  HeaderName,+  Param,+  ParamAnySchema (..),+  ParamLocation (..),+  ParamOtherSchema (..),+  Referenced (..),+  Response,+  Swagger,+  ToParamSchema (..),+  allOperations,+  description,+  headers,+  name,+  parameters,+  required,+  responses,+  schema,+ )+import Data.Swagger.Internal.Utils (swaggerMappend) 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.Swagger.Handler (DocNode (..), SwaggerHandler (..), nullNode, singletonNode)--mkParam ::-  forall name val.-  (KnownSymbol name, ToParamSchema val) =>-  Proxy name ->-  Proxy val ->-  Bool ->-  Param-mkParam proxyName proxyVal isRequired =-  (mempty :: Param)-    & name .~ fromString @Text (symbolVal proxyName)-    & required ?~ isRequired-    & schema-      .~ ParamOther-        ( ParamOtherSchema-            { _paramOtherSchemaIn = ParamHeader-            , _paramOtherSchemaAllowEmptyValue = Just (not isRequired)-            , _paramOtherSchemaParamSchema = toParamSchema proxyVal-            }-        )+import WebGear.Swagger.Handler (Documentation, SwaggerHandler (..), consumeDescription)  instance   ( KnownSymbol name   , ToParamSchema val-  , TraitAbsence (WG.RequestHeader Required ps name val) Request   ) =>-  Get (SwaggerHandler m) (WG.RequestHeader Required ps name val) Request+  Get (SwaggerHandler m) (WG.RequestHeader Required ps name val)   where   {-# INLINE getTrait #-}-  getTrait WG.RequestHeader =-    SwaggerHandler $ singletonNode (DocRequestHeader $ mkParam (Proxy @name) (Proxy @val) True)+  getTrait WG.RequestHeader = SwaggerHandler $ addRequestHeader (Proxy @name) (Proxy @val) True  instance   ( KnownSymbol name   , ToParamSchema val-  , TraitAbsence (WG.RequestHeader Optional ps name val) Request   ) =>-  Get (SwaggerHandler m) (WG.RequestHeader Optional ps name val) Request+  Get (SwaggerHandler m) (WG.RequestHeader Optional ps name val)   where   {-# INLINE getTrait #-}-  getTrait WG.RequestHeader =-    SwaggerHandler $ singletonNode (DocRequestHeader $ mkParam (Proxy @name) (Proxy @val) False)+  getTrait WG.RequestHeader = SwaggerHandler $ addRequestHeader (Proxy @name) (Proxy @val) False -instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Required name val) Response where+instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Required name val) where   {-# INLINE setTrait #-}-  setTrait WG.ResponseHeader _ =-    let headerName = fromString $ symbolVal $ Proxy @name-        header = mempty @Header-     in if headerName == "Content-Type"-          then SwaggerHandler nullNode-          else SwaggerHandler $ singletonNode (DocResponseHeader headerName header)+  setTrait WG.ResponseHeader _ = SwaggerHandler $ addResponseHeader (Proxy @name) (Proxy @val) -instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Optional name val) Response where+instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Optional name val) where   {-# INLINE setTrait #-}-  setTrait WG.ResponseHeader _ =-    let headerName = fromString $ symbolVal $ Proxy @name-        header = mempty @Header-     in SwaggerHandler $ singletonNode (DocResponseHeader headerName header)+  setTrait WG.ResponseHeader _ = SwaggerHandler $ addResponseHeader (Proxy @name) (Proxy @val)++addRequestHeader ::+  forall name val m.+  (KnownSymbol name, ToParamSchema val, MonadState Documentation m) =>+  Proxy name ->+  Proxy val ->+  Bool ->+  Swagger ->+  m Swagger+addRequestHeader _ _ isRequired doc = do+  desc <- consumeDescription+  let param =+        (mempty :: Param)+          & name .~ fromString @Text (symbolVal $ Proxy @name)+          & required ?~ isRequired+          & schema+            .~ ParamOther+              ( ParamOtherSchema+                  { _paramOtherSchemaIn = ParamHeader+                  , _paramOtherSchemaAllowEmptyValue = Just (not isRequired)+                  , _paramOtherSchemaParamSchema = toParamSchema (Proxy @val)+                  }+              )+          & description .~ fmap getDescription desc+  pure $ doc & allOperations . parameters <>~ [Inline param]++addResponseHeader ::+  forall name val m.+  (KnownSymbol name, MonadState Documentation m) =>+  Proxy name ->+  Proxy val ->+  Swagger ->+  m Swagger+addResponseHeader _ _ doc = do+  desc <- consumeDescription+  let headerName = fromString @HeaderName $ symbolVal $ Proxy @name+      header = mempty @Header & description .~ fmap getDescription desc+      resp = mempty @Response & headers <>~ [(headerName, header)]+  pure $+    if headerName == "Content-Type"+      then doc+      else doc & allOperations . responses . responses %~ Map.map (`swaggerMappend` Inline resp)

@@ -3,11 +3,29 @@ -- | Swagger implementation of 'Method' trait. module WebGear.Swagger.Trait.Method where -import WebGear.Core.Request (Request)+import Control.Lens ((%~), (&))+import qualified Data.HashMap.Strict.InsOrd as Map+import Data.Swagger (PathItem (..), paths)+import Network.HTTP.Types (StdMethod (..)) import WebGear.Core.Trait (Get (..)) import WebGear.Core.Trait.Method (Method (..))-import WebGear.Swagger.Handler (DocNode (DocMethod), SwaggerHandler (SwaggerHandler), singletonNode)+import WebGear.Swagger.Handler (SwaggerHandler (..), addRouteDocumentation) -instance Get (SwaggerHandler m) Method Request where+instance Get (SwaggerHandler m) Method where   {-# INLINE getTrait #-}-  getTrait (Method method) = SwaggerHandler $ singletonNode (DocMethod method)+  getTrait (Method method) = SwaggerHandler $ \doc -> do+    addRouteDocumentation $ doc & paths %~ Map.map (removeOtherMethods method)++removeOtherMethods :: StdMethod -> PathItem -> PathItem+removeOtherMethods method PathItem{..} =+  case method of+    GET -> mempty{_pathItemGet, _pathItemParameters}+    PUT -> mempty{_pathItemPut, _pathItemParameters}+    POST -> mempty{_pathItemPost, _pathItemParameters}+    DELETE -> mempty{_pathItemDelete, _pathItemParameters}+    HEAD -> mempty{_pathItemHead, _pathItemParameters}+    OPTIONS -> mempty{_pathItemOptions, _pathItemParameters}+    PATCH -> mempty{_pathItemPatch, _pathItemParameters}+    -- Swagger does not support CONNECT and TRACE+    CONNECT -> mempty{_pathItemParameters}+    TRACE -> mempty{_pathItemParameters}

@@ -3,48 +3,54 @@ -- | Swagger implementation of path traits. module WebGear.Swagger.Trait.Path where +import Control.Lens ((&), (<>~)) import Data.Data (Proxy (Proxy)) import Data.String (fromString) import Data.Swagger (   Param (..),-  ParamAnySchema (ParamOther),+  ParamAnySchema (..),   ParamLocation (ParamPath),   ParamOtherSchema (..),+  Referenced (Inline),+  allOperations,+  parameters,+  prependPath,  )+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.Swagger.Handler (-  DocNode (DocPathElem, DocPathVar),-  SwaggerHandler (..),-  singletonNode,- )+import WebGear.Swagger.Handler (SwaggerHandler (..), addRouteDocumentation) -instance Get (SwaggerHandler m) Path Request where+instance Get (SwaggerHandler m) Path where   {-# INLINE getTrait #-}   getTrait :: Path -> SwaggerHandler m (Request `With` ts) (Either () ())-  getTrait (Path p) = SwaggerHandler $ singletonNode (DocPathElem p)+  getTrait (Path p) = SwaggerHandler $ addRouteDocumentation . prependPath (unpack p) -instance (KnownSymbol tag) => Get (SwaggerHandler m) (PathVar tag val) Request where+instance (KnownSymbol tag) => Get (SwaggerHandler m) (PathVar tag val) where   {-# INLINE getTrait #-}   getTrait :: PathVar tag val -> SwaggerHandler 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             , _paramRequired = Just True             , _paramSchema =                 ParamOther-                  $ ParamOtherSchema+                  ParamOtherSchema                     { _paramOtherSchemaIn = ParamPath                     , _paramOtherSchemaParamSchema = mempty                     , _paramOtherSchemaAllowEmptyValue = Nothing                     }             }-     in SwaggerHandler $ singletonNode (DocPathVar param)+     in SwaggerHandler $ \doc ->+          addRouteDocumentation $+            prependPath ("{" <> paramName <> "}") doc+              & allOperations . parameters <>~ [Inline param] -instance Get (SwaggerHandler m) PathEnd Request where+instance Get (SwaggerHandler m) PathEnd where   {-# INLINE getTrait #-}   getTrait :: PathEnd -> SwaggerHandler m (Request `With` ts) (Either () ())-  getTrait PathEnd = SwaggerHandler $ singletonNode (DocPathElem "/")+  getTrait PathEnd = SwaggerHandler $ addRouteDocumentation . prependPath "/"

@@ -3,6 +3,8 @@ -- | Swagger implementation of 'QueryParam' trait. module WebGear.Swagger.Trait.QueryParam where +import Control.Lens ((&), (.~), (<>~))+import Control.Monad.State.Strict (MonadState) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.Swagger (@@ -10,15 +12,20 @@   ParamAnySchema (..),   ParamLocation (ParamQuery),   ParamOtherSchema (..),+  Referenced (Inline),+  Swagger,+  allOperations,+  description,+  parameters,  ) 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.Swagger.Handler (DocNode (DocQueryParam), SwaggerHandler (..), singletonNode)+import WebGear.Swagger.Handler (Documentation (..), SwaggerHandler (..), consumeDescription) -instance (KnownSymbol name, TraitAbsence (QueryParam Required ps name val) Request) => Get (SwaggerHandler m) (QueryParam Required ps name val) Request where+instance (KnownSymbol name) => Get (SwaggerHandler m) (QueryParam Required ps name val) where   {-# INLINE getTrait #-}   getTrait _ =     let param =@@ -27,15 +34,15 @@             , _paramRequired = Just True             , _paramSchema =                 ParamOther-                  $ ParamOtherSchema+                  ParamOtherSchema                     { _paramOtherSchemaIn = ParamQuery                     , _paramOtherSchemaAllowEmptyValue = Just True                     , _paramOtherSchemaParamSchema = mempty                     }             }-     in SwaggerHandler $ singletonNode (DocQueryParam param)+     in SwaggerHandler $ addParam param -instance (KnownSymbol name, TraitAbsence (QueryParam Optional ps name val) Request) => Get (SwaggerHandler m) (QueryParam Optional ps name val) Request where+instance (KnownSymbol name) => Get (SwaggerHandler m) (QueryParam Optional ps name val) where   {-# INLINE getTrait #-}   getTrait _ =     let param =@@ -44,10 +51,16 @@             , _paramRequired = Just False             , _paramSchema =                 ParamOther-                  $ ParamOtherSchema+                  ParamOtherSchema                     { _paramOtherSchemaIn = ParamQuery                     , _paramOtherSchemaAllowEmptyValue = Just True                     , _paramOtherSchemaParamSchema = mempty                     }             }-     in SwaggerHandler $ singletonNode (DocQueryParam param)+     in SwaggerHandler $ addParam param++addParam :: (MonadState Documentation m) => Param -> Swagger -> m Swagger+addParam param doc = do+  desc <- consumeDescription+  let param' = param & description .~ fmap getDescription desc+  pure $ doc & allOperations . parameters <>~ [Inline param']

@@ -3,16 +3,69 @@ -- | Swagger implementation of 'Status' trait. module WebGear.Swagger.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.Swagger (+  Operation,+  PathItem,+  Referenced (..),+  Response,+  delete,+  description,+  get,+  head_,+  options,+  patch,+  paths,+  post,+  put,+  responses,+ ) 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.Swagger.Handler (DocNode (DocStatus), SwaggerHandler (..), singletonNode)+import WebGear.Swagger.Handler (SwaggerHandler (..), addRootPath, consumeDescription) -instance Set (SwaggerHandler m) Status Response where+instance Set (SwaggerHandler m) Status where   {-# INLINE setTrait #-}   setTrait ::     Status ->-    (Response `With` ts -> Response -> HTTP.Status -> Response `With` (Status : ts)) ->-    SwaggerHandler m (Response `With` ts, HTTP.Status) (Response `With` (Status : ts))-  setTrait (Status status) _ = SwaggerHandler $ singletonNode (DocStatus status)+    (WG.Response `With` ts -> WG.Response -> HTTP.Status -> WG.Response `With` (Status : ts)) ->+    SwaggerHandler m (WG.Response `With` ts, HTTP.Status) (WG.Response `With` (Status : ts))+  setTrait status _ = SwaggerHandler $ \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+  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)

@@ -1,7 +1,7 @@ cabal-version:       2.4  name:                webgear-swagger-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.@@ -73,9 +73,10 @@                     , http-types ==0.12.*                     , insert-ordered-containers ==0.2.*                     , lens >=4.18.1 && <5.3+                    , mtl >=2.2 && <2.4                     , swagger2 >=2.6 && <2.9                     , 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