Merge branch 'origin/develop' into mls

changelog.d/0-release-notes/webapp-upgrade

@@ -1 +1 @@
-Upgrade webapp version to 2023-05-30-production.0-v0.31.16-0-1b2370b
+Upgrade webapp version to 2023-07-13-production.0-v0.31.16-0-a9b67c6

changelog.d/1-api-changes/connection-update

@@ -0,0 +1 @@
+The `connection-update` internal Brig endpoint has a different JSON format for its request body. See the swagger documentation for details.

charts/webapp/values.yaml

@@ -9,7 +9,7 @@ resources:
     cpu: "1"
 image:
   repository: quay.io/wire/webapp
-  tag: "2023-05-30-production.0-v0.31.16-0-1b2370b"
+  tag: "2023-07-13-production.0-v0.31.16-0-a9b67c6"
 service:
   https:
     externalPort: 443

docs/src/understand/associate/custom-backend-for-desktop-client.md

@@ -46,7 +46,7 @@ Create a file named `init.json` and set `customWebAppURL` and optionally `proxyS
 {
   "customWebAppURL": "https://app.custom-wire.com",
   "env": "CUSTOM",
-  "proxyServerURL": "http://127.0.0.1:3128",
+  "proxyServerURL": "http://127.0.0.1:3128"
 }
 ```
 

integration/test/Test/Conversation.hs

@@ -44,7 +44,7 @@ testDynamicBackendsNotFederating = do
         $ bindResponse
           (API.getFederationStatus uidA [domainB, domainC])
         $ \resp -> do
-          resp.status `shouldMatchInt` 400
+          resp.status `shouldMatchInt` 422
           resp.json %. "label" `shouldMatch` "federation-denied"
 
 testDynamicBackendsFullyConnectedWhenAllowDynamic :: HasCallStack => App ()

integration/test/Testlib/JSON.hs

@@ -9,7 +9,7 @@ import qualified Data.Aeson.Encode.Pretty as Aeson
 import qualified Data.Aeson.Key as KM
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.Aeson.Types as Aeson
-import Data.ByteString
+import Data.ByteString hiding ((!?))
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Lazy.Char8 as LC8
 import Data.Foldable
@@ -20,6 +20,7 @@ import qualified Data.Scientific as Sci
 import Data.String
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import Data.Vector ((!?))
 import GHC.Stack
 import Testlib.Env
 import Testlib.Types
@@ -120,31 +121,19 @@ asBool x =
     v -> assertFailureWithJSON x ("Bool" `typeWasExpectedButGot` v)
 
 -- | Get a (nested) field of a JSON object
--- Raise an AssertionFailure if the field at the (nested) key is missing.
+-- Raise an AssertionFailure if the field at the (nested) key is missing. See
+-- 'lookupField' for details.
 (%.) ::
   (HasCallStack, MakesValue a) =>
   a ->
   -- | A plain key, e.g. "id", or a nested key "user.profile.id"
   String ->
   App Value
-(%.) val selector = do
-  v <- make val
-  vp <- prettyJSON v
-  addFailureContext ("Getting (nested) field \"" <> selector <> "\" of object:\n" <> vp) $ do
-    let keys = splitOn "." selector
-    case keys of
-      (k : ks) -> go k ks v
-      [] -> assertFailure "No key provided"
-  where
-    go k [] v = l k v
-    go k (k2 : ks) v = do
-      r <- l k v
-      go k2 ks r
-    l k v = do
-      ob <- asObject v
-      case KM.lookup (KM.fromString k) ob of
-        Nothing -> assertFailureWithJSON ob $ "Field \"" <> k <> "\" is missing from object:"
-        Just x -> pure x
+(%.) x k = lookupField x k >>= assertField x k
+
+assertField :: (HasCallStack, MakesValue a) => a -> String -> Maybe Value -> App Value
+assertField x k Nothing = assertFailureWithJSON x $ "Field \"" <> k <> "\" is missing from object:"
+assertField _ _ (Just x) = pure x
 
 -- | Look up (nested) field of a JSON object
 --
@@ -155,6 +144,8 @@ asBool x =
 -- if the last component of the key field selector is missing from nested
 -- object. If any other component is missing this function raises an
 -- AssertionFailure.
+--
+-- Objects and arrays are supported. Array keys should be integers.
 lookupField ::
   (HasCallStack, MakesValue a) =>
   a ->
@@ -170,16 +161,17 @@ lookupField val selector = do
       (k : ks) -> go k ks v
       [] -> assertFailure "No key provided"
   where
-    go k [] v = do
-      ob <- asObject v
-      pure (KM.lookup (KM.fromString k) ob)
-    go k (k2 : ks) v = do
-      ob <- asObject v
-      r <-
-        case KM.lookup (KM.fromString k) ob of
-          Nothing -> assertFailureWithJSON ob $ "Field \"" <> k <> "\" is missing from object:"
-          Just x -> pure x
-      go k2 ks r
+    get v k = do
+      make v >>= \case
+        -- index object
+        Object ob -> pure (KM.lookup (KM.fromString k) ob)
+        -- index array
+        Array arr -> case reads k of
+          [(i, "")] -> pure (arr !? i)
+          _ -> assertFailureWithJSON arr $ "Invalid array index \"" <> k <> "\""
+        x -> assertFailureWithJSON x ("Object or Array" `typeWasExpectedButGot` x)
+    go k [] v = get v k
+    go k (k2 : ks) v = get v k >>= assertField v k >>= go k2 ks
 
 -- Update nested fields
 -- E.g. ob & "foo.bar.baz" %.= ("quux" :: String)

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 -- This file is part of the Wire Server implementation.
 --
@@ -154,8 +155,9 @@ module Wire.API.User
 where
 
 import Control.Applicative
+import Control.Arrow ((&&&))
 import Control.Error.Safe (rightMay)
-import Control.Lens (over, view, (.~), (?~), (^.))
+import Control.Lens (makePrisms, over, view, (.~), (?~), (^.))
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.Types as A
 import qualified Data.Attoparsec.ByteString as Parser
@@ -215,21 +217,6 @@ import Wire.API.User.Profile
 import Wire.API.User.RichInfo
 import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))
 
-------- Paritial Successes
-data ListUsersById = ListUsersById
-  { listUsersByIdFound :: [UserProfile],
-    listUsersByIdFailed :: Maybe (NonEmpty (Qualified UserId))
-  }
-  deriving (Eq, Show)
-  deriving (ToJSON, FromJSON, S.ToSchema) via Schema ListUsersById
-
-instance ToSchema ListUsersById where
-  schema =
-    object "ListUsersById" $
-      ListUsersById
-        <$> listUsersByIdFound .= field "found" (array schema)
-        <*> listUsersByIdFailed .= maybe_ (optField "failed" $ nonEmptyArray schema)
-
 --------------------------------------------------------------------------------
 -- UserIdList
 
@@ -495,17 +482,61 @@ data UpdateConnectionsInternal
     CreateConnectionForTest UserId (Qualified UserId)
   deriving (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform UpdateConnectionsInternal)
-  deriving (S.ToSchema) via Schema UpdateConnectionsInternal
 
-instance FromJSON UpdateConnectionsInternal
+$(makePrisms ''UpdateConnectionsInternal)
+
+data UpdateConnectionsInternalTag
+  = BlockForMissingLHConsentTag
+  | RemoveLHBlocksInvolvingTag
+  | CreateConnectionForTestTag
+  deriving (Eq, Show, Enum, Bounded)
+
+updateConnectionsInternalTag :: UpdateConnectionsInternal -> UpdateConnectionsInternalTag
+updateConnectionsInternalTag (BlockForMissingLHConsent _ _) = BlockForMissingLHConsentTag
+updateConnectionsInternalTag (RemoveLHBlocksInvolving _) = RemoveLHBlocksInvolvingTag
+updateConnectionsInternalTag (CreateConnectionForTest _ _) = CreateConnectionForTestTag
 
--- | `{"tag":"BlockForMissingLHConsent","contents":["3ae7f23a-bd47-11eb-932d-5fccbbcde454",["3ae7f23a-bd47-11eb-932d-5fccbbcde454"]]}`
-instance ToJSON UpdateConnectionsInternal
+instance ToSchema UpdateConnectionsInternalTag where
+  schema =
+    enum @Text "UpdateConnectionsInternalTag" $
+      element "BlockForMissingLHConsent" BlockForMissingLHConsentTag
+        <> element "RemoveLHBlocksInvolving" RemoveLHBlocksInvolvingTag
+        <> element "CreateConnectionForTest" CreateConnectionForTestTag
 
 instance ToSchema UpdateConnectionsInternal where
   schema =
-    -- `{"tag":"BlockForMissingLHConsent","contents":["3ae7f23a-bd47-11eb-932d-5fccbbcde454",["3ae7f23a-bd47-11eb-932d-5fccbbcde454"]]}`
-    undefined
+    object "UpdateConnectionsInternal" $
+      snd
+        <$> (updateConnectionsInternalTag &&& id)
+          .= bind
+            (fst .= field "tag" tagSchema)
+            (snd .= dispatch untaggedSchema)
+    where
+      tagSchema :: ValueSchema NamedSwaggerDoc UpdateConnectionsInternalTag
+      tagSchema = schema
+
+      untaggedSchema ::
+        UpdateConnectionsInternalTag ->
+        ObjectSchema SwaggerDoc UpdateConnectionsInternal
+      untaggedSchema BlockForMissingLHConsentTag =
+        tag _BlockForMissingLHConsent $
+          (,)
+            <$> fst .= field "user" schema
+            <*> snd .= field "others" (array schema)
+      untaggedSchema RemoveLHBlocksInvolvingTag =
+        tag _RemoveLHBlocksInvolving $
+          field "user" schema
+      untaggedSchema CreateConnectionForTestTag =
+        tag _CreateConnectionForTest $
+          (,)
+            <$> fst .= field "user" schema
+            <*> snd .= field "other" schema
+
+deriving via Schema UpdateConnectionsInternal instance (S.ToSchema UpdateConnectionsInternal)
+
+deriving via Schema UpdateConnectionsInternal instance (FromJSON UpdateConnectionsInternal)
+
+deriving via Schema UpdateConnectionsInternal instance (ToJSON UpdateConnectionsInternal)
 
 --------------------------------------------------------------------------------
 -- QualifiedUserIdList
@@ -2010,3 +2041,18 @@ instance ToSchema SupportedProtocolUpdate where
       SupportedProtocolUpdate
         <$> unSupportedProtocolUpdate
           .= field "supported_protocols" (set schema)
+
+------- Partial Successes
+data ListUsersById = ListUsersById
+  { listUsersByIdFound :: [UserProfile],
+    listUsersByIdFailed :: Maybe (NonEmpty (Qualified UserId))
+  }
+  deriving (Eq, Show)
+  deriving (ToJSON, FromJSON, S.ToSchema) via Schema ListUsersById
+
+instance ToSchema ListUsersById where
+  schema =
+    object "ListUsersById" $
+      ListUsersById
+        <$> listUsersByIdFound .= field "found" (array schema)
+        <*> listUsersByIdFailed .= maybe_ (optField "failed" $ nonEmptyArray schema)