Swagger fixes for MultiVerb and ErrorDescription

CHANGELOG-draft.md

@@ -40,6 +40,7 @@ THIS FILE ACCUMULATES THE RELEASE NOTES FOR THE UPCOMING RELEASE.
 ## Internal changes
 
 * Integration test script now displays output interactively (#1700)
+* Fixed a few issues with error response documentation in Swagger (#1707)
 
 ## Federation changes
 

CHANGELOG.md

@@ -3,8 +3,6 @@
 
 <!-- if you're not the release manager, do your edits to changelog in CHANGELOG-draft.md -->
 
-
-
 # [2021-08-16]
 
 ## Release Notes

libs/wire-api/src/Wire/API/ErrorDescription.hs

@@ -1,13 +1,13 @@
 module Wire.API.ErrorDescription where
 
-import Control.Lens (at, ix, over, (%~), (.~), (<>~), (?~))
-import Control.Lens.Combinators (_Just)
+import Control.Lens (at, (%~), (.~), (<>~), (?~))
 import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy as LBS
 import Data.SOP (I (..), NP (..), NS (..))
 import Data.Schema
 import Data.Swagger (Swagger)
-import qualified Data.Swagger as Swagger
+import qualified Data.Swagger as S
+import qualified Data.Swagger.Declare as S
 import qualified Data.Text as Text
 import GHC.TypeLits (KnownSymbol, Symbol, natVal, symbolVal)
 import GHC.TypeNats (Nat)
@@ -51,51 +51,23 @@ errorDescriptionAddToSwagger ::
   Swagger ->
   Swagger
 errorDescriptionAddToSwagger =
-  over (Swagger.paths . traverse) overridePathItem
+  (S.allOperations . S.responses . S.responses . at status %~ Just . addRef)
+    . (S.definitions <>~ defs)
   where
-    addRef ::
-      Maybe (Swagger.Referenced Swagger.Response) ->
-      Maybe (Swagger.Referenced Swagger.Response)
-    addRef Nothing =
-      Just . Swagger.Inline $
-        mempty
-          & Swagger.description .~ desc
-          & Swagger.schema ?~ Swagger.Inline (Swagger.toSchema (Proxy @(ErrorDescription code label desc)))
-    addRef (Just response) =
-      Just $
-        response
-          -- add the description of this error to the response description
-          & Swagger._Inline . Swagger.description
-            <>~ ("\n\n" <> desc)
-          -- add the label of this error to the possible values of the corresponding enum
-          & Swagger._Inline . Swagger.schema . _Just . Swagger._Inline . Swagger.properties . ix "label" . Swagger._Inline . Swagger.enum_ . _Just
-            <>~ [A.toJSON (symbolVal (Proxy @label))]
-
-    desc =
-      Text.pack (symbolVal (Proxy @desc))
-        <> " (label: `"
-        <> Text.pack (symbolVal (Proxy @label))
-        <> "`)"
-
-    overridePathItem :: Swagger.PathItem -> Swagger.PathItem
-    overridePathItem =
-      over (Swagger.get . _Just) overrideOp
-        . over (Swagger.post . _Just) overrideOp
-        . over (Swagger.put . _Just) overrideOp
-        . over (Swagger.head_ . _Just) overrideOp
-        . over (Swagger.patch . _Just) overrideOp
-        . over (Swagger.delete . _Just) overrideOp
-        . over (Swagger.options . _Just) overrideOp
-    overrideOp :: Swagger.Operation -> Swagger.Operation
-    overrideOp =
-      Swagger.responses . Swagger.responses . at (fromInteger $ natVal (Proxy @code))
-        %~ addRef
+    addRef :: Maybe (S.Referenced S.Response) -> S.Referenced S.Response
+    addRef Nothing = S.Inline resp
+    addRef (Just (S.Inline resp1)) = S.Inline (combineResponseSwagger resp1 resp)
+    addRef (Just r@(S.Ref _)) = r
+
+    status = fromInteger (natVal (Proxy @code))
+    (defs, resp) =
+      S.runDeclare (responseSwagger @(ErrorDescription code label desc)) mempty
 
 -- FUTUREWORK: Ponder about elevating label and messge to the type level. If all
 -- errors are static, there is probably no point in having them at value level.
 data ErrorDescription (statusCode :: Nat) (label :: Symbol) (desc :: Symbol) = ErrorDescription {edMessage :: Text}
   deriving stock (Show, Typeable)
-  deriving (A.ToJSON, A.FromJSON, Swagger.ToSchema) via Schema (ErrorDescription statusCode label desc)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema (ErrorDescription statusCode label desc)
 
 instance (KnownStatus statusCode, KnownSymbol label, KnownSymbol desc) => ToSchema (ErrorDescription statusCode label desc) where
   schema =
@@ -110,7 +82,7 @@ instance (KnownStatus statusCode, KnownSymbol label, KnownSymbol desc) => ToSche
       code = natVal (Proxy @statusCode)
       desc = Text.pack (symbolVal (Proxy @desc))
       addExample =
-        Swagger.schema . Swagger.example
+        S.schema . S.example
           ?~ A.toJSON (ErrorDescription @statusCode @label @desc desc)
       labelSchema :: ValueSchema SwaggerDoc Text
       labelSchema = unnamed $ enum @Text "Label" (element label label)
@@ -149,7 +121,17 @@ instance
   (KnownStatus s, KnownSymbol label, KnownSymbol desc) =>
   IsSwaggerResponse (ErrorDescription s label desc)
   where
-  responseSwagger = responseSwagger @(RespondWithErrorDescription s label desc)
+  responseSwagger =
+    pure $
+      mempty
+        & S.description .~ desc
+        & S.schema ?~ S.Inline (S.toSchema (Proxy @(ErrorDescription s label desc)))
+    where
+      desc =
+        Text.pack (symbolVal (Proxy @desc))
+          <> " (label: `"
+          <> Text.pack (symbolVal (Proxy @label))
+          <> "`)"
 
 instance
   (ResponseType r ~ a, KnownSymbol desc) =>
@@ -193,14 +175,11 @@ instance
   where
   responseSwagger =
     pure $
-      ResponseSwagger
-        { rsDescription =
-            Text.pack (symbolVal (Proxy @desc)) <> "\n\n"
-              <> "**Note**: This error has an empty body for legacy reasons",
-          rsStatus = statusVal (Proxy @s),
-          rsHeaders = mempty,
-          rsSchema = Nothing
-        }
+      mempty
+        & S.description
+          .~ ( Text.pack (symbolVal (Proxy @desc))
+                 <> "(**Note**: This error has an empty body for legacy reasons)"
+             )
 
 instance
   ( ResponseType r ~ a,

libs/wire-api/src/Wire/API/Routes/MultiVerb.hs

@@ -32,10 +32,10 @@ module Wire.API.Routes.MultiVerb
     ResponseType,
     IsResponse (..),
     IsSwaggerResponse (..),
+    combineResponseSwagger,
     RenderOutput (..),
     roAddContentType,
     roResponse,
-    ResponseSwagger (..),
     ResponseTypes,
     IsResponseList (..),
   )
@@ -46,6 +46,7 @@ import Control.Lens hiding (Context)
 import qualified Data.ByteString.Lazy as LBS
 import Data.Containers.ListUtils
 import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Proxy
 import Data.SOP
 import qualified Data.Sequence as Seq
@@ -82,13 +83,6 @@ data Respond (s :: Nat) (desc :: Symbol) (a :: *)
 -- Includes status code and description.
 data RespondEmpty (s :: Nat) (desc :: Symbol)
 
-data ResponseSwagger = ResponseSwagger
-  { rsDescription :: Text,
-    rsStatus :: Status,
-    rsHeaders :: InsOrdHashMap S.HeaderName S.Header,
-    rsSchema :: Maybe (S.Referenced S.Schema)
-  }
-
 data RenderOutput = RenderOutput
   { roStatus :: Status,
     roBody :: LByteString,
@@ -131,7 +125,7 @@ instance MonadPlus UnrenderResult where
   mplus m@(UnrenderSuccess _) _ = m
 
 class IsSwaggerResponse a where
-  responseSwagger :: Declare ResponseSwagger
+  responseSwagger :: Declare S.Response
 
 type family ResponseType a :: *
 
@@ -173,12 +167,12 @@ instance
   (KnownStatus s, KnownSymbol desc, S.ToSchema a) =>
   IsSwaggerResponse (Respond s desc a)
   where
-  responseSwagger =
-    ResponseSwagger desc status mempty . Just
-      <$> S.declareSchemaRef (Proxy @a)
-    where
-      desc = Text.pack (symbolVal (Proxy @desc))
-      status = statusVal (Proxy @s)
+  responseSwagger = do
+    ref <- S.declareSchemaRef (Proxy @a)
+    pure $
+      mempty
+        & S.description .~ Text.pack (symbolVal (Proxy @desc))
+        & S.schema ?~ ref
 
 type instance ResponseType (RespondEmpty s desc) = ()
 
@@ -200,10 +194,10 @@ instance KnownStatus s => IsResponse cs (RespondEmpty s desc) where
       )
 
 instance (KnownStatus s, KnownSymbol desc) => IsSwaggerResponse (RespondEmpty s desc) where
-  responseSwagger = pure $ ResponseSwagger desc status mempty Nothing
-    where
-      desc = Text.pack (symbolVal (Proxy @desc))
-      status = statusVal (Proxy @s)
+  responseSwagger =
+    pure $
+      mempty
+        & S.description .~ Text.pack (symbolVal (Proxy @desc))
 
 -- | This type adds response headers to a 'MultiVerb' response.
 --
@@ -281,11 +275,11 @@ instance
   where
   responseSwagger =
     fmap
-      (\rs -> rs {rsHeaders = toAllResponseHeaders (Proxy @hs)})
+      (S.headers .~ toAllResponseHeaders (Proxy @hs))
       (responseSwagger @r)
 
 class IsSwaggerResponseList as where
-  responseListSwagger :: Declare [ResponseSwagger]
+  responseListSwagger :: Declare (InsOrdHashMap S.HttpStatusCode S.Response)
 
 type family ResponseTypes (as :: [*]) where
   ResponseTypes '[] = '[]
@@ -303,7 +297,7 @@ instance IsResponseList cs '[] where
   responseListStatuses = []
 
 instance IsSwaggerResponseList '[] where
-  responseListSwagger = pure []
+  responseListSwagger = pure mempty
 
 instance
   ( IsResponse cs a,
@@ -322,10 +316,33 @@ instance
   responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as
 
 instance
-  (IsSwaggerResponse a, IsSwaggerResponseList as) =>
+  ( IsSwaggerResponse a,
+    KnownNat (ResponseStatus a),
+    IsSwaggerResponseList as
+  ) =>
   IsSwaggerResponseList (a ': as)
   where
-  responseListSwagger = (:) <$> responseSwagger @a <*> responseListSwagger @as
+  responseListSwagger =
+    InsOrdHashMap.insertWith
+      combineResponseSwagger
+      (fromIntegral (natVal (Proxy @(ResponseStatus a))))
+      <$> responseSwagger @a
+      <*> responseListSwagger @as
+
+combineResponseSwagger :: S.Response -> S.Response -> S.Response
+combineResponseSwagger r1 r2 =
+  r1
+    & S.description <>~ ("\n\n" <> r2 ^. S.description)
+    & S.schema . _Just . S._Inline %~ flip combineSwaggerSchema (r2 ^. S.schema . _Just . S._Inline)
+
+combineSwaggerSchema :: S.Schema -> S.Schema -> S.Schema
+combineSwaggerSchema s1 s2
+  -- if they are both errors, merge label enums
+  | notNullOf (S.properties . ix "code") s1
+      && notNullOf (S.properties . ix "code") s2 =
+    s1 & S.properties . ix "label" . S._Inline . S.enum_ . _Just
+      <>~ (s2 ^. S.properties . ix "label" . S._Inline . S.enum_ . _Just)
+  | otherwise = s1
 
 -- | This type can be used in Servant to produce an endpoint which can return
 -- multiple values with various content types and status codes. It is similar to
@@ -524,22 +541,13 @@ instance
                & method
                  ?~ ( mempty
                         & S.produces ?~ S.MimeList (nubOrd cs)
-                        & S.responses .~ foldr addResponse mempty responses
+                        & S.responses . S.responses .~ fmap S.Inline responses
                     )
            )
     where
       method = S.swaggerMethod (Proxy @method)
       cs = allMime (Proxy @cs)
       (defs, responses) = S.runDeclare (responseListSwagger @as) mempty
-      addResponse :: ResponseSwagger -> S.Responses -> S.Responses
-      addResponse response =
-        at (statusCode (rsStatus response))
-          .~ (Just . S.Inline)
-            ( mempty
-                & S.description .~ rsDescription response
-                & S.schema .~ rsSchema response
-                & S.headers .~ rsHeaders response
-            )
 
 roResponse :: RenderOutput -> Wai.Response
 roResponse ro = Wai.responseLBS (roStatus ro) (roHeaders ro) (roBody ro)