Serialisation of client capabilities

changelog.d/0-release-notes/client-internal-api

@@ -0,0 +1 @@
+The "addClient" internal endpoint of galley has been changed. This can cause temporary failures during upgrades if brig attempts to use this endpoint on a different version of galley.

changelog.d/1-api-changes/client-capabilities

@@ -0,0 +1 @@
+Create version 6 of client-related endpoints, fixing an oddity in the serialisation of capabilities.

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -65,6 +65,7 @@ import Wire.API.Routes.Public.Brig.Services (ServicesAPI)
 import Wire.API.Routes.Public.Util
 import Wire.API.Routes.QualifiedCapture
 import Wire.API.Routes.Version
+import Wire.API.Routes.Versioned
 import Wire.API.SystemSettings
 import Wire.API.Team.Invitation
 import Wire.API.Team.Size
@@ -126,8 +127,6 @@ type QualifiedCaptureUserId name = QualifiedCapture' '[Description "User Id"] na
 
 type CaptureClientId name = Capture' '[Description "ClientId"] name ClientId
 
-type NewClientResponse = Headers '[Header "Location" ClientId] Client
-
 type DeleteSelfResponses =
   '[ RespondEmpty 200 "Deletion is initiated.",
      RespondWithDeletionCodeTimeout
@@ -730,15 +729,18 @@ type PrekeyAPI =
                :> Post '[JSON] QualifiedUserClientPrekeyMapV4
            )
 
-type UserClientAPI =
-  -- User Client API ----------------------------------------------------
+-- User Client API ----------------------------------------------------
+
+type ClientHeaders = '[DescHeader "Location" "Client ID" ClientId]
 
+type UserClientAPI =
   -- This endpoint can lead to the following events being sent:
   -- - ClientAdded event to self
   -- - ClientRemoved event to self, if removing old clients due to max number
   Named
-    "add-client"
+    "add-client-v5"
     ( Summary "Register a new client"
+        :> Until 'V6
         :> MakesFederatedCall 'Brig "send-connection-action"
         :> CanThrow 'TooManyClients
         :> CanThrow 'MissingAuth
@@ -749,8 +751,38 @@ type UserClientAPI =
         :> ZConn
         :> "clients"
         :> ReqBody '[JSON] NewClient
-        :> Verb 'POST 201 '[JSON] NewClientResponse
+        :> MultiVerb1
+             'POST
+             '[JSON]
+             ( WithHeaders
+                 ClientHeaders
+                 Client
+                 (VersionedRespond 'V5 201 "Client registered" Client)
+             )
     )
+    :<|> Named
+           "add-client"
+           ( Summary "Register a new client"
+               :> From 'V6
+               :> MakesFederatedCall 'Brig "send-connection-action"
+               :> CanThrow 'TooManyClients
+               :> CanThrow 'MissingAuth
+               :> CanThrow 'MalformedPrekeys
+               :> CanThrow 'CodeAuthenticationFailed
+               :> CanThrow 'CodeAuthenticationRequired
+               :> ZUser
+               :> ZConn
+               :> "clients"
+               :> ReqBody '[JSON] NewClient
+               :> MultiVerb1
+                    'POST
+                    '[JSON]
+                    ( WithHeaders
+                        ClientHeaders
+                        Client
+                        (Respond 201 "Client registered" Client)
+                    )
+           )
     :<|> Named
            "update-client"
            ( Summary "Update a registered client"
@@ -774,16 +806,49 @@ type UserClientAPI =
           :> ReqBody '[JSON] RmClient
           :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Client deleted"] ()
       )
+    :<|> Named
+           "list-clients-v5"
+           ( Summary "List the registered clients"
+               :> Until 'V6
+               :> ZUser
+               :> "clients"
+               :> MultiVerb1
+                    'GET
+                    '[JSON]
+                    ( VersionedRespond 'V5 200 "List of clients" [Client]
+                    )
+           )
     :<|> Named
            "list-clients"
            ( Summary "List the registered clients"
+               :> From 'V6
+               :> ZUser
+               :> "clients"
+               :> MultiVerb1
+                    'GET
+                    '[JSON]
+                    ( Respond 200 "List of clients" [Client]
+                    )
+           )
+    :<|> Named
+           "get-client-v5"
+           ( Summary "Get a registered client by ID"
+               :> Until 'V6
                :> ZUser
                :> "clients"
-               :> Get '[JSON] [Client]
+               :> CaptureClientId "client"
+               :> MultiVerb
+                    'GET
+                    '[JSON]
+                    '[ EmptyErrorForLegacyReasons 404 "Client not found",
+                       VersionedRespond 'V5 200 "Client found" Client
+                     ]
+                    (Maybe Client)
            )
     :<|> Named
            "get-client"
            ( Summary "Get a registered client by ID"
+               :> From 'V6
                :> ZUser
                :> "clients"
                :> CaptureClientId "client"

libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs

@@ -30,6 +30,8 @@ import Wire.API.Provider.Bot (BotUserView)
 import Wire.API.Routes.MultiVerb
 import Wire.API.Routes.Named (Named)
 import Wire.API.Routes.Public
+import Wire.API.Routes.Version
+import Wire.API.Routes.Versioned
 import Wire.API.User
 import Wire.API.User.Client
 import Wire.API.User.Client.Prekey (PrekeyId)
@@ -39,11 +41,6 @@ type DeleteResponses =
      Respond 200 "User found" RemoveBotResponse
    ]
 
-type GetClientResponses =
-  '[ ErrorResponse 'ClientNotFound,
-     Respond 200 "Client found" Client
-   ]
-
 type BotAPI =
   Named
     "add-bot"
@@ -116,15 +113,39 @@ type BotAPI =
                :> ReqBody '[JSON] UpdateBotPrekeys
                :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "")
            )
+    :<|> Named
+           "bot-get-client-v5"
+           ( Summary "Get client for bot"
+               :> Until 'V6
+               :> CanThrow 'AccessDenied
+               :> CanThrow 'ClientNotFound
+               :> ZBot
+               :> "bot"
+               :> "client"
+               :> MultiVerb
+                    'GET
+                    '[JSON]
+                    '[ ErrorResponse 'ClientNotFound,
+                       VersionedRespond 'V5 200 "Client found" Client
+                     ]
+                    (Maybe Client)
+           )
     :<|> Named
            "bot-get-client"
            ( Summary "Get client for bot"
+               :> From 'V6
                :> CanThrow 'AccessDenied
                :> CanThrow 'ClientNotFound
                :> ZBot
                :> "bot"
                :> "client"
-               :> MultiVerb 'GET '[JSON] GetClientResponses (Maybe Client)
+               :> MultiVerb
+                    'GET
+                    '[JSON]
+                    '[ ErrorResponse 'ClientNotFound,
+                       Respond 200 "Client found" Client
+                     ]
+                    (Maybe Client)
            )
     :<|> Named
            "bot-claim-users-prekeys"

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

@@ -85,9 +85,11 @@ import Data.Misc (Latitude (..), Longitude (..), PlainTextPassword6)
 import Data.OpenApi hiding (Schema, ToSchema, nullable, schema)
 import Data.OpenApi qualified as Swagger hiding (nullable)
 import Data.Qualified
+import Data.SOP
 import Data.Schema
 import Data.Set qualified as Set
-import Data.Text.Encoding qualified as Text.E
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
 import Data.Time.Clock
 import Data.UUID (toASCIIBytes)
 import Deriving.Swagger
@@ -98,6 +100,9 @@ import Deriving.Swagger
   )
 import Imports
 import Wire.API.MLS.CipherSuite
+import Wire.API.Routes.MultiVerb
+import Wire.API.Routes.Version
+import Wire.API.Routes.Versioned
 import Wire.API.User.Auth
 import Wire.API.User.Client.Prekey as Prekey
 import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..), generateExample, mapOf', setOf')
@@ -373,17 +378,17 @@ instance Swagger.ToSchema UserClientsFull where
 
 instance ToJSON UserClientsFull where
   toJSON =
-    toJSON . Map.foldrWithKey' fn Map.empty . userClientsFull
+    toJSON . Map.foldrWithKey' f Map.empty . userClientsFull
     where
-      fn u c m =
-        let k = Text.E.decodeLatin1 (toASCIIBytes (toUUID u))
+      f u c m =
+        let k = T.decodeLatin1 (toASCIIBytes (toUUID u))
          in Map.insert k c m
 
 instance FromJSON UserClientsFull where
   parseJSON =
-    A.withObject "UserClientsFull" (fmap UserClientsFull . foldrM fn Map.empty . KeyMap.toList)
+    A.withObject "UserClientsFull" (fmap UserClientsFull . foldrM f Map.empty . KeyMap.toList)
     where
-      fn (k, v) m = Map.insert <$> parseJSON (A.String $ Key.toText k) <*> parseJSON v <*> pure m
+      f (k, v) m = Map.insert <$> parseJSON (A.String $ Key.toText k) <*> parseJSON v <*> pure m
 
 instance Arbitrary UserClientsFull where
   arbitrary = UserClientsFull <$> mapOf' arbitrary (setOf' arbitrary)
@@ -498,24 +503,46 @@ mlsPublicKeysSchema =
     mapSchema :: ValueSchema SwaggerDoc MLSPublicKeys
     mapSchema = map_ base64Schema
 
+clientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc Client
+clientSchema mv =
+  object ("Client" <> T.pack (foldMap show mv)) $
+    Client
+      <$> clientId .= field "id" schema
+      <*> clientType .= field "type" schema
+      <*> clientTime .= field "time" schema
+      <*> clientClass .= maybe_ (optField "class" schema)
+      <*> clientLabel .= maybe_ (optField "label" schema)
+      <*> clientCookie .= maybe_ (optField "cookie" schema)
+      <*> clientModel .= maybe_ (optField "model" schema)
+      <*> clientCapabilities .= (fromMaybe mempty <$> caps)
+      <*> clientMLSPublicKeys .= mlsPublicKeysFieldSchema
+      <*> clientLastActive .= maybe_ (optField "last_active" utcTimeSchema)
+  where
+    caps :: ObjectSchemaP SwaggerDoc ClientCapabilityList (Maybe ClientCapabilityList)
+    caps = case mv of
+      -- broken capability serialisation for backwards compatibility
+      Just v | v <= V5 -> optField "capabilities" schema
+      _ -> fmap ClientCapabilityList <$> fromClientCapabilityList .= capabilitiesFieldSchema
+
 instance ToSchema Client where
+  schema = clientSchema Nothing
+
+instance ToSchema (Versioned 'V5 Client) where
+  schema = Versioned <$> unVersioned .= clientSchema (Just V5)
+
+instance {-# OVERLAPPING #-} ToSchema (Versioned 'V5 [Client]) where
   schema =
-    object "Client" $
-      Client
-        <$> clientId .= field "id" schema
-        <*> clientType .= field "type" schema
-        <*> clientTime .= field "time" schema
-        <*> clientClass .= maybe_ (optField "class" schema)
-        <*> clientLabel .= maybe_ (optField "label" schema)
-        <*> clientCookie .= maybe_ (optField "cookie" schema)
-        <*> clientModel .= maybe_ (optField "model" schema)
-        <*> clientCapabilities .= (fromMaybe mempty <$> optField "capabilities" schema)
-        <*> clientMLSPublicKeys .= mlsPublicKeysFieldSchema
-        <*> clientLastActive .= maybe_ (optField "last_active" utcTimeSchema)
+    Versioned
+      <$> unVersioned
+        .= named "ClientList" (array (clientSchema (Just V5)))
 
 mlsPublicKeysFieldSchema :: ObjectSchema SwaggerDoc MLSPublicKeys
 mlsPublicKeysFieldSchema = fromMaybe mempty <$> optField "mls_public_keys" mlsPublicKeysSchema
 
+instance AsHeaders '[ClientId] Client Client where
+  toHeaders c = (I (clientId c) :* Nil, c)
+  fromHeaders = snd
+
 --------------------------------------------------------------------------------
 -- ClientList