WIP: ClientCapabilitiesList special serialization for V6

integration/test/Test/Client.hs

@@ -103,3 +103,21 @@ testUpdateClientWithConsumableNotificationsCapability = do
   getSelfClients alice `bindResponse` \resp -> do
     resp.status `shouldMatchInt` 200
     resp.json %. "0.capabilities" `shouldMatch` [consumeCapability]
+
+testGetClientCapabilitiesV6 :: App ()
+testGetClientCapabilitiesV6 = do
+  let allCapabilities = ["legalhold-implicit-consent", "consumable-notifications"]
+  alice <- randomUser OwnDomain def
+  addClient alice def {acapabilities = Just allCapabilities} `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 201
+    resp.json %. "capabilities" `shouldMatchSet` allCapabilities
+
+  getSelfClients alice `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    resp.json %. "0.capabilities" `shouldMatchSet` allCapabilities
+
+  -- In API v6 and below, the "capabilities" field is an enum, so having a new
+  -- value for this enum is a breaking change.
+  withAPIVersion 6 $ getSelfClients alice `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    resp.json %. "0.capabilities.capabilities" `shouldMatchSet` ["legalhold-implicit-consent"]

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

@@ -177,21 +177,27 @@ newtype ClientCapabilityList = ClientCapabilityList {fromClientCapabilityList ::
   deriving (ToJSON, FromJSON, Swagger.ToSchema) via (Schema ClientCapabilityList)
 
 instance ToSchema ClientCapabilityList where
+  schema = capabilitiesSchema Nothing
+
+instance ToSchema (Versioned V6 ClientCapabilityList) where
   schema =
-    object "ClientCapabilityList" $
-      ClientCapabilityList <$> fromClientCapabilityList .= fmap runIdentity capabilitiesFieldSchema
-
-capabilitiesFieldSchema ::
-  (FieldFunctor SwaggerDoc f) =>
-  ObjectSchemaP SwaggerDoc (Set ClientCapability) (f (Set ClientCapability))
-capabilitiesFieldSchema =
-  Set.toList
-    .= fieldWithDocModifierF "capabilities" mods (Set.fromList <$> array schema)
+    object "ClientCapabilityListV6" $
+      Versioned
+        <$> unVersioned .= field "capabilities" (capabilitiesSchema (Just V6))
+
+capabilitiesSchema ::
+  Maybe Version ->
+  ValueSchema NamedSwaggerDoc ClientCapabilityList
+capabilitiesSchema mVersion =
+  named "ClientCapabilityList" $
+    ClientCapabilityList
+      <$> (Set.toList . dropIncompatibleCapabilities . fromClientCapabilityList) .= (Set.fromList <$> array schema)
   where
-    mods =
-      description
-        ?~ "Hints provided by the client for the backend so it can \
-           \behave in a backwards-compatible way."
+    dropIncompatibleCapabilities :: Set ClientCapability -> Set ClientCapability
+    dropIncompatibleCapabilities caps =
+      case mVersion of
+        Just v | v <= V6 -> Set.delete ClientSupportsConsumableNotifications caps
+        _ -> caps
 
 --------------------------------------------------------------------------------
 -- UserClientMap
@@ -504,7 +510,7 @@ mlsPublicKeysSchema =
     mapSchema = map_ base64Schema
 
 clientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc Client
-clientSchema mv =
+clientSchema mVersion =
   object "Client" $
     Client
       <$> clientId .= field "id" schema
@@ -514,15 +520,17 @@ clientSchema mv =
       <*> clientLabel .= maybe_ (optField "label" schema)
       <*> clientCookie .= maybe_ (optField "cookie" schema)
       <*> clientModel .= maybe_ (optField "model" schema)
-      <*> clientCapabilities .= (fromMaybe mempty <$> caps)
+      <*> clientCapabilities .= (fromMaybe mempty <$> optField "capabilities" caps)
       <*> clientMLSPublicKeys .= mlsPublicKeysFieldSchema
       <*> clientLastActive .= maybe_ (optField "last_active" utcTimeSchema)
   where
-    caps :: ObjectSchemaP SwaggerDoc ClientCapabilityList (Maybe ClientCapabilityList)
-    caps = case mv of
+    caps :: ValueSchema NamedSwaggerDoc ClientCapabilityList
+    caps = case mVersion of
       -- broken capability serialisation for backwards compatibility
-      Just v | v <= V6 -> optField "capabilities" schema
-      _ -> fmap ClientCapabilityList <$> fromClientCapabilityList .= capabilitiesFieldSchema
+      Just v
+        | v <= V6 ->
+            dimap Versioned unVersioned $ schema @(Versioned V6 ClientCapabilityList)
+      _ -> schema @ClientCapabilityList
 
 instance ToSchema Client where
   schema = clientSchema Nothing
@@ -666,7 +674,7 @@ data NewClient = NewClient
     newClientCookie :: Maybe CookieLabel,
     newClientPassword :: Maybe PlainTextPassword6,
     newClientModel :: Maybe Text,
-    newClientCapabilities :: Maybe (Set ClientCapability),
+    newClientCapabilities :: Maybe ClientCapabilityList,
     newClientMLSPublicKeys :: MLSPublicKeys,
     newClientVerificationCode :: Maybe Code.Value
   }
@@ -730,7 +738,16 @@ instance ToSchema NewClient where
                 schema
             )
         <*> newClientModel .= maybe_ (optField "model" schema)
-        <*> newClientCapabilities .= maybe_ capabilitiesFieldSchema
+        <*> newClientCapabilities
+          .= maybe_
+            ( optFieldWithDocModifier
+                "capabilities"
+                ( description
+                    ?~ "Hints provided by the client for the backend so it can \
+                       \behave in a backwards-compatible way."
+                )
+                schema
+            )
         <*> newClientMLSPublicKeys .= mlsPublicKeysFieldSchema
         <*> newClientVerificationCode .= maybe_ (optField "verification_code" schema)
 
@@ -758,7 +775,7 @@ data UpdateClient = UpdateClient
     updateClientLastKey :: Maybe LastPrekey,
     updateClientLabel :: Maybe Text,
     -- | see haddocks for 'ClientCapability'
-    updateClientCapabilities :: Maybe (Set ClientCapability),
+    updateClientCapabilities :: Maybe ClientCapabilityList,
     updateClientMLSPublicKeys :: MLSPublicKeys
   }
   deriving stock (Eq, Show, Generic)
@@ -800,7 +817,13 @@ instance ToSchema UpdateClient where
                 (description ?~ "A new name for this client.")
                 schema
             )
-        <*> updateClientCapabilities .= maybe_ capabilitiesFieldSchema
+        <*> updateClientCapabilities
+          .= maybe_
+            ( optFieldWithDocModifier
+                "capabilities"
+                (description ?~ "Hints provided by the client for the backend so it can behave in a backwards-compatible way.")
+                schema
+            )
         <*> updateClientMLSPublicKeys .= mlsPublicKeysFieldSchema
 
 --------------------------------------------------------------------------------

libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewClient_user.hs

@@ -66,7 +66,7 @@ testObject_NewClient_user_2 =
               "I\1065423\995547oIC\by\1045956\&1\13659&w>S~z\35967\a{2Dj\v|Z\"\f\1060612*[\65357V\1086491kS\145031A\1106044\1056321(2\DLE\48205\SOi\SI(\1032525\168748f?q\SO5\146557d\1068952^nI\1103535_?\1019210H\119099\SUBf\995865\n\1004095x\ACKdZ\1053945^N\fa\SYN\SUBb=\1112183SP\128516aTd\EM\186127\DC3\ACK\ETB!\1011808\142127o{uoN\CANqL\NAK\ESCc=\v@o2\1043826\EOT\142486\US\1079334\&5v\STX\GS_k,\DC3mAV>$\1029013\1061276\RS\1089843\n\8980-\60552ea}G`r? \DEL\1004551\SOH\US\132757\&9\brl\155069}u\120967\1080794\1062392@M6M\155107\98552\167588|E5Ud\1051152tLjQ\1022837\6734\RS\v\DC1jE\ACK'~f\SIR\1010717\NAKd}}\1059960q\1031766\DC1\151174\&9\160469\RS\100592\ETX\186780\DEL\r\FS\US\36812\14285\NAK/\GS\25526\1090814\61061\NUL(:\1054313n#m9x \1078109\183480}\1052622\54486\GS\991929\b`\1087609G#T\DC2-8\NAK\18310\134655\tp/!\STX4C\SUB'DP'.\a\1110090\&8<9\SYN\NAKEq\168018Ep]\ajZ%\1025589\4170O\35069>\CAN\ACKw*f<\1102303\SOjzpjY\US\SUB\19086\DC1\DC1\ACK|\SO\1064500;\135633F!f\19971b%\1048714t9\DC2\f\121106X! \133247C\RS\1029038\162320C!\20923H(/\GSV)e\SYN2\NUL#H$BAJy\ETB\162654X\137014\FS\SUB\DEL~\f\ESC;\n<\GSf~{\b_"
           ),
       newClientModel = Just "om",
-      newClientCapabilities = Just (Set.fromList [ClientSupportsLegalholdImplicitConsent]),
+      newClientCapabilities = Just (ClientCapabilityList (Set.fromList [ClientSupportsLegalholdImplicitConsent])),
       newClientMLSPublicKeys = mempty,
       newClientVerificationCode = Nothing
     }

libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateClient_user.hs

@@ -287,6 +287,6 @@ testObject_UpdateClient_user_20 =
         ],
       updateClientLastKey = Just (lastPrekey "\DC4 }Kg\ve3"),
       updateClientLabel = Just "\ESC\EOT\SOHccn\US{Y5",
-      updateClientCapabilities = Just [ClientSupportsLegalholdImplicitConsent],
+      updateClientCapabilities = Just (ClientCapabilityList [ClientSupportsLegalholdImplicitConsent]),
       updateClientMLSPublicKeys = mempty
     }

libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs

@@ -106,12 +106,21 @@ tests =
           ],
       testGroup "ClientCapability" $
         testObjects
-          [(testObject_ClientCapability_1, "testObject_ClientCapability_1.json")],
-      testGroup "ClientCapabilityList" $
+          [ (testObject_ClientCapability_1, "testObject_ClientCapability_1.json"),
+            (testObject_ClientCapability_2, "testObject_ClientCapability_2.json")
+          ],
+      testGroup "ClientCapabilityListV6" $
         testObjects
           [ (testObject_ClientCapabilityList_1, "testObject_ClientCapabilityList_1.json"),
             (testObject_ClientCapabilityList_2, "testObject_ClientCapabilityList_2.json")
           ],
+      testGroup "ClientCapabilityListV6 - non-round-trip" $
+        [testToJSON testObject_ClientCapabilityList_3 "testObject_ClientCapabilityList_3.json"],
+      testGroup "ClientCapabilityList" $
+        testObjects
+          [ (testObject_ClientCapabilityList_4, "testObject_ClientCapabilityList_4.json"),
+            (testObject_ClientCapabilityList_5, "testObject_ClientCapabilityList_5.json")
+          ],
       testGroup
         "Event.FeatureConfig.Event"
         $ testObjects

libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ClientCapabilityList.hs

@@ -19,10 +19,35 @@ module Test.Wire.API.Golden.Manual.ClientCapabilityList where
 
 import Data.Set qualified as Set
 import Imports
+import Wire.API.Routes.Version
+import Wire.API.Routes.Versioned
 import Wire.API.User.Client (ClientCapability (..), ClientCapabilityList (..))
 
-testObject_ClientCapabilityList_1 :: ClientCapabilityList
-testObject_ClientCapabilityList_1 = ClientCapabilityList mempty
+testObject_ClientCapabilityList_1 :: Versioned V6 ClientCapabilityList
+testObject_ClientCapabilityList_1 = Versioned $ ClientCapabilityList mempty
 
-testObject_ClientCapabilityList_2 :: ClientCapabilityList
-testObject_ClientCapabilityList_2 = ClientCapabilityList (Set.fromList [ClientSupportsLegalholdImplicitConsent])
+testObject_ClientCapabilityList_2 :: Versioned V6 ClientCapabilityList
+testObject_ClientCapabilityList_2 = Versioned $ ClientCapabilityList (Set.fromList [ClientSupportsLegalholdImplicitConsent])
+
+testObject_ClientCapabilityList_3 :: Versioned V6 ClientCapabilityList
+testObject_ClientCapabilityList_3 =
+  Versioned $
+    ClientCapabilityList
+      ( Set.fromList
+          [ ClientSupportsLegalholdImplicitConsent,
+            ClientSupportsConsumableNotifications
+          ]
+      )
+
+testObject_ClientCapabilityList_4 :: ClientCapabilityList
+testObject_ClientCapabilityList_4 =
+  ClientCapabilityList mempty
+
+testObject_ClientCapabilityList_5 :: ClientCapabilityList
+testObject_ClientCapabilityList_5 =
+  ClientCapabilityList
+    ( Set.fromList
+        [ ClientSupportsLegalholdImplicitConsent,
+          ClientSupportsConsumableNotifications
+        ]
+    )

libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs

@@ -17,6 +17,7 @@
 
 module Test.Wire.API.Golden.Runner
   ( testObjects,
+    testToJSON,
     protoTestObjects,
     testFromJSONFailure,
     testFromJSONFailureWithMsg,
@@ -46,8 +47,19 @@ testObjects = fmap (\(obj, path) -> testCase path $ testObject obj path)
 
 testObject :: forall a. (Typeable a, ToJSON a, FromJSON a, Eq a, Show a) => a -> FilePath -> Assertion
 testObject obj path = do
+  assertJSONIsGolden obj path
+  assertEqual
+    (show (typeRep @a) <> ": FromJSON of " <> path <> " should match object")
+    (Success obj)
+    (fromJSON $ toJSON obj)
+
+testToJSON :: forall a. (Typeable a, ToJSON a) => a -> FilePath -> TestTree
+testToJSON obj path = testCase path $ assertJSONIsGolden obj path
+
+assertJSONIsGolden :: forall a. (Typeable a, ToJSON a) => a -> FilePath -> Assertion
+assertJSONIsGolden obj path = do
   let actualValue = toJSON obj :: Value
-      actualJson = encodePretty' config actualValue
+      actualJson = encodePretty' encodeConfig actualValue
       dir = "test/golden"
       fullPath = dir <> "/" <> path
   createDirectoryIfMissing True dir
@@ -60,20 +72,17 @@ testObject obj path = do
         <> ": ToJSON should match golden file: "
         <> path
         <> "\n\nexpected:\n"
-        <> cs (encodePretty' config expectedValue)
+        <> cs (encodePretty' encodeConfig expectedValue)
         <> "\n\nactual:\n"
-        <> cs (encodePretty' config actualValue)
+        <> cs (encodePretty' encodeConfig actualValue)
         <> "\n\ndiff:\n"
-        <> cs (encodePretty' config (AD.diff expectedValue actualValue))
+        <> cs (encodePretty' encodeConfig (AD.diff expectedValue actualValue))
     )
     (expectedValue == actualValue)
-  assertEqual
-    (show (typeRep @a) <> ": FromJSON of " <> path <> " should match object")
-    (Success obj)
-    (fromJSON actualValue)
   assertBool ("JSON golden file " <> path <> " does not exist") exists
-  where
-    config = defConfig {confCompare = compare, confTrailingNewline = True}
+
+encodeConfig :: Config
+encodeConfig = defConfig {confCompare = compare, confTrailingNewline = True}
 
 protoTestObjects ::
   forall m a.

libs/wire-api/test/golden/testObject_ClientCapabilityList_3.json

@@ -0,0 +1,5 @@
+{
+    "capabilities": [
+        "legalhold-implicit-consent"
+    ]
+}

libs/wire-api/test/golden/testObject_ClientCapabilityList_4.json

@@ -0,0 +1 @@
+[]

libs/wire-api/test/golden/testObject_ClientCapabilityList_5.json

@@ -0,0 +1,4 @@
+[
+    "legalhold-implicit-consent",
+    "consumable-notifications"
+]