Swagger fixes

CHANGELOG.md

@@ -20,6 +20,10 @@
 
 * schema-profunctor: add `optField` combinator and corresponding documentation (#1621, #1624).
 
+## Documentation
+
+* Fix validation errors in Swagger documentation (#1625).
+
 # 2021-06-23
 
 ## API Changes

libs/schema-profunctor/src/Data/Schema.hs

@@ -269,7 +269,7 @@ field = fieldOver id
 
 -- | A schema for a JSON object with a single optional field.
 optField ::
-  HasField doc' doc =>
+  (HasOpt doc, HasField doc' doc) =>
   Text ->
   -- | The value to use when serialising Nothing.
   Maybe A.Value ->
@@ -311,7 +311,7 @@ fieldOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
 -- See documentation of 'fieldOver' for more details.
 optFieldOver ::
   forall doc' doc v v' a b.
-  HasField doc' doc =>
+  (HasOpt doc, HasField doc' doc) =>
   Lens v v' A.Object A.Value ->
   Text ->
   Maybe A.Value ->
@@ -330,7 +330,7 @@ optFieldOver l name def sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
       pure [name A..= v]
     w Nothing = pure (maybeToList (fmap (name A..=) def))
 
-    s = mkField name (schemaDoc sch)
+    s = mkOpt (mkField name (schemaDoc sch))
 
 -- | Like 'field', but apply an arbitrary function to the
 -- documentation of the field.
@@ -345,7 +345,7 @@ fieldWithDocModifier name modify sch = field name (over doc modify sch)
 -- | Like 'optField', but apply an arbitrary function to the
 -- documentation of the field.
 optFieldWithDocModifier ::
-  HasField doc' doc =>
+  (HasOpt doc, HasField doc' doc) =>
   Text ->
   Maybe A.Value ->
   (doc' -> doc') ->

libs/types-common/src/Data/Qualified.hs

@@ -102,7 +102,7 @@ qualifiedSchema ::
   ValueSchema NamedSwaggerDoc a ->
   ValueSchema NamedSwaggerDoc (Qualified a)
 qualifiedSchema name fieldName sch =
-  object ("Qualified " <> name) $
+  object ("Qualified_" <> name) $
     Qualified
       <$> qUnqualified .= field fieldName sch
       <*> qDomain .= field "domain" schema

libs/wire-api/src/Wire/API/Conversation/Role.hs

@@ -102,12 +102,13 @@ instance S.ToSchema ConversationRole where
   declareNamedSchema _ = do
     conversationRoleSchema <-
       S.declareSchemaRef (Proxy @RoleName)
+    actionsSchema <- S.declareSchema (Proxy @[Action])
     let convRoleSchema :: S.Schema =
           mempty
             & S.properties . at "conversation_role" ?~ conversationRoleSchema
             & S.properties . at "actions"
               ?~ S.Inline
-                ( S.toSchema (Proxy @[Action])
+                ( actionsSchema
                     & description ?~ "The set of actions allowed for this role"
                 )
     pure (S.NamedSchema (Just "ConversationRole") convRoleSchema)

libs/wire-api/src/Wire/API/User/Orphans.hs

@@ -21,6 +21,7 @@
 
 module Wire.API.User.Orphans where
 
+import Control.Lens
 import Data.ISO3166_CountryCodes
 import Data.LanguageCodes
 import Data.Proxy
@@ -68,8 +69,23 @@ instance ToSchema SAML.NameIdPolicy where
 instance ToSchema SAML.NameIDFormat where
   declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
 
+-- The generic schema breaks on this type, so we define it by hand.
+--
+-- The reason is that genericDeclareNamedSchema tries to define the schema for
+-- this type as a heterogeneous array (i.e. tuple) with Swagger types String
+-- and AuthnRequest. However, Swagger does not support heterogeneous arrays,
+-- and this results in an array whose underlying type which is at the same time
+-- marked as a string, and referring to the schema for AuthnRequest, which is of
+-- course invalid.
 instance ToSchema (SAML.FormRedirect SAML.AuthnRequest) where
-  declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
+  declareNamedSchema _ = do
+    authnReqSchema <- declareSchemaRef (Proxy @SAML.AuthnRequest)
+    pure $
+      NamedSchema (Just "FormRedirect") $
+        mempty
+          & type_ ?~ SwaggerObject
+          & properties . at "uri" ?~ Inline (toSchema (Proxy @Text))
+          & properties . at "xml" ?~ authnReqSchema
 
 instance ToSchema (SAML.ID SAML.AuthnRequest) where
   declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions

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

@@ -61,7 +61,7 @@ instance (Typeable a, ToSchema a, ToJSON a, Arbitrary a) => ToSchema (UserMap (S
     mapSch <- declareSchema (Proxy @(Map UserId (Set a)))
     let valueTypeName = Text.pack $ show $ typeRep $ Proxy @a
     return $
-      NamedSchema (Just $ "UserMap (Set " <> valueTypeName <> ")") $
+      NamedSchema (Just $ "UserMap_Set_" <> valueTypeName) $
         mapSch
           & description ?~ "Map of UserId to (Set " <> valueTypeName <> ")"
           & example ?~ toJSON (Map.singleton (generateExample @UserId) (Set.singleton (generateExample @a)))
@@ -70,9 +70,9 @@ instance (Typeable a, ToSchema (UserMap a)) => ToSchema (QualifiedUserMap a) whe
   declareNamedSchema _ = do
     mapSch <- declareSchema (Proxy @(Map Domain (UserMap a)))
     let userMapSchema = toSchema (Proxy @(UserMap a))
-    let valueTypeName = Text.pack $ show $ typeRep $ Proxy @a
+    let valueTypeName = Text.replace " " "_" . Text.pack $ show $ typeRep $ Proxy @a
     return $
-      NamedSchema (Just $ "QualifiedUserMap (" <> valueTypeName <> ")") $
+      NamedSchema (Just $ "QualifiedUserMap_" <> valueTypeName) $
         mapSch
           & description ?~ "Map of Domain to (UserMap (" <> valueTypeName <> "))."
           & example

services/brig/src/Brig/API/Public.hs

@@ -53,12 +53,13 @@ import qualified Brig.User.Auth.Cookie as Auth
 import Brig.User.Email
 import Brig.User.Phone
 import Control.Error hiding (bool)
-import Control.Lens (view, (.~), (?~), (^.))
+import Control.Lens (view, (%~), (.~), (?~), (^.))
 import Control.Monad.Catch (throwM)
 import Data.Aeson hiding (json)
 import Data.ByteString.Conversion
 import qualified Data.ByteString.Lazy as Lazy
 import Data.CommaSeparatedList (CommaSeparatedList (fromCommaSeparatedList))
+import Data.Containers.ListUtils (nubOrd)
 import Data.Domain
 import Data.Handle (Handle, parseHandle)
 import Data.Id as Id
@@ -123,7 +124,11 @@ swaggerDocsAPI =
     (BrigAPI.swagger <> GalleyAPI.swaggerDoc <> LegalHoldAPI.swaggerDoc <> SparAPI.swaggerDoc)
       & S.info . S.title .~ "Wire-Server API"
       & S.info . S.description ?~ desc
+      & S.security %~ nub
+      & S.definitions . traverse %~ sanitise
   where
+    sanitise :: S.Schema -> S.Schema
+    sanitise = (S.properties . traverse . S._Inline %~ sanitise) . (S.required %~ nubOrd)
     desc =
       Text.pack
         [QQ.i|