Fix: (de-)serialization of client capabilities.

changelog.d/3-bug-fixes/wpb-6400-client-caps-aeson-schema

@@ -0,0 +1 @@
+Fix: (de-)serialization of client capabilities

libs/brig-types/src/Brig/Types/User/Event.hs

@@ -68,7 +68,7 @@ data PropertyEvent
   | PropertiesCleared !UserId
 
 data ClientEvent
-  = ClientAdded !UserId !Client
+  = ClientAdded !UserId !Client'
   | ClientRemoved !UserId !ClientId
 
 data UserUpdatedData = UserUpdatedData

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

@@ -450,7 +450,7 @@ type AccountAPI =
            ( "clients"
                :> "full"
                :> ReqBody '[Servant.JSON] UserSet
-               :> Post '[Servant.JSON] UserClientsFull
+               :> Post '[Servant.JSON] (UserClientsFull ClientV5 {- for smooth upgrades around #3873; see 'addClientInternalH' for details -})
            )
     :<|> Named
            "iAddClient"
@@ -463,7 +463,7 @@ type AccountAPI =
                :> QueryParam' [Optional, Strict] "skip_reauth" Bool
                :> ReqBody '[Servant.JSON] NewClient
                :> Header' [Optional, Strict] "Z-Connection" ConnId
-               :> Verb 'POST 201 '[Servant.JSON] Client
+               :> Verb 'POST 201 '[Servant.JSON] (ClientV5 {- for smooth upgrades around #3873; see 'addClientInternalH' for details -})
            )
     :<|> Named
            "iLegalholdAddClient"

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

@@ -126,7 +126,7 @@ type QualifiedCaptureUserId name = QualifiedCapture' '[Description "User Id"] na
 
 type CaptureClientId name = Capture' '[Description "ClientId"] name ClientId
 
-type NewClientResponse = Headers '[Header "Location" ClientId] Client
+type NewClientResponse client = Headers '[Header "Location" ClientId] client
 
 type DeleteSelfResponses =
   '[ RespondEmpty 200 "Deletion is initiated.",
@@ -726,8 +726,9 @@ type UserClientAPI =
   -- - ClientAdded event to self
   -- - ClientRemoved event to self, if removing old clients due to max number
   Named
-    "add-client"
+    "add-client-v6"
     ( Summary "Register a new client"
+        :> Until 'V6
         :> CanThrow 'TooManyClients
         :> CanThrow 'MissingAuth
         :> CanThrow 'MalformedPrekeys
@@ -737,8 +738,23 @@ type UserClientAPI =
         :> ZConn
         :> "clients"
         :> ReqBody '[JSON] NewClient
-        :> Verb 'POST 201 '[JSON] NewClientResponse
+        :> Verb 'POST 201 '[JSON] (NewClientResponse ClientV5)
     )
+    :<|> Named
+           "add-client@v6"
+           ( Summary "Register a new client"
+               :> From 'V6
+               :> CanThrow 'TooManyClients
+               :> CanThrow 'MissingAuth
+               :> CanThrow 'MalformedPrekeys
+               :> CanThrow 'CodeAuthenticationFailed
+               :> CanThrow 'CodeAuthenticationRequired
+               :> ZUser
+               :> ZConn
+               :> "clients"
+               :> ReqBody '[JSON] NewClient
+               :> Verb 'POST 201 '[JSON] (NewClientResponse Client')
+           )
     :<|> Named
            "update-client"
            ( Summary "Update a registered client"
@@ -763,25 +779,48 @@ type UserClientAPI =
           :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Client deleted"] ()
       )
     :<|> Named
-           "list-clients"
+           "list-clients-v6"
+           ( Summary "List the registered clients"
+               :> ZUser
+               :> "clients"
+               :> Get '[JSON] [ClientV5]
+           )
+    :<|> Named
+           "list-clients@v6"
            ( Summary "List the registered clients"
                :> ZUser
                :> "clients"
-               :> Get '[JSON] [Client]
+               :> Get '[JSON] [Client']
+           )
+    :<|> Named
+           "get-client-v6"
+           ( Summary "Get a registered client by ID"
+               :> Until 'V6
+               :> ZUser
+               :> "clients"
+               :> CaptureClientId "client"
+               :> MultiVerb
+                    'GET
+                    '[JSON]
+                    '[ EmptyErrorForLegacyReasons 404 "Client not found",
+                       Respond 200 "Client found" ClientV5
+                     ]
+                    (Maybe ClientV5)
            )
     :<|> Named
-           "get-client"
+           "get-client@v6"
            ( Summary "Get a registered client by ID"
+               :> From 'V6
                :> ZUser
                :> "clients"
                :> CaptureClientId "client"
                :> MultiVerb
                     'GET
                     '[JSON]
                     '[ EmptyErrorForLegacyReasons 404 "Client not found",
-                       Respond 200 "Client found" Client
+                       Respond 200 "Client found" Client'
                      ]
-                    (Maybe Client)
+                    (Maybe Client')
            )
     :<|> Named
            "get-client-capabilities"

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

@@ -30,6 +30,7 @@ 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.User
 import Wire.API.User.Client
 import Wire.API.User.Client.Prekey (PrekeyId)
@@ -39,9 +40,9 @@ type DeleteResponses =
      Respond 200 "User found" RemoveBotResponse
    ]
 
-type GetClientResponses =
+type GetClientResponses client =
   '[ ErrorResponse 'ClientNotFound,
-     Respond 200 "Client found" Client
+     Respond 200 "Client found" client
    ]
 
 type BotAPI =
@@ -117,14 +118,26 @@ type BotAPI =
                :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "")
            )
     :<|> Named
-           "bot-get-client"
+           "bot-get-client-v6"
            ( Summary "Get client for bot"
+               :> Until 'V6
                :> CanThrow 'AccessDenied
                :> CanThrow 'ClientNotFound
                :> ZBot
                :> "bot"
                :> "client"
-               :> MultiVerb 'GET '[JSON] GetClientResponses (Maybe Client)
+               :> MultiVerb 'GET '[JSON] (GetClientResponses ClientV5) (Maybe ClientV5)
+           )
+    :<|> Named
+           "bot-get-client@v6"
+           ( Summary "Get client for bot"
+               :> From 'V6
+               :> CanThrow 'AccessDenied
+               :> CanThrow 'ClientNotFound
+               :> ZBot
+               :> "bot"
+               :> "client"
+               :> MultiVerb 'GET '[JSON] (GetClientResponses Client') (Maybe Client')
            )
     :<|> Named
            "bot-claim-users-prekeys"

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

@@ -45,7 +45,8 @@ module Wire.API.User.Client
     filterClientsFull,
 
     -- * Client
-    Client (..),
+    Client' (..),
+    ClientV5 (..),
     PubClient (..),
     ClientType (..),
     ClientClass (..),
@@ -74,6 +75,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Aeson qualified as A
 import Data.Aeson.Key qualified as Key
 import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Aeson.Types qualified as A
 import Data.Bifunctor (second)
 import Data.Code qualified as Code
 import Data.Coerce
@@ -84,6 +86,7 @@ import Data.Map.Strict qualified as Map
 import Data.Misc (Latitude (..), Longitude (..), PlainTextPassword6)
 import Data.OpenApi hiding (Schema, ToSchema, nullable, schema)
 import Data.OpenApi qualified as Swagger hiding (nullable)
+import Data.Proxy
 import Data.Qualified
 import Data.Schema
 import Data.Set qualified as Set
@@ -161,7 +164,6 @@ instance Cql.Cql ClientCapability where
     n -> Left $ "Unexpected ClientCapability value: " ++ show n
   fromCql _ = Left "ClientCapability value: int expected"
 
--- FUTUREWORK: add golden tests for this?
 newtype ClientCapabilityList = ClientCapabilityList {fromClientCapabilityList :: Set ClientCapability}
   deriving stock (Eq, Ord, Show, Generic)
   deriving newtype (Semigroup, Monoid)
@@ -353,16 +355,19 @@ instance ToSchema ClientInfo where
 --------------------------------------------------------------------------------
 -- UserClients
 
-newtype UserClientsFull = UserClientsFull
-  { userClientsFull :: Map UserId (Set Client)
+newtype UserClientsFull client = UserClientsFull
+  { userClientsFull :: Map UserId (Set client)
   }
   deriving stock (Eq, Show, Generic)
   deriving newtype (Semigroup, Monoid)
 
+instance Swagger.ToSchema (UserClientsFull ClientV5) where
+  declareNamedSchema _ = declareNamedSchema (Proxy @(UserClientsFull Client'))
+
 -- | Json rendering of `UserClientsFull` is dynamic in the object fields, so it's unclear how
 -- machine-generated swagger would look like.  We just leave the manual aeson instances in
 -- place and write something in English into the docs here.
-instance Swagger.ToSchema UserClientsFull where
+instance Swagger.ToSchema (UserClientsFull Client') where
   declareNamedSchema _ = do
     pure $
       NamedSchema (Just "UserClientsFull") $
@@ -371,24 +376,24 @@ instance Swagger.ToSchema UserClientsFull where
           & description ?~ "Dictionary object of `Client` objects indexed by `UserId`."
           & example ?~ "{\"1355c55a-0ac8-11ee-97ee-db1a6351f093\": <Client object>, ...}"
 
-instance ToJSON UserClientsFull where
+instance (Ord client, ToJSON client) => ToJSON (UserClientsFull client) where
   toJSON =
     toJSON . Map.foldrWithKey' fn Map.empty . userClientsFull
     where
       fn u c m =
         let k = Text.E.decodeLatin1 (toASCIIBytes (toUUID u))
          in Map.insert k c m
 
-instance FromJSON UserClientsFull where
+instance (Ord client, FromJSON client) => FromJSON (UserClientsFull client) where
   parseJSON =
     A.withObject "UserClientsFull" (fmap UserClientsFull . foldrM fn Map.empty . KeyMap.toList)
     where
       fn (k, v) m = Map.insert <$> parseJSON (A.String $ Key.toText k) <*> parseJSON v <*> pure m
 
-instance Arbitrary UserClientsFull where
+instance (Ord client, Arbitrary client) => Arbitrary (UserClientsFull client) where
   arbitrary = UserClientsFull <$> mapOf' arbitrary (setOf' arbitrary)
 
-userClientsFullToUserClients :: UserClientsFull -> UserClients
+userClientsFullToUserClients :: UserClientsFull Client' -> UserClients
 userClientsFullToUserClients (UserClientsFull mp) = UserClients $ Set.map clientId <$> mp
 
 newtype UserClients = UserClients
@@ -422,7 +427,7 @@ instance Arbitrary UserClients where
 filterClients :: (Set ClientId -> Bool) -> UserClients -> UserClients
 filterClients p (UserClients c) = UserClients $ Map.filter p c
 
-filterClientsFull :: (Set Client -> Bool) -> UserClientsFull -> UserClientsFull
+filterClientsFull :: (Set Client' -> Bool) -> UserClientsFull Client' -> UserClientsFull Client'
 filterClientsFull p (UserClientsFull c) = UserClientsFull $ Map.filter p c
 
 newtype QualifiedUserClients = QualifiedUserClients
@@ -462,7 +467,7 @@ instance ToSchema QualifiedUserClients where
 --------------------------------------------------------------------------------
 -- Client
 
-data Client = Client
+data Client' = Client
   { clientId :: ClientId,
     clientType :: ClientType,
     clientTime :: UTCTimeMillis,
@@ -475,8 +480,70 @@ data Client = Client
     clientLastActive :: Maybe UTCTime
   }
   deriving stock (Eq, Show, Generic, Ord)
-  deriving (Arbitrary) via (GenericUniform Client)
-  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema Client
+  deriving (Arbitrary) via (GenericUniform Client')
+  deriving (ToJSON, Swagger.ToSchema) via Schema Client'
+
+instance ToSchema 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)
+        <*> (Just . fromClientCapabilityList . clientCapabilities) .= maybe_ (ClientCapabilityList . fromMaybe Set.empty <$> capabilitiesFieldSchema)
+        <*> clientMLSPublicKeys .= mlsPublicKeysFieldSchema
+        <*> clientLastActive .= maybe_ (optField "last_active" utcTimeSchema)
+
+-- | For the time we grant users to upgrade accross #3873, this lenient parser parses both
+-- Client and ClientV5 as Client.  Once everybody has upgraded, we can go back to deriving
+-- this and failing on ClientV5 input.  (See 'addClientInternalH' for details.)
+instance FromJSON Client' where
+  parseJSON = A.withObject "Client" $ \obj -> do
+    Client
+      <$> obj A..: "id"
+      <*> obj A..: "type"
+      <*> obj A..: "time"
+      <*> obj A..:? "class"
+      <*> obj A..:? "label"
+      <*> obj A..:? "cookie"
+      <*> obj A..:? "model"
+      <*> (maybe (pure $ ClientCapabilityList Set.empty) parseCaps =<< obj A..:? "capabilities")
+      <*> _ -- (fromMaybe mempty <$> obj A..:? "mls_public_keys")
+      <*> obj A..:? "last_active"
+    where
+      -- TODO: it should be possible to base implementations for all 3 `_` on existing
+      -- `ToSchema` instances of Client', ClientV5.  but how?
+
+      parseCaps :: A.Value -> A.Parser ClientCapabilityList
+      parseCaps val = prs val <|> prsLegacy val
+        where
+          prs = _
+          prsLegacy = _
+
+newtype ClientV5 = ClientV5 {fromClientV5 :: Client'}
+  deriving newtype (Eq, Show, Generic, Ord, Arbitrary)
+  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema ClientV5
+
+instance ToSchema ClientV5 where
+  schema =
+    ClientV5
+      <$> ( object "Client" $
+              Client
+                <$> (clientId . fromClientV5) .= field "id" schema
+                <*> (clientType . fromClientV5) .= field "type" schema
+                <*> (clientTime . fromClientV5) .= field "time" schema
+                <*> (clientClass . fromClientV5) .= maybe_ (optField "class" schema)
+                <*> (clientLabel . fromClientV5) .= maybe_ (optField "label" schema)
+                <*> (clientCookie . fromClientV5) .= maybe_ (optField "cookie" schema)
+                <*> (clientModel . fromClientV5) .= maybe_ (optField "model" schema)
+                <*> (clientCapabilities . fromClientV5) .= (fromMaybe mempty <$> optField "capabilities" schema)
+                <*> (clientMLSPublicKeys . fromClientV5) .= mlsPublicKeysFieldSchema
+                <*> (clientLastActive . fromClientV5) .= maybe_ (optField "last_active" utcTimeSchema)
+          )
 
 type MLSPublicKeys = Map SignatureSchemeTag ByteString
 
@@ -498,21 +565,6 @@ mlsPublicKeysSchema =
     mapSchema :: ValueSchema SwaggerDoc MLSPublicKeys
     mapSchema = map_ base64Schema
 
-instance ToSchema 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)
-
 mlsPublicKeysFieldSchema :: ObjectSchema SwaggerDoc MLSPublicKeys
 mlsPublicKeysFieldSchema = fromMaybe mempty <$> optField "mls_public_keys" mlsPublicKeysSchema