diff --git a/CHANGELOG-draft.md b/CHANGELOG-draft.md index f0105c05e1..a371a3082e 100644 --- a/CHANGELOG-draft.md +++ b/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 diff --git a/CHANGELOG.md b/CHANGELOG.md index 14f52297b1..1870b9cb9c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,8 +3,6 @@ - - # [2021-08-16] ## Release Notes diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 9856e050ca..b990798fbb 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/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, diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 44d3e7a28f..1eb1d56fcf 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/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)