MLS commit processing (#2247)

* Add MLS message API stub

* Migration to add conversation epoch

* Load and store epoch number

* Execute add proposals

* Update client membership when executing a proposal

When an Add proposal is executed, we check if the list of clients in the
conversation consists of exactly the MLS-enabled clients of the given
user, and fail the request otherwise.

Galley needs to make a request to Brig to fetch an up-to-date list of
MLS-enabled clients. This is not yet implemented.

Also, all federation behaviour is stubbed out for now.

* Stub test for adding a user to an MLS conversation

* Simplify conv → group ID mapping

Use SHA256, as we are already using it for 1-1 conversations, and there
is no need for the length of the group ID to be random.

* Pass group id to crypto-cli in base64

* fixup! Update client membership when executing a proposal

* Add internal endpoint for fetching mls clients

* Test adding unconnected users

* Check that join events are returned

* Extract client setup in test

* Extract group setup in tests

* Create more than one client in MLS messaging setup

* Test partially adding a user to a conversation

* Save MLS clients after adding members

This accomplishes two things:

 - it makes sure that the member records exist before setting the
   corresponding `mls_clients` field
 - it prevents clients from being set for members that could not be
   added to a conversation (for authorisation reasons, say).

Also add a test for the case where a new client of an already-present
user is added to a conversation.

* Clean up Swagger of MLS endpoints

* WIP: check message epoch against conversation

* Make it possible to setup a proteus conv in tests

* Test conversation protocol check

* Change endpoint name to `POST /mls/messages`

* Fix internal client creation query

We need the new `--group-out` option to be able to update the group
state after a commit.

changelog.d/2-features/mls

@@ -0,0 +1,3 @@
+MLS implementation progress:
+
+ - commit messages containing add proposals are now processed

docs/reference/cassandra-schema.cql

@@ -42,6 +42,7 @@ CREATE TABLE galley_test.conversation (
     access_roles_v2 set<int>,
     creator uuid,
     deleted boolean,
+    epoch bigint,
     group_id blob,
     message_timer bigint,
     name text,

libs/api-client/src/Network/Wire/Client/API/Push.hs

@@ -77,7 +77,7 @@ import Network.Wire.Client.Monad
 import Network.Wire.Client.Session
 import qualified System.Logger as Log
 import Wire.API.Connection (UserConnection (..))
-import Wire.API.Conversation.Member (MemberUpdate (..))
+import Wire.API.Conversation
 import Wire.API.Event.Conversation hiding (Event, EventType)
 import Wire.API.User (Name (..), User (..), UserIdList (..), userEmail)
 

libs/wire-api/package.yaml

@@ -84,6 +84,7 @@ library:
   - string-conversions
   - swagger >=0.1
   - swagger2
+  - tagged
   - text >=0.11
   - time >=1.4
   - unordered-containers >=0.2

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
@@ -19,7 +21,10 @@ module Wire.API.Conversation.Protocol
   ( ProtocolTag (..),
     protocolTag,
     protocolTagSchema,
+    Epoch (..),
     Protocol (..),
+    _ProtocolMLS,
+    _ProtocolProteus,
     protocolSchema,
     ConversationMLSData (..),
   )
@@ -32,14 +37,17 @@ import Data.Schema
 import Imports
 import Wire.API.Arbitrary
 import Wire.API.MLS.Group
+import Wire.API.MLS.Message
 
 data ProtocolTag = ProtocolProteusTag | ProtocolMLSTag
   deriving stock (Eq, Show, Enum, Bounded, Generic)
   deriving (Arbitrary) via GenericUniform ProtocolTag
 
 data ConversationMLSData = ConversationMLSData
   { -- | The MLS group ID associated to the conversation.
-    cnvmlsGroupId :: GroupId
+    cnvmlsGroupId :: GroupId,
+    -- | The current epoch number of the corresponding MLS group.
+    cnvmlsEpoch :: Epoch
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via GenericUniform ConversationMLSData
@@ -94,3 +102,8 @@ mlsDataSchema =
       "group_id"
       (description ?~ "An MLS group identifier (at most 256 bytes long)")
       schema
+    <*> cnvmlsEpoch
+    .= fieldWithDocModifier
+      "epoch"
+      (description ?~ "The epoch number of the corresponding MLS group")
+      schema

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

@@ -255,6 +255,9 @@ errorToWai = toWai (dynError @(MapError e))
 class APIError e where
   toWai :: e -> Wai.Error
 
+instance APIError Wai.Error where
+  toWai = id
+
 instance APIError DynError where
   toWai (DynError c l m) = Wai.mkError (toEnum (fromIntegral c)) (LT.fromStrict l) (LT.fromStrict m)
 

libs/wire-api/src/Wire/API/Error/Brig.hs

@@ -53,7 +53,7 @@ data BrigError
   | TooManyTeamMembers
   | MLSIdentityMismatch
   | MLSProtocolError
-  | DuplicateMLSPublicKey
+  | MLSDuplicatePublicKey
   | InvalidPhone
   | UserKeyExists
   | NameManagedByScim
@@ -114,7 +114,7 @@ type instance MapError 'InvalidHandle = 'StaticError 400 "invalid-handle" "The g
 
 type instance MapError 'HandleNotFound = 'StaticError 404 "not-found" "Handle not found"
 
-type instance MapError 'DuplicateMLSPublicKey = 'StaticError 400 "mls-duplicate-public-key" "MLS public key for the given signature scheme already exists"
+type instance MapError 'MLSDuplicatePublicKey = 'StaticError 400 "mls-duplicate-public-key" "MLS public key for the given signature scheme already exists"
 
 type instance MapError 'BlacklistedPhone = 'StaticError 403 "blacklisted-phone" "The given phone number has been blacklisted due to suspected abuse or a complaint"
 

libs/wire-api/src/Wire/API/Error/Galley.hs

@@ -18,18 +18,26 @@
 module Wire.API.Error.Galley
   ( GalleyError (..),
     OperationDenied,
+    MLSProtocolError,
+    mlsProtocolError,
     AuthenticationError (..),
     TeamFeatureError (..),
+    MLSProposalFailure (..),
   )
 where
 
+import Control.Lens ((%~))
 import Data.Singletons.Prelude (Show_)
+import qualified Data.Swagger as S
+import Data.Tagged
 import GHC.TypeLits
 import Imports
+import qualified Network.Wai.Utilities.Error as Wai
 import Polysemy
 import Polysemy.Error
 import Wire.API.Conversation.Role
 import Wire.API.Error
+import qualified Wire.API.Error.Brig as BrigError
 import Wire.API.Routes.API
 import Wire.API.Team.Permission
 
@@ -52,8 +60,18 @@ data GalleyError
   | InvalidTarget
   | ConvNotFound
   | ConvAccessDenied
-  | MLSNonEmptyMemberList
-  | NoBindingTeamMembers
+  | -- MLS Errors
+    MLSNonEmptyMemberList
+  | MLSDuplicatePublicKey
+  | MLSKeyPackageRefNotFound
+  | MLSUnsupportedMessage
+  | MLSProposalNotFound
+  | MLSUnsupportedProposal
+  | MLSProtocolErrorTag
+  | MLSClientMismatch
+  | MLSStaleMessage
+  | --
+    NoBindingTeamMembers
   | NoBindingTeam
   | NotAOneMemberTeam
   | TooManyMembers
@@ -63,7 +81,6 @@ data GalleyError
   | InvalidPermissions
   | InvalidTeamStatusUpdate
   | AccessDenied
-  | UnknownWelcomeRecipient
   | CustomBackendNotFound
   | DeleteQueueFull
   | TeamSearchVisibilityNotEnabled
@@ -72,10 +89,24 @@ data GalleyError
 instance KnownError (MapError e) => IsSwaggerError (e :: GalleyError) where
   addToSwagger = addStaticErrorToSwagger @(MapError e)
 
--- | Convenience synonym for an operation denied error with an unspecified permission
+instance KnownError (MapError e) => APIError (Tagged (e :: GalleyError) ()) where
+  toWai _ = toWai $ dynError @(MapError e)
+
+-- | Convenience synonym for an operation denied error with an unspecified permission.
 type OperationDenied = 'MissingPermission 'Nothing
 
-type instance ErrorEffect (e :: GalleyError) = ErrorS e
+-- | An MLS protocol error with associated text.
+type MLSProtocolError = Tagged 'MLSProtocolErrorTag Text
+
+-- | Create an MLS protocol error value.
+mlsProtocolError :: Text -> MLSProtocolError
+mlsProtocolError = Tagged
+
+type family GalleyErrorEffect (e :: GalleyError) :: Effect where
+  GalleyErrorEffect 'MLSProtocolErrorTag = Error MLSProtocolError
+  GalleyErrorEffect e = ErrorS e
+
+type instance ErrorEffect (e :: GalleyError) = GalleyErrorEffect e
 
 type instance MapError 'InvalidAction = 'StaticError 400 "invalid-actions" "The specified actions are invalid"
 
@@ -113,6 +144,22 @@ type instance MapError 'ConvAccessDenied = 'StaticError 403 "access-denied" "Con
 
 type instance MapError 'MLSNonEmptyMemberList = 'StaticError 400 "non-empty-member-list" "Attempting to add group members outside MLS"
 
+type instance MapError 'MLSDuplicatePublicKey = 'StaticError 400 "mls-duplicate-public-key" "MLS public key for the given signature scheme already exists"
+
+type instance MapError 'MLSKeyPackageRefNotFound = 'StaticError 404 "mls-key-package-ref-not-found" "A referenced key package could not be mapped to a known client"
+
+type instance MapError 'MLSUnsupportedMessage = 'StaticError 422 "mls-unsupported-message" "Attempted to send a message with an unsupported combination of content type and wire format"
+
+type instance MapError 'MLSProposalNotFound = 'StaticError 404 "mls-proposal-not-found" "A proposal referenced in a commit message could not be found"
+
+type instance MapError 'MLSUnsupportedProposal = 'StaticError 422 "mls-unsupported-proposal" "Unsupported proposal type"
+
+type instance MapError 'MLSProtocolErrorTag = MapError 'BrigError.MLSProtocolError
+
+type instance MapError 'MLSClientMismatch = 'StaticError 409 "mls-client-mismatch" "A proposal of type Add or Remove does not apply to the full list of clients for a user"
+
+type instance MapError 'MLSStaleMessage = 'StaticError 409 "mls-stale-message" "The conversation epoch in a message is too old"
+
 type instance MapError 'NoBindingTeamMembers = 'StaticError 403 "non-binding-team-members" "Both users must be members of the same binding team"
 
 type instance MapError 'NoBindingTeam = 'StaticError 403 "no-binding-team" "Operation allowed only on binding teams"
@@ -133,8 +180,6 @@ type instance MapError 'InvalidTeamStatusUpdate = 'StaticError 403 "invalid-team
 
 type instance MapError 'AccessDenied = 'StaticError 403 "access-denied" "You do not have permission to access this resource"
 
-type instance MapError 'UnknownWelcomeRecipient = 'StaticError 400 "mls-unknown-welcome-recipient" "One of the key packages of a welcome message could not be mapped to a known client"
-
 type instance MapError 'CustomBackendNotFound = 'StaticError 404 "custom-backend-not-found" "Custom backend not found"
 
 type instance MapError 'DeleteQueueFull = 'StaticError 503 "queue-full" "The delete queue is full; no further delete requests can be processed at the moment"
@@ -225,3 +270,29 @@ instance Member (Error DynError) r => ServerEffect (Error TeamFeatureError) r wh
     LegalHoldWhitelistedOnly -> dynError @(MapError 'LegalHoldWhitelistedOnly)
     DisableSsoNotImplemented -> dynError @(MapError 'DisableSsoNotImplemented)
     FeatureLocked -> dynError @(MapError 'FeatureLocked)
+
+--------------------------------------------------------------------------------
+-- Proposal failure
+
+data MLSProposalFailure = MLSProposalFailure
+  { pfInner :: Wai.Error
+  }
+
+type instance ErrorEffect MLSProposalFailure = Error MLSProposalFailure
+
+-- Proposal failures are only reported generically in Swagger
+instance IsSwaggerError MLSProposalFailure where
+  addToSwagger = S.allOperations . S.description %~ Just . (<> desc) . fold
+    where
+      desc =
+        "\n\n**Note**: this endpoint can execute proposals, and therefore \
+        \return all possible errors associated with adding or removing members to \
+        \a conversation, in addition to the ones listed below. See the documentation of [POST \
+        \/conversations/{cnv}/members/v2](#/default/post_conversations__cnv__members_v2) \
+        \and [POST \
+        \/conversations/{cnv_domain}/{cnv}/members/{usr_domain}/{usr}](#/default/delete_conversations__cnv_domain___cnv__members__usr_domain___usr_) \
+        \for more details on the possible error responses of each type of \
+        \proposal."
+
+instance Member (Error Wai.Error) r => ServerEffect (Error MLSProposalFailure) r where
+  interpretServerEffect = mapError pfInner

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

@@ -58,7 +58,6 @@ module Wire.API.Event.Conversation
     ConversationAccessData (..),
     ConversationMessageTimerUpdate (..),
     ConversationCode (..),
-    Conversation (..),
     TypingData (..),
     QualifiedUserIdList (..),
   )

libs/wire-api/src/Wire/API/MLS/Group.hs

@@ -17,8 +17,13 @@
 
 module Wire.API.MLS.Group where
 
+import qualified Crypto.Hash as Crypto
 import qualified Data.Aeson as A
+import Data.ByteArray (convert)
+import Data.ByteString.Conversion
+import Data.Id
 import Data.Json.Util
+import Data.Qualified
 import Data.Schema
 import qualified Data.Swagger as S
 import Imports
@@ -41,3 +46,10 @@ instance ToSchema GroupId where
     GroupId
       <$> unGroupId
       .= named "GroupId" (Base64ByteString .= fmap fromBase64ByteString (unnamed schema))
+
+-- | Return the group ID associated to a conversation ID. Note that is not
+-- assumed to be stable over time or even consistent among different backends.
+convToGroupId :: Local ConvId -> GroupId
+convToGroupId (qUntagged -> qcnv) =
+  GroupId . convert . Crypto.hash @ByteString @Crypto.SHA256 $
+    toByteString' (qUnqualified qcnv) <> toByteString' (qDomain qcnv)

libs/wire-api/src/Wire/API/MLS/KeyPackage.hs

@@ -119,6 +119,7 @@ instance ToSchema KeyPackageRef where
 instance ParseMLS KeyPackageRef where
   parseMLS = KeyPackageRef <$> getByteString 16
 
+-- | Compute key package ref given a ciphersuite and the raw key package data.
 kpRef :: CipherSuiteTag -> KeyPackageData -> KeyPackageRef
 kpRef cs =
   KeyPackageRef
@@ -129,6 +130,8 @@ kpRef cs =
     . csHash cs "MLS 1.0 ref"
     . kpData
 
+-- | Compute ref of a key package. Return 'Nothing' if the key package cipher
+-- suite is invalid or unsupported.
 kpRef' :: RawMLS KeyPackage -> Maybe KeyPackageRef
 kpRef' kp =
   kpRef

libs/wire-api/src/Wire/API/MLS/Message.hs

@@ -19,7 +19,8 @@
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
 module Wire.API.MLS.Message
-  ( Message (..),
+  ( Epoch (..),
+    Message (..),
     WireFormatTag (..),
     SWireFormatTag (..),
     SomeMessage (..),
@@ -33,14 +34,24 @@ module Wire.API.MLS.Message
 where
 
 import Data.Binary
+import Data.Schema
 import Data.Singletons.TH
+import qualified Data.Swagger as S
 import Imports
+import Wire.API.Arbitrary
 import Wire.API.MLS.Commit
 import Wire.API.MLS.Group
 import Wire.API.MLS.KeyPackage
 import Wire.API.MLS.Proposal
 import Wire.API.MLS.Serialisation
 
+newtype Epoch = Epoch {epochNumber :: Word64}
+  deriving stock (Eq, Show)
+  deriving newtype (Arbitrary, Enum, ToSchema)
+
+instance ParseMLS Epoch where
+  parseMLS = Epoch <$> parseMLS
+
 data WireFormatTag = MLSPlainText | MLSCipherText
   deriving (Bounded, Enum, Eq, Show)
 
@@ -51,7 +62,7 @@ instance ParseMLS WireFormatTag where
 
 data Message (tag :: WireFormatTag) = Message
   { msgGroupId :: GroupId,
-    msgEpoch :: Word64,
+    msgEpoch :: Epoch,
     msgAuthData :: ByteString,
     msgSender :: Sender tag,
     msgPayload :: MessagePayload tag
@@ -79,6 +90,9 @@ instance ParseMLS (Message 'MLSCipherText) where
 data SomeMessage where
   SomeMessage :: Sing tag -> Message tag -> SomeMessage
 
+instance S.ToSchema SomeMessage where
+  declareNamedSchema _ = pure (mlsSwagger "MLSMessage")
+
 instance ParseMLS SomeMessage where
   parseMLS =
     parseMLS >>= \case

libs/wire-api/src/Wire/API/MLS/Proposal.hs

@@ -43,7 +43,7 @@ instance ParseMLS ProposalTag where
   parseMLS = parseMLSEnum @Word16 "proposal type"
 
 data Proposal
-  = AddProposal KeyPackage
+  = AddProposal (RawMLS KeyPackage)
   | UpdateProposal KeyPackage
   | RemoveProposal KeyPackageRef
   | PreSharedKeyProposal PreSharedKeyID

libs/wire-api/src/Wire/API/MLS/Serialisation.hs

@@ -32,12 +32,14 @@ module Wire.API.MLS.Serialisation
     decodeMLSWith',
     RawMLS (..),
     rawMLSSchema,
+    mlsSwagger,
     parseRawMLS,
   )
 where
 
 import Control.Applicative
 import Control.Comonad
+import Control.Lens ((?~))
 import Data.Aeson (FromJSON (..))
 import qualified Data.Aeson as Aeson
 import Data.Bifunctor
@@ -163,6 +165,14 @@ rawMLSSchema name p =
   (toBase64Text . rmRaw)
     .= parsedText name (rawMLSFromText p)
 
+mlsSwagger :: Text -> S.NamedSchema
+mlsSwagger name =
+  S.NamedSchema (Just name) $
+    mempty
+      & S.description
+        ?~ "This object can only be parsed in TLS format. \
+           \Please refer to the MLS specification for details."
+
 rawMLSFromText :: (ByteString -> Either Text a) -> Text -> Either String (RawMLS a)
 rawMLSFromText p txt = do
   mlsData <- fromBase64Text txt