diff --git a/Makefile b/Makefile index dd49069100..8e7bb9c56c 100644 --- a/Makefile +++ b/Makefile @@ -225,11 +225,7 @@ git-add-cassandra-schema: db-migrate git-add-cassandra-schema-impl .PHONY: git-add-cassandra-schema-impl git-add-cassandra-schema-impl: - $(eval CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1')) - ( echo '-- automatically generated with `make git-add-cassandra-schema`'; \ - docker exec -i $(CASSANDRA_CONTAINER) /usr/bin/cqlsh -e "DESCRIBE schema;" ) \ - | sed "s/CREATE TABLE galley_test.member_client/-- NOTE: this table is unused. It was replaced by mls_group_member_client\nCREATE TABLE galley_test.member_client/g" \ - > ./cassandra-schema.cql + ./hack/bin/cassandra_dump_schema > ./cassandra-schema.cql git add ./cassandra-schema.cql .PHONY: cqlsh diff --git a/cassandra-schema.cql b/cassandra-schema.cql index 3bc45633bc..6e8b8ea692 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -444,6 +444,8 @@ CREATE TABLE galley_test.mls_group_member_client ( user uuid, client text, key_package_ref blob, + leaf_node_index int, + removal_pending boolean, PRIMARY KEY (group_id, user_domain, user, client) ) WITH CLUSTERING ORDER BY (user_domain ASC, user ASC, client ASC) AND bloom_filter_fp_chance = 0.01 diff --git a/changelog.d/1-api-changes/mls-upgrade b/changelog.d/1-api-changes/mls-upgrade new file mode 100644 index 0000000000..de9bd3f4d8 --- /dev/null +++ b/changelog.d/1-api-changes/mls-upgrade @@ -0,0 +1,7 @@ +Switch to MLS draft 20. The following endpoints are affected by the change: + + - All endpoints with `message/mls` content type now expect and return draft-20 MLS structures. + - `POST /conversations` does not require `creator_client` anymore. + - `POST /mls/commit-bundles` now expects a "stream" of MLS messages, i.e. a sequence of TLS-serialised messages, one after the other, in any order. Its protobuf interface has been removed. + - `POST /mls/welcome` has been removed. Welcome messages can now only be sent as part of a commit bundle. + - `POST /mls/message` does not accept commit messages anymore. All commit messages must be sent as part of a commit bundle. diff --git a/changelog.d/5-internal/key-package-mapping b/changelog.d/5-internal/key-package-mapping new file mode 100644 index 0000000000..e861208c19 --- /dev/null +++ b/changelog.d/5-internal/key-package-mapping @@ -0,0 +1 @@ +Brig does not perform key package ref mapping anymore. Claimed key packages are simply removed from the `mls_key_packages` table. The `mls_key_package_refs` table is now unused, and will be removed in the future. diff --git a/hack/bin/cassandra_dump_schema b/hack/bin/cassandra_dump_schema new file mode 100755 index 0000000000..624e4a0a18 --- /dev/null +++ b/hack/bin/cassandra_dump_schema @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +import subprocess +from subprocess import PIPE +from itertools import zip_longest +import re + +def run_cqlsh(container, expr): + p = subprocess.run(["docker", "exec", "-i", container, '/usr/bin/cqlsh', '-e', expr], stdout=PIPE, check=True).stdout.decode('utf8').strip() + return p + +def transpose(a): + return [x for col in zip_longest(*a, fillvalue='') for x in col] + +def main(): + container = subprocess.run(["docker", "ps", "--filter=name=cassandra", "--format={{.ID}}"], stdout=PIPE, check=True).stdout.decode('utf8').rstrip() + s = run_cqlsh(container, 'DESCRIBE keyspaces;') + + ks = [] + for line in s.splitlines(): + ks.append(re.split('\s+', line)) + + keyspaces = transpose(ks) + print("-- automatically generated with `make git-add-cassandra-schema`\n") + for keyspace in keyspaces: + if keyspace.endswith('_test'): + s = run_cqlsh(container, f'DESCRIBE keyspace {keyspace}') + print(s.replace('CREATE TABLE galley_test.member_client','-- NOTE: this table is unused. It was replaced by mls_group_member_client\nCREATE TABLE galley_test.member_client')) + print() + +if __name__ == '__main__': + main() diff --git a/hack/python/wire/mlscli.py b/hack/python/wire/mlscli.py index 99eca439d5..be53f849f1 100644 --- a/hack/python/wire/mlscli.py +++ b/hack/python/wire/mlscli.py @@ -189,7 +189,7 @@ def add_member(state, kpfiles): "", "--welcome-out", welcome_file, - "--group-state-out", + "--group-info-out", pgs_file, "--group-out", "", diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index f9c36367bd..d6fc8ee3cc 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -27,7 +27,7 @@ import Test.QuickCheck (Arbitrary) import Wire.API.Federation.API.Common import Wire.API.Federation.Endpoint import Wire.API.Federation.Version -import Wire.API.MLS.Credential +import Wire.API.MLS.CipherSuite import Wire.API.MLS.KeyPackage import Wire.API.User (UserProfile) import Wire.API.User.Client diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 319a4470c8..06d3217cbd 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -445,8 +445,11 @@ data ConversationUpdateResponse via (CustomEncoded ConversationUpdateResponse) -- | A wrapper around a raw welcome message -newtype MLSWelcomeRequest = MLSWelcomeRequest - { unMLSWelcomeRequest :: Base64ByteString +data MLSWelcomeRequest = MLSWelcomeRequest + { -- | A serialised welcome message. + welcomeMessage :: Base64ByteString, + -- | Recipients local to the target backend. + recipients :: [(UserId, ClientId)] } deriving stock (Eq, Generic, Show) deriving (Arbitrary) via (GenericUniform MLSWelcomeRequest) diff --git a/libs/wire-api/default.nix b/libs/wire-api/default.nix index 8981908490..59bfd69672 100644 --- a/libs/wire-api/default.nix +++ b/libs/wire-api/default.nix @@ -247,6 +247,7 @@ mkDerivation { process proto-lens QuickCheck + random saml2-web-sso schema-profunctor servant diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index b06efe0300..b412fa2cdd 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -72,7 +72,7 @@ data GalleyError MLSNotEnabled | MLSNonEmptyMemberList | MLSDuplicatePublicKey - | MLSKeyPackageRefNotFound + | MLSInvalidLeafNodeIndex | MLSUnsupportedMessage | MLSProposalNotFound | MLSUnsupportedProposal @@ -85,7 +85,6 @@ data GalleyError | MLSClientSenderUserMismatch | MLSWelcomeMismatch | MLSMissingGroupInfo - | MLSMissingSenderClient | MLSUnexpectedSenderClient | MLSSubConvUnsupportedConvType | MLSSubConvClientNotInParent @@ -201,7 +200,7 @@ type instance MapError 'MLSNonEmptyMemberList = 'StaticError 400 "non-empty-memb 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 'MLSInvalidLeafNodeIndex = 'StaticError 400 "mls-invalid-leaf-node-index" "A referenced leaf node index points to a blank or non-existing node" type instance MapError 'MLSUnsupportedMessage = 'StaticError 422 "mls-unsupported-message" "Attempted to send a message with an unsupported combination of content type and wire format" @@ -227,8 +226,6 @@ type instance MapError 'MLSWelcomeMismatch = 'StaticError 400 "mls-welcome-misma type instance MapError 'MLSMissingGroupInfo = 'StaticError 404 "mls-missing-group-info" "The conversation has no group information" -type instance MapError 'MLSMissingSenderClient = 'StaticError 403 "mls-missing-sender-client" "The client has to refresh their access token and provide their client ID" - type instance MapError 'MLSSubConvUnsupportedConvType = 'StaticError 403 "mls-subconv-unsupported-convtype" "MLS subconversations are only supported for regular conversations" type instance MapError 'MLSSubConvClientNotInParent = 'StaticError 403 "mls-subconv-join-parent-missing" "MLS client cannot join the subconversation because it is not member of the parent conversation" diff --git a/libs/wire-api/src/Wire/API/MLS/AuthenticatedContent.hs b/libs/wire-api/src/Wire/API/MLS/AuthenticatedContent.hs new file mode 100644 index 0000000000..394a18ede1 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/AuthenticatedContent.hs @@ -0,0 +1,111 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.AuthenticatedContent + ( AuthenticatedContent (..), + TaggedSender (..), + authContentRef, + publicMessageRef, + mkSignedPublicMessage, + ) +where + +import Crypto.PubKey.Ed25519 +import Imports +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Context +import Wire.API.MLS.Epoch +import Wire.API.MLS.Group +import Wire.API.MLS.LeafNode +import Wire.API.MLS.Message +import Wire.API.MLS.Proposal +import Wire.API.MLS.ProtocolVersion +import Wire.API.MLS.Serialisation + +-- | Needed to compute proposal refs. +-- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-7 +data AuthenticatedContent = AuthenticatedContent + { wireFormat :: WireFormatTag, + content :: RawMLS FramedContent, + authData :: RawMLS FramedContentAuthData + } + deriving (Eq, Show) + +instance SerialiseMLS AuthenticatedContent where + serialiseMLS ac = do + serialiseMLS ac.wireFormat + serialiseMLS ac.content + serialiseMLS ac.authData + +msgAuthContent :: PublicMessage -> AuthenticatedContent +msgAuthContent msg = + AuthenticatedContent + { wireFormat = WireFormatPublicTag, + content = msg.content, + authData = msg.authData + } + +-- | Compute the proposal ref given a ciphersuite and the raw proposal data. +authContentRef :: CipherSuiteTag -> AuthenticatedContent -> ProposalRef +authContentRef cs = ProposalRef . csHash cs proposalContext . mkRawMLS + +publicMessageRef :: CipherSuiteTag -> PublicMessage -> ProposalRef +publicMessageRef cs = authContentRef cs . msgAuthContent + +-- | Sender, plus with a membership tag in the case of a member sender. +data TaggedSender + = TaggedSenderMember LeafIndex ByteString + | TaggedSenderExternal Word32 + | TaggedSenderNewMemberProposal + | TaggedSenderNewMemberCommit + +taggedSenderToSender :: TaggedSender -> Sender +taggedSenderToSender (TaggedSenderMember i _) = SenderMember i +taggedSenderToSender (TaggedSenderExternal n) = SenderExternal n +taggedSenderToSender TaggedSenderNewMemberProposal = SenderNewMemberProposal +taggedSenderToSender TaggedSenderNewMemberCommit = SenderNewMemberCommit + +taggedSenderMembershipTag :: TaggedSender -> Maybe ByteString +taggedSenderMembershipTag (TaggedSenderMember _ t) = Just t +taggedSenderMembershipTag _ = Nothing + +-- | Craft a message with the backend itself as a sender. Return the message and its ref. +mkSignedPublicMessage :: + SecretKey -> PublicKey -> GroupId -> Epoch -> TaggedSender -> FramedContentData -> PublicMessage +mkSignedPublicMessage priv pub gid epoch sender payload = + let framedContent = + mkRawMLS + FramedContent + { groupId = gid, + epoch = epoch, + sender = taggedSenderToSender sender, + content = payload, + authenticatedData = mempty + } + tbs = + FramedContentTBS + { protocolVersion = defaultProtocolVersion, + wireFormat = WireFormatPublicTag, + content = framedContent, + groupContext = Nothing + } + sig = signWithLabel "FramedContentTBS" priv pub (mkRawMLS tbs) + in PublicMessage + { content = framedContent, + authData = mkRawMLS (FramedContentAuthData sig Nothing), + membershipTag = taggedSenderMembershipTag sender + } diff --git a/libs/wire-api/src/Wire/API/MLS/Capabilities.hs b/libs/wire-api/src/Wire/API/MLS/Capabilities.hs new file mode 100644 index 0000000000..64386ef72e --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/Capabilities.hs @@ -0,0 +1,55 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.Capabilities where + +import Imports +import Test.QuickCheck +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Credential +import Wire.API.MLS.ProposalTag +import Wire.API.MLS.ProtocolVersion +import Wire.API.MLS.Serialisation +import Wire.Arbitrary + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 +data Capabilities = Capabilities + { versions :: [ProtocolVersion], + ciphersuites :: [CipherSuite], + extensions :: [Word16], + proposals :: [ProposalTag], + credentials :: [CredentialTag] + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform Capabilities) + +instance ParseMLS Capabilities where + parseMLS = + Capabilities + <$> parseMLSVector @VarInt parseMLS + <*> parseMLSVector @VarInt parseMLS + <*> parseMLSVector @VarInt parseMLS + <*> parseMLSVector @VarInt parseMLS + <*> parseMLSVector @VarInt parseMLS + +instance SerialiseMLS Capabilities where + serialiseMLS caps = do + serialiseMLSVector @VarInt serialiseMLS caps.versions + serialiseMLSVector @VarInt serialiseMLS caps.ciphersuites + serialiseMLSVector @VarInt serialiseMLS caps.extensions + serialiseMLSVector @VarInt serialiseMLS caps.proposals + serialiseMLSVector @VarInt serialiseMLS caps.credentials diff --git a/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs index aaf42cd5af..c4fc037648 100644 --- a/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs +++ b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs @@ -17,21 +17,49 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.MLS.CipherSuite where +module Wire.API.MLS.CipherSuite + ( -- * MLS ciphersuites + CipherSuite (..), + CipherSuiteTag (..), + cipherSuiteTag, + tagCipherSuite, + -- * MLS signature schemes + SignatureScheme (..), + SignatureSchemeTag (..), + signatureScheme, + signatureSchemeName, + signatureSchemeTag, + csSignatureScheme, + + -- * Utilities + csHash, + csVerifySignatureWithLabel, + csVerifySignature, + signWithLabel, + ) +where + +import Cassandra.CQL +import Control.Error (note) import Control.Lens ((?~)) import Crypto.Error +import Crypto.Hash (hashWith) import Crypto.Hash.Algorithms -import qualified Crypto.KDF.HKDF as HKDF import qualified Crypto.PubKey.Ed25519 as Ed25519 -import Data.Aeson (parseJSON, toJSON) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) +import qualified Data.Aeson.Types as Aeson +import Data.ByteArray hiding (index) +import qualified Data.ByteArray as BA import Data.Proxy import Data.Schema import qualified Data.Swagger as S import qualified Data.Swagger.Internal.Schema as S +import qualified Data.Text as T import Data.Word import Imports -import Wire.API.MLS.Credential +import Servant (FromHttpApiData (parseQueryParam)) import Wire.API.MLS.Serialisation import Wire.Arbitrary @@ -79,16 +107,117 @@ cipherSuiteTag (CipherSuite n) = case n of tagCipherSuite :: CipherSuiteTag -> CipherSuite tagCipherSuite MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 = CipherSuite 1 -csHash :: CipherSuiteTag -> ByteString -> ByteString -> ByteString +csHash :: CipherSuiteTag -> ByteString -> RawMLS a -> ByteString csHash MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 ctx value = - HKDF.expand (HKDF.extract @SHA256 (mempty :: ByteString) value) ctx 16 + convert . hashWith SHA256 . encodeMLS' $ RefHashInput ctx value -csVerifySignature :: CipherSuiteTag -> ByteString -> ByteString -> ByteString -> Bool +csVerifySignature :: CipherSuiteTag -> ByteString -> RawMLS a -> ByteString -> Bool csVerifySignature MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 pub x sig = fromMaybe False . maybeCryptoError $ do pub' <- Ed25519.publicKey pub sig' <- Ed25519.signature sig - pure $ Ed25519.verify pub' x sig' + pure $ Ed25519.verify pub' x.raw sig' + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-5.2-5 +type RefHashInput = SignContent + +pattern RefHashInput :: ByteString -> RawMLS a -> RefHashInput a +pattern RefHashInput label content = SignContent label content + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-5.1.2-6 +data SignContent a = SignContent + { sigLabel :: ByteString, + content :: RawMLS a + } + +instance SerialiseMLS (SignContent a) where + serialiseMLS c = do + serialiseMLSBytes @VarInt c.sigLabel + serialiseMLSBytes @VarInt c.content.raw + +mkSignContent :: ByteString -> RawMLS a -> SignContent a +mkSignContent sigLabel content = + SignContent + { sigLabel = "MLS 1.0 " <> sigLabel, + content = content + } + +csVerifySignatureWithLabel :: + CipherSuiteTag -> + ByteString -> + ByteString -> + RawMLS a -> + ByteString -> + Bool +csVerifySignatureWithLabel cs pub label x sig = + csVerifySignature cs pub (mkRawMLS (mkSignContent label x)) sig + +-- FUTUREWORK: generalise to arbitrary ciphersuites +signWithLabel :: ByteString -> Ed25519.SecretKey -> Ed25519.PublicKey -> RawMLS a -> ByteString +signWithLabel sigLabel priv pub x = BA.convert $ Ed25519.sign priv pub (encodeMLS' (mkSignContent sigLabel x)) csSignatureScheme :: CipherSuiteTag -> SignatureSchemeTag csSignatureScheme MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 = Ed25519 + +-- | A TLS signature scheme. +-- +-- See . +newtype SignatureScheme = SignatureScheme {unSignatureScheme :: Word16} + deriving stock (Eq, Show) + deriving newtype (ParseMLS, Arbitrary) + +signatureScheme :: SignatureSchemeTag -> SignatureScheme +signatureScheme = SignatureScheme . signatureSchemeNumber + +data SignatureSchemeTag = Ed25519 + deriving stock (Bounded, Enum, Eq, Ord, Show, Generic) + deriving (Arbitrary) via GenericUniform SignatureSchemeTag + +instance Cql SignatureSchemeTag where + ctype = Tagged TextColumn + toCql = CqlText . signatureSchemeName + fromCql (CqlText name) = + note ("Unexpected signature scheme: " <> T.unpack name) $ + signatureSchemeFromName name + fromCql _ = Left "SignatureScheme: Text expected" + +signatureSchemeNumber :: SignatureSchemeTag -> Word16 +signatureSchemeNumber Ed25519 = 0x807 + +signatureSchemeName :: SignatureSchemeTag -> Text +signatureSchemeName Ed25519 = "ed25519" + +signatureSchemeTag :: SignatureScheme -> Maybe SignatureSchemeTag +signatureSchemeTag (SignatureScheme n) = getAlt $ + flip foldMap [minBound .. maxBound] $ \s -> + guard (signatureSchemeNumber s == n) $> s + +signatureSchemeFromName :: Text -> Maybe SignatureSchemeTag +signatureSchemeFromName name = getAlt $ + flip foldMap [minBound .. maxBound] $ \s -> + guard (signatureSchemeName s == name) $> s + +parseSignatureScheme :: MonadFail f => Text -> f SignatureSchemeTag +parseSignatureScheme name = + maybe + (fail ("Unsupported signature scheme " <> T.unpack name)) + pure + (signatureSchemeFromName name) + +instance FromJSON SignatureSchemeTag where + parseJSON = Aeson.withText "SignatureScheme" parseSignatureScheme + +instance FromJSONKey SignatureSchemeTag where + fromJSONKey = Aeson.FromJSONKeyTextParser parseSignatureScheme + +instance S.ToParamSchema SignatureSchemeTag where + toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString + +instance FromHttpApiData SignatureSchemeTag where + parseQueryParam = note "Unknown signature scheme" . signatureSchemeFromName + +instance ToJSON SignatureSchemeTag where + toJSON = Aeson.String . signatureSchemeName + +instance ToJSONKey SignatureSchemeTag where + toJSONKey = Aeson.toJSONKeyText signatureSchemeName diff --git a/libs/wire-api/src/Wire/API/MLS/Commit.hs b/libs/wire-api/src/Wire/API/MLS/Commit.hs index 8f1a17c8ce..81223db550 100644 --- a/libs/wire-api/src/Wire/API/MLS/Commit.hs +++ b/libs/wire-api/src/Wire/API/MLS/Commit.hs @@ -18,49 +18,74 @@ module Wire.API.MLS.Commit where import Imports -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.Arbitrary +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.4-3 data Commit = Commit - { cProposals :: [ProposalOrRef], - cPath :: Maybe UpdatePath + { proposals :: [ProposalOrRef], + path :: Maybe UpdatePath } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform Commit) instance ParseMLS Commit where - parseMLS = Commit <$> parseMLSVector @Word32 parseMLS <*> parseMLSOptional parseMLS + parseMLS = + Commit + <$> parseMLSVector @VarInt parseMLS + <*> parseMLSOptional parseMLS + +instance SerialiseMLS Commit where + serialiseMLS c = do + serialiseMLSVector @VarInt serialiseMLS c.proposals + serialiseMLSOptional serialiseMLS c.path +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.6-2 data UpdatePath = UpdatePath - { upLeaf :: RawMLS KeyPackage, - upNodes :: [UpdatePathNode] + { leaf :: RawMLS LeafNode, + nodes :: [UpdatePathNode] } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UpdatePath) instance ParseMLS UpdatePath where - parseMLS = UpdatePath <$> parseMLS <*> parseMLSVector @Word32 parseMLS + parseMLS = UpdatePath <$> parseMLS <*> parseMLSVector @VarInt parseMLS +instance SerialiseMLS UpdatePath where + serialiseMLS up = do + serialiseMLS up.leaf + serialiseMLSVector @VarInt serialiseMLS up.nodes + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.6-2 data UpdatePathNode = UpdatePathNode - { upnPublicKey :: ByteString, - upnSecret :: [HPKECiphertext] + { publicKey :: ByteString, + secret :: [HPKECiphertext] } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UpdatePathNode) instance ParseMLS UpdatePathNode where - parseMLS = UpdatePathNode <$> parseMLSBytes @Word16 <*> parseMLSVector @Word32 parseMLS + parseMLS = UpdatePathNode <$> parseMLSBytes @VarInt <*> parseMLSVector @VarInt parseMLS + +instance SerialiseMLS UpdatePathNode where + serialiseMLS upn = do + serialiseMLSBytes @VarInt upn.publicKey + serialiseMLSVector @VarInt serialiseMLS upn.secret +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.6-2 data HPKECiphertext = HPKECiphertext - { hcOutput :: ByteString, - hcCiphertext :: ByteString + { output :: ByteString, + ciphertext :: ByteString } deriving (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform HPKECiphertext) instance ParseMLS HPKECiphertext where - parseMLS = HPKECiphertext <$> parseMLSBytes @Word16 <*> parseMLSBytes @Word16 + parseMLS = HPKECiphertext <$> parseMLSBytes @VarInt <*> parseMLSBytes @VarInt instance SerialiseMLS HPKECiphertext where serialiseMLS (HPKECiphertext out ct) = do - serialiseMLSBytes @Word16 out - serialiseMLSBytes @Word16 ct + serialiseMLSBytes @VarInt out + serialiseMLSBytes @VarInt ct diff --git a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs index e04902d969..1ca590e04e 100644 --- a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs @@ -15,65 +15,82 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.MLS.CommitBundle where +module Wire.API.MLS.CommitBundle (CommitBundle (..)) where -import Control.Lens (view, (.~), (?~)) -import Data.Bifunctor (first) -import qualified Data.ByteString as BS -import Data.ProtoLens (decodeMessage, encodeMessage) -import qualified Data.ProtoLens (Message (defMessage)) +import Control.Applicative import qualified Data.Swagger as S import qualified Data.Text as T import Imports -import qualified Proto.Mls -import qualified Proto.Mls_Fields as Proto.Mls -import Wire.API.ConverProtoLens -import Wire.API.MLS.GroupInfoBundle +import Wire.API.MLS.GroupInfo import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.Welcome data CommitBundle = CommitBundle - { cbCommitMsg :: RawMLS (Message 'MLSPlainText), - cbWelcome :: Maybe (RawMLS Welcome), - cbGroupInfoBundle :: GroupInfoBundle + { commitMsg :: RawMLS Message, + welcome :: Maybe (RawMLS Welcome), + groupInfo :: RawMLS GroupInfo } - deriving (Eq, Show) + deriving stock (Eq, Show, Generic) -instance ConvertProtoLens Proto.Mls.CommitBundle CommitBundle where - fromProtolens protoBundle = protoLabel "CommitBundle" $ do - CommitBundle - <$> protoLabel "commit" (decodeMLS' (view Proto.Mls.commit protoBundle)) - <*> protoLabel - "welcome" - ( let bs = view Proto.Mls.welcome protoBundle - in if BS.length bs == 0 - then pure Nothing - else Just <$> decodeMLS' bs - ) - <*> protoLabel "group_info_bundle" (fromProtolens (view Proto.Mls.groupInfoBundle protoBundle)) - toProtolens bundle = - let commitData = rmRaw (cbCommitMsg bundle) - welcomeData = foldMap rmRaw (cbWelcome bundle) - groupInfoData = toProtolens (cbGroupInfoBundle bundle) - in ( Data.ProtoLens.defMessage - & Proto.Mls.commit .~ commitData - & Proto.Mls.welcome .~ welcomeData - & Proto.Mls.groupInfoBundle .~ groupInfoData - ) +data CommitBundleF f = CommitBundleF + { commitMsg :: f (RawMLS Message), + welcome :: f (RawMLS Welcome), + groupInfo :: f (RawMLS GroupInfo) + } -instance S.ToSchema CommitBundle where - declareNamedSchema _ = - pure $ - S.NamedSchema (Just "CommitBundle") $ - mempty - & S.description - ?~ "A protobuf-serialized object. See wireapp/generic-message-proto for the definition." +deriving instance Show (CommitBundleF []) + +instance Alternative f => Semigroup (CommitBundleF f) where + cb1 <> cb2 = + CommitBundleF + (cb1.commitMsg <|> cb2.commitMsg) + (cb1.welcome <|> cb2.welcome) + (cb1.groupInfo <|> cb2.groupInfo) + +instance Alternative f => Monoid (CommitBundleF f) where + mempty = CommitBundleF empty empty empty + +checkCommitBundleF :: CommitBundleF [] -> Either Text CommitBundle +checkCommitBundleF cb = + CommitBundle + <$> check "commit" cb.commitMsg + <*> checkOpt "welcome" cb.welcome + <*> check "group info" cb.groupInfo + where + check :: Text -> [a] -> Either Text a + check _ [x] = pure x + check name [] = Left ("Missing " <> name) + check name _ = Left ("Redundant occurrence of " <> name) -deserializeCommitBundle :: ByteString -> Either Text CommitBundle -deserializeCommitBundle b = do - protoCommitBundle :: Proto.Mls.CommitBundle <- first (("Parsing protobuf failed: " <>) . T.pack) (decodeMessage b) - first ("Converting from protobuf failed: " <>) (fromProtolens protoCommitBundle) + checkOpt :: Text -> [a] -> Either Text (Maybe a) + checkOpt _ [] = pure Nothing + checkOpt _ [x] = pure (Just x) + checkOpt name _ = Left ("Redundant occurrence of " <> name) -serializeCommitBundle :: CommitBundle -> ByteString -serializeCommitBundle = encodeMessage . (toProtolens @Proto.Mls.CommitBundle @CommitBundle) +findMessageInStream :: Alternative f => RawMLS Message -> Either Text (CommitBundleF f) +findMessageInStream msg = case msg.value.content of + MessagePublic mp -> case mp.content.value.content of + FramedContentCommit _ -> pure (CommitBundleF (pure msg) empty empty) + _ -> Left "unexpected public message" + MessageWelcome w -> pure (CommitBundleF empty (pure w) empty) + MessageGroupInfo gi -> pure (CommitBundleF empty empty (pure gi)) + _ -> Left "unexpected message type" + +findMessagesInStream :: Alternative f => [RawMLS Message] -> Either Text (CommitBundleF f) +findMessagesInStream = getAp . foldMap (Ap . findMessageInStream) + +instance ParseMLS CommitBundle where + parseMLS = do + msgs <- parseMLSStream parseMLS + either (fail . T.unpack) pure $ + findMessagesInStream msgs >>= checkCommitBundleF + +instance SerialiseMLS CommitBundle where + serialiseMLS cb = do + serialiseMLS cb.commitMsg + traverse_ (serialiseMLS . mkMessage . MessageWelcome) cb.welcome + serialiseMLS $ mkMessage (MessageGroupInfo cb.groupInfo) + +instance S.ToSchema CommitBundle where + declareNamedSchema _ = pure (mlsSwagger "CommitBundle") diff --git a/libs/wire-api/src/Wire/API/MLS/Context.hs b/libs/wire-api/src/Wire/API/MLS/Context.hs index 661b7ce632..4324b61d7a 100644 --- a/libs/wire-api/src/Wire/API/MLS/Context.hs +++ b/libs/wire-api/src/Wire/API/MLS/Context.hs @@ -19,15 +19,6 @@ module Wire.API.MLS.Context where import Imports --- Warning: the "context" string here is different from the one mandated by --- the spec, but it is the one that happens to be used by openmls. Until --- openmls is patched and we switch to a fixed version, we will have to use --- the "wrong" string here as well. --- --- This is used when invoking 'csHash'. -context :: ByteString -context = "MLS 1.0 ref" - proposalContext, keyPackageContext :: ByteString -proposalContext = context -keyPackageContext = context +proposalContext = "MLS 1.0 Proposal Reference" +keyPackageContext = "MLS 1.0 KeyPackage Reference" diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index e695eba1d9..f614269b83 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -19,7 +17,6 @@ module Wire.API.MLS.Credential where -import Cassandra.CQL import Control.Error.Util import Control.Lens ((?~)) import Data.Aeson (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) @@ -30,13 +27,16 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Parser import Data.Binary.Parser.Char8 +import Data.Binary.Put import Data.Domain import Data.Id import Data.Qualified import Data.Schema import qualified Data.Swagger as S import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.UUID +import GHC.Records import Imports import Web.HttpApiData import Wire.API.MLS.Serialisation @@ -45,94 +45,39 @@ import Wire.Arbitrary -- | An MLS credential. -- -- Only the @BasicCredential@ type is supported. -data Credential = BasicCredential - { bcIdentity :: ByteString, - bcSignatureScheme :: SignatureScheme, - bcSignatureKey :: ByteString - } +-- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-5.3-3 +data Credential = BasicCredential ByteString deriving stock (Eq, Show, Generic) deriving (Arbitrary) via GenericUniform Credential -data CredentialTag = BasicCredentialTag - deriving stock (Enum, Bounded, Eq, Show) +data CredentialTag where + BasicCredentialTag :: CredentialTag + deriving stock (Enum, Bounded, Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform CredentialTag) instance ParseMLS CredentialTag where parseMLS = parseMLSEnum @Word16 "credential type" +instance SerialiseMLS CredentialTag where + serialiseMLS = serialiseMLSEnum @Word16 + instance ParseMLS Credential where parseMLS = parseMLS >>= \case BasicCredentialTag -> BasicCredential - <$> parseMLSBytes @Word16 - <*> parseMLS - <*> parseMLSBytes @Word16 + <$> parseMLSBytes @VarInt + +instance SerialiseMLS Credential where + serialiseMLS (BasicCredential i) = do + serialiseMLS BasicCredentialTag + serialiseMLSBytes @VarInt i credentialTag :: Credential -> CredentialTag credentialTag BasicCredential {} = BasicCredentialTag --- | A TLS signature scheme. --- --- See . -newtype SignatureScheme = SignatureScheme {unSignatureScheme :: Word16} - deriving stock (Eq, Show) - deriving newtype (ParseMLS, Arbitrary) - -signatureScheme :: SignatureSchemeTag -> SignatureScheme -signatureScheme = SignatureScheme . signatureSchemeNumber - -data SignatureSchemeTag = Ed25519 - deriving stock (Bounded, Enum, Eq, Ord, Show, Generic) - deriving (Arbitrary) via GenericUniform SignatureSchemeTag - -instance Cql SignatureSchemeTag where - ctype = Tagged TextColumn - toCql = CqlText . signatureSchemeName - fromCql (CqlText name) = - note ("Unexpected signature scheme: " <> T.unpack name) $ - signatureSchemeFromName name - fromCql _ = Left "SignatureScheme: Text expected" - -signatureSchemeNumber :: SignatureSchemeTag -> Word16 -signatureSchemeNumber Ed25519 = 0x807 - -signatureSchemeName :: SignatureSchemeTag -> Text -signatureSchemeName Ed25519 = "ed25519" - -signatureSchemeTag :: SignatureScheme -> Maybe SignatureSchemeTag -signatureSchemeTag (SignatureScheme n) = getAlt $ - flip foldMap [minBound .. maxBound] $ \s -> - guard (signatureSchemeNumber s == n) $> s - -signatureSchemeFromName :: Text -> Maybe SignatureSchemeTag -signatureSchemeFromName name = getAlt $ - flip foldMap [minBound .. maxBound] $ \s -> - guard (signatureSchemeName s == name) $> s - -parseSignatureScheme :: MonadFail f => Text -> f SignatureSchemeTag -parseSignatureScheme name = - maybe - (fail ("Unsupported signature scheme " <> T.unpack name)) - pure - (signatureSchemeFromName name) - -instance FromJSON SignatureSchemeTag where - parseJSON = Aeson.withText "SignatureScheme" parseSignatureScheme - -instance FromJSONKey SignatureSchemeTag where - fromJSONKey = Aeson.FromJSONKeyTextParser parseSignatureScheme - -instance S.ToParamSchema SignatureSchemeTag where - toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString - -instance FromHttpApiData SignatureSchemeTag where - parseQueryParam = note "Unknown signature scheme" . signatureSchemeFromName - -instance ToJSON SignatureSchemeTag where - toJSON = Aeson.String . signatureSchemeName - -instance ToJSONKey SignatureSchemeTag where - toJSONKey = Aeson.toJSONKeyText signatureSchemeName +instance HasField "identityData" Credential ByteString where + getField (BasicCredential i) = i data ClientIdentity = ClientIdentity { ciDomain :: Domain, @@ -141,6 +86,7 @@ data ClientIdentity = ClientIdentity } deriving stock (Eq, Ord, Generic) deriving (FromJSON, ToJSON, S.ToSchema) via Schema ClientIdentity + deriving (Arbitrary) via (GenericUniform ClientIdentity) instance Show ClientIdentity where show (ClientIdentity dom u c) = @@ -164,6 +110,17 @@ instance ToSchema ClientIdentity where <*> ciUser .= field "user_id" schema <*> ciClient .= field "client_id" schema +instance S.ToParamSchema ClientIdentity where + toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString + +instance FromHttpApiData ClientIdentity where + parseHeader = decodeMLS' + parseUrlPiece = decodeMLS' . T.encodeUtf8 + +instance ToHttpApiData ClientIdentity where + toHeader = encodeMLS' + toUrlPiece = T.decodeUtf8 . encodeMLS' + instance ParseMLS ClientIdentity where parseMLS = do uid <- @@ -175,6 +132,14 @@ instance ParseMLS ClientIdentity where either fail pure . (mkDomain . T.pack) =<< many' anyChar pure $ ClientIdentity dom uid cid +instance SerialiseMLS ClientIdentity where + serialiseMLS cid = do + putByteString $ toASCIIBytes (toUUID (ciUser cid)) + putCharUtf8 ':' + putStringUtf8 $ T.unpack (client (ciClient cid)) + putCharUtf8 '@' + putStringUtf8 $ T.unpack (domainText (ciDomain cid)) + mkClientIdentity :: Qualified UserId -> ClientId -> ClientIdentity mkClientIdentity (Qualified uid domain) = ClientIdentity domain uid diff --git a/libs/wire-api/src/Wire/API/MLS/Extension.hs b/libs/wire-api/src/Wire/API/MLS/Extension.hs index 5093398adf..eab027e715 100644 --- a/libs/wire-api/src/Wire/API/MLS/Extension.hs +++ b/libs/wire-api/src/Wire/API/MLS/Extension.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -19,52 +15,14 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.MLS.Extension - ( -- * Extensions - Extension (..), - decodeExtension, - parseExtension, - ExtensionTag (..), - CapabilitiesExtensionTagSym0, - LifetimeExtensionTagSym0, - SExtensionTag (..), - SomeExtension (..), - Capabilities (..), - Lifetime (..), - - -- * Other types - Timestamp (..), - ProtocolVersion (..), - ProtocolVersionTag (..), - - -- * Utilities - pvTag, - tsPOSIX, - ) -where +module Wire.API.MLS.Extension where import Data.Binary -import Data.Kind -import Data.Singletons.TH -import Data.Time.Clock.POSIX import Imports -import Wire.API.MLS.CipherSuite import Wire.API.MLS.Serialisation import Wire.Arbitrary -newtype ProtocolVersion = ProtocolVersion {pvNumber :: Word8} - deriving newtype (Eq, Ord, Show, Binary, Arbitrary, ParseMLS, SerialiseMLS) - -data ProtocolVersionTag = ProtocolMLS10 | ProtocolMLSDraft11 - deriving stock (Bounded, Enum, Eq, Show, Generic) - deriving (Arbitrary) via GenericUniform ProtocolVersionTag - -pvTag :: ProtocolVersion -> Maybe ProtocolVersionTag -pvTag (ProtocolVersion v) = case v of - 1 -> pure ProtocolMLS10 - 200 -> pure ProtocolMLSDraft11 - _ -> Nothing - +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 data Extension = Extension { extType :: Word16, extData :: ByteString @@ -73,78 +31,9 @@ data Extension = Extension deriving (Arbitrary) via GenericUniform Extension instance ParseMLS Extension where - parseMLS = Extension <$> parseMLS <*> parseMLSBytes @Word32 + parseMLS = Extension <$> parseMLS <*> parseMLSBytes @VarInt instance SerialiseMLS Extension where serialiseMLS (Extension ty d) = do serialiseMLS ty - serialiseMLSBytes @Word32 d - -data ExtensionTag - = CapabilitiesExtensionTag - | LifetimeExtensionTag - deriving (Bounded, Enum) - -$(genSingletons [''ExtensionTag]) - -type family ExtensionType (t :: ExtensionTag) :: Type where - ExtensionType 'CapabilitiesExtensionTag = Capabilities - ExtensionType 'LifetimeExtensionTag = Lifetime - -parseExtension :: Sing t -> Get (ExtensionType t) -parseExtension SCapabilitiesExtensionTag = parseMLS -parseExtension SLifetimeExtensionTag = parseMLS - -data SomeExtension where - SomeExtension :: Sing t -> ExtensionType t -> SomeExtension - -instance Eq SomeExtension where - SomeExtension SCapabilitiesExtensionTag caps1 == SomeExtension SCapabilitiesExtensionTag caps2 = caps1 == caps2 - SomeExtension SLifetimeExtensionTag lt1 == SomeExtension SLifetimeExtensionTag lt2 = lt1 == lt2 - _ == _ = False - -instance Show SomeExtension where - show (SomeExtension SCapabilitiesExtensionTag caps) = show caps - show (SomeExtension SLifetimeExtensionTag lt) = show lt - -decodeExtension :: Extension -> Either Text (Maybe SomeExtension) -decodeExtension e = do - case toMLSEnum' (extType e) of - Left MLSEnumUnknown -> pure Nothing - Left MLSEnumInvalid -> Left "Invalid extension type" - Right t -> withSomeSing t $ \st -> - Just <$> decodeMLSWith' (SomeExtension st <$> parseExtension st) (extData e) - -data Capabilities = Capabilities - { capVersions :: [ProtocolVersion], - capCiphersuites :: [CipherSuite], - capExtensions :: [Word16], - capProposals :: [Word16] - } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform Capabilities) - -instance ParseMLS Capabilities where - parseMLS = - Capabilities - <$> parseMLSVector @Word8 parseMLS - <*> parseMLSVector @Word8 parseMLS - <*> parseMLSVector @Word8 parseMLS - <*> parseMLSVector @Word8 parseMLS - --- | Seconds since the UNIX epoch. -newtype Timestamp = Timestamp {timestampSeconds :: Word64} - deriving newtype (Eq, Show, Arbitrary, ParseMLS) - -tsPOSIX :: Timestamp -> POSIXTime -tsPOSIX = fromIntegral . timestampSeconds - -data Lifetime = Lifetime - { ltNotBefore :: Timestamp, - ltNotAfter :: Timestamp - } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via GenericUniform Lifetime - -instance ParseMLS Lifetime where - parseMLS = Lifetime <$> parseMLS <*> parseMLS + serialiseMLSBytes @VarInt d diff --git a/libs/wire-api/src/Wire/API/MLS/Group.hs b/libs/wire-api/src/Wire/API/MLS/Group.hs index c693ddd2a2..3110552000 100644 --- a/libs/wire-api/src/Wire/API/MLS/Group.hs +++ b/libs/wire-api/src/Wire/API/MLS/Group.hs @@ -39,10 +39,10 @@ instance IsString GroupId where fromString = GroupId . fromString instance ParseMLS GroupId where - parseMLS = GroupId <$> parseMLSBytes @Word8 + parseMLS = GroupId <$> parseMLSBytes @VarInt instance SerialiseMLS GroupId where - serialiseMLS (GroupId gid) = serialiseMLSBytes @Word8 gid + serialiseMLS (GroupId gid) = serialiseMLSBytes @VarInt gid instance ToSchema GroupId where schema = diff --git a/libs/wire-api/src/Wire/API/MLS/GroupInfo.hs b/libs/wire-api/src/Wire/API/MLS/GroupInfo.hs new file mode 100644 index 0000000000..77cf203662 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/GroupInfo.hs @@ -0,0 +1,140 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.GroupInfo + ( GroupContext (..), + GroupInfo (..), + GroupInfoData (..), + ) +where + +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Swagger as S +import GHC.Records +import Imports +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Epoch +import Wire.API.MLS.Extension +import Wire.API.MLS.Group +import Wire.API.MLS.ProtocolVersion +import Wire.API.MLS.Serialisation +import Wire.Arbitrary + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-8.1-2 +data GroupContext = GroupContext + { protocolVersion :: ProtocolVersion, + cipherSuite :: CipherSuite, + groupId :: GroupId, + epoch :: Epoch, + treeHash :: ByteString, + confirmedTranscriptHash :: ByteString, + extensions :: [Extension] + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform GroupContext) + +instance ParseMLS GroupContext where + parseMLS = + GroupContext + <$> parseMLS + <*> parseMLS + <*> parseMLS + <*> parseMLS + <*> parseMLSBytes @VarInt + <*> parseMLSBytes @VarInt + <*> parseMLSVector @VarInt parseMLS + +instance SerialiseMLS GroupContext where + serialiseMLS gc = do + serialiseMLS gc.protocolVersion + serialiseMLS gc.cipherSuite + serialiseMLS gc.groupId + serialiseMLS gc.epoch + serialiseMLSBytes @VarInt gc.treeHash + serialiseMLSBytes @VarInt gc.confirmedTranscriptHash + serialiseMLSVector @VarInt serialiseMLS gc.extensions + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.4.3-7 +data GroupInfoTBS = GroupInfoTBS + { groupContext :: GroupContext, + extensions :: [Extension], + confirmationTag :: ByteString, + signer :: Word32 + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform GroupInfoTBS) + +instance ParseMLS GroupInfoTBS where + parseMLS = + GroupInfoTBS + <$> parseMLS + <*> parseMLSVector @VarInt parseMLS + <*> parseMLSBytes @VarInt + <*> parseMLS + +instance SerialiseMLS GroupInfoTBS where + serialiseMLS tbs = do + serialiseMLS tbs.groupContext + serialiseMLSVector @VarInt serialiseMLS tbs.extensions + serialiseMLSBytes @VarInt tbs.confirmationTag + serialiseMLS tbs.signer + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.4.3-2 +data GroupInfo = GroupInfo + { tbs :: GroupInfoTBS, + signature_ :: ByteString + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform GroupInfo) + +instance ParseMLS GroupInfo where + parseMLS = + GroupInfo + <$> parseMLS + <*> parseMLSBytes @VarInt + +instance SerialiseMLS GroupInfo where + serialiseMLS gi = do + serialiseMLS gi.tbs + serialiseMLSBytes @VarInt gi.signature_ + +instance HasField "groupContext" GroupInfo GroupContext where + getField = (.tbs.groupContext) + +instance HasField "extensions" GroupInfo [Extension] where + getField = (.tbs.extensions) + +instance HasField "confirmationTag" GroupInfo ByteString where + getField = (.tbs.confirmationTag) + +instance HasField "signer" GroupInfo Word32 where + getField = (.tbs.signer) + +newtype GroupInfoData = GroupInfoData {unGroupInfoData :: ByteString} + deriving stock (Eq, Ord, Show) + deriving newtype (Arbitrary) + +instance ParseMLS GroupInfoData where + parseMLS = GroupInfoData . LBS.toStrict <$> getRemainingLazyByteString + +instance SerialiseMLS GroupInfoData where + serialiseMLS (GroupInfoData bs) = putByteString bs + +instance S.ToSchema GroupInfoData where + declareNamedSchema _ = pure (mlsSwagger "GroupInfoData") diff --git a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs b/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs deleted file mode 100644 index 93cc706e98..0000000000 --- a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs +++ /dev/null @@ -1,98 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Wire.API.MLS.GroupInfoBundle where - -import Control.Lens (view, (.~)) -import Data.ProtoLens (Message (defMessage)) -import Imports -import qualified Proto.Mls -import qualified Proto.Mls_Fields as Proto.Mls -import Test.QuickCheck -import Wire.API.ConverProtoLens -import Wire.API.MLS.PublicGroupState -import Wire.API.MLS.Serialisation -import Wire.Arbitrary - -data GroupInfoType = GroupInfoTypePublicGroupState | UnencryptedGroupInfo | JweEncryptedGroupInfo - deriving stock (Eq, Show, Generic, Enum, Bounded) - deriving (Arbitrary) via (GenericUniform GroupInfoType) - -instance ConvertProtoLens Proto.Mls.GroupInfoType GroupInfoType where - fromProtolens Proto.Mls.PUBLIC_GROUP_STATE = pure GroupInfoTypePublicGroupState - fromProtolens Proto.Mls.GROUP_INFO = pure UnencryptedGroupInfo - fromProtolens Proto.Mls.GROUP_INFO_JWE = pure JweEncryptedGroupInfo - - toProtolens GroupInfoTypePublicGroupState = Proto.Mls.PUBLIC_GROUP_STATE - toProtolens UnencryptedGroupInfo = Proto.Mls.GROUP_INFO - toProtolens JweEncryptedGroupInfo = Proto.Mls.GROUP_INFO_JWE - -data RatchetTreeType = TreeFull | TreeDelta | TreeByRef - deriving stock (Eq, Show, Generic, Bounded, Enum) - deriving (Arbitrary) via (GenericUniform RatchetTreeType) - -instance ConvertProtoLens Proto.Mls.RatchetTreeType RatchetTreeType where - fromProtolens Proto.Mls.FULL = pure TreeFull - fromProtolens Proto.Mls.DELTA = pure TreeDelta - fromProtolens Proto.Mls.REFERENCE = pure TreeByRef - - toProtolens TreeFull = Proto.Mls.FULL - toProtolens TreeDelta = Proto.Mls.DELTA - toProtolens TreeByRef = Proto.Mls.REFERENCE - -data GroupInfoBundle = GroupInfoBundle - { gipGroupInfoType :: GroupInfoType, - gipRatchetTreeType :: RatchetTreeType, - gipGroupState :: RawMLS PublicGroupState - } - deriving stock (Eq, Show, Generic) - -instance ConvertProtoLens Proto.Mls.GroupInfoBundle GroupInfoBundle where - fromProtolens protoBundle = - protoLabel "GroupInfoBundle" $ - GroupInfoBundle - <$> protoLabel "field group_info_type" (fromProtolens (view Proto.Mls.groupInfoType protoBundle)) - <*> protoLabel "field ratchet_tree_type" (fromProtolens (view Proto.Mls.ratchetTreeType protoBundle)) - <*> protoLabel "field group_info" (decodeMLS' (view Proto.Mls.groupInfo protoBundle)) - toProtolens bundle = - let encryptionType = toProtolens (gipGroupInfoType bundle) - treeType = toProtolens (gipRatchetTreeType bundle) - in ( defMessage - & Proto.Mls.groupInfoType .~ encryptionType - & Proto.Mls.ratchetTreeType .~ treeType - & Proto.Mls.groupInfo .~ rmRaw (gipGroupState bundle) - ) - -instance Arbitrary GroupInfoBundle where - arbitrary = - GroupInfoBundle - <$> arbitrary - <*> arbitrary - <*> (mkRawMLS <$> arbitrary) - -instance ParseMLS GroupInfoBundle where - parseMLS = - GroupInfoBundle - <$> parseMLSEnum @Word8 "GroupInfoTypeEnum" - <*> parseMLSEnum @Word8 "RatchetTreeEnum" - <*> parseMLS - -instance SerialiseMLS GroupInfoBundle where - serialiseMLS (GroupInfoBundle e t pgs) = do - serialiseMLSEnum @Word8 e - serialiseMLSEnum @Word8 t - serialiseMLS pgs diff --git a/libs/wire-api/src/Wire/API/MLS/HPKEPublicKey.hs b/libs/wire-api/src/Wire/API/MLS/HPKEPublicKey.hs new file mode 100644 index 0000000000..3d0d947f08 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/HPKEPublicKey.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.HPKEPublicKey where + +import Imports +import Test.QuickCheck +import Wire.API.MLS.Serialisation + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-5.1.1-2 +newtype HPKEPublicKey = HPKEPublicKey {unHPKEPublicKey :: ByteString} + deriving (Show, Eq, Arbitrary) + +instance ParseMLS HPKEPublicKey where + parseMLS = HPKEPublicKey <$> parseMLSBytes @VarInt + +instance SerialiseMLS HPKEPublicKey where + serialiseMLS = serialiseMLSBytes @VarInt . unHPKEPublicKey diff --git a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs index 4d213c71b0..19e9490993 100644 --- a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs +++ b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -24,17 +22,11 @@ module Wire.API.MLS.KeyPackage KeyPackageCount (..), KeyPackageData (..), KeyPackage (..), - kpProtocolVersion, - kpCipherSuite, - kpInitKey, - kpCredential, - kpExtensions, - kpIdentity, + keyPackageIdentity, kpRef, kpRef', KeyPackageTBS (..), KeyPackageRef (..), - KeyPackageUpdate (..), ) where @@ -42,16 +34,13 @@ import Cassandra.CQL hiding (Set) import Control.Applicative import Control.Lens hiding (set, (.=)) import Data.Aeson (FromJSON, ToJSON) -import Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LBS import Data.Id import Data.Json.Util import Data.Qualified import Data.Schema import qualified Data.Swagger as S +import GHC.Records import Imports import Test.QuickCheck import Web.HttpApiData @@ -59,18 +48,21 @@ import Wire.API.MLS.CipherSuite import Wire.API.MLS.Context import Wire.API.MLS.Credential import Wire.API.MLS.Extension +import Wire.API.MLS.HPKEPublicKey +import Wire.API.MLS.LeafNode +import Wire.API.MLS.ProtocolVersion import Wire.API.MLS.Serialisation import Wire.Arbitrary data KeyPackageUpload = KeyPackageUpload - {kpuKeyPackages :: [RawMLS KeyPackage]} + {keyPackages :: [RawMLS KeyPackage]} deriving (FromJSON, ToJSON, S.ToSchema) via Schema KeyPackageUpload instance ToSchema KeyPackageUpload where schema = object "KeyPackageUpload" $ KeyPackageUpload - <$> kpuKeyPackages .= field "key_packages" (array rawKeyPackageSchema) + <$> keyPackages .= field "key_packages" (array rawKeyPackageSchema) newtype KeyPackageData = KeyPackageData {kpData :: ByteString} deriving stock (Eq, Ord, Show) @@ -90,10 +82,10 @@ instance Cql KeyPackageData where fromCql _ = Left "Expected CqlBlob" data KeyPackageBundleEntry = KeyPackageBundleEntry - { kpbeUser :: Qualified UserId, - kpbeClient :: ClientId, - kpbeRef :: KeyPackageRef, - kpbeKeyPackage :: KeyPackageData + { user :: Qualified UserId, + client :: ClientId, + ref :: KeyPackageRef, + keyPackage :: KeyPackageData } deriving stock (Eq, Ord, Show) @@ -101,12 +93,12 @@ instance ToSchema KeyPackageBundleEntry where schema = object "KeyPackageBundleEntry" $ KeyPackageBundleEntry - <$> kpbeUser .= qualifiedObjectSchema "user" schema - <*> kpbeClient .= field "client" schema - <*> kpbeRef .= field "key_package_ref" schema - <*> kpbeKeyPackage .= field "key_package" schema + <$> (.user) .= qualifiedObjectSchema "user" schema + <*> (.client) .= field "client" schema + <*> (.ref) .= field "key_package_ref" schema + <*> (.keyPackage) .= field "key_package" schema -newtype KeyPackageBundle = KeyPackageBundle {kpbEntries :: Set KeyPackageBundleEntry} +newtype KeyPackageBundle = KeyPackageBundle {entries :: Set KeyPackageBundleEntry} deriving stock (Eq, Show) deriving (FromJSON, ToJSON, S.ToSchema) via Schema KeyPackageBundle @@ -114,7 +106,7 @@ instance ToSchema KeyPackageBundle where schema = object "KeyPackageBundle" $ KeyPackageBundle - <$> kpbEntries .= field "key_packages" (set schema) + <$> (.entries) .= field "key_packages" (set schema) newtype KeyPackageCount = KeyPackageCount {unKeyPackageCount :: Int} deriving newtype (Eq, Ord, Num, Show) @@ -129,18 +121,16 @@ newtype KeyPackageRef = KeyPackageRef {unKeyPackageRef :: ByteString} deriving stock (Eq, Ord, Show) deriving (FromHttpApiData, ToHttpApiData, S.ToParamSchema) via Base64ByteString deriving (ToJSON, FromJSON, S.ToSchema) via (Schema KeyPackageRef) - -instance Arbitrary KeyPackageRef where - arbitrary = KeyPackageRef . B.pack <$> vectorOf 16 arbitrary + deriving newtype (Arbitrary) instance ToSchema KeyPackageRef where schema = named "KeyPackageRef" $ unKeyPackageRef .= fmap KeyPackageRef base64Schema instance ParseMLS KeyPackageRef where - parseMLS = KeyPackageRef <$> getByteString 16 + parseMLS = KeyPackageRef <$> parseMLSBytes @VarInt instance SerialiseMLS KeyPackageRef where - serialiseMLS = putByteString . unKeyPackageRef + serialiseMLS = serialiseMLSBytes @VarInt . unKeyPackageRef instance Cql KeyPackageRef where ctype = Tagged BlobColumn @@ -153,6 +143,7 @@ kpRef :: CipherSuiteTag -> KeyPackageData -> KeyPackageRef kpRef cs = KeyPackageRef . csHash cs keyPackageContext + . flip RawMLS () . kpData -- | Compute ref of a key package. Return 'Nothing' if the key package cipher @@ -160,17 +151,18 @@ kpRef cs = kpRef' :: RawMLS KeyPackage -> Maybe KeyPackageRef kpRef' kp = kpRef - <$> cipherSuiteTag (kpCipherSuite (rmValue kp)) - <*> pure (KeyPackageData (rmRaw kp)) + <$> cipherSuiteTag (kp.value.cipherSuite) + <*> pure (KeyPackageData (raw kp)) -------------------------------------------------------------------------------- +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-10-6 data KeyPackageTBS = KeyPackageTBS - { kpuProtocolVersion :: ProtocolVersion, - kpuCipherSuite :: CipherSuite, - kpuInitKey :: ByteString, - kpuCredential :: Credential, - kpuExtensions :: [Extension] + { protocolVersion :: ProtocolVersion, + cipherSuite :: CipherSuite, + initKey :: HPKEPublicKey, + leafNode :: LeafNode, + extensions :: [Extension] } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via GenericUniform KeyPackageTBS @@ -180,36 +172,46 @@ instance ParseMLS KeyPackageTBS where KeyPackageTBS <$> parseMLS <*> parseMLS - <*> parseMLSBytes @Word16 <*> parseMLS - <*> parseMLSVector @Word32 parseMLS + <*> parseMLS + <*> parseMLSVector @VarInt parseMLS +instance SerialiseMLS KeyPackageTBS where + serialiseMLS tbs = do + serialiseMLS tbs.protocolVersion + serialiseMLS tbs.cipherSuite + serialiseMLS tbs.initKey + serialiseMLS tbs.leafNode + serialiseMLSVector @VarInt serialiseMLS tbs.extensions + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-10-6 data KeyPackage = KeyPackage - { kpTBS :: RawMLS KeyPackageTBS, - kpSignature :: ByteString + { tbs :: RawMLS KeyPackageTBS, + signature_ :: ByteString } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform KeyPackage) instance S.ToSchema KeyPackage where declareNamedSchema _ = pure (mlsSwagger "KeyPackage") -kpProtocolVersion :: KeyPackage -> ProtocolVersion -kpProtocolVersion = kpuProtocolVersion . rmValue . kpTBS +instance HasField "protocolVersion" KeyPackage ProtocolVersion where + getField = (.tbs.value.protocolVersion) -kpCipherSuite :: KeyPackage -> CipherSuite -kpCipherSuite = kpuCipherSuite . rmValue . kpTBS +instance HasField "cipherSuite" KeyPackage CipherSuite where + getField = (.tbs.value.cipherSuite) -kpInitKey :: KeyPackage -> ByteString -kpInitKey = kpuInitKey . rmValue . kpTBS +instance HasField "initKey" KeyPackage HPKEPublicKey where + getField = (.tbs.value.initKey) -kpCredential :: KeyPackage -> Credential -kpCredential = kpuCredential . rmValue . kpTBS +instance HasField "extensions" KeyPackage [Extension] where + getField = (.tbs.value.extensions) -kpExtensions :: KeyPackage -> [Extension] -kpExtensions = kpuExtensions . rmValue . kpTBS +instance HasField "leafNode" KeyPackage LeafNode where + getField = (.tbs.value.leafNode) -kpIdentity :: KeyPackage -> Either Text ClientIdentity -kpIdentity = decodeMLS' @ClientIdentity . bcIdentity . kpCredential +keyPackageIdentity :: KeyPackage -> Either Text ClientIdentity +keyPackageIdentity = decodeMLS' @ClientIdentity . (.leafNode.credential.identityData) rawKeyPackageSchema :: ValueSchema NamedSwaggerDoc (RawMLS KeyPackage) rawKeyPackageSchema = @@ -223,11 +225,9 @@ instance ParseMLS KeyPackage where parseMLS = KeyPackage <$> parseRawMLS parseMLS - <*> parseMLSBytes @Word16 - --------------------------------------------------------------------------------- + <*> parseMLSBytes @VarInt -data KeyPackageUpdate = KeyPackageUpdate - { kpupPrevious :: KeyPackageRef, - kpupNext :: KeyPackageRef - } +instance SerialiseMLS KeyPackage where + serialiseMLS kp = do + serialiseMLS kp.tbs + serialiseMLSBytes @VarInt kp.signature_ diff --git a/libs/wire-api/src/Wire/API/MLS/Keys.hs b/libs/wire-api/src/Wire/API/MLS/Keys.hs index 96841a4686..8a47539e8b 100644 --- a/libs/wire-api/src/Wire/API/MLS/Keys.hs +++ b/libs/wire-api/src/Wire/API/MLS/Keys.hs @@ -32,6 +32,7 @@ import qualified Data.Map as Map import Data.Schema import qualified Data.Swagger as S import Imports +import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential data MLSKeys = MLSKeys diff --git a/libs/wire-api/src/Wire/API/MLS/LeafNode.hs b/libs/wire-api/src/Wire/API/MLS/LeafNode.hs new file mode 100644 index 0000000000..9e362bd6c7 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/LeafNode.hs @@ -0,0 +1,201 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.LeafNode + ( LeafIndex, + LeafNode (..), + LeafNodeCore (..), + LeafNodeTBS (..), + LeafNodeTBSExtra (..), + LeafNodeSource (..), + LeafNodeSourceTag (..), + leafNodeSourceTag, + ) +where + +import Data.Binary +import qualified Data.Swagger as S +import GHC.Records +import Imports +import Test.QuickCheck +import Wire.API.MLS.Capabilities +import Wire.API.MLS.Credential +import Wire.API.MLS.Extension +import Wire.API.MLS.Group +import Wire.API.MLS.HPKEPublicKey +import Wire.API.MLS.Lifetime +import Wire.API.MLS.Serialisation +import Wire.Arbitrary + +type LeafIndex = Word32 + +-- LeafNodeCore contains fields in the intersection of LeafNode and LeafNodeTBS +-- +-- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 +data LeafNodeCore = LeafNodeCore + { encryptionKey :: HPKEPublicKey, + signatureKey :: ByteString, + credential :: Credential, + capabilities :: Capabilities, + source :: LeafNodeSource, + extensions :: [Extension] + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform LeafNodeCore) + +-- extra fields in LeafNodeTBS, but not in LeafNode +-- +-- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 +data LeafNodeTBSExtra + = LeafNodeTBSExtraKeyPackage + | LeafNodeTBSExtraUpdate GroupId LeafIndex + | LeafNodeTBSExtraCommit GroupId LeafIndex + +serialiseUntaggedLeafNodeTBSExtra :: LeafNodeTBSExtra -> Put +serialiseUntaggedLeafNodeTBSExtra LeafNodeTBSExtraKeyPackage = pure () +serialiseUntaggedLeafNodeTBSExtra (LeafNodeTBSExtraUpdate gid idx) = do + serialiseMLS gid + serialiseMLS idx +serialiseUntaggedLeafNodeTBSExtra (LeafNodeTBSExtraCommit gid idx) = do + serialiseMLS gid + serialiseMLS idx + +instance HasField "tag" LeafNodeTBSExtra LeafNodeSourceTag where + getField = \case + LeafNodeTBSExtraKeyPackage -> LeafNodeSourceKeyPackageTag + LeafNodeTBSExtraCommit _ _ -> LeafNodeSourceCommitTag + LeafNodeTBSExtraUpdate _ _ -> LeafNodeSourceUpdateTag + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 +data LeafNodeTBS = LeafNodeTBS + { core :: RawMLS LeafNodeCore, + extra :: LeafNodeTBSExtra + } + +instance SerialiseMLS LeafNodeTBS where + serialiseMLS tbs = do + serialiseMLS tbs.core + serialiseUntaggedLeafNodeTBSExtra tbs.extra + +instance ParseMLS LeafNodeCore where + parseMLS = + LeafNodeCore + <$> parseMLS + <*> parseMLSBytes @VarInt + <*> parseMLS + <*> parseMLS + <*> parseMLS + <*> parseMLSVector @VarInt parseMLS + +instance SerialiseMLS LeafNodeCore where + serialiseMLS core = do + serialiseMLS core.encryptionKey + serialiseMLSBytes @VarInt core.signatureKey + serialiseMLS core.credential + serialiseMLS core.capabilities + serialiseMLS core.source + serialiseMLSVector @VarInt serialiseMLS core.extensions + +-- | This type can only verify the signature when the LeafNodeSource is +-- LeafNodeSourceKeyPackage +-- +-- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 +data LeafNode = LeafNode + { core :: RawMLS LeafNodeCore, + signature_ :: ByteString + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform LeafNode) + +instance ParseMLS LeafNode where + parseMLS = + LeafNode + <$> parseMLS + <*> parseMLSBytes @VarInt + +instance SerialiseMLS LeafNode where + serialiseMLS ln = do + serialiseMLS ln.core + serialiseMLSBytes @VarInt ln.signature_ + +instance S.ToSchema LeafNode where + declareNamedSchema _ = pure (mlsSwagger "LeafNode") + +instance HasField "encryptionKey" LeafNode HPKEPublicKey where + getField = (.core.value.encryptionKey) + +instance HasField "signatureKey" LeafNode ByteString where + getField = (.core.value.signatureKey) + +instance HasField "credential" LeafNode Credential where + getField = (.core.value.credential) + +instance HasField "capabilities" LeafNode Capabilities where + getField = (.core.value.capabilities) + +instance HasField "source" LeafNode LeafNodeSource where + getField = (.core.value.source) + +instance HasField "extensions" LeafNode [Extension] where + getField = (.core.value.extensions) + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 +data LeafNodeSource + = LeafNodeSourceKeyPackage Lifetime + | LeafNodeSourceUpdate + | LeafNodeSourceCommit ByteString + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform LeafNodeSource) + +instance ParseMLS LeafNodeSource where + parseMLS = + parseMLS >>= \case + LeafNodeSourceKeyPackageTag -> LeafNodeSourceKeyPackage <$> parseMLS + LeafNodeSourceUpdateTag -> pure LeafNodeSourceUpdate + LeafNodeSourceCommitTag -> LeafNodeSourceCommit <$> parseMLSBytes @VarInt + +instance SerialiseMLS LeafNodeSource where + serialiseMLS (LeafNodeSourceKeyPackage lt) = do + serialiseMLS LeafNodeSourceKeyPackageTag + serialiseMLS lt + serialiseMLS LeafNodeSourceUpdate = + serialiseMLS LeafNodeSourceUpdateTag + serialiseMLS (LeafNodeSourceCommit bs) = do + serialiseMLS LeafNodeSourceCommitTag + serialiseMLSBytes @VarInt bs + +data LeafNodeSourceTag + = LeafNodeSourceKeyPackageTag + | LeafNodeSourceUpdateTag + | LeafNodeSourceCommitTag + deriving (Show, Eq, Ord, Enum, Bounded) + +instance ParseMLS LeafNodeSourceTag where + parseMLS = parseMLSEnum @Word8 "leaf node source" + +instance SerialiseMLS LeafNodeSourceTag where + serialiseMLS = serialiseMLSEnum @Word8 + +instance HasField "name" LeafNodeSourceTag Text where + getField LeafNodeSourceKeyPackageTag = "key_package" + getField LeafNodeSourceUpdateTag = "update" + getField LeafNodeSourceCommitTag = "commit" + +leafNodeSourceTag :: LeafNodeSource -> LeafNodeSourceTag +leafNodeSourceTag (LeafNodeSourceKeyPackage _) = LeafNodeSourceKeyPackageTag +leafNodeSourceTag LeafNodeSourceUpdate = LeafNodeSourceUpdateTag +leafNodeSourceTag (LeafNodeSourceCommit _) = LeafNodeSourceCommitTag diff --git a/libs/wire-api/src/Wire/API/MLS/Lifetime.hs b/libs/wire-api/src/Wire/API/MLS/Lifetime.hs new file mode 100644 index 0000000000..0f17c2978d --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/Lifetime.hs @@ -0,0 +1,48 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Wire.API.MLS.Lifetime where + +import Data.Time.Clock.POSIX +import Imports +import Test.QuickCheck +import Wire.API.MLS.Serialisation +import Wire.Arbitrary + +-- | Seconds since the UNIX epoch. +newtype Timestamp = Timestamp {timestampSeconds :: Word64} + deriving newtype (Eq, Show, Arbitrary, ParseMLS, SerialiseMLS) + +tsPOSIX :: Timestamp -> POSIXTime +tsPOSIX = fromIntegral . timestampSeconds + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-7.2-2 +data Lifetime = Lifetime + { ltNotBefore :: Timestamp, + ltNotAfter :: Timestamp + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform Lifetime + +instance ParseMLS Lifetime where + parseMLS = Lifetime <$> parseMLS <*> parseMLS + +instance SerialiseMLS Lifetime where + serialiseMLS lt = do + serialiseMLS lt.ltNotBefore + serialiseMLS lt.ltNotAfter diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 1787ceab4b..df56293ccf 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -20,224 +16,193 @@ -- with this program. If not, see . module Wire.API.MLS.Message - ( Message (..), - msgGroupId, - msgEpoch, - msgSender, - msgPayload, - MessageTBS (..), - MessageExtraFields (..), + ( -- * MLS Message types WireFormatTag (..), - SWireFormatTag (..), - SomeMessage (..), - ContentType (..), - MessagePayload (..), + Message (..), + mkMessage, + MessageContent (..), + PublicMessage (..), + PrivateMessage (..), + FramedContent (..), + FramedContentData (..), + FramedContentDataTag (..), + FramedContentTBS (..), + FramedContentAuthData (..), Sender (..), - MLSPlainTextSym0, - MLSCipherTextSym0, - MLSMessageSendingStatus (..), - KnownFormatTag (..), UnreachableUsers (..), + + -- * Utilities verifyMessageSignature, - mkSignedMessage, + + -- * Servant types + MLSMessageSendingStatus (..), ) where import Control.Lens ((?~)) -import Crypto.PubKey.Ed25519 import qualified Data.Aeson as A import Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteArray as BA import Data.Id import Data.Json.Util -import Data.Kind import Data.Qualified import Data.Schema -import Data.Singletons.TH import qualified Data.Swagger as S +import GHC.Records import Imports -import Test.QuickCheck hiding (label) import Wire.API.Event.Conversation import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.Epoch import Wire.API.MLS.Group +import Wire.API.MLS.GroupInfo import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.Proposal +import Wire.API.MLS.ProtocolVersion import Wire.API.MLS.Serialisation -import Wire.Arbitrary (GenericUniform (..)) +import Wire.API.MLS.Welcome +import Wire.Arbitrary -data WireFormatTag = MLSPlainText | MLSCipherText - deriving (Bounded, Enum, Eq, Show) - -$(genSingletons [''WireFormatTag]) +data WireFormatTag + = WireFormatPublicTag + | WireFormatPrivateTag + | WireFormatWelcomeTag + | WireFormatGroupInfoTag + | WireFormatKeyPackageTag + deriving (Enum, Bounded, Eq, Show) instance ParseMLS WireFormatTag where - parseMLS = parseMLSEnum @Word8 "wire format" - -data family MessageExtraFields (tag :: WireFormatTag) :: Type - -data instance MessageExtraFields 'MLSPlainText = MessageExtraFields - { msgSignature :: ByteString, - msgConfirmation :: Maybe ByteString, - msgMembership :: Maybe ByteString - } - deriving (Generic) - deriving (Arbitrary) via (GenericUniform (MessageExtraFields 'MLSPlainText)) + parseMLS = parseMLSEnum @Word16 "wire format" -instance ParseMLS (MessageExtraFields 'MLSPlainText) where - parseMLS = - MessageExtraFields - <$> label "msgSignature" (parseMLSBytes @Word16) - <*> label "msgConfirmation" (parseMLSOptional (parseMLSBytes @Word8)) - <*> label "msgMembership" (parseMLSOptional (parseMLSBytes @Word8)) - -instance SerialiseMLS (MessageExtraFields 'MLSPlainText) where - serialiseMLS (MessageExtraFields sig mconf mmemb) = do - serialiseMLSBytes @Word16 sig - serialiseMLSOptional (serialiseMLSBytes @Word8) mconf - serialiseMLSOptional (serialiseMLSBytes @Word8) mmemb - -data instance MessageExtraFields 'MLSCipherText = NoExtraFields - -instance ParseMLS (MessageExtraFields 'MLSCipherText) where - parseMLS = pure NoExtraFields - -deriving instance Eq (MessageExtraFields 'MLSPlainText) +instance SerialiseMLS WireFormatTag where + serialiseMLS = serialiseMLSEnum @Word16 -deriving instance Eq (MessageExtraFields 'MLSCipherText) - -deriving instance Show (MessageExtraFields 'MLSPlainText) - -deriving instance Show (MessageExtraFields 'MLSCipherText) - -data Message (tag :: WireFormatTag) = Message - { msgTBS :: RawMLS (MessageTBS tag), - msgExtraFields :: MessageExtraFields tag +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 +data Message = Message + { protocolVersion :: ProtocolVersion, + content :: MessageContent } + deriving (Eq, Show) -deriving instance Eq (Message 'MLSPlainText) - -deriving instance Eq (Message 'MLSCipherText) - -deriving instance Show (Message 'MLSPlainText) - -deriving instance Show (Message 'MLSCipherText) - -instance ParseMLS (Message 'MLSPlainText) where - parseMLS = Message <$> label "tbs" parseMLS <*> label "MessageExtraFields" parseMLS - -instance SerialiseMLS (Message 'MLSPlainText) where - serialiseMLS (Message msgTBS msgExtraFields) = do - putByteString (rmRaw msgTBS) - serialiseMLS msgExtraFields - -instance ParseMLS (Message 'MLSCipherText) where - parseMLS = Message <$> parseMLS <*> parseMLS - --- | This corresponds to the format byte at the beginning of a message. --- It does not convey any information, but it needs to be present in --- order for signature verification to work. -data KnownFormatTag (tag :: WireFormatTag) = KnownFormatTag - -instance ParseMLS (KnownFormatTag tag) where - parseMLS = parseMLS @WireFormatTag $> KnownFormatTag - -instance SerialiseMLS (KnownFormatTag 'MLSPlainText) where - serialiseMLS _ = put (fromMLSEnum @Word8 MLSPlainText) - -instance SerialiseMLS (KnownFormatTag 'MLSCipherText) where - serialiseMLS _ = put (fromMLSEnum @Word8 MLSCipherText) - -deriving instance Eq (KnownFormatTag 'MLSPlainText) +mkMessage :: MessageContent -> Message +mkMessage = Message defaultProtocolVersion -deriving instance Eq (KnownFormatTag 'MLSCipherText) +instance ParseMLS Message where + parseMLS = + Message + <$> parseMLS + <*> parseMLS + +instance SerialiseMLS Message where + serialiseMLS msg = do + serialiseMLS msg.protocolVersion + serialiseMLS msg.content + +instance HasField "wireFormat" Message WireFormatTag where + getField = (.content.wireFormat) + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 +data MessageContent + = MessagePrivate (RawMLS PrivateMessage) + | MessagePublic PublicMessage + | MessageWelcome (RawMLS Welcome) + | MessageGroupInfo (RawMLS GroupInfo) + | MessageKeyPackage (RawMLS KeyPackage) + deriving (Eq, Show) -deriving instance Show (KnownFormatTag 'MLSPlainText) +instance HasField "wireFormat" MessageContent WireFormatTag where + getField (MessagePrivate _) = WireFormatPrivateTag + getField (MessagePublic _) = WireFormatPublicTag + getField (MessageWelcome _) = WireFormatWelcomeTag + getField (MessageGroupInfo _) = WireFormatGroupInfoTag + getField (MessageKeyPackage _) = WireFormatKeyPackageTag -deriving instance Show (KnownFormatTag 'MLSCipherText) +instance ParseMLS MessageContent where + parseMLS = + parseMLS >>= \case + WireFormatPrivateTag -> MessagePrivate <$> parseMLS + WireFormatPublicTag -> MessagePublic <$> parseMLS + WireFormatWelcomeTag -> MessageWelcome <$> parseMLS + WireFormatGroupInfoTag -> MessageGroupInfo <$> parseMLS + WireFormatKeyPackageTag -> MessageKeyPackage <$> parseMLS + +instance SerialiseMLS MessageContent where + serialiseMLS (MessagePrivate msg) = do + serialiseMLS WireFormatPrivateTag + serialiseMLS msg + serialiseMLS (MessagePublic msg) = do + serialiseMLS WireFormatPublicTag + serialiseMLS msg + serialiseMLS (MessageWelcome welcome) = do + serialiseMLS WireFormatWelcomeTag + serialiseMLS welcome + serialiseMLS (MessageGroupInfo gi) = do + serialiseMLS WireFormatGroupInfoTag + serialiseMLS gi + serialiseMLS (MessageKeyPackage kp) = do + serialiseMLS WireFormatKeyPackageTag + serialiseMLS kp + +instance S.ToSchema Message where + declareNamedSchema _ = pure (mlsSwagger "MLSMessage") -data MessageTBS (tag :: WireFormatTag) = MessageTBS - { tbsMsgFormat :: KnownFormatTag tag, - tbsMsgGroupId :: GroupId, - tbsMsgEpoch :: Epoch, - tbsMsgAuthData :: ByteString, - tbsMsgSender :: Sender tag, - tbsMsgPayload :: MessagePayload tag +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6.2-2 +data PublicMessage = PublicMessage + { content :: RawMLS FramedContent, + authData :: RawMLS FramedContentAuthData, + -- Present iff content.value.sender is of type Member. + -- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6.2-4 + membershipTag :: Maybe ByteString } + deriving (Eq, Show) -msgGroupId :: Message tag -> GroupId -msgGroupId = tbsMsgGroupId . rmValue . msgTBS - -msgEpoch :: Message tag -> Epoch -msgEpoch = tbsMsgEpoch . rmValue . msgTBS - -msgSender :: Message tag -> Sender tag -msgSender = tbsMsgSender . rmValue . msgTBS - -msgPayload :: Message tag -> MessagePayload tag -msgPayload = tbsMsgPayload . rmValue . msgTBS - -instance ParseMLS (MessageTBS 'MLSPlainText) where +instance ParseMLS PublicMessage where parseMLS = do - f <- parseMLS - g <- parseMLS - e <- parseMLS - s <- parseMLS - d <- parseMLSBytes @Word32 - MessageTBS f g e d s <$> parseMLS - -instance ParseMLS (MessageTBS 'MLSCipherText) where - parseMLS = do - f <- parseMLS - g <- parseMLS - e <- parseMLS - ct <- parseMLS - d <- parseMLSBytes @Word32 - s <- parseMLS - p <- parseMLSBytes @Word32 - pure $ MessageTBS f g e d s (CipherText ct p) - -instance SerialiseMLS (MessageTBS 'MLSPlainText) where - serialiseMLS (MessageTBS f g e d s p) = do - serialiseMLS f - serialiseMLS g - serialiseMLS e - serialiseMLS s - serialiseMLSBytes @Word32 d - serialiseMLS p - -deriving instance Eq (MessageTBS 'MLSPlainText) - -deriving instance Eq (MessageTBS 'MLSCipherText) - -deriving instance Show (MessageTBS 'MLSPlainText) - -deriving instance Show (MessageTBS 'MLSCipherText) - -data SomeMessage where - SomeMessage :: Sing tag -> Message tag -> SomeMessage - -instance S.ToSchema SomeMessage where - declareNamedSchema _ = pure (mlsSwagger "MLSMessage") - -instance ParseMLS SomeMessage where - parseMLS = - lookAhead parseMLS >>= \case - MLSPlainText -> SomeMessage SMLSPlainText <$> parseMLS - MLSCipherText -> SomeMessage SMLSCipherText <$> parseMLS - -data family Sender (tag :: WireFormatTag) :: Type - -data instance Sender 'MLSCipherText = EncryptedSender {esData :: ByteString} + content <- parseMLS + authData <- parseRawMLS (parseFramedContentAuthData (framedContentDataTag (content.value.content))) + membershipTag <- case content.value.sender of + SenderMember _ -> Just <$> parseMLSBytes @VarInt + _ -> pure Nothing + pure + PublicMessage + { content = content, + authData = authData, + membershipTag = membershipTag + } + +instance SerialiseMLS PublicMessage where + serialiseMLS msg = do + serialiseMLS msg.content + serialiseMLS msg.authData + traverse_ (serialiseMLSBytes @VarInt) msg.membershipTag + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6.3.1-2 +data PrivateMessage = PrivateMessage + { groupId :: GroupId, + epoch :: Epoch, + tag :: FramedContentDataTag, + authenticatedData :: ByteString, + encryptedSenderData :: ByteString, + ciphertext :: ByteString + } deriving (Eq, Show) -instance ParseMLS (Sender 'MLSCipherText) where - parseMLS = EncryptedSender <$> parseMLSBytes @Word8 - -data SenderTag = MemberSenderTag | PreconfiguredSenderTag | NewMemberSenderTag +instance ParseMLS PrivateMessage where + parseMLS = + PrivateMessage + <$> parseMLS + <*> parseMLS + <*> parseMLS + <*> parseMLSBytes @VarInt + <*> parseMLSBytes @VarInt + <*> parseMLSBytes @VarInt + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 +data SenderTag + = SenderMemberTag + | SenderExternalTag + | SenderNewMemberProposalTag + | SenderNewMemberCommitTag deriving (Bounded, Enum, Show, Eq) instance ParseMLS SenderTag where @@ -246,77 +211,170 @@ instance ParseMLS SenderTag where instance SerialiseMLS SenderTag where serialiseMLS = serialiseMLSEnum @Word8 --- NOTE: according to the spec, the preconfigured sender case contains a --- bytestring, not a u32. However, as of 2022-08-02, the openmls fork used by --- the clients is using a u32 here. -data instance Sender 'MLSPlainText - = MemberSender KeyPackageRef - | PreconfiguredSender Word32 - | NewMemberSender +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 +data Sender + = SenderMember LeafIndex + | SenderExternal Word32 + | SenderNewMemberProposal + | SenderNewMemberCommit deriving (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform Sender) -instance ParseMLS (Sender 'MLSPlainText) where +instance ParseMLS Sender where parseMLS = parseMLS >>= \case - MemberSenderTag -> MemberSender <$> parseMLS - PreconfiguredSenderTag -> PreconfiguredSender <$> get - NewMemberSenderTag -> pure NewMemberSender - -instance SerialiseMLS (Sender 'MLSPlainText) where - serialiseMLS (MemberSender r) = do - serialiseMLS MemberSenderTag - serialiseMLS r - serialiseMLS (PreconfiguredSender x) = do - serialiseMLS PreconfiguredSenderTag - put x - serialiseMLS NewMemberSender = serialiseMLS NewMemberSenderTag - -data family MessagePayload (tag :: WireFormatTag) :: Type - -deriving instance Eq (MessagePayload 'MLSPlainText) - -deriving instance Eq (MessagePayload 'MLSCipherText) - -deriving instance Show (MessagePayload 'MLSPlainText) - -deriving instance Show (MessagePayload 'MLSCipherText) - -data instance MessagePayload 'MLSCipherText = CipherText - { msgContentType :: Word8, - msgCipherText :: ByteString + SenderMemberTag -> SenderMember <$> parseMLS + SenderExternalTag -> SenderExternal <$> parseMLS + SenderNewMemberProposalTag -> pure SenderNewMemberProposal + SenderNewMemberCommitTag -> pure SenderNewMemberCommit + +instance SerialiseMLS Sender where + serialiseMLS (SenderMember i) = do + serialiseMLS SenderMemberTag + serialiseMLS i + serialiseMLS (SenderExternal w) = do + serialiseMLS SenderExternalTag + serialiseMLS w + serialiseMLS SenderNewMemberProposal = + serialiseMLS SenderNewMemberProposalTag + serialiseMLS SenderNewMemberCommit = + serialiseMLS SenderNewMemberCommitTag + +needsGroupContext :: Sender -> Bool +needsGroupContext (SenderMember _) = True +needsGroupContext (SenderExternal _) = True +needsGroupContext _ = False + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 +data FramedContent = FramedContent + { groupId :: GroupId, + epoch :: Epoch, + sender :: Sender, + authenticatedData :: ByteString, + content :: FramedContentData } + deriving (Eq, Show) -data ContentType - = ApplicationMessageTag - | ProposalMessageTag - | CommitMessageTag - deriving (Bounded, Enum, Eq, Show) +instance ParseMLS FramedContent where + parseMLS = + FramedContent + <$> parseMLS + <*> parseMLS + <*> parseMLS + <*> parseMLSBytes @VarInt + <*> parseMLS + +instance SerialiseMLS FramedContent where + serialiseMLS fc = do + serialiseMLS fc.groupId + serialiseMLS fc.epoch + serialiseMLS fc.sender + serialiseMLSBytes @VarInt fc.authenticatedData + serialiseMLS fc.content + +data FramedContentDataTag + = FramedContentApplicationDataTag + | FramedContentProposalTag + | FramedContentCommitTag + deriving (Enum, Bounded, Eq, Ord, Show) + +instance ParseMLS FramedContentDataTag where + parseMLS = parseMLSEnum @Word8 "ContentType" + +instance SerialiseMLS FramedContentDataTag where + serialiseMLS = serialiseMLSEnum @Word8 -instance ParseMLS ContentType where - parseMLS = parseMLSEnum @Word8 "content type" +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 +data FramedContentData + = FramedContentApplicationData ByteString + | FramedContentProposal (RawMLS Proposal) + | FramedContentCommit (RawMLS Commit) + deriving (Eq, Show) -data instance MessagePayload 'MLSPlainText - = ApplicationMessage ByteString - | ProposalMessage (RawMLS Proposal) - | CommitMessage Commit +framedContentDataTag :: FramedContentData -> FramedContentDataTag +framedContentDataTag (FramedContentApplicationData _) = FramedContentApplicationDataTag +framedContentDataTag (FramedContentProposal _) = FramedContentProposalTag +framedContentDataTag (FramedContentCommit _) = FramedContentCommitTag -instance ParseMLS (MessagePayload 'MLSPlainText) where +instance ParseMLS FramedContentData where parseMLS = parseMLS >>= \case - ApplicationMessageTag -> ApplicationMessage <$> parseMLSBytes @Word32 - ProposalMessageTag -> ProposalMessage <$> parseMLS - CommitMessageTag -> CommitMessage <$> parseMLS + FramedContentApplicationDataTag -> + FramedContentApplicationData <$> parseMLSBytes @VarInt + FramedContentProposalTag -> FramedContentProposal <$> parseMLS + FramedContentCommitTag -> FramedContentCommit <$> parseMLS + +instance SerialiseMLS FramedContentData where + serialiseMLS (FramedContentApplicationData bs) = do + serialiseMLS FramedContentApplicationDataTag + serialiseMLSBytes @VarInt bs + serialiseMLS (FramedContentProposal prop) = do + serialiseMLS FramedContentProposalTag + serialiseMLS prop + serialiseMLS (FramedContentCommit commit) = do + serialiseMLS FramedContentCommitTag + serialiseMLS commit + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6.1-2 +data FramedContentTBS = FramedContentTBS + { protocolVersion :: ProtocolVersion, + wireFormat :: WireFormatTag, + content :: RawMLS FramedContent, + groupContext :: Maybe (RawMLS GroupContext) + } + deriving (Eq, Show) -instance SerialiseMLS ContentType where - serialiseMLS = serialiseMLSEnum @Word8 +instance SerialiseMLS FramedContentTBS where + serialiseMLS tbs = do + serialiseMLS tbs.protocolVersion + serialiseMLS tbs.wireFormat + serialiseMLS tbs.content + traverse_ serialiseMLS tbs.groupContext + +framedContentTBS :: RawMLS GroupContext -> RawMLS FramedContent -> FramedContentTBS +framedContentTBS ctx msgContent = + FramedContentTBS + { protocolVersion = defaultProtocolVersion, + wireFormat = WireFormatPublicTag, + content = msgContent, + groupContext = guard (needsGroupContext msgContent.value.sender) $> ctx + } + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6.1-2 +data FramedContentAuthData = FramedContentAuthData + { signature_ :: ByteString, + -- Present iff it is part of a commit. + confirmationTag :: Maybe ByteString + } + deriving (Eq, Show) -instance SerialiseMLS (MessagePayload 'MLSPlainText) where - serialiseMLS (ProposalMessage raw) = do - serialiseMLS ProposalMessageTag - putByteString (rmRaw raw) - -- We do not need to serialise Commit and Application messages, - -- so the next case is left as a stub - serialiseMLS _ = pure () +parseFramedContentAuthData :: FramedContentDataTag -> Get FramedContentAuthData +parseFramedContentAuthData t = do + sig <- parseMLSBytes @VarInt + confirmationTag <- case t of + FramedContentCommitTag -> Just <$> parseMLSBytes @VarInt + _ -> pure Nothing + pure (FramedContentAuthData sig confirmationTag) + +instance SerialiseMLS FramedContentAuthData where + serialiseMLS ad = do + serialiseMLSBytes @VarInt ad.signature_ + traverse_ (serialiseMLSBytes @VarInt) ad.confirmationTag + +verifyMessageSignature :: + RawMLS GroupContext -> + RawMLS FramedContent -> + RawMLS FramedContentAuthData -> + ByteString -> + Bool +verifyMessageSignature ctx msgContent authData pubkey = isJust $ do + let tbs = mkRawMLS (framedContentTBS ctx msgContent) + sig = authData.value.signature_ + cs <- cipherSuiteTag ctx.value.cipherSuite + guard $ csVerifySignature cs pubkey tbs sig + +-------------------------------------------------------------------------------- +-- Servant newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: [Qualified UserId]} deriving stock (Eq, Show) @@ -357,28 +415,3 @@ instance ToSchema MLSMessageSendingStatus where "failed_to_send" (description ?~ "List of federated users who could not be reached and did not receive the message") schema - -verifyMessageSignature :: CipherSuiteTag -> Message 'MLSPlainText -> ByteString -> Bool -verifyMessageSignature cs msg pubkey = - csVerifySignature cs pubkey (rmRaw (msgTBS msg)) (msgSignature (msgExtraFields msg)) - -mkSignedMessage :: - SecretKey -> - PublicKey -> - GroupId -> - Epoch -> - MessagePayload 'MLSPlainText -> - Message 'MLSPlainText -mkSignedMessage priv pub gid epoch payload = - let tbs = - mkRawMLS $ - MessageTBS - { tbsMsgFormat = KnownFormatTag, - tbsMsgGroupId = gid, - tbsMsgEpoch = epoch, - tbsMsgAuthData = mempty, - tbsMsgSender = PreconfiguredSender 0, - tbsMsgPayload = payload - } - sig = BA.convert $ sign priv pub (rmRaw tbs) - in Message tbs (MessageExtraFields sig Nothing Nothing) diff --git a/libs/wire-api/src/Wire/API/MLS/Proposal.hs b/libs/wire-api/src/Wire/API/MLS/Proposal.hs index 1226811c6e..1ae2ef989a 100644 --- a/libs/wire-api/src/Wire/API/MLS/Proposal.hs +++ b/libs/wire-api/src/Wire/API/MLS/Proposal.hs @@ -1,4 +1,6 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -15,54 +17,46 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# LANGUAGE TemplateHaskell #-} module Wire.API.MLS.Proposal where import Cassandra -import Control.Arrow import Control.Lens (makePrisms) import Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString.Lazy as LBS +import Data.ByteString as B +import GHC.Records import Imports +import Test.QuickCheck import Wire.API.MLS.CipherSuite -import Wire.API.MLS.Context import Wire.API.MLS.Extension import Wire.API.MLS.Group import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode +import Wire.API.MLS.ProposalTag +import Wire.API.MLS.ProtocolVersion import Wire.API.MLS.Serialisation import Wire.Arbitrary -data ProposalTag - = AddProposalTag - | UpdateProposalTag - | RemoveProposalTag - | PreSharedKeyProposalTag - | ReInitProposalTag - | ExternalInitProposalTag - | AppAckProposalTag - | GroupContextExtensionsProposalTag - deriving stock (Bounded, Enum, Eq, Generic, Show) - deriving (Arbitrary) via GenericUniform ProposalTag - -instance ParseMLS ProposalTag where - parseMLS = parseMLSEnum @Word16 "proposal type" - -instance SerialiseMLS ProposalTag where - serialiseMLS = serialiseMLSEnum @Word16 - +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.1-2 data Proposal = AddProposal (RawMLS KeyPackage) - | UpdateProposal KeyPackage - | RemoveProposal KeyPackageRef - | PreSharedKeyProposal PreSharedKeyID - | ReInitProposal ReInit + | UpdateProposal (RawMLS LeafNode) + | RemoveProposal LeafIndex + | PreSharedKeyProposal (RawMLS PreSharedKeyID) + | ReInitProposal (RawMLS ReInit) | ExternalInitProposal ByteString - | AppAckProposal [MessageRange] | GroupContextExtensionsProposal [Extension] - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform Proposal) + +instance HasField "tag" Proposal ProposalTag where + getField (AddProposal _) = AddProposalTag + getField (UpdateProposal _) = UpdateProposalTag + getField (RemoveProposal _) = RemoveProposalTag + getField (PreSharedKeyProposal _) = PreSharedKeyProposalTag + getField (ReInitProposal _) = ReInitProposalTag + getField (ExternalInitProposal _) = ExternalInitProposalTag + getField (GroupContextExtensionsProposal _) = GroupContextExtensionsProposalTag instance ParseMLS Proposal where parseMLS = @@ -72,57 +66,86 @@ instance ParseMLS Proposal where RemoveProposalTag -> RemoveProposal <$> parseMLS PreSharedKeyProposalTag -> PreSharedKeyProposal <$> parseMLS ReInitProposalTag -> ReInitProposal <$> parseMLS - ExternalInitProposalTag -> ExternalInitProposal <$> parseMLSBytes @Word16 - AppAckProposalTag -> AppAckProposal <$> parseMLSVector @Word32 parseMLS + ExternalInitProposalTag -> ExternalInitProposal <$> parseMLSBytes @VarInt GroupContextExtensionsProposalTag -> - GroupContextExtensionsProposal <$> parseMLSVector @Word32 parseMLS - -mkRemoveProposal :: KeyPackageRef -> RawMLS Proposal -mkRemoveProposal ref = RawMLS bytes (RemoveProposal ref) - where - bytes = LBS.toStrict . runPut $ do - serialiseMLS RemoveProposalTag - serialiseMLS ref - -serialiseAppAckProposal :: [MessageRange] -> Put -serialiseAppAckProposal mrs = do - serialiseMLS AppAckProposalTag - serialiseMLSVector @Word32 serialiseMLS mrs - -mkAppAckProposal :: [MessageRange] -> RawMLS Proposal -mkAppAckProposal = uncurry RawMLS . (bytes &&& AppAckProposal) - where - bytes = LBS.toStrict . runPut . serialiseAppAckProposal - --- | Compute the proposal ref given a ciphersuite and the raw proposal data. -proposalRef :: CipherSuiteTag -> RawMLS Proposal -> ProposalRef -proposalRef cs = - ProposalRef - . csHash cs proposalContext - . rmRaw - + GroupContextExtensionsProposal <$> parseMLSVector @VarInt parseMLS + +instance SerialiseMLS Proposal where + serialiseMLS (AddProposal kp) = do + serialiseMLS AddProposalTag + serialiseMLS kp + serialiseMLS (UpdateProposal ln) = do + serialiseMLS UpdateProposalTag + serialiseMLS ln + serialiseMLS (RemoveProposal i) = do + serialiseMLS RemoveProposalTag + serialiseMLS i + serialiseMLS (PreSharedKeyProposal k) = do + serialiseMLS PreSharedKeyProposalTag + serialiseMLS k + serialiseMLS (ReInitProposal ri) = do + serialiseMLS ReInitProposalTag + serialiseMLS ri + serialiseMLS (ExternalInitProposal ko) = do + serialiseMLS ExternalInitProposalTag + serialiseMLSBytes @VarInt ko + serialiseMLS (GroupContextExtensionsProposal es) = do + serialiseMLS GroupContextExtensionsProposalTag + serialiseMLSVector @VarInt serialiseMLS es + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-8.4-6 data PreSharedKeyTag = ExternalKeyTag | ResumptionKeyTag deriving (Bounded, Enum, Eq, Show) instance ParseMLS PreSharedKeyTag where - parseMLS = parseMLSEnum @Word16 "PreSharedKeyID type" + parseMLS = parseMLSEnum @Word8 "PreSharedKeyID type" -data PreSharedKeyID = ExternalKeyID ByteString | ResumptionKeyID Resumption - deriving stock (Eq, Show) +instance SerialiseMLS PreSharedKeyTag where + serialiseMLS = serialiseMLSEnum @Word8 -instance ParseMLS PreSharedKeyID where +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-8.4-6 +data PreSharedKeyIDCore = ExternalKeyID ByteString | ResumptionKeyID Resumption + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform PreSharedKeyIDCore) + +instance ParseMLS PreSharedKeyIDCore where parseMLS = do t <- parseMLS case t of - ExternalKeyTag -> ExternalKeyID <$> parseMLSBytes @Word8 + ExternalKeyTag -> ExternalKeyID <$> parseMLSBytes @VarInt ResumptionKeyTag -> ResumptionKeyID <$> parseMLS +instance SerialiseMLS PreSharedKeyIDCore where + serialiseMLS (ExternalKeyID bs) = do + serialiseMLS ExternalKeyTag + serialiseMLSBytes @VarInt bs + serialiseMLS (ResumptionKeyID r) = do + serialiseMLS ResumptionKeyTag + serialiseMLS r + +data PreSharedKeyID = PreSharedKeyID + { core :: PreSharedKeyIDCore, + nonce :: ByteString + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform PreSharedKeyID) + +instance ParseMLS PreSharedKeyID where + parseMLS = PreSharedKeyID <$> parseMLS <*> parseMLSBytes @VarInt + +instance SerialiseMLS PreSharedKeyID where + serialiseMLS psk = do + serialiseMLS psk.core + serialiseMLSBytes @VarInt psk.nonce + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-8.4-6 data Resumption = Resumption - { resUsage :: Word8, - resGroupId :: GroupId, - resEpoch :: Word64 + { usage :: Word8, + groupId :: GroupId, + epoch :: Word64 } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform Resumption) instance ParseMLS Resumption where parseMLS = @@ -131,13 +154,21 @@ instance ParseMLS Resumption where <*> parseMLS <*> parseMLS +instance SerialiseMLS Resumption where + serialiseMLS r = do + serialiseMLS r.usage + serialiseMLS r.groupId + serialiseMLS r.epoch + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.1.5-2 data ReInit = ReInit - { riGroupId :: GroupId, - riProtocolVersion :: ProtocolVersion, - riCipherSuite :: CipherSuite, - riExtensions :: [Extension] + { groupId :: GroupId, + protocolVersion :: ProtocolVersion, + cipherSuite :: CipherSuite, + extensions :: [Extension] } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform ReInit) instance ParseMLS ReInit where parseMLS = @@ -145,12 +176,19 @@ instance ParseMLS ReInit where <$> parseMLS <*> parseMLS <*> parseMLS - <*> parseMLSVector @Word32 parseMLS + <*> parseMLSVector @VarInt parseMLS + +instance SerialiseMLS ReInit where + serialiseMLS ri = do + serialiseMLS ri.groupId + serialiseMLS ri.protocolVersion + serialiseMLS ri.cipherSuite + serialiseMLSVector @VarInt serialiseMLS ri.extensions data MessageRange = MessageRange - { mrSender :: KeyPackageRef, - mrFirstGeneration :: Word32, - mrLastGeneration :: Word32 + { sender :: KeyPackageRef, + firstGeneration :: Word32, + lastGeneration :: Word32 } deriving stock (Eq, Show) @@ -166,18 +204,24 @@ instance ParseMLS MessageRange where instance SerialiseMLS MessageRange where serialiseMLS MessageRange {..} = do - serialiseMLS mrSender - serialiseMLS mrFirstGeneration - serialiseMLS mrLastGeneration + serialiseMLS sender + serialiseMLS firstGeneration + serialiseMLS lastGeneration +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.4-3 data ProposalOrRefTag = InlineTag | RefTag deriving stock (Bounded, Enum, Eq, Show) instance ParseMLS ProposalOrRefTag where parseMLS = parseMLSEnum @Word8 "ProposalOrRef type" +instance SerialiseMLS ProposalOrRefTag where + serialiseMLS = serialiseMLSEnum @Word8 + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.4-3 data ProposalOrRef = Inline Proposal | Ref ProposalRef - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform ProposalOrRef) instance ParseMLS ProposalOrRef where parseMLS = @@ -185,11 +229,23 @@ instance ParseMLS ProposalOrRef where InlineTag -> Inline <$> parseMLS RefTag -> Ref <$> parseMLS +instance SerialiseMLS ProposalOrRef where + serialiseMLS (Inline p) = do + serialiseMLS InlineTag + serialiseMLS p + serialiseMLS (Ref r) = do + serialiseMLS RefTag + serialiseMLS r + newtype ProposalRef = ProposalRef {unProposalRef :: ByteString} - deriving stock (Eq, Show, Ord) + deriving stock (Eq, Show, Ord, Generic) + deriving newtype (Arbitrary) instance ParseMLS ProposalRef where - parseMLS = ProposalRef <$> getByteString 16 + parseMLS = ProposalRef <$> parseMLSBytes @VarInt + +instance SerialiseMLS ProposalRef where + serialiseMLS = serialiseMLSBytes @VarInt . unProposalRef makePrisms ''ProposalOrRef diff --git a/libs/wire-api/src/Wire/API/MLS/ProposalTag.hs b/libs/wire-api/src/Wire/API/MLS/ProposalTag.hs new file mode 100644 index 0000000000..8e7d8b3670 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/ProposalTag.hs @@ -0,0 +1,40 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.ProposalTag where + +import Data.Binary +import Imports +import Wire.API.MLS.Serialisation +import Wire.Arbitrary + +data ProposalTag + = AddProposalTag + | UpdateProposalTag + | RemoveProposalTag + | PreSharedKeyProposalTag + | ReInitProposalTag + | ExternalInitProposalTag + | GroupContextExtensionsProposalTag + deriving stock (Bounded, Enum, Eq, Ord, Generic, Show) + deriving (Arbitrary) via GenericUniform ProposalTag + +instance ParseMLS ProposalTag where + parseMLS = parseMLSEnum @Word16 "proposal type" + +instance SerialiseMLS ProposalTag where + serialiseMLS = serialiseMLSEnum @Word16 diff --git a/libs/wire-api/src/Wire/API/MLS/ProtocolVersion.hs b/libs/wire-api/src/Wire/API/MLS/ProtocolVersion.hs new file mode 100644 index 0000000000..9d8a022068 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/ProtocolVersion.hs @@ -0,0 +1,53 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Wire.API.MLS.ProtocolVersion + ( ProtocolVersion (..), + ProtocolVersionTag (..), + pvTag, + protocolVersionFromTag, + defaultProtocolVersion, + ) +where + +import Data.Binary +import Imports +import Wire.API.MLS.Serialisation +import Wire.Arbitrary + +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 +newtype ProtocolVersion = ProtocolVersion {pvNumber :: Word16} + deriving newtype (Eq, Ord, Show, Binary, Arbitrary, ParseMLS, SerialiseMLS) + +data ProtocolVersionTag = ProtocolMLS10 | ProtocolMLSDraft11 + deriving stock (Bounded, Enum, Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform ProtocolVersionTag + +pvTag :: ProtocolVersion -> Maybe ProtocolVersionTag +pvTag (ProtocolVersion v) = case v of + 1 -> pure ProtocolMLS10 + -- used by openmls + 200 -> pure ProtocolMLSDraft11 + _ -> Nothing + +protocolVersionFromTag :: ProtocolVersionTag -> ProtocolVersion +protocolVersionFromTag ProtocolMLS10 = ProtocolVersion 1 +protocolVersionFromTag ProtocolMLSDraft11 = ProtocolVersion 200 + +defaultProtocolVersion :: ProtocolVersion +defaultProtocolVersion = protocolVersionFromTag ProtocolMLS10 diff --git a/libs/wire-api/src/Wire/API/MLS/PublicGroupState.hs b/libs/wire-api/src/Wire/API/MLS/PublicGroupState.hs deleted file mode 100644 index 38772d5b00..0000000000 --- a/libs/wire-api/src/Wire/API/MLS/PublicGroupState.hs +++ /dev/null @@ -1,121 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . -{-# LANGUAGE RecordWildCards #-} - -module Wire.API.MLS.PublicGroupState where - -import Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Swagger as S -import Imports -import Test.QuickCheck hiding (label) -import Wire.API.MLS.CipherSuite -import Wire.API.MLS.Epoch -import Wire.API.MLS.Extension -import Wire.API.MLS.Group -import Wire.API.MLS.KeyPackage -import Wire.API.MLS.Serialisation -import Wire.Arbitrary - -data PublicGroupStateTBS = PublicGroupStateTBS - { pgsVersion :: ProtocolVersion, - pgsCipherSuite :: CipherSuite, - pgsGroupId :: GroupId, - pgsEpoch :: Epoch, - pgsTreeHash :: ByteString, - pgsInterimTranscriptHash :: ByteString, - pgsConfirmedInterimTranscriptHash :: ByteString, - pgsGroupContextExtensions :: ByteString, - pgsOtherExtensions :: ByteString, - pgsExternalPub :: ByteString, - pgsSigner :: KeyPackageRef - } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform PublicGroupStateTBS) - -instance ParseMLS PublicGroupStateTBS where - parseMLS = - PublicGroupStateTBS - <$> label "pgsVersion" parseMLS - <*> label "pgsCipherSuite" parseMLS - <*> label "pgsGroupId" parseMLS - <*> label "pgsEpoch" parseMLS - <*> label "pgsTreeHash" (parseMLSBytes @Word8) - <*> label "pgsInterimTranscriptHash" (parseMLSBytes @Word8) - <*> label "pgsConfirmedInterimTranscriptHash" (parseMLSBytes @Word8) - <*> label "pgsGroupContextExtensions" (parseMLSBytes @Word32) - <*> label "pgsOtherExtensions" (parseMLSBytes @Word32) - <*> label "pgsExternalPub" (parseMLSBytes @Word16) - <*> label "pgsSigner" parseMLS - -instance SerialiseMLS PublicGroupStateTBS where - serialiseMLS (PublicGroupStateTBS {..}) = do - serialiseMLS pgsVersion - serialiseMLS pgsCipherSuite - serialiseMLS pgsGroupId - serialiseMLS pgsEpoch - serialiseMLSBytes @Word8 pgsTreeHash - serialiseMLSBytes @Word8 pgsInterimTranscriptHash - serialiseMLSBytes @Word8 pgsConfirmedInterimTranscriptHash - serialiseMLSBytes @Word32 pgsGroupContextExtensions - serialiseMLSBytes @Word32 pgsOtherExtensions - serialiseMLSBytes @Word16 pgsExternalPub - serialiseMLS pgsSigner - -data PublicGroupState = PublicGroupState - { pgTBS :: RawMLS PublicGroupStateTBS, - pgSignature :: ByteString - } - deriving stock (Eq, Show, Generic) - --- | A type that holds an MLS-encoded 'PublicGroupState' value via --- 'serialiseMLS'. -newtype OpaquePublicGroupState = OpaquePublicGroupState - {unOpaquePublicGroupState :: ByteString} - deriving (Generic, Eq, Show) - deriving (Arbitrary) via (GenericUniform OpaquePublicGroupState) - -instance ParseMLS OpaquePublicGroupState where - parseMLS = OpaquePublicGroupState . LBS.toStrict <$> getRemainingLazyByteString - -instance SerialiseMLS OpaquePublicGroupState where - serialiseMLS (OpaquePublicGroupState bs) = putByteString bs - -instance S.ToSchema OpaquePublicGroupState where - declareNamedSchema _ = pure (mlsSwagger "OpaquePublicGroupState") - -toOpaquePublicGroupState :: RawMLS PublicGroupState -> OpaquePublicGroupState -toOpaquePublicGroupState = OpaquePublicGroupState . rmRaw - -instance Arbitrary PublicGroupState where - arbitrary = - PublicGroupState - <$> (mkRawMLS <$> arbitrary) - <*> arbitrary - -instance ParseMLS PublicGroupState where - parseMLS = - PublicGroupState - <$> label "pgTBS" parseMLS - <*> label "pgSignature" (parseMLSBytes @Word16) - -instance SerialiseMLS PublicGroupState where - serialiseMLS PublicGroupState {..} = do - serialiseMLS pgTBS - serialiseMLSBytes @Word16 pgSignature diff --git a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs index 0881c31773..ebb4b4307a 100644 --- a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs +++ b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -18,6 +21,9 @@ module Wire.API.MLS.Serialisation ( ParseMLS (..), SerialiseMLS (..), + VarInt (..), + parseMLSStream, + serialiseMLSStream, parseMLSVector, serialiseMLSVector, parseMLSBytes, @@ -42,6 +48,7 @@ module Wire.API.MLS.Serialisation mlsSwagger, parseRawMLS, mkRawMLS, + traceMLS, ) where @@ -52,9 +59,10 @@ import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as Aeson import Data.Bifunctor import Data.Binary -import Data.Binary.Builder +import Data.Binary.Builder (toLazyByteString) import Data.Binary.Get import Data.Binary.Put +import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Json.Util @@ -63,7 +71,9 @@ import Data.Proxy import Data.Schema import qualified Data.Swagger as S import qualified Data.Text as Text +import Debug.Trace import Imports +import Test.QuickCheck (Arbitrary (..), chooseInt) -- | Parse a value encoded using the "TLS presentation" format. class ParseMLS a where @@ -73,6 +83,55 @@ class ParseMLS a where class SerialiseMLS a where serialiseMLS :: a -> Put +-- | An integer value serialised with a variable-size encoding. +-- +-- The underlying Word32 must be strictly less than 2^30. +newtype VarInt = VarInt {unVarInt :: Word32} + deriving newtype (Eq, Ord, Num, Enum, Integral, Real, Show) + +instance Arbitrary VarInt where + arbitrary = fromIntegral <$> chooseInt (0, 1073741823) + +-- From the MLS spec: +-- +-- Prefix | Length | Usable Bits | Min | Max +-- -------+--------+-------------+-----+--------- +-- 00 1 6 0 63 +-- 01 2 14 64 16383 +-- 10 4 30 16384 1073741823 +-- 11 invalid - - - +-- +instance Binary VarInt where + put :: VarInt -> Put + put (VarInt w) + | w < 64 = putWord8 (fromIntegral w) + | w < 16384 = putWord16be (0x4000 .|. fromIntegral w) + | w < 1073741824 = putWord32be (0x80000000 .|. w) + | otherwise = error "invalid VarInt" + + get :: Get VarInt + get = do + w <- lookAhead getWord8 + case shiftR (w .&. 0xc0) 6 of + 0b00 -> VarInt . fromIntegral <$> getWord8 + 0b01 -> VarInt . (.&. 0x3fff) . fromIntegral <$> getWord16be + 0b10 -> VarInt . (.&. 0x3fffffff) . fromIntegral <$> getWord32be + _ -> fail "invalid VarInt prefix" + +instance SerialiseMLS VarInt where serialiseMLS = put + +instance ParseMLS VarInt where parseMLS = get + +parseMLSStream :: Get a -> Get [a] +parseMLSStream p = do + e <- isEmpty + if e + then pure [] + else (:) <$> p <*> parseMLSStream p + +serialiseMLSStream :: (a -> Put) -> [a] -> Put +serialiseMLSStream = traverse_ + parseMLSVector :: forall w a. (Binary w, Integral w) => Get a -> Get [a] parseMLSVector getItem = do len <- get @w @@ -139,19 +198,19 @@ serialiseMLSEnum :: Put serialiseMLSEnum = put . fromMLSEnum @w -data MLSEnumError = MLSEnumUnknown | MLSEnumInvalid +data MLSEnumError = MLSEnumUnknown Int | MLSEnumInvalid toMLSEnum' :: forall a w. (Bounded a, Enum a, Integral w) => w -> Either MLSEnumError a toMLSEnum' w = case fromIntegral w - 1 of n | n < 0 -> Left MLSEnumInvalid - | n < fromEnum @a minBound || n > fromEnum @a maxBound -> Left MLSEnumUnknown + | n < fromEnum @a minBound || n > fromEnum @a maxBound -> Left (MLSEnumUnknown n) | otherwise -> pure (toEnum n) toMLSEnum :: forall a w f. (Bounded a, Enum a, MonadFail f, Integral w) => String -> w -> f a toMLSEnum name = either err pure . toMLSEnum' where - err MLSEnumUnknown = fail $ "Unknown " <> name + err (MLSEnumUnknown value) = fail $ "Unknown " <> name <> ": " <> show value err MLSEnumInvalid = fail $ "Invalid " <> name fromMLSEnum :: (Integral w, Enum a) => a -> w @@ -205,11 +264,14 @@ decodeMLSWith' p = decodeMLSWith p . LBS.fromStrict -- retain the original serialised bytes (e.g. for signature verification, or to -- forward them verbatim). data RawMLS a = RawMLS - { rmRaw :: ByteString, - rmValue :: a + { raw :: ByteString, + value :: a } deriving stock (Eq, Show, Foldable) +instance (Arbitrary a, SerialiseMLS a) => Arbitrary (RawMLS a) where + arbitrary = mkRawMLS <$> arbitrary + -- | A schema for a raw MLS object. -- -- This can be used for embedding MLS objects into JSON. It expresses the @@ -219,7 +281,7 @@ data RawMLS a = RawMLS -- Note that a 'ValueSchema' for the underlying type @a@ is /not/ required. rawMLSSchema :: Text -> (ByteString -> Either Text a) -> ValueSchema NamedSwaggerDoc (RawMLS a) rawMLSSchema name p = - (toBase64Text . rmRaw) + (toBase64Text . raw) .= parsedText name (rawMLSFromText p) mlsSwagger :: Text -> S.NamedSchema @@ -260,7 +322,15 @@ instance ParseMLS a => ParseMLS (RawMLS a) where parseMLS = parseRawMLS parseMLS instance SerialiseMLS (RawMLS a) where - serialiseMLS = putByteString . rmRaw + serialiseMLS = putByteString . raw mkRawMLS :: SerialiseMLS a => a -> RawMLS a mkRawMLS x = RawMLS (LBS.toStrict (runPut (serialiseMLS x))) x + +traceMLS :: Show a => String -> Get a -> Get a +traceMLS l g = do + begin <- bytesRead + r <- g + end <- bytesRead + traceM $ l <> " " <> show begin <> ":" <> show end <> " " <> show r + pure r diff --git a/libs/wire-api/src/Wire/API/MLS/Servant.hs b/libs/wire-api/src/Wire/API/MLS/Servant.hs index 33831f241b..9a34c399de 100644 --- a/libs/wire-api/src/Wire/API/MLS/Servant.hs +++ b/libs/wire-api/src/Wire/API/MLS/Servant.hs @@ -15,17 +15,14 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.MLS.Servant (MLS, mimeUnrenderMLSWith, CommitBundleMimeType) where +module Wire.API.MLS.Servant (MLS, mimeUnrenderMLSWith) where import Data.Bifunctor import Data.Binary -import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import Imports import Network.HTTP.Media ((//)) import Servant.API hiding (Get) -import Wire.API.MLS.CommitBundle -import Wire.API.MLS.PublicGroupState (OpaquePublicGroupState, unOpaquePublicGroupState) import Wire.API.MLS.Serialisation data MLS @@ -36,19 +33,8 @@ instance Accept MLS where instance {-# OVERLAPPABLE #-} ParseMLS a => MimeUnrender MLS a where mimeUnrender _ = mimeUnrenderMLSWith parseMLS -instance MimeRender MLS OpaquePublicGroupState where - mimeRender _ = LBS.fromStrict . unOpaquePublicGroupState +instance {-# OVERLAPPABLE #-} SerialiseMLS a => MimeRender MLS a where + mimeRender _ = encodeMLS mimeUnrenderMLSWith :: Get a -> LByteString -> Either String a mimeUnrenderMLSWith p = first T.unpack . decodeMLSWith p - -data CommitBundleMimeType - -instance Accept CommitBundleMimeType where - contentType _ = "application" // "x-protobuf" - -instance MimeUnrender CommitBundleMimeType CommitBundle where - mimeUnrender _ = first T.unpack . deserializeCommitBundle . LBS.toStrict - -instance MimeRender CommitBundleMimeType CommitBundle where - mimeRender _ = LBS.fromStrict . serializeCommitBundle diff --git a/libs/wire-api/src/Wire/API/MLS/Validation.hs b/libs/wire-api/src/Wire/API/MLS/Validation.hs new file mode 100644 index 0000000000..bb13cd4cd7 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/Validation.hs @@ -0,0 +1,125 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.Validation + ( -- * Main key package validation function + validateKeyPackage, + validateLeafNode, + ) +where + +import Control.Applicative +import Imports +import Wire.API.MLS.Capabilities +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Credential +import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode +import Wire.API.MLS.Lifetime +import Wire.API.MLS.ProtocolVersion +import Wire.API.MLS.Serialisation + +validateKeyPackage :: + Maybe ClientIdentity -> + KeyPackage -> + Either Text (CipherSuiteTag, Lifetime) +validateKeyPackage mIdentity kp = do + -- get ciphersuite + cs <- + maybe + (Left "Unsupported ciphersuite") + pure + $ cipherSuiteTag kp.cipherSuite + + -- validate signature + unless + ( csVerifySignatureWithLabel + cs + kp.leafNode.signatureKey + "KeyPackageTBS" + kp.tbs + kp.signature_ + ) + $ Left "Invalid KeyPackage signature" + + -- validate protocol version + maybe + (Left "Unsupported protocol version") + pure + (pvTag (kp.protocolVersion) >>= guard . (== ProtocolMLS10)) + + -- validate credential, lifetime and capabilities + validateLeafNode cs mIdentity LeafNodeTBSExtraKeyPackage kp.leafNode + + lt <- case kp.leafNode.source of + LeafNodeSourceKeyPackage lt -> pure lt + -- unreachable + _ -> Left "Unexpected leaf node source" + + pure (cs, lt) + +validateLeafNode :: + CipherSuiteTag -> + Maybe ClientIdentity -> + LeafNodeTBSExtra -> + LeafNode -> + Either Text () +validateLeafNode cs mIdentity extra leafNode = do + let tbs = LeafNodeTBS leafNode.core extra + unless + ( csVerifySignatureWithLabel + cs + leafNode.signatureKey + "LeafNodeTBS" + (mkRawMLS tbs) + leafNode.signature_ + ) + $ Left "Invalid LeafNode signature" + + validateCredential mIdentity leafNode.credential + validateSource extra.tag leafNode.source + validateCapabilities leafNode.capabilities + +validateCredential :: Maybe ClientIdentity -> Credential -> Either Text () +validateCredential mIdentity (BasicCredential cred) = do + identity <- + either credentialError pure $ + decodeMLS' cred + unless (maybe True (identity ==) mIdentity) $ + Left "client identity does not match credential identity" + where + credentialError e = + Left $ + "Failed to parse identity: " <> e + +validateSource :: LeafNodeSourceTag -> LeafNodeSource -> Either Text () +validateSource t s = do + let t' = leafNodeSourceTag s + if t == t' + then pure () + else + Left $ + "Expected '" + <> t.name + <> "' source, got '" + <> t'.name + <> "'" + +validateCapabilities :: Capabilities -> Either Text () +validateCapabilities caps = + unless (BasicCredentialTag `elem` caps.credentials) $ + Left "missing BasicCredential capability" diff --git a/libs/wire-api/src/Wire/API/MLS/Welcome.hs b/libs/wire-api/src/Wire/API/MLS/Welcome.hs index 929dc78af5..17dc605d8c 100644 --- a/libs/wire-api/src/Wire/API/MLS/Welcome.hs +++ b/libs/wire-api/src/Wire/API/MLS/Welcome.hs @@ -21,14 +21,13 @@ import qualified Data.Swagger as S import Imports import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit -import Wire.API.MLS.Extension import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation import Wire.Arbitrary +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.4.3.1-5 data Welcome = Welcome - { welProtocolVersion :: ProtocolVersion, - welCipherSuite :: CipherSuite, + { welCipherSuite :: CipherSuite, welSecrets :: [GroupSecrets], welGroupInfo :: ByteString } @@ -41,18 +40,17 @@ instance S.ToSchema Welcome where instance ParseMLS Welcome where parseMLS = Welcome - <$> parseMLS @ProtocolVersion - <*> parseMLS - <*> parseMLSVector @Word32 parseMLS - <*> parseMLSBytes @Word32 + <$> parseMLS + <*> parseMLSVector @VarInt parseMLS + <*> parseMLSBytes @VarInt instance SerialiseMLS Welcome where - serialiseMLS (Welcome pv cs ss gi) = do - serialiseMLS pv + serialiseMLS (Welcome cs ss gi) = do serialiseMLS cs - serialiseMLSVector @Word32 serialiseMLS ss - serialiseMLSBytes @Word32 gi + serialiseMLSVector @VarInt serialiseMLS ss + serialiseMLSBytes @VarInt gi +-- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-12.4.3.1-5 data GroupSecrets = GroupSecrets { gsNewMember :: KeyPackageRef, gsSecrets :: HPKECiphertext diff --git a/libs/wire-api/src/Wire/API/OAuth.hs b/libs/wire-api/src/Wire/API/OAuth.hs index 21d8b3a85e..b9ca600b36 100644 --- a/libs/wire-api/src/Wire/API/OAuth.hs +++ b/libs/wire-api/src/Wire/API/OAuth.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Wire.API.OAuth where diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 8acf770941..50285d680b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -29,10 +29,6 @@ module Wire.API.Routes.Internal.Brig DeleteAccountConferenceCallingConfig, swaggerDoc, module Wire.API.Routes.Internal.Brig.EJPD, - NewKeyPackageRef (..), - NewKeyPackage (..), - NewKeyPackageResult (..), - DeleteKeyPackageRefsRequest (..), ) where @@ -51,8 +47,7 @@ import Servant.Swagger.Internal.Orphans () import Wire.API.Connection import Wire.API.Error import Wire.API.Error.Brig -import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.CipherSuite (SignatureSchemeTag) import Wire.API.MakesFederatedCall import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Brig.EJPD @@ -182,138 +177,7 @@ instance ToSchema NewKeyPackageRef where <*> nkprClientId .= field "client_id" schema <*> nkprConversation .= field "conversation" schema -data NewKeyPackage = NewKeyPackage - { nkpConversation :: Qualified ConvId, - nkpKeyPackage :: KeyPackageData - } - deriving stock (Eq, Show, Generic) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewKeyPackage) - -instance ToSchema NewKeyPackage where - schema = - object "NewKeyPackage" $ - NewKeyPackage - <$> nkpConversation .= field "conversation" schema - <*> nkpKeyPackage .= field "key_package" schema - -data NewKeyPackageResult = NewKeyPackageResult - { nkpresClientIdentity :: ClientIdentity, - nkpresKeyPackageRef :: KeyPackageRef - } - deriving stock (Eq, Show, Generic) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewKeyPackageResult) - -instance ToSchema NewKeyPackageResult where - schema = - object "NewKeyPackageResult" $ - NewKeyPackageResult - <$> nkpresClientIdentity .= field "client_identity" schema - <*> nkpresKeyPackageRef .= field "key_package_ref" schema - -newtype DeleteKeyPackageRefsRequest = DeleteKeyPackageRefsRequest {unDeleteKeyPackageRefsRequest :: [KeyPackageRef]} - deriving (Eq, Show) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema DeleteKeyPackageRefsRequest) - -instance ToSchema DeleteKeyPackageRefsRequest where - schema = - object "DeleteKeyPackageRefsRequest" $ - DeleteKeyPackageRefsRequest - <$> unDeleteKeyPackageRefsRequest .= field "key_package_refs" (array schema) - -type MLSAPI = - "mls" - :> ( ( "key-packages" - :> ( ( Capture "ref" KeyPackageRef - :> ( Named - "get-client-by-key-package-ref" - ( Summary "Resolve an MLS key package ref to a qualified client ID" - :> MultiVerb - 'GET - '[Servant.JSON] - '[ RespondEmpty 404 "Key package ref not found", - Respond 200 "Key package ref found" ClientIdentity - ] - (Maybe ClientIdentity) - ) - :<|> ( "conversation" - :> ( PutConversationByKeyPackageRef - :<|> GetConversationByKeyPackageRef - ) - ) - :<|> Named - "put-key-package-ref" - ( Summary "Create a new KeyPackageRef mapping" - :> ReqBody '[Servant.JSON] NewKeyPackageRef - :> MultiVerb - 'PUT - '[Servant.JSON] - '[RespondEmpty 201 "Key package ref mapping created"] - () - ) - :<|> Named - "post-key-package-ref" - ( Summary "Update a KeyPackageRef in mapping" - :> ReqBody '[Servant.JSON] KeyPackageRef - :> MultiVerb - 'POST - '[Servant.JSON] - '[RespondEmpty 201 "Key package ref mapping updated"] - () - ) - ) - ) - :<|> Named - "delete-key-package-refs" - ( Summary "Delete a batch of KeyPackageRef mappings" - :> ReqBody '[Servant.JSON] DeleteKeyPackageRefsRequest - :> MultiVerb - 'DELETE - '[Servant.JSON] - '[RespondEmpty 200 "Key package ref mappings deleted"] - () - ) - ) - ) - :<|> GetMLSClients - :<|> MapKeyPackageRefs - :<|> Named - "put-key-package-add" - ( "key-package-add" - :> ReqBody '[Servant.JSON] NewKeyPackage - :> MultiVerb1 - 'PUT - '[Servant.JSON] - (Respond 200 "Key package ref mapping updated" NewKeyPackageResult) - ) - ) - -type PutConversationByKeyPackageRef = - Named - "put-conversation-by-key-package-ref" - ( Summary "Associate a conversation with a key package" - :> ReqBody '[Servant.JSON] (Qualified ConvId) - :> MultiVerb - 'PUT - '[Servant.JSON] - [ RespondEmpty 404 "No key package found by reference", - RespondEmpty 204 "Converstaion associated" - ] - Bool - ) - -type GetConversationByKeyPackageRef = - Named - "get-conversation-by-key-package-ref" - ( Summary - "Retrieve the conversation associated with a key package" - :> MultiVerb - 'GET - '[Servant.JSON] - [ RespondEmpty 404 "No associated conversation or bad key package", - Respond 200 "Conversation found" (Qualified ConvId) - ] - (Maybe (Qualified ConvId)) - ) +type MLSAPI = "mls" :> GetMLSClients type GetMLSClients = Summary "Return all clients and all MLS-capable clients of a user" @@ -326,12 +190,6 @@ type GetMLSClients = '[Servant.JSON] (Respond 200 "MLS clients" (Set ClientInfo)) -type MapKeyPackageRefs = - Summary "Insert bundle into the KeyPackage ref mapping. Only for tests." - :> "key-package-refs" - :> ReqBody '[Servant.JSON] KeyPackageBundle - :> MultiVerb 'PUT '[Servant.JSON] '[RespondEmpty 204 "Mapping was updated"] () - type GetVerificationCode = Summary "Get verification code for a given email and action" :> "users" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index 7519255d91..b0da0f7509 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -33,7 +33,7 @@ import Wire.API.Conversation.Typing import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.Servant import Wire.API.MLS.SubConversation import Wire.API.MakesFederatedCall @@ -213,7 +213,7 @@ type ConversationAPI = ( Respond 200 "The group information" - OpaquePublicGroupState + GroupInfoData ) ) :<|> Named @@ -371,7 +371,6 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-created" :> Until 'V3 :> CanThrow 'ConvAccessDenied - :> CanThrow 'MLSMissingSenderClient :> CanThrow 'MLSNonEmptyMemberList :> CanThrow 'MLSNotEnabled :> CanThrow 'NotConnected @@ -380,7 +379,6 @@ type ConversationAPI = :> CanThrow 'MissingLegalholdConsent :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" :> ZLocalUser - :> ZOptClient :> ZOptConn :> "conversations" :> VersionedReqBody 'V2 '[Servant.JSON] NewConv @@ -394,7 +392,6 @@ type ConversationAPI = :> From 'V3 :> Until 'V4 :> CanThrow 'ConvAccessDenied - :> CanThrow 'MLSMissingSenderClient :> CanThrow 'MLSNonEmptyMemberList :> CanThrow 'MLSNotEnabled :> CanThrow 'NotConnected @@ -403,7 +400,6 @@ type ConversationAPI = :> CanThrow 'MissingLegalholdConsent :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" :> ZLocalUser - :> ZOptClient :> ZOptConn :> "conversations" :> ReqBody '[Servant.JSON] NewConv @@ -415,7 +411,6 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-created" :> From 'V4 :> CanThrow 'ConvAccessDenied - :> CanThrow 'MLSMissingSenderClient :> CanThrow 'MLSNonEmptyMemberList :> CanThrow 'MLSNotEnabled :> CanThrow 'NotConnected @@ -424,7 +419,6 @@ type ConversationAPI = :> CanThrow 'MissingLegalholdConsent :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" :> ZLocalUser - :> ZOptClient :> ZOptConn :> "conversations" :> ReqBody '[Servant.JSON] NewConv @@ -551,7 +545,7 @@ type ConversationAPI = ( Respond 200 "The group information" - OpaquePublicGroupState + GroupInfoData ) ) -- This endpoint can lead to the following events being sent: @@ -1261,7 +1255,6 @@ type ConversationAPI = :> CanThrow 'ConvInvalidProtocolTransition :> CanThrow 'ConvMemberNotFound :> ZLocalUser - :> ZClient :> ZConn :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs index 9d010bf6e9..b0c9dce832 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs @@ -21,109 +21,53 @@ import Servant hiding (WithStatus) import Servant.Swagger.Internal.Orphans () import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Event.Conversation import Wire.API.MLS.CommitBundle import Wire.API.MLS.Keys import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.Servant -import Wire.API.MLS.Welcome import Wire.API.MakesFederatedCall import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named import Wire.API.Routes.Public -import Wire.API.Routes.Version type MLSMessagingAPI = Named - "mls-welcome-message" - ( Summary "Post an MLS welcome message" - :> Until 'V3 - :> MakesFederatedCall 'Galley "mls-welcome" - :> CanThrow 'MLSKeyPackageRefNotFound + "mls-message" + ( Summary "Post an MLS message" + :> MakesFederatedCall 'Galley "on-mls-message-sent" + :> MakesFederatedCall 'Galley "send-mls-message" + :> MakesFederatedCall 'Galley "on-conversation-updated" + :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" + :> MakesFederatedCall 'Brig "get-mls-clients" + :> MakesFederatedCall 'Galley "on-delete-mls-conversation" + :> CanThrow 'ConvAccessDenied + :> CanThrow 'ConvMemberNotFound + :> CanThrow 'ConvNotFound + :> CanThrow 'LegalHoldNotEnabled + :> CanThrow 'MissingLegalholdConsent + :> CanThrow 'MLSClientMismatch + :> CanThrow 'MLSClientSenderUserMismatch + :> CanThrow 'MLSCommitMissingReferences + :> CanThrow 'MLSGroupConversationMismatch + :> CanThrow 'MLSInvalidLeafNodeIndex :> CanThrow 'MLSNotEnabled - :> "welcome" + :> CanThrow 'MLSProposalNotFound + :> CanThrow 'MLSProtocolErrorTag + :> CanThrow 'MLSSelfRemovalNotAllowed + :> CanThrow 'MLSStaleMessage + :> CanThrow 'MLSSubConvClientNotInParent + :> CanThrow 'MLSUnsupportedMessage + :> CanThrow 'MLSUnsupportedProposal + :> CanThrow MLSProposalFailure + :> "messages" :> ZLocalUser + :> ZClient :> ZConn - :> ReqBody '[MLS] (RawMLS Welcome) - :> MultiVerb1 'POST '[JSON] (RespondEmpty 201 "Welcome message sent") + :> ReqBody '[MLS] (RawMLS Message) + :> MultiVerb1 'POST '[JSON] (Respond 201 "Message sent" MLSMessageSendingStatus) ) - :<|> Named - "mls-message-v1" - ( Summary "Post an MLS message" - :> MakesFederatedCall 'Brig "get-mls-clients" - :> MakesFederatedCall 'Galley "on-conversation-updated" - :> MakesFederatedCall 'Galley "on-delete-mls-conversation" - :> MakesFederatedCall 'Galley "on-mls-message-sent" - :> MakesFederatedCall 'Galley "on-new-remote-conversation" - :> MakesFederatedCall 'Galley "on-new-remote-subconversation" - :> MakesFederatedCall 'Galley "send-mls-message" - :> Until 'V2 - :> CanThrow 'ConvAccessDenied - :> CanThrow 'ConvMemberNotFound - :> CanThrow 'ConvNotFound - :> CanThrow 'LegalHoldNotEnabled - :> CanThrow 'MLSClientMismatch - :> CanThrow 'MLSCommitMissingReferences - :> CanThrow 'MLSKeyPackageRefNotFound - :> CanThrow 'MLSNotEnabled - :> CanThrow 'MLSProposalNotFound - :> CanThrow 'MLSProtocolErrorTag - :> CanThrow 'MLSSelfRemovalNotAllowed - :> CanThrow 'MLSStaleMessage - :> CanThrow 'MLSUnsupportedMessage - :> CanThrow 'MLSUnsupportedProposal - :> CanThrow 'MLSClientSenderUserMismatch - :> CanThrow 'MLSGroupConversationMismatch - :> CanThrow 'MLSMissingSenderClient - :> CanThrow 'MissingLegalholdConsent - :> CanThrow 'MLSSubConvClientNotInParent - :> CanThrow MLSProposalFailure - :> "messages" - :> ZLocalUser - :> ZOptClient - :> ZConn - :> ReqBody '[MLS] (RawMLS SomeMessage) - :> MultiVerb1 'POST '[JSON] (Respond 201 "Message sent" [Event]) - ) - :<|> Named - "mls-message" - ( Summary "Post an MLS message" - :> MakesFederatedCall 'Galley "on-mls-message-sent" - :> MakesFederatedCall 'Galley "send-mls-message" - :> MakesFederatedCall 'Galley "on-conversation-updated" - :> MakesFederatedCall 'Galley "on-new-remote-conversation" - :> MakesFederatedCall 'Galley "on-new-remote-subconversation" - :> MakesFederatedCall 'Brig "get-mls-clients" - :> MakesFederatedCall 'Galley "on-delete-mls-conversation" - :> From 'V2 - :> CanThrow 'ConvAccessDenied - :> CanThrow 'ConvMemberNotFound - :> CanThrow 'ConvNotFound - :> CanThrow 'LegalHoldNotEnabled - :> CanThrow 'MLSClientMismatch - :> CanThrow 'MLSCommitMissingReferences - :> CanThrow 'MLSKeyPackageRefNotFound - :> CanThrow 'MLSNotEnabled - :> CanThrow 'MLSProposalNotFound - :> CanThrow 'MLSProtocolErrorTag - :> CanThrow 'MLSSelfRemovalNotAllowed - :> CanThrow 'MLSStaleMessage - :> CanThrow 'MLSUnsupportedMessage - :> CanThrow 'MLSUnsupportedProposal - :> CanThrow 'MLSClientSenderUserMismatch - :> CanThrow 'MLSGroupConversationMismatch - :> CanThrow 'MLSMissingSenderClient - :> CanThrow 'MissingLegalholdConsent - :> CanThrow 'MLSSubConvClientNotInParent - :> CanThrow MLSProposalFailure - :> "messages" - :> ZLocalUser - :> ZOptClient - :> ZConn - :> ReqBody '[MLS] (RawMLS SomeMessage) - :> MultiVerb1 'POST '[JSON] (Respond 201 "Message sent" MLSMessageSendingStatus) - ) :<|> Named "mls-commit-bundle" ( Summary "Post a MLS CommitBundle" @@ -135,39 +79,36 @@ type MLSMessagingAPI = :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> MakesFederatedCall 'Brig "get-mls-clients" :> MakesFederatedCall 'Galley "on-delete-mls-conversation" - :> From 'V4 :> CanThrow 'ConvAccessDenied :> CanThrow 'ConvMemberNotFound :> CanThrow 'ConvNotFound :> CanThrow 'LegalHoldNotEnabled + :> CanThrow 'MissingLegalholdConsent :> CanThrow 'MLSClientMismatch + :> CanThrow 'MLSClientSenderUserMismatch :> CanThrow 'MLSCommitMissingReferences - :> CanThrow 'MLSKeyPackageRefNotFound + :> CanThrow 'MLSGroupConversationMismatch + :> CanThrow 'MLSInvalidLeafNodeIndex :> CanThrow 'MLSNotEnabled :> CanThrow 'MLSProposalNotFound :> CanThrow 'MLSProtocolErrorTag :> CanThrow 'MLSSelfRemovalNotAllowed :> CanThrow 'MLSStaleMessage + :> CanThrow 'MLSSubConvClientNotInParent :> CanThrow 'MLSUnsupportedMessage :> CanThrow 'MLSUnsupportedProposal - :> CanThrow 'MLSClientSenderUserMismatch - :> CanThrow 'MLSGroupConversationMismatch - :> CanThrow 'MLSMissingSenderClient :> CanThrow 'MLSWelcomeMismatch - :> CanThrow 'MissingLegalholdConsent - :> CanThrow 'MLSSubConvClientNotInParent :> CanThrow MLSProposalFailure :> "commit-bundles" :> ZLocalUser - :> ZOptClient + :> ZClient :> ZConn - :> ReqBody '[CommitBundleMimeType] CommitBundle + :> ReqBody '[MLS] (RawMLS CommitBundle) :> MultiVerb1 'POST '[JSON] (Respond 201 "Commit accepted and forwarded" MLSMessageSendingStatus) ) :<|> Named "mls-public-keys" ( Summary "Get public keys used by the backend to sign external proposals" - :> From 'V4 :> CanThrow 'MLSNotEnabled :> "public-keys" :> ZLocalUser diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 397ee41cd9..45053ff4a5 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -100,8 +100,8 @@ import Deriving.Swagger StripPrefix, ) import Imports -import Wire.API.MLS.Credential -import Wire.API.User.Auth (CookieLabel) +import Wire.API.MLS.CipherSuite +import Wire.API.User.Auth import Wire.API.User.Client.Prekey as Prekey import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..), generateExample, mapOf', setOf') diff --git a/libs/wire-api/test/golden.hs b/libs/wire-api/test/golden.hs new file mode 100644 index 0000000000..0ff7c7e4ca --- /dev/null +++ b/libs/wire-api/test/golden.hs @@ -0,0 +1,5 @@ +import Imports +import qualified Test.Wire.API.Golden.Run as Run + +main :: IO () +main = Run.main diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Client_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Client_user.hs index 65b4ad7d34..c137ae7b69 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Client_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Client_user.hs @@ -25,7 +25,7 @@ import qualified Data.Map as Map import Data.Misc import Data.Set as Set import Imports -import Wire.API.MLS.Credential +import Wire.API.MLS.CipherSuite import Wire.API.User.Auth (CookieLabel (CookieLabel, cookieLabelText)) import Wire.API.User.Client diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewClient_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewClient_user.hs index 6af4068cdb..fbe5d29ac0 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewClient_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewClient_user.hs @@ -26,7 +26,7 @@ import Data.Range (unsafeRange) import qualified Data.Set as Set import Data.Text.Ascii (AsciiChars (validate)) import Imports (Maybe (Just, Nothing), fromRight, mempty, undefined) -import Wire.API.MLS.Credential +import Wire.API.MLS.CipherSuite import Wire.API.User.Auth (CookieLabel (CookieLabel, cookieLabelText)) import Wire.API.User.Client import Wire.API.User.Client.Prekey diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateClient_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateClient_user.hs index 5f164f77cf..655532ef6a 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateClient_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateClient_user.hs @@ -21,7 +21,7 @@ module Test.Wire.API.Golden.Generated.UpdateClient_user where import qualified Data.Map as Map import Imports -import Wire.API.MLS.Credential +import Wire.API.MLS.CipherSuite import Wire.API.User.Client import Wire.API.User.Client.Prekey diff --git a/libs/wire-api/test/golden/Main.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Run.hs similarity index 96% rename from libs/wire-api/test/golden/Main.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Run.hs index 7ad5b57d55..e1e110783e 100644 --- a/libs/wire-api/test/golden/Main.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Run.hs @@ -15,10 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main - ( main, - ) -where +module Test.Wire.API.Golden.Run (main) where import Imports import Test.Tasty diff --git a/libs/wire-api/test/resources/key_package1.mls b/libs/wire-api/test/resources/key_package1.mls deleted file mode 100644 index 8023c69079..0000000000 Binary files a/libs/wire-api/test/resources/key_package1.mls and /dev/null differ diff --git a/libs/wire-api/test/unit.hs b/libs/wire-api/test/unit.hs new file mode 100644 index 0000000000..dbf3fb9acb --- /dev/null +++ b/libs/wire-api/test/unit.hs @@ -0,0 +1,5 @@ +import Imports +import qualified Test.Wire.API.Run as Run + +main :: IO () +main = Run.main diff --git a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs index ea608ae122..10ec20569a 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs @@ -19,36 +19,36 @@ module Test.Wire.API.MLS where import Control.Concurrent.Async import qualified Crypto.PubKey.Ed25519 as Ed25519 -import Data.ByteArray +import Data.ByteArray hiding (length) import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Char8 as B8 import Data.Domain -import Data.Either.Combinators -import Data.Hex import Data.Id import Data.Json.Util (toBase64Text) import Data.Qualified import qualified Data.Text as T import qualified Data.Text as Text -import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import Imports import System.Exit import System.FilePath (()) import System.Process +import System.Random import Test.Tasty import Test.Tasty.HUnit import UnliftIO (withSystemTempDirectory) +import Wire.API.MLS.AuthenticatedContent import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.Credential import Wire.API.MLS.Epoch -import Wire.API.MLS.Extension import Wire.API.MLS.Group +import Wire.API.MLS.GroupInfo +import Wire.API.MLS.HPKEPublicKey import Wire.API.MLS.KeyPackage import Wire.API.MLS.Message import Wire.API.MLS.Proposal -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.ProtocolVersion import Wire.API.MLS.Serialisation import Wire.API.MLS.Welcome @@ -58,117 +58,140 @@ tests = [ testCase "parse key package" testParseKeyPackage, testCase "parse commit message" testParseCommit, testCase "parse application message" testParseApplication, - testCase "parse welcome message" testParseWelcome, + testCase "parse welcome and groupinfo message" testParseWelcomeAndGroupInfo, testCase "key package ref" testKeyPackageRef, - testCase "validate message signature" testVerifyMLSPlainTextWithKey, - testCase "create signed remove proposal" testRemoveProposalMessageSignature, - testCase "parse GroupInfoBundle" testParseGroupInfoBundle -- TODO: remove this also + testCase "create signed remove proposal" testRemoveProposalMessageSignature ] testParseKeyPackage :: IO () testParseKeyPackage = do - kpData <- BS.readFile "test/resources/key_package1.mls" + alice <- randomIdentity + let qcid = B8.unpack (encodeMLS' alice) + kpData <- withSystemTempDirectory "mls" $ \tmp -> do + void $ spawn (cli qcid tmp ["init", qcid]) Nothing + spawn (cli qcid tmp ["key-package", "create"]) Nothing + kp <- case decodeMLS' @KeyPackage kpData of Left err -> assertFailure (T.unpack err) Right x -> pure x - pvTag (kpProtocolVersion kp) @?= Just ProtocolMLS10 - kpCipherSuite kp @?= CipherSuite 1 - BS.length (kpInitKey kp) @?= 32 + pvTag (kp.protocolVersion) @?= Just ProtocolMLS10 + kp.cipherSuite @?= CipherSuite 1 + BS.length (unHPKEPublicKey kp.initKey) @?= 32 - case decodeMLS' @ClientIdentity (bcIdentity (kpCredential kp)) of + case keyPackageIdentity kp of Left err -> assertFailure $ "Failed to parse identity: " <> T.unpack err - Right identity -> - identity - @?= ClientIdentity - { ciDomain = Domain "mls.example.com", - ciUser = Id (fromJust (UUID.fromString "b455a431-9db6-4404-86e7-6a3ebe73fcaf")), - ciClient = newClientId 0x3ae58155 - } - - -- check raw TBS package - let rawTBS = rmRaw (kpTBS kp) - rawTBS @?= BS.take 196 kpData + Right identity -> identity @?= alice testParseCommit :: IO () testParseCommit = do - msgData <- LBS.readFile "test/resources/commit1.mls" - msg :: Message 'MLSPlainText <- case decodeMLS @SomeMessage msgData of + qcid <- B8.unpack . encodeMLS' <$> randomIdentity + commitData <- withSystemTempDirectory "mls" $ \tmp -> do + void $ spawn (cli qcid tmp ["init", qcid]) Nothing + groupJSON <- spawn (cli qcid tmp ["group", "create", "Zm9v"]) Nothing + spawn (cli qcid tmp ["commit", "--group", "-"]) (Just groupJSON) + + msg <- case decodeMLS' @Message commitData of Left err -> assertFailure (T.unpack err) - Right (SomeMessage SMLSCipherText _) -> - assertFailure "Expected plain text message, found encrypted" - Right (SomeMessage SMLSPlainText msg) -> - pure msg + Right x -> pure x + + pvTag (msg.protocolVersion) @?= Just ProtocolMLS10 - msgGroupId msg @?= "test_group" - msgEpoch msg @?= Epoch 0 + pmsg <- case msg.content of + MessagePublic x -> pure x + _ -> assertFailure "expected public message" - case msgSender msg of - MemberSender kp -> kp @?= KeyPackageRef (fromRight' (unhex "24e4b0a802a2b81f00a9af7df5e91da8")) - _ -> assertFailure "Unexpected sender type" + pmsg.content.value.sender @?= SenderMember 0 - let payload = msgPayload msg - commit <- case payload of - CommitMessage c -> pure c - _ -> assertFailure "Unexpected message type" + commit <- case pmsg.content.value.content of + FramedContentCommit c -> pure c + _ -> assertFailure "expected commit" - case cProposals commit of - [Inline (AddProposal _)] -> pure () - _ -> assertFailure "Unexpected proposals" + commit.value.proposals @?= [] testParseApplication :: IO () testParseApplication = do - msgData <- LBS.readFile "test/resources/app_message1.mls" - msg :: Message 'MLSCipherText <- case decodeMLS @SomeMessage msgData of - Left err -> assertFailure (T.unpack err) - Right (SomeMessage SMLSCipherText msg) -> pure msg - Right (SomeMessage SMLSPlainText _) -> - assertFailure "Expected encrypted message, found plain text" - - msgGroupId msg @?= "test_group" - msgEpoch msg @?= Epoch 0 - msgContentType (msgPayload msg) @?= fromMLSEnum ApplicationMessageTag - -testParseWelcome :: IO () -testParseWelcome = do - welData <- LBS.readFile "test/resources/welcome1.mls" - wel <- case decodeMLS welData of + qcid <- B8.unpack . encodeMLS' <$> randomIdentity + msgData <- withSystemTempDirectory "mls" $ \tmp -> do + void $ spawn (cli qcid tmp ["init", qcid]) Nothing + groupJSON <- spawn (cli qcid tmp ["group", "create", "Zm9v"]) Nothing + spawn (cli qcid tmp ["message", "--group", "-", "hello"]) (Just groupJSON) + + msg <- case decodeMLS' @Message msgData of Left err -> assertFailure (T.unpack err) Right x -> pure x - welCipherSuite wel @?= CipherSuite 1 - map gsNewMember (welSecrets wel) @?= [KeyPackageRef (fromRight' (unhex "ab4692703ca6d50ffdeaae3096f885c2"))] + pvTag (msg.protocolVersion) @?= Just ProtocolMLS10 + + pmsg <- case msg.content of + MessagePrivate x -> pure x.value + _ -> assertFailure "expected private message" + + pmsg.groupId @?= GroupId "foo" + pmsg.epoch @?= Epoch 0 + +testParseWelcomeAndGroupInfo :: IO () +testParseWelcomeAndGroupInfo = do + qcid <- B8.unpack . encodeMLS' <$> randomIdentity + qcid2 <- B8.unpack . encodeMLS' <$> randomIdentity + (welData, giData) <- withSystemTempDirectory "mls" $ \tmp -> do + void $ spawn (cli qcid tmp ["init", qcid]) Nothing + void $ spawn (cli qcid2 tmp ["init", qcid2]) Nothing + groupJSON <- spawn (cli qcid tmp ["group", "create", "Zm9v"]) Nothing + kp <- spawn (cli qcid2 tmp ["key-package", "create"]) Nothing + BS.writeFile (tmp "kp") kp + void $ + spawn + ( cli + qcid + tmp + [ "member", + "add", + "--group", + "-", + tmp "kp", + "--welcome-out", + tmp "welcome", + "--group-info-out", + tmp "gi" + ] + ) + (Just groupJSON) + (,) + <$> BS.readFile (tmp "welcome") + <*> BS.readFile (tmp "gi") + + do + welcomeMsg <- case decodeMLS' @Message welData of + Left err -> assertFailure (T.unpack err) + Right x -> pure x + + pvTag (welcomeMsg.protocolVersion) @?= Just ProtocolMLS10 + + wel <- case welcomeMsg.content of + MessageWelcome x -> pure x.value + _ -> assertFailure "expected welcome message" + + length (wel.welSecrets) @?= 1 + + do + gi <- case decodeMLS' @GroupInfo giData of + Left err -> assertFailure (T.unpack err) + Right x -> pure x + + gi.groupContext.groupId @?= GroupId "foo" + gi.groupContext.epoch @?= Epoch 1 testKeyPackageRef :: IO () testKeyPackageRef = do - kpData <- BS.readFile "test/resources/key_package1.mls" - ref <- KeyPackageRef <$> BS.readFile "test/resources/key_package_ref1" - kpRef MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 (KeyPackageData kpData) @?= ref + let qcid = "b455a431-9db6-4404-86e7-6a3ebe73fcaf:3ae58155@mls.example.com" + (kpData, ref) <- withSystemTempDirectory "mls" $ \tmp -> do + void $ spawn (cli qcid tmp ["init", qcid]) Nothing + kpData <- spawn (cli qcid tmp ["key-package", "create"]) Nothing + ref <- spawn (cli qcid tmp ["key-package", "ref", "-"]) (Just kpData) + pure (kpData, KeyPackageRef ref) -testVerifyMLSPlainTextWithKey :: IO () -testVerifyMLSPlainTextWithKey = do - -- this file was created with openmls from the client that is in the add proposal - msgData <- BS.readFile "test/resources/external_proposal.mls" - - msg :: Message 'MLSPlainText <- case decodeMLS' @SomeMessage msgData of - Left err -> assertFailure (T.unpack err) - Right (SomeMessage SMLSCipherText _) -> - assertFailure "Expected SomeMessage SMLSCipherText" - Right (SomeMessage SMLSPlainText msg) -> - pure msg - - kp <- case msgPayload msg of - ProposalMessage prop -> - case rmValue prop of - AddProposal kp -> pure kp - _ -> error "Expected AddProposal" - _ -> error "Expected ProposalMessage" - - let pubkey = bcSignatureKey . kpCredential . rmValue $ kp - liftIO - $ assertBool - "message signature verification failed" - $ verifyMessageSignature MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 msg pubkey + kpRef MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 (KeyPackageData kpData) @?= ref testRemoveProposalMessageSignature :: IO () testRemoveProposalMessageSignature = withSystemTempDirectory "mls" $ \tmp -> do @@ -176,32 +199,42 @@ testRemoveProposalMessageSignature = withSystemTempDirectory "mls" $ \tmp -> do let c = newClientId 0x3ae58155 usr <- flip Qualified (Domain "example.com") <$> (Id <$> UUID.nextRandom) pure (userClientQid usr c) - void . liftIO $ spawn (cli qcid tmp ["init", qcid]) Nothing + void $ spawn (cli qcid tmp ["init", qcid]) Nothing qcid2 <- do let c = newClientId 0x4ae58157 usr <- flip Qualified (Domain "example.com") <$> (Id <$> UUID.nextRandom) pure (userClientQid usr c) - void . liftIO $ spawn (cli qcid2 tmp ["init", qcid2]) Nothing - kp <- liftIO $ decodeMLSError <$> spawn (cli qcid2 tmp ["key-package", "create"]) Nothing - liftIO $ BS.writeFile (tmp qcid2) (rmRaw kp) + void $ spawn (cli qcid2 tmp ["init", qcid2]) Nothing + kp :: RawMLS KeyPackage <- + decodeMLSError <$> spawn (cli qcid2 tmp ["key-package", "create"]) Nothing + BS.writeFile (tmp qcid2) (raw kp) + secretKey <- Ed25519.generateSecretKey let groupFilename = "group" - let gid = GroupId "abcd" - createGroup tmp qcid groupFilename gid + gid = GroupId "abcd" + signerKeyFilename = "signer-key.bin" + publicKey = Ed25519.toPublic secretKey + BS.writeFile (tmp signerKeyFilename) (convert publicKey) + createGroup tmp qcid groupFilename signerKeyFilename gid - void $ liftIO $ spawn (cli qcid tmp ["member", "add", "--group", tmp groupFilename, "--in-place", tmp qcid2]) Nothing + void $ spawn (cli qcid tmp ["member", "add", "--group", tmp groupFilename, "--in-place", tmp qcid2]) Nothing - secretKey <- Ed25519.generateSecretKey - let publicKey = Ed25519.toPublic secretKey - let message = mkSignedMessage secretKey publicKey gid (Epoch 1) (ProposalMessage (mkRemoveProposal (fromJust (kpRef' kp)))) + let proposal = mkRawMLS (RemoveProposal 1) + pmessage = + mkSignedPublicMessage + secretKey + publicKey + gid + (Epoch 1) + (TaggedSenderExternal 0) + (FramedContentProposal proposal) + message = mkMessage $ MessagePublic pmessage + messageFilename = "signed-message.mls" - let messageFilename = "signed-message.mls" - BS.writeFile (tmp messageFilename) (rmRaw (mkRawMLS message)) - let signerKeyFilename = "signer-key.bin" - BS.writeFile (tmp signerKeyFilename) (convert publicKey) + BS.writeFile (tmp messageFilename) (raw (mkRawMLS message)) - void . liftIO $ + void $ spawn ( cli qcid @@ -209,65 +242,25 @@ testRemoveProposalMessageSignature = withSystemTempDirectory "mls" $ \tmp -> do [ "consume", "--group", tmp groupFilename, - "--signer-key", - tmp signerKeyFilename, tmp messageFilename ] ) Nothing -testParseGroupInfoBundle :: IO () -testParseGroupInfoBundle = withSystemTempDirectory "mls" $ \tmp -> do - qcid <- do - let c = newClientId 0x3ae58155 - usr <- flip Qualified (Domain "example.com") <$> (Id <$> UUID.nextRandom) - pure (userClientQid usr c) - void . liftIO $ spawn (cli qcid tmp ["init", qcid]) Nothing - - qcid2 <- do - let c = newClientId 0x4ae58157 - usr <- flip Qualified (Domain "example.com") <$> (Id <$> UUID.nextRandom) - pure (userClientQid usr c) - void . liftIO $ spawn (cli qcid2 tmp ["init", qcid2]) Nothing - kp :: RawMLS KeyPackage <- liftIO $ decodeMLSError <$> spawn (cli qcid2 tmp ["key-package", "create"]) Nothing - liftIO $ BS.writeFile (tmp qcid2) (rmRaw kp) - - let groupFilename = "group" - let gid = GroupId "abcd" - createGroup tmp qcid groupFilename gid - - void $ - liftIO $ - spawn - ( cli - qcid - tmp - [ "member", - "add", - "--group", - tmp groupFilename, - "--in-place", - tmp qcid2, - "--group-state-out", - tmp "group-info-bundle" - ] - ) - Nothing - - bundleBS <- BS.readFile (tmp "group-info-bundle") - case decodeMLS' @PublicGroupState bundleBS of - Left err -> assertFailure ("Failed parsing PublicGroupState: " <> T.unpack err) - Right _ -> pure () - -createGroup :: FilePath -> String -> String -> GroupId -> IO () -createGroup tmp store groupName gid = do +createGroup :: FilePath -> String -> String -> String -> GroupId -> IO () +createGroup tmp store groupName removalKey gid = do groupJSON <- liftIO $ spawn ( cli store tmp - ["group", "create", T.unpack (toBase64Text (unGroupId gid))] + [ "group", + "create", + "--removal-key", + tmp removalKey, + T.unpack (toBase64Text (unGroupId gid)) + ] ) Nothing liftIO $ BS.writeFile (tmp groupName) groupJSON @@ -281,7 +274,7 @@ userClientQid :: Qualified UserId -> ClientId -> String userClientQid usr c = show (qUnqualified usr) <> ":" - <> T.unpack (client c) + <> T.unpack c.client <> "@" <> T.unpack (domainText (qDomain usr)) @@ -306,3 +299,9 @@ cli :: String -> FilePath -> [String] -> CreateProcess cli store tmp args = proc "mls-test-cli" $ ["--store", tmp (store <> ".db")] <> args + +randomIdentity :: IO ClientIdentity +randomIdentity = do + uid <- Id <$> UUID.nextRandom + c <- newClientId <$> randomIO + pure $ ClientIdentity (Domain "mls.example.com") uid c diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs index d73620945b..df82c017e0 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -15,24 +16,23 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# OPTIONS_GHC -Wwarn #-} module Test.Wire.API.Roundtrip.MLS (tests) where -import Data.Binary.Put +import Data.Hex import Imports -import qualified Proto.Mls import qualified Test.Tasty as T import Test.Tasty.QuickCheck import Type.Reflection (typeRep) -import Wire.API.ConverProtoLens +import Wire.API.MLS.Commit import Wire.API.MLS.CommitBundle +import Wire.API.MLS.Credential import Wire.API.MLS.Extension -import Wire.API.MLS.GroupInfoBundle +import Wire.API.MLS.GroupInfo import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.Message import Wire.API.MLS.Proposal -import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Serialisation import Wire.API.MLS.Welcome @@ -40,17 +40,21 @@ tests :: T.TestTree tests = T.localOption (T.Timeout (60 * 1000000) "60s") . T.testGroup "MLS roundtrip tests" $ [ testRoundTrip @KeyPackageRef, + testRoundTrip @LeafNode, + testRoundTrip @LeafNodeCore, + testRoundTrip @KeyPackageTBS, + testRoundTrip @Credential, + testRoundTrip @ClientIdentity, testRoundTrip @TestPreconfiguredSender, testRoundTrip @RemoveProposalMessage, testRoundTrip @RemoveProposalPayload, - testRoundTrip @AppAckProposalTest, testRoundTrip @ExtensionVector, - testRoundTrip @PublicGroupStateTBS, - testRoundTrip @PublicGroupState, + testRoundTrip @GroupInfoData, + testRoundTrip @TestCommitBundle, testRoundTrip @Welcome, - testRoundTrip @OpaquePublicGroupState, - testConvertProtoRoundTrip @Proto.Mls.GroupInfoBundle @GroupInfoBundle, - testConvertProtoRoundTrip @Proto.Mls.CommitBundle @TestCommitBundle + testRoundTrip @Proposal, + testRoundTrip @ProposalRef, + testRoundTrip @VarInt ] testRoundTrip :: @@ -61,138 +65,125 @@ testRoundTrip = testProperty msg trip where msg = show (typeRep @a) trip (v :: a) = - counterexample (show (runPut (serialiseMLS v))) $ - Right v === (decodeMLS . runPut . serialiseMLS) v - -testConvertProtoRoundTrip :: - forall p a. - ( Arbitrary a, - Typeable a, - Show a, - Show p, - Eq a, - ConvertProtoLens p a - ) => - T.TestTree -testConvertProtoRoundTrip = testProperty (show (typeRep @a)) trip - where - trip (v :: a) = - counterexample (show (toProtolens @p @a v)) $ - Right v === do - let pa = toProtolens @p @a v - fromProtolens @p @a pa + let serialised = encodeMLS v + parsed = decodeMLS serialised + in counterexample (show $ hex serialised) $ + Right v === parsed -------------------------------------------------------------------------------- -- auxiliary types class ArbitrarySender a where - arbitrarySender :: Gen (Sender 'MLSPlainText) + arbitrarySender :: Gen Sender -class ArbitraryMessagePayload a where - arbitraryMessagePayload :: Gen (MessagePayload 'MLSPlainText) +instance ArbitrarySender Sender where + arbitrarySender = arbitrary -class ArbitraryMessageTBS a where - arbitraryArbitraryMessageTBS :: Gen (MessageTBS 'MLSPlainText) +class ArbitraryFramedContentData a where + arbitraryFramedContentData :: Gen FramedContentData -newtype MessageGenerator tbs = MessageGenerator {unMessageGenerator :: Message 'MLSPlainText} - deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) +class ArbitraryFramedContent a where + arbitraryFramedContent :: Gen FramedContent -instance (ArbitraryMessageTBS tbs) => Arbitrary (MessageGenerator tbs) where - arbitrary = do - tbs <- arbitraryArbitraryMessageTBS @tbs - MessageGenerator - <$> (Message (mkRawMLS tbs) <$> arbitrary) +newtype MessageGenerator fc = MessageGenerator {unMessageGenerator :: Message} + deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) -data MessageTBSGenerator sender payload +instance ArbitraryFramedContent fc => Arbitrary (MessageGenerator fc) where + arbitrary = + fmap MessageGenerator $ do + fc <- arbitraryFramedContent @fc + mt <- case fc.sender of + SenderMember _ -> Just <$> arbitrary + _ -> pure Nothing + confirmationTag <- case fc.content of + FramedContentCommit _ -> Just <$> arbitrary + _ -> pure Nothing + Message + <$> arbitrary + <*> fmap + MessagePublic + ( PublicMessage (mkRawMLS fc) + <$> (mkRawMLS <$> (FramedContentAuthData <$> arbitrary <*> pure confirmationTag)) + <*> pure mt + ) + +data FramedContentGenerator sender payload instance ( ArbitrarySender sender, - ArbitraryMessagePayload payload + ArbitraryFramedContentData payload ) => - ArbitraryMessageTBS (MessageTBSGenerator sender payload) + ArbitraryFramedContent (FramedContentGenerator sender payload) where - arbitraryArbitraryMessageTBS = - MessageTBS KnownFormatTag + arbitraryFramedContent = + FramedContent <$> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrarySender @sender - <*> arbitraryMessagePayload @payload + <*> arbitrary + <*> arbitraryFramedContentData @payload --- -newtype RemoveProposalMessage = RemoveProposalMessage {unRemoveProposalMessage :: Message 'MLSPlainText} +newtype RemoveProposalMessage = RemoveProposalMessage Message deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) instance Arbitrary RemoveProposalMessage where arbitrary = RemoveProposalMessage - <$> (unMessageGenerator <$> arbitrary @(MessageGenerator (MessageTBSGenerator TestPreconfiguredSender RemoveProposalPayload))) + <$> (unMessageGenerator <$> arbitrary @(MessageGenerator (FramedContentGenerator TestPreconfiguredSender RemoveProposalPayload))) --- -newtype RemoveProposalPayload = RemoveProposalPayload {unRemoveProposalPayload :: MessagePayload 'MLSPlainText} +newtype RemoveProposalPayload = RemoveProposalPayload {unRemoveProposalPayload :: FramedContentData} deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) instance Arbitrary RemoveProposalPayload where - arbitrary = RemoveProposalPayload . ProposalMessage . mkRemoveProposal <$> arbitrary + arbitrary = RemoveProposalPayload . FramedContentProposal . mkRawMLS . RemoveProposal <$> arbitrary -instance ArbitraryMessagePayload RemoveProposalPayload where - arbitraryMessagePayload = unRemoveProposalPayload <$> arbitrary +instance ArbitraryFramedContentData RemoveProposalPayload where + arbitraryFramedContentData = unRemoveProposalPayload <$> arbitrary --- newtype TestPreconfiguredSender = TestPreconfiguredSender - {unTestPreconfiguredSender :: Sender 'MLSPlainText} + {unTestPreconfiguredSender :: Sender} deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) instance Arbitrary TestPreconfiguredSender where - arbitrary = TestPreconfiguredSender . PreconfiguredSender <$> arbitrary + arbitrary = TestPreconfiguredSender . SenderExternal <$> arbitrary instance ArbitrarySender TestPreconfiguredSender where arbitrarySender = unTestPreconfiguredSender <$> arbitrary --- -newtype AppAckProposalTest = AppAckProposalTest Proposal - deriving newtype (ParseMLS, Eq, Show) - -instance Arbitrary AppAckProposalTest where - arbitrary = AppAckProposalTest . AppAckProposal <$> arbitrary - -instance SerialiseMLS AppAckProposalTest where - serialiseMLS (AppAckProposalTest (AppAckProposal mrs)) = serialiseAppAckProposal mrs - serialiseMLS _ = serialiseAppAckProposal [] - ---- - newtype ExtensionVector = ExtensionVector [Extension] deriving newtype (Arbitrary, Eq, Show) instance ParseMLS ExtensionVector where - parseMLS = ExtensionVector <$> parseMLSVector @Word32 (parseMLS @Extension) + parseMLS = ExtensionVector <$> parseMLSVector @VarInt (parseMLS @Extension) instance SerialiseMLS ExtensionVector where serialiseMLS (ExtensionVector exts) = do - serialiseMLSVector @Word32 serialiseMLS exts + serialiseMLSVector @VarInt serialiseMLS exts ---- +-- -newtype TestCommitBundle = TestCommitBundle {unTestCommitBundle :: CommitBundle} - deriving (Show, Eq) +newtype TestCommitBundle = TestCommitBundle CommitBundle + deriving newtype (Eq, Show, ParseMLS, SerialiseMLS) --- | The commit bundle should contain a commit message, not a remove proposal --- message. However defining MLS serialization for Commits and all nested types --- seems overkill to test the commit bundle roundtrip instance Arbitrary TestCommitBundle where - arbitrary = do - bundle <- - CommitBundle - <$> (mkRawMLS . unRemoveProposalMessage <$> arbitrary) - <*> oneof [Just <$> (mkRawMLS <$> arbitrary), pure Nothing] - <*> arbitrary - pure (TestCommitBundle bundle) - -instance ConvertProtoLens Proto.Mls.CommitBundle TestCommitBundle where - fromProtolens = fmap TestCommitBundle . fromProtolens @Proto.Mls.CommitBundle @CommitBundle - toProtolens = toProtolens . unTestCommitBundle + arbitrary = + TestCommitBundle <$> do + commitMsg <- + mkRawMLS . unMessageGenerator @(FramedContentGenerator Sender CommitPayload) + <$> arbitrary + welcome <- arbitrary + CommitBundle commitMsg welcome <$> arbitrary + +newtype CommitPayload = CommitPayload {unCommitPayload :: RawMLS Commit} + deriving newtype (Arbitrary) + +instance ArbitraryFramedContentData CommitPayload where + arbitraryFramedContentData = FramedContentCommit . unCommitPayload <$> arbitrary diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Test/Wire/API/Run.hs similarity index 98% rename from libs/wire-api/test/unit/Main.hs rename to libs/wire-api/test/unit/Test/Wire/API/Run.hs index a1b492c371..14382593d0 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Run.hs @@ -15,10 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main - ( main, - ) -where +module Test.Wire.API.Run (main) where import Imports import System.IO.Unsafe (unsafePerformIO) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index f3d8f7ce9e..f70e2c36eb 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 3.0 name: wire-api version: 0.1.0 description: API types of the Wire collaboration platform @@ -6,11 +6,64 @@ category: Network author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2020 Wire Swiss GmbH -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE build-type: Simple +common common-all + default-language: Haskell2010 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -Wredundant-constraints + + default-extensions: + NoImplicitPrelude + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + library + import: common-all + -- cabal-fmt: expand src exposed-modules: Wire.API.ApplyMods @@ -43,6 +96,8 @@ library Wire.API.MakesFederatedCall Wire.API.Message Wire.API.Message.Proto + Wire.API.MLS.AuthenticatedContent + Wire.API.MLS.Capabilities Wire.API.MLS.CipherSuite Wire.API.MLS.Commit Wire.API.MLS.CommitBundle @@ -51,15 +106,20 @@ library Wire.API.MLS.Epoch Wire.API.MLS.Extension Wire.API.MLS.Group - Wire.API.MLS.GroupInfoBundle + Wire.API.MLS.GroupInfo + Wire.API.MLS.HPKEPublicKey Wire.API.MLS.KeyPackage Wire.API.MLS.Keys + Wire.API.MLS.LeafNode + Wire.API.MLS.Lifetime Wire.API.MLS.Message Wire.API.MLS.Proposal - Wire.API.MLS.PublicGroupState + Wire.API.MLS.ProposalTag + Wire.API.MLS.ProtocolVersion Wire.API.MLS.Serialisation Wire.API.MLS.Servant Wire.API.MLS.SubConversation + Wire.API.MLS.Validation Wire.API.MLS.Welcome Wire.API.Notification Wire.API.OAuth @@ -162,57 +222,10 @@ library Wire.API.VersionInfo Wire.API.Wrapped - other-modules: Paths_wire_api - hs-source-dirs: src - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints - + other-modules: Paths_wire_api + hs-source-dirs: src build-depends: - aeson >=2.0.1.0 + , aeson >=2.0.1.0 , attoparsec >=0.10 , base >=4 && <5 , base64-bytestring >=1.0 @@ -305,15 +318,13 @@ library , x509 , zauth - default-language: Haskell2010 - test-suite wire-api-golden-tests - type: exitcode-stdio-1.0 - main-is: Main.hs + import: common-all + type: exitcode-stdio-1.0 + main-is: ../golden.hs -- cabal-fmt: expand test/golden other-modules: - Main Paths_wire_api Test.Wire.API.Golden.FromJSON Test.Wire.API.Golden.Generated @@ -560,58 +571,13 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual.UserClientPrekeyMap Test.Wire.API.Golden.Manual.UserIdList Test.Wire.API.Golden.Protobuf + Test.Wire.API.Golden.Run Test.Wire.API.Golden.Runner - hs-source-dirs: test/golden - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -with-rtsopts=-N -Wredundant-constraints - + ghc-options: -threaded -with-rtsopts=-N + hs-source-dirs: test/golden build-depends: - aeson >=2.0.1.0 + , aeson >=2.0.1.0 , aeson-pretty , aeson-qq , base @@ -654,15 +620,13 @@ test-suite wire-api-golden-tests , wire-api , wire-message-proto-lens - default-language: Haskell2010 - test-suite wire-api-tests - type: exitcode-stdio-1.0 - main-is: Main.hs + import: common-all + type: exitcode-stdio-1.0 + main-is: ../unit.hs -- cabal-fmt: expand test/unit other-modules: - Main Paths_wire_api Test.Wire.API.Call.Config Test.Wire.API.Conversation @@ -678,6 +642,7 @@ test-suite wire-api-tests Test.Wire.API.Routes Test.Wire.API.Routes.Version Test.Wire.API.Routes.Version.Wai + Test.Wire.API.Run Test.Wire.API.Swagger Test.Wire.API.Team.Export Test.Wire.API.Team.Member @@ -686,56 +651,9 @@ test-suite wire-api-tests Test.Wire.API.User.RichInfo Test.Wire.API.User.Search - hs-source-dirs: test/unit - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -with-rtsopts=-N -Wredundant-constraints - + hs-source-dirs: test/unit build-depends: - aeson >=2.0.1.0 + , aeson >=2.0.1.0 , aeson-pretty , aeson-qq , async @@ -769,6 +687,7 @@ test-suite wire-api-tests , process , proto-lens , QuickCheck + , random , saml2-web-sso , schema-profunctor , servant @@ -793,4 +712,4 @@ test-suite wire-api-tests , wire-api , wire-message-proto-lens - default-language: Haskell2010 + ghc-options: -threaded -with-rtsopts=-N diff --git a/nix/pkgs/mls-test-cli/default.nix b/nix/pkgs/mls-test-cli/default.nix index 968b60d904..ddbf9b342a 100644 --- a/nix/pkgs/mls-test-cli/default.nix +++ b/nix/pkgs/mls-test-cli/default.nix @@ -8,20 +8,29 @@ , gitMinimal }: -rustPlatform.buildRustPackage rec { - name = "mls-test-cli-${version}"; - version = "0.6.0"; - nativeBuildInputs = [ pkg-config perl gitMinimal ]; - buildInputs = [ libsodium ]; +let + version = "0.7.0"; src = fetchFromGitHub { owner = "wireapp"; repo = "mls-test-cli"; - sha256 = "sha256-FjgAcYdUr/ZWdQxbck2UEG6NEEQLuz0S4a55hrAxUs4="; - rev = "82fc148964ef5baa92a90d086fdc61adaa2b5dbf"; + rev = "29109bd32cedae64bdd9a47ef373710fad477590"; + sha256 = "sha256-1GMiEMkzcKPOd5AsQkQTSMLDkNqy3yjCC03K20vyFVY="; }; - doCheck = false; - cargoSha256 = "sha256-AlZrxa7f5JwxxrzFBgeFSaYU6QttsUpfLYfq1HzsdbE="; - cargoDepsHook = '' - mkdir -p mls-test-cli-${version}-vendor.tar.gz/ring/.git + cargoLockFile = builtins.toFile "cargo.lock" (builtins.readFile "${src}/Cargo.lock"); +in rustPlatform.buildRustPackage rec { + name = "mls-test-cli-${version}"; + inherit version src; + + cargoLock = { + lockFile = cargoLockFile; + outputHashes = { + "hpke-0.10.0" = "sha256-XYkG72ZeQ3nM4JjgNU5Fe0HqNGkBGcI70rE1Kbz/6vs="; + "openmls-0.20.0" = "sha256-i5xNTYP1wPzwlnqz+yPu8apKCibRZacz4OV5VVZwY5Y="; + }; + }; + + postPatch = '' + cp ${cargoLockFile} Cargo.lock ''; + doCheck = false; } diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 00a464df5c..c10aa3b01f 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 3.0 name: brig version: 2.0 synopsis: User Service @@ -6,7 +6,7 @@ category: Network author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE build-type: Simple extra-source-files: @@ -14,7 +14,60 @@ extra-source-files: docs/swagger-v1.json docs/swagger.md +common common-all + default-language: Haskell2010 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -Wredundant-constraints + + default-extensions: + NoImplicitPrelude + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + library + import: common-all + -- cabal-fmt: expand src exposed-modules: Brig.Allowlists @@ -133,58 +186,14 @@ library Brig.Version Brig.ZAuth - other-modules: Paths_brig - hs-source-dirs: src - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - + other-modules: Paths_brig + hs-source-dirs: src ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -fplugin=Polysemy.Plugin - -fplugin=TransitiveAnns.Plugin -Wredundant-constraints + -fplugin=TransitiveAnns.Plugin build-depends: - aeson >=2.0.1.0 + , aeson >=2.0.1.0 , amazonka >=2 , amazonka-core >=2 , amazonka-dynamodb >=2 @@ -317,131 +326,43 @@ library , yaml >=0.8.22 , zauth >=0.10.3 - default-language: Haskell2010 + default-language: Haskell2010 executable brig - main-is: exec/Main.hs - other-modules: Paths_brig - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - + import: common-all + main-is: exec/Main.hs + other-modules: Paths_brig ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints + -rtsopts build-depends: - base + , base , brig , HsOpenSSL , imports , optparse-applicative >=0.10 , types-common - default-language: Haskell2010 + default-language: Haskell2010 executable brig-index - main-is: index/src/Main.hs - other-modules: Paths_brig - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N - -Wredundant-constraints - + import: common-all + main-is: index/src/Main.hs + other-modules: Paths_brig + ghc-options: -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: - base + , base , brig , imports , optparse-applicative , tinylog - default-language: Haskell2010 + default-language: Haskell2010 executable brig-integration - main-is: Main.hs + import: common-all + main-is: ../integration.hs -- cabal-fmt: expand test/integration other-modules: @@ -478,62 +399,15 @@ executable brig-integration Federation.End2end Federation.Util Index.Create - Main + Run SMTP Util Util.AWS - hs-source-dirs: test/integration - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N - -Wredundant-constraints - + hs-source-dirs: test/integration + ghc-options: -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: - aeson + , aeson , async , attoparsec , base @@ -627,14 +501,15 @@ executable brig-integration , yaml , zauth - default-language: Haskell2010 + default-language: Haskell2010 executable brig-schema - main-is: Main.hs + import: common-all + main-is: ../main.hs -- cabal-fmt: expand schema/src other-modules: - Main + Run V43 V44 V45 @@ -671,55 +546,10 @@ executable brig-schema V_FUTUREWORK hs-source-dirs: schema/src - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -Wredundant-constraints - + ghc-options: -funbox-strict-fields -Wredundant-constraints + default-extensions: TemplateHaskell build-depends: - base + , base , cassandra-util >=0.12 , extended , imports @@ -732,12 +562,11 @@ executable brig-schema default-language: Haskell2010 test-suite brig-tests - type: exitcode-stdio-1.0 - main-is: Main.hs - - -- cabal-fmt: expand test/unit + import: common-all + type: exitcode-stdio-1.0 + main-is: ../unit.hs other-modules: - Main + Run Test.Brig.Calling Test.Brig.Calling.Internal Test.Brig.Effects.Delay @@ -746,57 +575,10 @@ test-suite brig-tests Test.Brig.Roundtrip Test.Brig.User.Search.Index.Types - hs-source-dirs: test/unit - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N - -Wredundant-constraints - + hs-source-dirs: test/unit + ghc-options: -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: - aeson + , aeson , base , binary , bloodhound @@ -831,4 +613,4 @@ test-suite brig-tests , wire-api , wire-api-federation - default-language: Haskell2010 + default-language: Haskell2010 diff --git a/services/brig/schema/main.hs b/services/brig/schema/main.hs new file mode 100644 index 0000000000..d4037ab9cf --- /dev/null +++ b/services/brig/schema/main.hs @@ -0,0 +1,5 @@ +import Imports +import qualified Run + +main :: IO () +main = Run.main diff --git a/services/brig/schema/src/Main.hs b/services/brig/schema/src/Run.hs similarity index 99% rename from services/brig/schema/src/Main.hs rename to services/brig/schema/src/Run.hs index f1f35ccd37..96bd6d1675 100644 --- a/services/brig/schema/src/Main.hs +++ b/services/brig/schema/src/Run.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main where +module Run where import Cassandra.Schema import Control.Exception (finally) diff --git a/services/brig/schema/src/V69_MLSKeyPackageRefMapping.hs b/services/brig/schema/src/V69_MLSKeyPackageRefMapping.hs index 34c95d70e1..aae2b698ae 100644 --- a/services/brig/schema/src/V69_MLSKeyPackageRefMapping.hs +++ b/services/brig/schema/src/V69_MLSKeyPackageRefMapping.hs @@ -26,6 +26,7 @@ import Cassandra.Schema import Imports import Text.RawString.QQ +-- FUTUREWORK: remove this table migration :: Migration migration = Migration 69 "Add key package ref mapping" $ diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index f992ff8258..55dc93cbcf 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -27,7 +27,6 @@ import qualified Brig.API.Client as API import qualified Brig.API.Connection as API import Brig.API.Error import Brig.API.Handler -import Brig.API.MLS.KeyPackages.Validation import Brig.API.OAuth (internalOauthAPI) import Brig.API.Types import qualified Brig.API.User as API @@ -86,10 +85,7 @@ import Wire.API.Connection import Wire.API.Error import qualified Wire.API.Error.Brig as E import Wire.API.Federation.API -import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage -import Wire.API.MLS.Serialisation -import Wire.API.Routes.Internal.Brig +import Wire.API.MLS.CipherSuite import qualified Wire.API.Routes.Internal.Brig as BrigIRoutes import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named @@ -132,20 +128,7 @@ ejpdAPI = :<|> getConnectionsStatus mlsAPI :: ServerT BrigIRoutes.MLSAPI (Handler r) -mlsAPI = - ( ( \ref -> - Named @"get-client-by-key-package-ref" (getClientByKeyPackageRef ref) - :<|> ( Named @"put-conversation-by-key-package-ref" (putConvIdByKeyPackageRef ref) - :<|> Named @"get-conversation-by-key-package-ref" (getConvIdByKeyPackageRef ref) - ) - :<|> Named @"put-key-package-ref" (putKeyPackageRef ref) - :<|> Named @"post-key-package-ref" (postKeyPackageRef ref) - ) - :<|> Named @"delete-key-package-refs" deleteKeyPackageRefs - ) - :<|> getMLSClients - :<|> mapKeyPackageRefsInternal - :<|> Named @"put-key-package-add" upsertKeyPackage +mlsAPI = getMLSClients accountAPI :: ( Member BlacklistStore r, @@ -187,62 +170,6 @@ deleteAccountConferenceCallingConfig :: UserId -> (Handler r) NoContent deleteAccountConferenceCallingConfig uid = lift $ wrapClient $ Data.updateFeatureConferenceCalling uid Nothing $> NoContent -getClientByKeyPackageRef :: KeyPackageRef -> Handler r (Maybe ClientIdentity) -getClientByKeyPackageRef = runMaybeT . mapMaybeT wrapClientE . Data.derefKeyPackage - --- Used by galley to update conversation id in mls_key_package_ref -putConvIdByKeyPackageRef :: KeyPackageRef -> Qualified ConvId -> Handler r Bool -putConvIdByKeyPackageRef ref = lift . wrapClient . Data.keyPackageRefSetConvId ref - --- Used by galley to create a new record in mls_key_package_ref -putKeyPackageRef :: KeyPackageRef -> NewKeyPackageRef -> Handler r () -putKeyPackageRef ref = lift . wrapClient . Data.addKeyPackageRef ref - --- Used by galley to retrieve conversation id from mls_key_package_ref -getConvIdByKeyPackageRef :: KeyPackageRef -> Handler r (Maybe (Qualified ConvId)) -getConvIdByKeyPackageRef = runMaybeT . mapMaybeT wrapClientE . Data.keyPackageRefConvId - --- Used by galley to update key packages in mls_key_package_ref on commits with update_path -postKeyPackageRef :: KeyPackageRef -> KeyPackageRef -> Handler r () -postKeyPackageRef ref = lift . wrapClient . Data.updateKeyPackageRef ref - --- Used by galley to update key package refs and also validate -upsertKeyPackage :: NewKeyPackage -> Handler r NewKeyPackageResult -upsertKeyPackage nkp = do - kp <- - either - (const $ mlsProtocolError "upsertKeyPackage: Cannot decocode KeyPackage") - pure - $ decodeMLS' @(RawMLS KeyPackage) (kpData . nkpKeyPackage $ nkp) - ref <- kpRef' kp & noteH "upsertKeyPackage: Unsupported CipherSuite" - - identity <- - either - (const $ mlsProtocolError "upsertKeyPackage: Cannot decode ClientIdentity") - pure - $ kpIdentity (rmValue kp) - mp <- lift . wrapClient . runMaybeT $ Data.derefKeyPackage ref - when (isNothing mp) $ do - void $ validateKeyPackage identity kp - lift . wrapClient $ - Data.addKeyPackageRef - ref - ( NewKeyPackageRef - (fst <$> cidQualifiedClient identity) - (ciClient identity) - (nkpConversation nkp) - ) - - pure $ NewKeyPackageResult identity ref - where - noteH :: Text -> Maybe a -> Handler r a - noteH errMsg Nothing = mlsProtocolError errMsg - noteH _ (Just y) = pure y - -deleteKeyPackageRefs :: DeleteKeyPackageRefsRequest -> Handler r () -deleteKeyPackageRefs (DeleteKeyPackageRefsRequest refs) = - lift . wrapClient $ pooledForConcurrentlyN_ 16 refs Data.deleteKeyPackageRef - getMLSClients :: UserId -> SignatureSchemeTag -> Handler r (Set ClientInfo) getMLSClients usr _ss = do -- FUTUREWORK: check existence of key packages with a given ciphersuite @@ -260,12 +187,6 @@ getMLSClients usr _ss = do (cid,) . (> 0) <$> Data.countKeyPackages lusr cid -mapKeyPackageRefsInternal :: KeyPackageBundle -> Handler r () -mapKeyPackageRefsInternal bundle = do - wrapClientE $ - for_ (kpbEntries bundle) $ \e -> - Data.mapKeyPackageRef (kpbeRef e) (kpbeUser e) (kpbeClient e) - getVerificationCode :: UserId -> VerificationAction -> Handler r (Maybe Code.Value) getVerificationCode uid action = do user <- wrapClientE $ Api.lookupUser NoPendingInvitations uid diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index 74742fe176..53bd3fe164 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -48,10 +48,10 @@ import Wire.API.Team.LegalHold import Wire.API.User.Client uploadKeyPackages :: Local UserId -> ClientId -> KeyPackageUpload -> Handler r () -uploadKeyPackages lusr cid (kpuKeyPackages -> kps) = do +uploadKeyPackages lusr cid kps = do assertMLSEnabled let identity = mkClientIdentity (tUntagged lusr) cid - kps' <- traverse (validateKeyPackage identity) kps + kps' <- traverse (validateUploadedKeyPackage identity) kps.keyPackages lift . wrapClient $ Data.insertKeyPackages (tUnqualified lusr) cid kps' claimKeyPackages :: @@ -111,22 +111,20 @@ claimRemoteKeyPackages lusr target = do ckprTarget = tUnqualified target } - -- validate and set up mappings for all claimed key packages - for_ (kpbEntries bundle) $ \e -> do - let cid = mkClientIdentity (kpbeUser e) (kpbeClient e) + -- validate all claimed key packages + for_ bundle.entries $ \e -> do + let cid = mkClientIdentity e.user e.client kpRaw <- withExceptT (const . clientDataError $ KeyPackageDecodingError) . except . decodeMLS' . kpData - . kpbeKeyPackage - $ e - (refVal, _) <- validateKeyPackage cid kpRaw - unless (refVal == kpbeRef e) + $ e.keyPackage + (refVal, _) <- validateUploadedKeyPackage cid kpRaw + unless (refVal == e.ref) . throwE . clientDataError $ InvalidKeyPackageRef - wrapClientE $ Data.mapKeyPackageRef (kpbeRef e) (kpbeUser e) (kpbeClient e) pure bundle where diff --git a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs index 2ebed2e370..26de9a143f 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs @@ -17,13 +17,9 @@ module Brig.API.MLS.KeyPackages.Validation ( -- * Main key package validation function - validateKeyPackage, - reLifetime, - mlsProtocolError, - - -- * Exported for unit tests - findExtensions, + validateUploadedKeyPackage, validateLifetime', + mlsProtocolError, ) where @@ -32,9 +28,8 @@ import Brig.API.Handler import Brig.App import qualified Brig.Data.Client as Data import Brig.Options -import Control.Applicative -import Control.Lens (view) -import qualified Data.ByteString.Lazy as LBS +import Control.Lens +import qualified Data.ByteString as LBS import Data.Qualified import Data.Time.Clock import Data.Time.Clock.POSIX @@ -43,110 +38,46 @@ import Wire.API.Error import Wire.API.Error.Brig import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential -import Wire.API.MLS.Extension import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Lifetime import Wire.API.MLS.Serialisation +import Wire.API.MLS.Validation -validateKeyPackage :: +validateUploadedKeyPackage :: ClientIdentity -> RawMLS KeyPackage -> Handler r (KeyPackageRef, KeyPackageData) -validateKeyPackage identity (RawMLS (KeyPackageData -> kpd) kp) = do - loc <- qualifyLocal () - -- get ciphersuite - cs <- - maybe - (mlsProtocolError "Unsupported ciphersuite") - pure - $ cipherSuiteTag (kpCipherSuite kp) +validateUploadedKeyPackage identity kp = do + (cs, lt) <- either mlsProtocolError pure $ validateKeyPackage (Just identity) kp.value - -- validate signature scheme - let ss = csSignatureScheme cs - when (signatureScheme ss /= bcSignatureScheme (kpCredential kp)) $ - mlsProtocolError "Signature scheme incompatible with ciphersuite" + validateLifetime lt -- Authenticate signature key. This is performed only upon uploading a key -- package for a local client. + loc <- qualifyLocal () foldQualified loc ( \_ -> do - key <- - fmap LBS.toStrict $ - maybe - (mlsProtocolError "No key associated to the given identity and signature scheme") - pure - =<< lift (wrapClient (Data.lookupMLSPublicKey (ciUser identity) (ciClient identity) ss)) - when (key /= bcSignatureKey (kpCredential kp)) $ + mkey :: Maybe LByteString <- + lift . wrapClient $ + Data.lookupMLSPublicKey + (ciUser identity) + (ciClient identity) + (csSignatureScheme cs) + key :: LByteString <- + maybe + (mlsProtocolError "No key associated to the given identity and signature scheme") + pure + mkey + when (key /= LBS.fromStrict kp.value.leafNode.signatureKey) $ mlsProtocolError "Unrecognised signature key" ) - (pure . const ()) + (\_ -> pure ()) (cidQualifiedClient identity) - -- validate signature - unless - ( csVerifySignature - cs - (bcSignatureKey (kpCredential kp)) - (rmRaw (kpTBS kp)) - (kpSignature kp) - ) - $ mlsProtocolError "Invalid signature" - -- validate protocol version - maybe - (mlsProtocolError "Unsupported protocol version") - pure - (pvTag (kpProtocolVersion kp) >>= guard . (== ProtocolMLS10)) - -- validate credential - validateCredential identity (kpCredential kp) - -- validate extensions - validateExtensions (kpExtensions kp) + let kpd = KeyPackageData kp.raw pure (kpRef cs kpd, kpd) -validateCredential :: ClientIdentity -> Credential -> Handler r () -validateCredential identity cred = do - identity' <- - either credentialError pure $ - decodeMLS' (bcIdentity cred) - when (identity /= identity') $ - throwStd (errorToWai @'MLSIdentityMismatch) - where - credentialError e = - mlsProtocolError $ - "Failed to parse identity: " <> e - -data RequiredExtensions f = RequiredExtensions - { reLifetime :: f Lifetime, - reCapabilities :: f () - } - -deriving instance (Show (f Lifetime), Show (f ())) => Show (RequiredExtensions f) - -instance Alternative f => Semigroup (RequiredExtensions f) where - RequiredExtensions lt1 cap1 <> RequiredExtensions lt2 cap2 = - RequiredExtensions (lt1 <|> lt2) (cap1 <|> cap2) - -instance Alternative f => Monoid (RequiredExtensions f) where - mempty = RequiredExtensions empty empty - -checkRequiredExtensions :: RequiredExtensions Maybe -> Either Text (RequiredExtensions Identity) -checkRequiredExtensions re = - RequiredExtensions - <$> maybe (Left "Missing lifetime extension") (pure . Identity) (reLifetime re) - <*> maybe (Left "Missing capability extension") (pure . Identity) (reCapabilities re) - -findExtensions :: [Extension] -> Either Text (RequiredExtensions Identity) -findExtensions = checkRequiredExtensions <=< (getAp . foldMap findExtension) - -findExtension :: Extension -> Ap (Either Text) (RequiredExtensions Maybe) -findExtension ext = (Ap (decodeExtension ext) >>=) . foldMap $ \case - (SomeExtension SLifetimeExtensionTag lt) -> pure $ RequiredExtensions (Just lt) Nothing - (SomeExtension SCapabilitiesExtensionTag _) -> pure $ RequiredExtensions Nothing (Just ()) - -validateExtensions :: [Extension] -> Handler r () -validateExtensions exts = do - re <- either mlsProtocolError pure $ findExtensions exts - validateLifetime . runIdentity . reLifetime $ re - validateLifetime :: Lifetime -> Handler r () validateLifetime lt = do now <- liftIO getPOSIXTime diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 5e532d974e..0c58480f94 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -86,7 +86,7 @@ import qualified System.CryptoBox as CryptoBox import System.Logger.Class (field, msg, val) import qualified System.Logger.Class as Log import UnliftIO (pooledMapConcurrentlyN) -import Wire.API.MLS.Credential +import Wire.API.MLS.CipherSuite import Wire.API.User.Auth import Wire.API.User.Client hiding (UpdateClient (..)) import Wire.API.User.Client.Prekey diff --git a/services/brig/src/Brig/Data/MLS/KeyPackage.hs b/services/brig/src/Brig/Data/MLS/KeyPackage.hs index 2f99e355bc..03a69e69ab 100644 --- a/services/brig/src/Brig/Data/MLS/KeyPackage.hs +++ b/services/brig/src/Brig/Data/MLS/KeyPackage.hs @@ -18,14 +18,7 @@ module Brig.Data.MLS.KeyPackage ( insertKeyPackages, claimKeyPackage, - mapKeyPackageRef, countKeyPackages, - derefKeyPackage, - keyPackageRefConvId, - keyPackageRefSetConvId, - addKeyPackageRef, - updateKeyPackageRef, - deleteKeyPackageRef, ) where @@ -33,24 +26,19 @@ import Brig.API.MLS.KeyPackages.Validation import Brig.App import Brig.Options hiding (Timeout) import Cassandra -import Cassandra.Settings import Control.Arrow import Control.Error -import Control.Exception import Control.Lens -import Control.Monad.Catch import Control.Monad.Random (randomRIO) -import Data.Domain import Data.Functor import Data.Id import Data.Qualified import Data.Time.Clock import Data.Time.Clock.POSIX import Imports -import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.Serialisation -import Wire.API.Routes.Internal.Brig insertKeyPackages :: MonadClient m => UserId -> ClientId -> [(KeyPackageRef, KeyPackageData)] -> m () insertKeyPackages uid cid kps = retry x5 . batch $ do @@ -80,7 +68,6 @@ claimKeyPackage u c = do for mk $ \(ref, kpd) -> do retry x5 $ write deleteByRef (params LocalQuorum (tUnqualified u, c, ref)) pure (ref, kpd) - lift $ mapKeyPackageRef ref (tUntagged u) c pure (ref, kpd) where deleteByRef :: PrepQuery W (UserId, ClientId, KeyPackageRef) () @@ -127,19 +114,11 @@ getNonClaimedKeyPackages u c = do hasExpired :: POSIXTime -> Maybe NominalDiffTime -> (KeyPackage, a) -> Bool hasExpired now mMaxLifetime (kp, _) = - case findExtensions (kpExtensions kp) of - Left _ -> True -- the assumption is the key package is valid and has the - -- required extensions so we return 'True' - Right (runIdentity . reLifetime -> lt) -> + case kp.leafNode.source of + LeafNodeSourceKeyPackage lt -> either (const True) (const False) . validateLifetime' now mMaxLifetime $ lt - --- | Add key package ref to mapping table. -mapKeyPackageRef :: MonadClient m => KeyPackageRef -> Qualified UserId -> ClientId -> m () -mapKeyPackageRef ref u c = - write insertQuery (params LocalQuorum (ref, qDomain u, qUnqualified u, c)) - where - insertQuery :: PrepQuery W (KeyPackageRef, Domain, UserId, ClientId) () - insertQuery = "INSERT INTO mls_key_package_refs (ref, domain, user, client) VALUES (?, ?, ?, ?)" + _ -> True -- the assumption is the key package is valid and has the + -- required extensions so we return 'True' countKeyPackages :: ( MonadReader Env m, @@ -150,104 +129,9 @@ countKeyPackages :: m Int64 countKeyPackages u c = fromIntegral . length <$> getNonClaimedKeyPackages u c -derefKeyPackage :: MonadClient m => KeyPackageRef -> MaybeT m ClientIdentity -derefKeyPackage ref = do - (d, u, c) <- MaybeT . retry x1 $ query1 q (params LocalQuorum (Identity ref)) - pure $ ClientIdentity d u c - where - q :: PrepQuery R (Identity KeyPackageRef) (Domain, UserId, ClientId) - q = "SELECT domain, user, client from mls_key_package_refs WHERE ref = ?" - -keyPackageRefConvId :: MonadClient m => KeyPackageRef -> MaybeT m (Qualified ConvId) -keyPackageRefConvId ref = MaybeT $ do - qr <- retry x1 $ query1 q (params LocalSerial (Identity ref)) - pure $ do - (domain, cid) <- qr - Qualified <$> cid <*> domain - where - q :: PrepQuery R (Identity KeyPackageRef) (Maybe Domain, Maybe ConvId) - q = "SELECT conv_domain, conv FROM mls_key_package_refs WHERE ref = ?" - --- We want to proper update, not an upsert, to avoid "ghost" refs without user+client -keyPackageRefSetConvId :: MonadClient m => KeyPackageRef -> Qualified ConvId -> m Bool -keyPackageRefSetConvId ref convId = do - updated <- - retry x5 $ - trans - q - (params LocalQuorum (qDomain convId, qUnqualified convId, ref)) - { serialConsistency = Just LocalSerialConsistency - } - case updated of - [] -> pure False - [_] -> pure True - _ -> throwM $ ErrorCall "Primary key violation detected mls_key_package_refs.ref" - where - q :: PrepQuery W (Domain, ConvId, KeyPackageRef) x - q = "UPDATE mls_key_package_refs SET conv_domain = ?, conv = ? WHERE ref = ? IF EXISTS" - -addKeyPackageRef :: MonadClient m => KeyPackageRef -> NewKeyPackageRef -> m () -addKeyPackageRef ref nkpr = - retry x5 $ - write - q - (params LocalQuorum (nkprClientId nkpr, qUnqualified (nkprConversation nkpr), qDomain (nkprConversation nkpr), qDomain (nkprUserId nkpr), qUnqualified (nkprUserId nkpr), ref)) - where - q :: PrepQuery W (ClientId, ConvId, Domain, Domain, UserId, KeyPackageRef) x - q = "UPDATE mls_key_package_refs SET client = ?, conv = ?, conv_domain = ?, domain = ?, user = ? WHERE ref = ?" - --- | Update key package ref, used in Galley when commit reveals key package ref update for the sender. --- Nothing is changed if the previous key package ref is not found in the table. --- Updating amounts to INSERT the new key package ref, followed by DELETE the --- previous one. --- --- FUTUREWORK: this function has to be extended if a table mapping (client, --- conversation) to key package ref is added, for instance, when implementing --- external delete proposals. -updateKeyPackageRef :: MonadClient m => KeyPackageRef -> KeyPackageRef -> m () -updateKeyPackageRef prevRef newRef = - void . runMaybeT $ do - backup <- backupKeyPackageMeta prevRef - lift $ do - restoreKeyPackageMeta newRef backup - deleteKeyPackage prevRef - -deleteKeyPackageRef :: MonadClient m => KeyPackageRef -> m () -deleteKeyPackageRef ref = do - retry x5 $ - write q (params LocalQuorum (Identity ref)) - where - q :: PrepQuery W (Identity KeyPackageRef) x - q = "DELETE FROM mls_key_package_refs WHERE ref = ?" - -------------------------------------------------------------------------------- -- Utilities -backupKeyPackageMeta :: MonadClient m => KeyPackageRef -> MaybeT m (ClientId, Maybe (Qualified ConvId), Qualified UserId) -backupKeyPackageMeta ref = do - (clientId, convId, convDomain, userDomain, userId) <- MaybeT . retry x1 $ query1 q (params LocalQuorum (Identity ref)) - pure (clientId, Qualified <$> convId <*> convDomain, Qualified userId userDomain) - where - q :: PrepQuery R (Identity KeyPackageRef) (ClientId, Maybe ConvId, Maybe Domain, Domain, UserId) - q = "SELECT client, conv, conv_domain, domain, user FROM mls_key_package_refs WHERE ref = ?" - -restoreKeyPackageMeta :: MonadClient m => KeyPackageRef -> (ClientId, Maybe (Qualified ConvId), Qualified UserId) -> m () -restoreKeyPackageMeta ref (clientId, convId, userId) = do - write q (params LocalQuorum (ref, clientId, qUnqualified <$> convId, qDomain <$> convId, qDomain userId, qUnqualified userId)) - where - q :: PrepQuery W (KeyPackageRef, ClientId, Maybe ConvId, Maybe Domain, Domain, UserId) () - q = "INSERT INTO mls_key_package_refs (ref, client, conv, conv_domain, domain, user) VALUES (?, ?, ?, ?, ?, ?)" - -deleteKeyPackage :: MonadClient m => KeyPackageRef -> m () -deleteKeyPackage ref = - retry x5 $ - write - q - (params LocalQuorum (Identity ref)) - where - q :: PrepQuery W (Identity KeyPackageRef) x - q = "DELETE FROM mls_key_package_refs WHERE ref = ?" - pick :: [a] -> IO (Maybe a) pick [] = pure Nothing pick xs = do diff --git a/services/brig/test/integration.hs b/services/brig/test/integration.hs new file mode 100644 index 0000000000..d4037ab9cf --- /dev/null +++ b/services/brig/test/integration.hs @@ -0,0 +1,5 @@ +import Imports +import qualified Run + +main :: IO () +main = Run.main diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index af65db356b..36e1e42b65 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -47,14 +47,12 @@ import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import UnliftIO.Temporary import Util -import Web.HttpApiData import Wire.API.Connection import Wire.API.Federation.API.Brig import qualified Wire.API.Federation.API.Brig as FedBrig import qualified Wire.API.Federation.API.Brig as S import Wire.API.Federation.Component import Wire.API.Federation.Version -import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage import Wire.API.User import Wire.API.User.Client @@ -426,7 +424,7 @@ testClaimKeyPackages brig fedBrigClient = do ClaimKeyPackageRequest (qUnqualified alice) (qUnqualified bob) liftIO $ - Set.map (\e -> (kpbeUser e, kpbeClient e)) (kpbEntries bundle) + Set.map (\e -> (e.user, e.client)) bundle.entries @?= Set.fromList [(bob, c) | c <- bobClients] -- check that we have one fewer key package now @@ -434,17 +432,6 @@ testClaimKeyPackages brig fedBrigClient = do count <- getKeyPackageCount brig bob c liftIO $ count @?= 1 - -- check that the package refs are correctly mapped - for_ (kpbEntries bundle) $ \e -> do - cid <- - responseJsonError - =<< get (brig . paths ["i", "mls", "key-packages", toHeader (kpbeRef e)]) - Opt.Opts -> Brig -> Http () testClaimKeyPackagesMLSDisabled opts brig = do alice <- fakeRemoteUser diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index 516b8934c9..b3dd9c1073 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -36,26 +36,21 @@ import qualified Cassandra as Cass import Cassandra.Util import Control.Exception (ErrorCall (ErrorCall), throwIO) import Control.Lens ((^.), (^?!)) -import Data.Aeson (decode) import qualified Data.Aeson.Lens as Aeson import qualified Data.Aeson.Types as Aeson import Data.ByteString.Conversion (toByteString') import Data.Default import Data.Id -import Data.Qualified (Qualified (qDomain, qUnqualified)) +import Data.Qualified import qualified Data.Set as Set import GHC.TypeLits (KnownSymbol) import Imports -import Servant.API (ToHttpApiData (toUrlPiece)) -import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty import Test.Tasty.HUnit import UnliftIO (withSystemTempDirectory) import Util import Util.Options (Endpoint) import qualified Wire.API.Connection as Conn -import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage import Wire.API.Routes.Internal.Brig import Wire.API.Team.Feature import qualified Wire.API.Team.Feature as ApiFt @@ -74,14 +69,6 @@ tests opts mgr db brig brigep gundeck galley = do test mgr "suspend non existing user and verify no db entry" $ testSuspendNonExistingUser db brig, test mgr "mls/clients" $ testGetMlsClients brig, - testGroup - "mls/key-packages" - $ [ test mgr "fresh get" $ testKpcFreshGet brig, - test mgr "put,get" $ testKpcPutGet brig, - test mgr "get,get" $ testKpcGetGet brig, - test mgr "put,put" $ testKpcPutPut brig, - test mgr "add key package ref" $ testAddKeyPackageRef brig - ], test mgr "writetimeToInt64" $ testWritetimeRepresentation opts mgr db brig brigep galley ] @@ -256,118 +243,6 @@ testGetMlsClients brig = do ) liftIO $ toList cs1 @?= [ClientInfo c True] -keyPackageCreate :: HasCallStack => Brig -> Http KeyPackageRef -keyPackageCreate brig = do - uid <- userQualifiedId <$> randomUser brig - clid <- createClient brig uid 0 - withSystemTempDirectory "mls" $ \tmp -> - uploadKeyPackages brig tmp def uid clid 2 - - uid2 <- userQualifiedId <$> randomUser brig - claimResp <- - post - ( brig - . paths - [ "mls", - "key-packages", - "claim", - toByteString' (qDomain uid), - toByteString' (qUnqualified uid) - ] - . zUser (qUnqualified uid2) - . contentJson - ) - liftIO $ - assertEqual "POST mls/key-packages/claim/:domain/:user failed" 200 (statusCode claimResp) - case responseBody claimResp >>= decode of - Nothing -> liftIO $ assertFailure "Claim response empty" - Just bundle -> case toList $ kpbEntries bundle of - [] -> liftIO $ assertFailure "Claim response held no bundles" - (h : _) -> pure $ kpbeRef h - -kpcPut :: HasCallStack => Brig -> KeyPackageRef -> Qualified ConvId -> Http () -kpcPut brig ref qConv = do - resp <- - put - ( brig - . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref, "conversation"] - . contentJson - . json qConv - ) - liftIO $ assertEqual "PUT i/mls/key-packages/:ref/conversation failed" 204 (statusCode resp) - -kpcGet :: HasCallStack => Brig -> KeyPackageRef -> Http (Maybe (Qualified ConvId)) -kpcGet brig ref = do - resp <- - get (brig . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref, "conversation"]) - liftIO $ case statusCode resp of - 404 -> pure Nothing - 200 -> pure $ responseBody resp >>= decode - _ -> assertFailure "GET i/mls/key-packages/:ref/conversation failed" - -testKpcFreshGet :: Brig -> Http () -testKpcFreshGet brig = do - ref <- keyPackageCreate brig - mqConv <- kpcGet brig ref - liftIO $ assertEqual "(fresh) Get ~= Nothing" Nothing mqConv - -testKpcPutGet :: Brig -> Http () -testKpcPutGet brig = do - ref <- keyPackageCreate brig - qConv <- liftIO $ generate arbitrary - kpcPut brig ref qConv - mqConv <- kpcGet brig ref - liftIO $ assertEqual "Put x; Get ~= x" (Just qConv) mqConv - -testKpcGetGet :: Brig -> Http () -testKpcGetGet brig = do - ref <- keyPackageCreate brig - liftIO (generate arbitrary) >>= kpcPut brig ref - mqConv1 <- kpcGet brig ref - mqConv2 <- kpcGet brig ref - liftIO $ assertEqual "Get; Get ~= Get" mqConv1 mqConv2 - -testKpcPutPut :: Brig -> Http () -testKpcPutPut brig = do - ref <- keyPackageCreate brig - qConv <- liftIO $ generate arbitrary - qConv2 <- liftIO $ generate arbitrary - kpcPut brig ref qConv - kpcPut brig ref qConv2 - mqConv <- kpcGet brig ref - liftIO $ assertEqual "Put x; Put y ~= Put y" (Just qConv2) mqConv - -testAddKeyPackageRef :: Brig -> Http () -testAddKeyPackageRef brig = do - ref <- keyPackageCreate brig - qcnv <- liftIO $ generate arbitrary - qusr <- liftIO $ generate arbitrary - c <- liftIO $ generate arbitrary - put - ( brig - . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref] - . json - NewKeyPackageRef - { nkprUserId = qusr, - nkprClientId = c, - nkprConversation = qcnv - } - ) - !!! const 201 === statusCode - ci <- - responseJsonError - =<< get (brig . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref]) - (Request -> Request) -> UserId -> m ResponseLBS getFeatureConfig galley uid = do get $ apiVersion "v1" . galley . paths ["feature-configs", featureNameBS @cfg] . zUser uid diff --git a/services/brig/test/integration/API/MLS.hs b/services/brig/test/integration/API/MLS.hs index 440da8e28d..e236f3f54d 100644 --- a/services/brig/test/integration/API/MLS.hs +++ b/services/brig/test/integration/API/MLS.hs @@ -28,13 +28,13 @@ import Data.Id import Data.Qualified import qualified Data.Set as Set import Data.Timeout +import Debug.Trace (traceM) import Federation.Util import Imports import Test.Tasty import Test.Tasty.HUnit import UnliftIO.Temporary import Util -import Web.HttpApiData import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation @@ -48,7 +48,7 @@ tests m b opts = [ test m "POST /mls/key-packages/self/:client" (testKeyPackageUpload b), test m "POST /mls/key-packages/self/:client (no public keys)" (testKeyPackageUploadNoKey b), test m "GET /mls/key-packages/self/:client/count" (testKeyPackageZeroCount b), - test m "GET /mls/key-packages/self/:client/count (expired package)" (testKeyPackageExpired b), + -- FUTUREWORK test m "GET /mls/key-packages/self/:client/count (expired package)" (testKeyPackageExpired b), test m "GET /mls/key-packages/claim/local/:user" (testKeyPackageClaim b), test m "GET /mls/key-packages/claim/local/:user - self claim" (testKeyPackageSelfClaim b), test m "GET /mls/key-packages/claim/remote/:user" (testKeyPackageRemoteClaim opts b) @@ -115,7 +115,7 @@ testKeyPackageClaim brig = do -- claim packages for both clients of u u' <- userQualifiedId <$> randomUser brig - bundle <- + bundle :: KeyPackageBundle <- responseJsonError =<< post ( brig @@ -124,8 +124,7 @@ testKeyPackageClaim brig = do ) (kpbeUser e, kpbeClient e)) (kpbEntries bundle) @?= Set.fromList [(u, c1), (u, c2)] - checkMapping brig u bundle + liftIO $ Set.map (\e -> (e.user, e.client)) bundle.entries @?= Set.fromList [(u, c1), (u, c2)] -- check that we have one fewer key package now for_ [c1, c2] $ \c -> do @@ -145,7 +144,7 @@ testKeyPackageSelfClaim brig = do -- claim own packages but skip the first do - bundle <- + bundle :: KeyPackageBundle <- responseJsonError =<< post ( brig @@ -154,7 +153,7 @@ testKeyPackageSelfClaim brig = do . zUser (qUnqualified u) ) (kpbeUser e, kpbeClient e)) (kpbEntries bundle) @?= Set.fromList [(u, c2)] + liftIO $ Set.map (\e -> (e.user, e.client)) bundle.entries @?= Set.fromList [(u, c2)] -- check that we still have all keypackages for client c1 count <- getKeyPackageCount brig u c1 @@ -163,7 +162,7 @@ testKeyPackageSelfClaim brig = do -- if another user sets skip_own, nothing is skipped do u' <- userQualifiedId <$> randomUser brig - bundle <- + bundle :: KeyPackageBundle <- responseJsonError =<< post ( brig @@ -172,7 +171,7 @@ testKeyPackageSelfClaim brig = do . zUser (qUnqualified u') ) (kpbeUser e, kpbeClient e)) (kpbEntries bundle) @?= Set.fromList [(u, c1), (u, c2)] + liftIO $ Set.map (\e -> (e.user, e.client)) bundle.entries @?= Set.fromList [(u, c1), (u, c2)] -- check package counts again for_ [(c1, 2), (c2, 1)] $ \(c, n) -> do @@ -181,6 +180,7 @@ testKeyPackageSelfClaim brig = do testKeyPackageRemoteClaim :: Opts -> Brig -> Http () testKeyPackageRemoteClaim opts brig = do + traceM "sun" u <- fakeRemoteUser u' <- userQualifiedId <$> randomUser brig @@ -192,12 +192,13 @@ testKeyPackageRemoteClaim opts brig = do (r, kp) <- generateKeyPackage tmp qcid Nothing pure $ KeyPackageBundleEntry - { kpbeUser = u, - kpbeClient = ciClient qcid, - kpbeRef = kp, - kpbeKeyPackage = KeyPackageData . rmRaw $ r + { user = u, + client = ciClient qcid, + ref = kp, + keyPackage = KeyPackageData . raw $ r } let mockBundle = KeyPackageBundle (Set.fromList entries) + traceM "gun" (bundle :: KeyPackageBundle, _reqs) <- liftIO . withTempMockFederator opts (Aeson.encode mockBundle) $ responseJsonError @@ -209,23 +210,10 @@ testKeyPackageRemoteClaim opts brig = do Qualified UserId -> KeyPackageBundle -> Http () -checkMapping brig u bundle = - for_ (kpbEntries bundle) $ \e -> do - cid <- - responseJsonError - =<< get (brig . paths ["i", "mls", "key-packages", toHeader (kpbeRef e)]) - Qualified UserId -> Int -> Http ClientId createClient brig u i = fmap clientId $ diff --git a/services/brig/test/integration/API/MLS/Util.hs b/services/brig/test/integration/API/MLS/Util.hs index 02af682b7c..e22bd40568 100644 --- a/services/brig/test/integration/API/MLS/Util.hs +++ b/services/brig/test/integration/API/MLS/Util.hs @@ -34,6 +34,7 @@ import System.FilePath import System.Process import Test.Tasty.HUnit import Util +import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation @@ -109,7 +110,7 @@ uploadKeyPackages brig tmp KeyingInfo {..} u c n = do . json defUpdateClient {updateClientMLSPublicKeys = Map.fromList [(Ed25519, pk)]} ) !!! const 200 === statusCode - let upload = object ["key_packages" .= toJSON (map (Base64ByteString . rmRaw) kps)] + let upload = object ["key_packages" .= toJSON (map (Base64ByteString . raw) kps)] post ( brig . paths ["mls", "key-packages", "self", toByteString' c] diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index b7bfeac716..01bcca00c7 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -61,7 +61,7 @@ import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util import Wire.API.Internal.Notification -import Wire.API.MLS.Credential +import Wire.API.MLS.CipherSuite import qualified Wire.API.Team.Feature as Public import Wire.API.User import qualified Wire.API.User as Public diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 353516b10e..1c8ba92eab 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -61,7 +61,7 @@ import Wire.API.Conversation.Role import Wire.API.Conversation.Typing import Wire.API.Event.Conversation import Wire.API.Internal.Notification (ntfTransient) -import Wire.API.MLS.Credential +import Wire.API.MLS.CipherSuite import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation @@ -686,7 +686,7 @@ claimRemoteKeyPackages brig1 brig2 = do for_ bobClients $ \c -> uploadKeyPackages brig2 tmp def bob c 5 - bundle <- + bundle :: KeyPackageBundle <- responseJsonError =<< post ( brig1 @@ -696,7 +696,7 @@ claimRemoteKeyPackages brig1 brig2 = do (kpbeUser e, kpbeClient e)) (kpbEntries bundle) + Set.map (\e -> (e.user, e.client)) bundle.entries @?= Set.fromList [(bob, c) | c <- bobClients] -- bob creates an MLS conversation on domain 2 with alice on domain 1, then sends a @@ -719,7 +719,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do let aliceClientId = show (userId alice) <> ":" - <> T.unpack (client aliceClient) + <> T.unpack aliceClient.client <> "@" <> T.unpack (domainText (qDomain (userQualifiedId alice))) @@ -737,7 +737,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do { updateClientMLSPublicKeys = Map.singleton Ed25519 - (bcSignatureKey (kpCredential (rmValue aliceKP))) + aliceKP.value.leafNode.signatureKey } put ( brig1 @@ -769,7 +769,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do let bobClientId = show (userId bob) <> ":" - <> T.unpack (client bobClient) + <> T.unpack bobClient.client <> "@" <> T.unpack (domainText (qDomain (userQualifiedId bob))) void . liftIO $ spawn (cli bobClientId tmp ["init", bobClientId]) Nothing @@ -820,7 +820,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do liftIO $ BS.writeFile (tmp "group.json") groupJSON -- invite alice - liftIO $ BS.writeFile (tmp aliceClientId) (rmRaw aliceKP) + liftIO $ BS.writeFile (tmp aliceClientId) (raw aliceKP) commit <- liftIO $ spawn @@ -834,6 +834,8 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do tmp "group.json", "--welcome-out", tmp "welcome", + "--group-info-out", + tmp "groupinfo.mls", tmp aliceClientId ] ) @@ -873,31 +875,14 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do -- send welcome, commit and dove WS.bracketR cannon1 (userId alice) $ \wsAlice -> do - post - ( galley2 - . paths - ["mls", "messages"] - . zUser (userId bob) - . zClient bobClient - . zConn "conn" - . header "Z-Type" "access" - . content "message/mls" - . bytes commit - ) - !!! const 201 === statusCode - - post - ( unversioned - . galley2 - . paths ["v2", "mls", "welcome"] - . zUser (userId bob) - . zClient bobClient - . zConn "conn" - . header "Z-Type" "access" - . content "message/mls" - . bytes welcome - ) - !!! const 201 === statusCode + sendCommitBundle + tmp + "groupinfo.mls" + (Just "welcome") + galley2 + (userId bob) + bobClient + commit post ( galley2 @@ -982,7 +967,7 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 let aliceClientId = show (userId alice) <> ":" - <> T.unpack (client aliceClient) + <> T.unpack aliceClient.client <> "@" <> T.unpack (domainText (qDomain (userQualifiedId alice))) @@ -997,7 +982,7 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 let bobClientId = show (userId bob) <> ":" - <> T.unpack (client bobClient) + <> T.unpack (bobClient.client) <> "@" <> T.unpack (domainText (qDomain (userQualifiedId bob))) @@ -1015,7 +1000,7 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 { updateClientMLSPublicKeys = Map.singleton Ed25519 - (bcSignatureKey (kpCredential (rmValue aliceKP))) + aliceKP.value.leafNode.signatureKey } put ( brig1 @@ -1084,7 +1069,7 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 liftIO $ BS.writeFile (tmp "group.json") groupJSON -- invite alice - liftIO $ BS.writeFile (tmp aliceClientId) (rmRaw aliceKP) + liftIO $ BS.writeFile (tmp aliceClientId) (raw aliceKP) commit <- liftIO $ spawn @@ -1098,6 +1083,8 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 tmp "group.json", "--welcome-out", tmp "welcome", + "--group-info-out", + tmp "groupinfo.mls", tmp aliceClientId ] ) @@ -1106,32 +1093,14 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 -- send welcome and commit WS.bracketR cannon1 (userId alice) $ \wsAlice -> do - post - ( galley2 - . paths - ["mls", "messages"] - . zUser (userId bob) - . zClient bobClient - . zConn "conn" - . header "Z-Type" "access" - . content "message/mls" - . bytes commit - ) - !!! const 201 === statusCode - - post - ( unversioned - . galley2 - . paths - ["v2", "mls", "welcome"] - . zUser (userId bob) - . zClient bobClient - . zConn "conn" - . header "Z-Type" "access" - . content "message/mls" - . bytes welcome - ) - !!! const 201 === statusCode + sendCommitBundle + tmp + "groupinfo.mls" + (Just "welcome") + galley2 + (userId bob) + bobClient + commit -- verify that alice receives the welcome message WS.assertMatch_ (5 # Second) wsAlice $ \n -> do @@ -1198,7 +1167,7 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 "--in-place", "--group", tmp "subgroup.json", - "--group-state-out", + "--group-info-out", tmp "subgroupstate.mls" ] ) @@ -1206,6 +1175,7 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 sendCommitBundle tmp "subgroupstate.mls" + Nothing galley2 (userId bob) bobClient @@ -1222,9 +1192,9 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 [ "external-commit", "--group-out", tmp "subgroupA.json", - "--group-state-in", + "--group-info-in", tmp "subgroupstate.mls", - "--group-state-out", + "--group-info-out", tmp "subgroupstateA.mls" ] ) @@ -1232,6 +1202,7 @@ testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 sendCommitBundle tmp "subgroupstateA.mls" + Nothing galley1 (userId alice) aliceClient diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index 8d56f4f4b0..399f17124a 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -67,7 +67,7 @@ import Wire.API.Conversation (Conversation (cnvMembers)) import Wire.API.Conversation.Member (OtherMember (OtherMember), cmOthers) import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.MLS.CommitBundle -import Wire.API.MLS.GroupInfoBundle +import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.Team.Feature (FeatureStatus (..)) import Wire.API.User @@ -118,13 +118,22 @@ connectUsersEnd2End brig1 brig2 quid1 quid2 = do putConnectionQualified brig2 (qUnqualified quid2) quid1 Accepted !!! const 200 === statusCode -sendCommitBundle :: FilePath -> FilePath -> Galley -> UserId -> ClientId -> ByteString -> Http () -sendCommitBundle tmp subGroupStateFn galley uid cid commit = do +sendCommitBundle :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Galley -> UserId -> ClientId -> ByteString -> Http () +sendCommitBundle tmp subGroupStateFn welcomeFn galley uid cid commit = do subGroupStateRaw <- liftIO $ BS.readFile $ tmp subGroupStateFn subGroupState <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ subGroupStateRaw subCommit <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ commit - let subGroupBundle = CommitBundle subCommit Nothing (GroupInfoBundle UnencryptedGroupInfo TreeFull subGroupState) - let subGroupBundleRaw = serializeCommitBundle subGroupBundle + mbWelcome <- + for + welcomeFn + $ \fn -> do + bs <- liftIO $ BS.readFile $ tmp fn + msg :: Message <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ bs + case msg.content of + MessageWelcome welcome -> pure welcome + _ -> liftIO . assertFailure $ "Expected a welcome" + + let subGroupBundle = CommitBundle subCommit mbWelcome subGroupState post ( galley . paths @@ -133,7 +142,7 @@ sendCommitBundle tmp subGroupStateFn galley uid cid commit = do . zClient cid . zConn "conn" . header "Z-Type" "access" - . content "application/x-protobuf" - . bytes subGroupBundleRaw + . Bilge.content "message/mls" + . lbytes (encodeMLS subGroupBundle) ) !!! const 201 === statusCode diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Run.hs similarity index 99% rename from services/brig/test/integration/Main.hs rename to services/brig/test/integration/Run.hs index dee2c47caa..4c71bcba7a 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Run.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main +module Run ( main, ) where diff --git a/services/brig/test/unit.hs b/services/brig/test/unit.hs new file mode 100644 index 0000000000..a26473d24e --- /dev/null +++ b/services/brig/test/unit.hs @@ -0,0 +1 @@ +import Run diff --git a/services/brig/test/unit/Main.hs b/services/brig/test/unit/Main.hs index 8cc53f5f81..6ab5658fca 100644 --- a/services/brig/test/unit/Main.hs +++ b/services/brig/test/unit/Main.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main +module Run ( main, ) where diff --git a/services/brig/test/unit/Run.hs b/services/brig/test/unit/Run.hs new file mode 100644 index 0000000000..6ab5658fca --- /dev/null +++ b/services/brig/test/unit/Run.hs @@ -0,0 +1,43 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Run + ( main, + ) +where + +import Imports +import qualified Test.Brig.Calling +import qualified Test.Brig.Calling.Internal +import qualified Test.Brig.InternalNotification +import qualified Test.Brig.MLS +import qualified Test.Brig.Roundtrip +import qualified Test.Brig.User.Search.Index.Types +import Test.Tasty + +main :: IO () +main = + defaultMain $ + testGroup + "Tests" + [ Test.Brig.User.Search.Index.Types.tests, + Test.Brig.Calling.tests, + Test.Brig.Calling.Internal.tests, + Test.Brig.Roundtrip.tests, + Test.Brig.MLS.tests, + Test.Brig.InternalNotification.tests + ] diff --git a/services/brig/test/unit/Test/Brig/MLS.hs b/services/brig/test/unit/Test/Brig/MLS.hs index e4c4f8d258..92e2b5eb52 100644 --- a/services/brig/test/unit/Test/Brig/MLS.hs +++ b/services/brig/test/unit/Test/Brig/MLS.hs @@ -19,16 +19,12 @@ module Test.Brig.MLS where import Brig.API.MLS.KeyPackages.Validation import Data.Binary -import Data.Binary.Put -import qualified Data.ByteString.Lazy as LBS import Data.Either import Data.Time.Clock import Imports import Test.Tasty import Test.Tasty.QuickCheck -import Wire.API.MLS.CipherSuite -import Wire.API.MLS.Extension -import Wire.API.MLS.Serialisation +import Wire.API.MLS.Lifetime -- | A lifetime with a length of at least 1 day. newtype ValidLifetime = ValidLifetime Lifetime @@ -57,69 +53,6 @@ midpoint lt = ) ) -newtype ValidExtensions = ValidExtensions [Extension] - -instance Show ValidExtensions where - show (ValidExtensions exts) = "ValidExtensions (length " <> show (length exts) <> ")" - -unknownExt :: Gen Extension -unknownExt = do - Positive t0 <- arbitrary - let t = t0 + fromEnum (maxBound :: ExtensionTag) + 1 - Extension (fromIntegral t) <$> arbitrary - --- | Generate a list of extensions containing all the required ones. -instance Arbitrary ValidExtensions where - arbitrary = do - exts0 <- listOf unknownExt - LifetimeAndExtension ext1 _ <- arbitrary - exts2 <- listOf unknownExt - CapabilitiesAndExtension ext3 _ <- arbitrary - exts4 <- listOf unknownExt - pure . ValidExtensions $ exts0 <> [ext1] <> exts2 <> [ext3] <> exts4 - -newtype InvalidExtensions = InvalidExtensions [Extension] - --- | Generate a list of extensions which does not contain one of the required extensions. -instance Show InvalidExtensions where - show (InvalidExtensions exts) = "InvalidExtensions (length " <> show (length exts) <> ")" - -instance Arbitrary InvalidExtensions where - arbitrary = do - req <- fromMLSEnum <$> elements [LifetimeExtensionTag, CapabilitiesExtensionTag] - InvalidExtensions <$> listOf (arbitrary `suchThat` ((/= req) . extType)) - -data LifetimeAndExtension = LifetimeAndExtension Extension Lifetime - deriving (Show) - -instance Arbitrary LifetimeAndExtension where - arbitrary = do - lt <- arbitrary - let ext = Extension (fromIntegral (fromEnum LifetimeExtensionTag + 1)) . LBS.toStrict . runPut $ do - put (timestampSeconds (ltNotBefore lt)) - put (timestampSeconds (ltNotAfter lt)) - pure $ LifetimeAndExtension ext lt - -data CapabilitiesAndExtension = CapabilitiesAndExtension Extension Capabilities - deriving (Show) - -instance Arbitrary CapabilitiesAndExtension where - arbitrary = do - caps <- arbitrary - let ext = Extension (fromIntegral (fromEnum CapabilitiesExtensionTag + 1)) . LBS.toStrict . runPut $ do - putWord8 (fromIntegral (length (capVersions caps))) - traverse_ (putWord8 . pvNumber) (capVersions caps) - - putWord8 (fromIntegral (length (capCiphersuites caps) * 2)) - traverse_ (put . cipherSuiteNumber) (capCiphersuites caps) - - putWord8 (fromIntegral (length (capExtensions caps) * 2)) - traverse_ put (capExtensions caps) - - putWord8 (fromIntegral (length (capProposals caps) * 2)) - traverse_ put (capProposals caps) - pure $ CapabilitiesAndExtension ext caps - tests :: TestTree tests = testGroup @@ -142,16 +75,5 @@ tests = isRight $ validateLifetime' (midpoint lt) Nothing lt, testProperty "expiration too far" $ \(ValidLifetime lt) -> isLeft $ validateLifetime' (midpoint lt) (Just 10) lt - ], - testGroup - "Extensions" - [ testProperty "required extensions are found" $ \(ValidExtensions exts) -> - isRight (findExtensions exts), - testProperty "missing required extensions" $ \(InvalidExtensions exts) -> - isLeft (findExtensions exts), - testProperty "lifetime extension" $ \(LifetimeAndExtension ext lt) -> - decodeExtension ext == Right (Just (SomeExtension SLifetimeExtensionTag lt)), - testProperty "capabilities extension" $ \(CapabilitiesAndExtension ext caps) -> - decodeExtension ext == Right (Just (SomeExtension SCapabilitiesExtensionTag caps)) ] ] diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index aed44b951a..20711d9312 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 3.0 name: galley version: 0.83.0 synopsis: Conversations @@ -6,7 +6,7 @@ category: Network author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE build-type: Simple @@ -15,7 +15,60 @@ flag static manual: True default: False +common common-all + default-language: Haskell2010 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -Wredundant-constraints + + default-extensions: + NoImplicitPrelude + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + library + import: common-all + -- cabal-fmt: expand src exposed-modules: Galley.API @@ -31,13 +84,18 @@ library Galley.API.Mapping Galley.API.Message Galley.API.MLS + Galley.API.MLS.Commit + Galley.API.MLS.Commit.Core + Galley.API.MLS.Commit.ExternalCommit + Galley.API.MLS.Commit.InternalCommit Galley.API.MLS.Conversation Galley.API.MLS.Enabled Galley.API.MLS.GroupInfo - Galley.API.MLS.KeyPackage + Galley.API.MLS.IncomingMessage Galley.API.MLS.Keys Galley.API.MLS.Message Galley.API.MLS.Propagate + Galley.API.MLS.Proposal Galley.API.MLS.Removal Galley.API.MLS.SubConversation Galley.API.MLS.Types @@ -145,57 +203,11 @@ library Galley.Types.UserList Galley.Validation - other-modules: Paths_galley - hs-source-dirs: src - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -fplugin=TransitiveAnns.Plugin -Wredundant-constraints - + ghc-options: -fplugin=TransitiveAnns.Plugin + other-modules: Paths_galley + hs-source-dirs: src build-depends: - aeson >=2.0.1.0 + , aeson >=2.0.1.0 , amazonka >=1.4.5 , amazonka-sqs >=1.4.5 , asn1-encoding @@ -300,60 +312,15 @@ library , wire-api-federation , x509 - default-language: Haskell2010 + default-language: Haskell2010 executable galley - main-is: exec/Main.hs - other-modules: Paths_galley - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -with-rtsopts=-T -rtsopts -Wredundant-constraints - + import: common-all + main-is: exec/Main.hs + other-modules: Paths_galley + ghc-options: -threaded -with-rtsopts=-T -rtsopts build-depends: - base + , base , case-insensitive , extended , extra >=1.3 @@ -375,10 +342,11 @@ executable galley if flag(static) ld-options: -static - default-language: Haskell2010 + default-language: Haskell2010 executable galley-integration - main-is: Main.hs + import: common-all + main-is: ../integration.hs -- cabal-fmt: expand test/integration other-modules: @@ -399,60 +367,14 @@ executable galley-integration API.Teams.LegalHold.Util API.Util API.Util.TeamFeature - Main + Run TestHelpers TestSetup - hs-source-dirs: test/integration - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -with-rtsopts=-N -Wredundant-constraints - + ghc-options: -threaded -with-rtsopts=-N -rtsopts + hs-source-dirs: test/integration build-depends: - aeson + , aeson , aeson-qq , amazonka , amazonka-sqs @@ -559,70 +481,22 @@ executable galley-integration , wire-message-proto-lens , yaml - default-language: Haskell2010 - executable galley-migrate-data - main-is: Main.hs + import: common-all + main-is: ../main.hs -- cabal-fmt: expand migrate-data/src other-modules: Galley.DataMigration Galley.DataMigration.Types - Main Paths_galley + Run V1_BackfillBillingTeamMembers V2_MigrateMLSMembers - hs-source-dirs: migrate-data/src - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints - + hs-source-dirs: migrate-data/src build-depends: - base + , base , case-insensitive , cassandra-util , conduit @@ -653,14 +527,15 @@ executable galley-migrate-data if flag(static) ld-options: -static - default-language: Haskell2010 + default-language: Haskell2010 executable galley-schema - main-is: Main.hs + import: common-all + main-is: ../main.hs -- cabal-fmt: expand schema/src other-modules: - Main + Run V20 V21 V22 @@ -723,57 +598,12 @@ executable galley-schema V79_TeamFeatureMlsE2EId V80_AddConversationCodePassword V81_MLSSubconversation + V82_MLSDraft17 hs-source-dirs: schema/src - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints - + default-extensions: TemplateHaskell build-depends: - base + , base , case-insensitive , cassandra-util , extended @@ -798,66 +628,22 @@ executable galley-schema default-language: Haskell2010 test-suite galley-tests - type: exitcode-stdio-1.0 - main-is: Main.hs + import: common-all + type: exitcode-stdio-1.0 + main-is: ../unit.hs other-modules: Paths_galley + Run Test.Galley.API Test.Galley.API.Message Test.Galley.API.One2One Test.Galley.Intra.User Test.Galley.Mapping - hs-source-dirs: test/unit - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -with-rtsopts=-N -Wredundant-constraints - + ghc-options: -threaded -with-rtsopts=-N + hs-source-dirs: test/unit build-depends: - base + , base , case-insensitive , containers , extended @@ -889,4 +675,4 @@ test-suite galley-tests , wire-api , wire-api-federation - default-language: Haskell2010 + default-language: Haskell2010 diff --git a/services/galley/migrate-data/main.hs b/services/galley/migrate-data/main.hs new file mode 100644 index 0000000000..a26473d24e --- /dev/null +++ b/services/galley/migrate-data/main.hs @@ -0,0 +1 @@ +import Run diff --git a/services/galley/migrate-data/src/Main.hs b/services/galley/migrate-data/src/Run.hs similarity index 98% rename from services/galley/migrate-data/src/Main.hs rename to services/galley/migrate-data/src/Run.hs index f6a051b8d5..cb1288bafb 100644 --- a/services/galley/migrate-data/src/Main.hs +++ b/services/galley/migrate-data/src/Run.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main where +module Run where import Galley.DataMigration import Imports diff --git a/services/galley/schema/main.hs b/services/galley/schema/main.hs new file mode 100644 index 0000000000..d4037ab9cf --- /dev/null +++ b/services/galley/schema/main.hs @@ -0,0 +1,5 @@ +import Imports +import qualified Run + +main :: IO () +main = Run.main diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Run.hs similarity index 98% rename from services/galley/schema/src/Main.hs rename to services/galley/schema/src/Run.hs index 4805a7470b..447b203f4e 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Run.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main where +module Run where import Cassandra.Schema import Control.Exception (finally) @@ -84,6 +84,7 @@ import qualified V78_TeamFeatureOutlookCalIntegration import qualified V79_TeamFeatureMlsE2EId import qualified V80_AddConversationCodePassword import qualified V81_MLSSubconversation +import qualified V82_MLSDraft17 main :: IO () main = do @@ -153,7 +154,8 @@ main = do V78_TeamFeatureOutlookCalIntegration.migration, V79_TeamFeatureMlsE2EId.migration, V80_AddConversationCodePassword.migration, - V81_MLSSubconversation.migration + V81_MLSSubconversation.migration, + V82_MLSDraft17.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Cassandra -- (see also docs/developer/cassandra-interaction.md) diff --git a/services/galley/src/Galley/API/MLS/KeyPackage.hs b/services/galley/schema/src/V82_MLSDraft17.hs similarity index 59% rename from services/galley/src/Galley/API/MLS/KeyPackage.hs rename to services/galley/schema/src/V82_MLSDraft17.hs index 23fe2760c0..b277d89cf2 100644 --- a/services/galley/src/Galley/API/MLS/KeyPackage.hs +++ b/services/galley/schema/src/V82_MLSDraft17.hs @@ -15,24 +15,18 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.KeyPackage where +module V82_MLSDraft17 (migration) where -import qualified Data.ByteString as BS -import Galley.Effects.BrigAccess +import Cassandra.Schema import Imports -import Polysemy -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage +import Text.RawString.QQ -nullKeyPackageRef :: KeyPackageRef -nullKeyPackageRef = KeyPackageRef (BS.replicate 16 0) - -derefKeyPackage :: - ( Member BrigAccess r, - Member (ErrorS 'MLSKeyPackageRefNotFound) r - ) => - KeyPackageRef -> - Sem r ClientIdentity -derefKeyPackage = noteS @'MLSKeyPackageRefNotFound <=< getClientByKeyPackageRef +migration :: Migration +migration = + Migration 82 "Upgrade to MLS draft 17 structures" $ do + schema' + [r| ALTER TABLE mls_group_member_client + ADD (leaf_node_index int, + removal_pending boolean + ); + |] diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 3916bbb914..2f9b52acc9 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -55,7 +55,6 @@ import Data.Singletons import Data.Time.Clock import Galley.API.Error import Galley.API.MLS.Removal -import Galley.API.MLS.Types (cmAssocs) import Galley.API.Util import Galley.App import Galley.Data.Conversation @@ -342,9 +341,6 @@ performAction tag origUser lconv action = do pure (mempty, action) SConversationDeleteTag -> do let deleteGroup groupId = do - cm <- E.lookupMLSClients groupId - let refs = cm & cmAssocs & map (snd . snd) - E.deleteKeyPackageRefs refs E.removeAllMLSClients groupId E.deleteAllProposals groupId diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 58ed1273dd..80382af9ed 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -43,7 +43,6 @@ import Data.Time import qualified Data.UUID.Tagged as U import Galley.API.Error import Galley.API.MLS -import Galley.API.MLS.KeyPackage (nullKeyPackageRef) import Galley.API.MLS.Keys (getMLSRemovalKey) import Galley.API.Mapping import Galley.API.One2One @@ -70,7 +69,6 @@ import Polysemy.Error import Polysemy.Input import qualified Polysemy.TinyLog as P import Wire.API.Conversation hiding (Conversation, Member) -import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation @@ -90,7 +88,6 @@ import Wire.API.Team.Permission hiding (self) createGroupConversationUpToV3 :: ( Member BrigAccess r, Member ConversationStore r, - Member MemberStore r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -100,7 +97,6 @@ createGroupConversationUpToV3 :: Member (ErrorS 'NotConnected) r, Member (ErrorS 'MLSNotEnabled) r, Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MissingLegalholdConsent) r, Member FederatorAccess r, Member GundeckAccess r, @@ -108,18 +104,17 @@ createGroupConversationUpToV3 :: Member (Input Opts) r, Member (Input UTCTime) r, Member LegalHoldStore r, + Member MemberStore r, Member TeamStore r, Member P.TinyLog r ) => Local UserId -> - Maybe ClientId -> Maybe ConnId -> NewConv -> Sem r ConversationResponse -createGroupConversationUpToV3 lusr mCreatorClient conn newConv = +createGroupConversationUpToV3 lusr conn newConv = createGroupConversationGeneric lusr - mCreatorClient conn newConv (const conversationCreated) @@ -129,7 +124,6 @@ createGroupConversationUpToV3 lusr mCreatorClient conn newConv = createGroupConversation :: ( Member BrigAccess r, Member ConversationStore r, - Member MemberStore r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -139,7 +133,6 @@ createGroupConversation :: Member (ErrorS 'NotConnected) r, Member (ErrorS 'MLSNotEnabled) r, Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MissingLegalholdConsent) r, Member FederatorAccess r, Member GundeckAccess r, @@ -147,18 +140,17 @@ createGroupConversation :: Member (Input Opts) r, Member (Input UTCTime) r, Member LegalHoldStore r, + Member MemberStore r, Member TeamStore r, Member P.TinyLog r ) => Local UserId -> - Maybe ClientId -> Maybe ConnId -> NewConv -> Sem r CreateGroupConversationResponse -createGroupConversation lusr mCreatorClient conn newConv = +createGroupConversation lusr conn newConv = createGroupConversationGeneric lusr - mCreatorClient conn newConv groupConversationCreated @@ -176,7 +168,6 @@ createGroupConversationGeneric :: Member (ErrorS 'NotConnected) r, Member (ErrorS 'MLSNotEnabled) r, Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MissingLegalholdConsent) r, Member FederatorAccess r, Member GundeckAccess r, @@ -188,7 +179,6 @@ createGroupConversationGeneric :: Member P.TinyLog r ) => Local UserId -> - Maybe ClientId -> Maybe ConnId -> NewConv -> -- | The function that incorporates the failed to add remote users in the @@ -196,7 +186,7 @@ createGroupConversationGeneric :: -- ignores the first argument. (Set (Remote UserId) -> Local UserId -> Conversation -> Sem r resp) -> Sem r resp -createGroupConversationGeneric lusr mCreatorClient conn newConv convCreated = do +createGroupConversationGeneric lusr conn newConv convCreated = do (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv let tinfo = newConvTeam newConv checkCreateConvPermissions lusr newConv tinfo allUsers @@ -218,14 +208,6 @@ createGroupConversationGeneric lusr mCreatorClient conn newConv convCreated = do failedToNotify <- do conv <- E.createConversation lcnv nc - -- set creator client for MLS conversations - case (convProtocol conv, mCreatorClient) of - (ProtocolProteus, _) -> pure () - (ProtocolMLS mlsMeta, Just c) -> - E.addMLSClients (cnvmlsGroupId mlsMeta) (tUntagged lusr) (Set.singleton (c, nullKeyPackageRef)) - (ProtocolMLS _mlsMeta, Nothing) -> throwS @'MLSMissingSenderClient - (ProtocolMixed _mlsMeta, _) -> pure () - -- NOTE: We only send (conversation) events to members of the conversation failedToNotify <- notifyCreatedConversation lusr conn conv -- We already added all the invitees, but now remove from the conversation diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 92ccd96874..389b9a4c22 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -46,7 +46,6 @@ import Galley.API.Action import Galley.API.Error import Galley.API.MLS.Enabled import Galley.API.MLS.GroupInfo -import Galley.API.MLS.KeyPackage import Galley.API.MLS.Message import Galley.API.MLS.Removal import Galley.API.MLS.SubConversation hiding (leaveSubConversation) @@ -93,13 +92,11 @@ import Wire.API.Federation.API.Common (EmptyResponse (..)) import Wire.API.Federation.API.Galley import qualified Wire.API.Federation.API.Galley as F import Wire.API.Federation.Error -import Wire.API.MLS.CommitBundle import Wire.API.MLS.Credential -import Wire.API.MLS.Message -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation -import Wire.API.MLS.Welcome +-- import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named (Named (Named)) @@ -667,18 +664,21 @@ sendMLSCommitBundle remoteDomain msr = assertMLSEnabled loc <- qualifyLocal () let sender = toRemoteUnsafe remoteDomain (F.mmsrSender msr) - bundle <- either (throw . mlsProtocolError) pure $ deserializeCommitBundle (fromBase64ByteString (F.mmsrRawMessage msr)) - let msg = rmValue (cbCommitMsg bundle) - qConvOrSub <- E.lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound + bundle <- + either (throw . mlsProtocolError) pure $ + decodeMLS' (fromBase64ByteString (F.mmsrRawMessage msr)) + + ibundle <- noteS @'MLSUnsupportedMessage $ mkIncomingBundle bundle + qConvOrSub <- E.lookupConvByGroupId ibundle.groupId >>= noteS @'ConvNotFound when (qUnqualified qConvOrSub /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch uncurry F.MLSMessageResponseUpdates . first (map lcuUpdate) <$> postMLSCommitBundle loc (tUntagged sender) - (Just (mmsrSenderClient msr)) + (mmsrSenderClient msr) qConvOrSub Nothing - bundle + ibundle sendMLSMessage :: ( Member BrigAccess r, @@ -694,7 +694,6 @@ sendMLSMessage :: Member (Input UTCTime) r, Member LegalHoldStore r, Member MemberStore r, - Member Resource r, Member TeamStore r, Member P.TinyLog r, Member ProposalStore r, @@ -716,22 +715,20 @@ sendMLSMessage remoteDomain msr = loc <- qualifyLocal () let sender = toRemoteUnsafe remoteDomain (F.mmsrSender msr) raw <- either (throw . mlsProtocolError) pure $ decodeMLS' (fromBase64ByteString (F.mmsrRawMessage msr)) - case rmValue raw of - SomeMessage _ msg -> do - qConvOrSub <- E.lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound - when (qUnqualified qConvOrSub /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch - uncurry F.MLSMessageResponseUpdates . first (map lcuUpdate) - <$> postMLSMessage - loc - (tUntagged sender) - (Just (mmsrSenderClient msr)) - qConvOrSub - Nothing - raw + msg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage raw + qConvOrSub <- E.lookupConvByGroupId msg.groupId >>= noteS @'ConvNotFound + when (qUnqualified qConvOrSub /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch + uncurry F.MLSMessageResponseUpdates . first (map lcuUpdate) + <$> postMLSMessage + loc + (tUntagged sender) + (mmsrSenderClient msr) + qConvOrSub + Nothing + msg mlsSendWelcome :: - ( Member BrigAccess r, - Member (Error InternalError) r, + ( Member (Error InternalError) r, Member GundeckAccess r, Member (Input Env) r, Member (Input (Local ())) r, @@ -740,26 +737,17 @@ mlsSendWelcome :: Domain -> F.MLSWelcomeRequest -> Sem r F.MLSWelcomeResponse -mlsSendWelcome _origDomain (fromBase64ByteString . F.unMLSWelcomeRequest -> rawWelcome) = +mlsSendWelcome _origDomain req = fmap (either (const MLSWelcomeMLSNotEnabled) (const MLSWelcomeSent)) . runError @(Tagged 'MLSNotEnabled ()) $ do assertMLSEnabled loc <- qualifyLocal () now <- input - welcome <- either (throw . InternalErrorWithDescription . LT.fromStrict) pure $ decodeMLS' rawWelcome - -- Extract only recipients local to this backend - rcpts <- - fmap catMaybes - $ traverse - ( fmap (fmap cidQualifiedClient . hush) - . runError @(Tagged 'MLSKeyPackageRefNotFound ()) - . derefKeyPackage - . gsNewMember - ) - $ welSecrets welcome - let lrcpts = qualifyAs loc $ fst $ partitionQualified loc rcpts - sendLocalWelcomes Nothing now rawWelcome lrcpts + welcome <- + either (throw . InternalErrorWithDescription . LT.fromStrict) pure $ + decodeMLS' (fromBase64ByteString req.welcomeMessage) + sendLocalWelcomes Nothing now welcome (qualifyAs loc req.recipients) onMLSMessageSent :: ( Member ExternalAccess r, @@ -829,7 +817,7 @@ queryGroupInfo origDomain req = getSubConversationGroupInfoFromLocalConv (tUntagged sender) subConvId lconvId pure . Base64ByteString - . unOpaquePublicGroupState + . unGroupInfoData $ state updateTypingIndicator :: diff --git a/services/galley/src/Galley/API/MLS.hs b/services/galley/src/Galley/API/MLS.hs index cbd8307232..2b06791739 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/services/galley/src/Galley/API/MLS.hs @@ -18,11 +18,9 @@ module Galley.API.MLS ( isMLSEnabled, assertMLSEnabled, - postMLSWelcomeFromLocalUser, postMLSMessage, postMLSCommitBundleFromLocalUser, postMLSMessageFromLocalUser, - postMLSMessageFromLocalUserV1, getMLSPublicKeys, ) where @@ -32,7 +30,6 @@ import Data.Id import Data.Qualified import Galley.API.MLS.Enabled import Galley.API.MLS.Message -import Galley.API.MLS.Welcome import Galley.Env import Imports import Polysemy diff --git a/services/galley/src/Galley/API/MLS/Commit.hs b/services/galley/src/Galley/API/MLS/Commit.hs new file mode 100644 index 0000000000..39088273b8 --- /dev/null +++ b/services/galley/src/Galley/API/MLS/Commit.hs @@ -0,0 +1,28 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.MLS.Commit + ( getCommitData, + getExternalCommitData, + processInternalCommit, + processExternalCommit, + ) +where + +import Galley.API.MLS.Commit.Core +import Galley.API.MLS.Commit.ExternalCommit +import Galley.API.MLS.Commit.InternalCommit diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/services/galley/src/Galley/API/MLS/Commit/Core.hs new file mode 100644 index 0000000000..50eca037f1 --- /dev/null +++ b/services/galley/src/Galley/API/MLS/Commit/Core.hs @@ -0,0 +1,195 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.MLS.Commit.Core + ( getCommitData, + incrementEpoch, + getClientInfo, + HasProposalActionEffects, + ProposalErrors, + HandleMLSProposalFailures (..), + ) +where + +import Control.Comonad +import Data.Id +import Data.Qualified +import Data.Time +import Galley.API.Error +import Galley.API.MLS.Conversation +import Galley.API.MLS.Proposal +import Galley.API.MLS.Types +import Galley.Effects +import Galley.Effects.BrigAccess +import Galley.Effects.ConversationStore +import Galley.Effects.FederatorAccess +import Galley.Effects.SubConversationStore +import Galley.Env +import Galley.Options +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Internal +import Polysemy.State +import Polysemy.TinyLog +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Federation.API +import Wire.API.Federation.API.Brig +import Wire.API.Federation.Error +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Commit +import Wire.API.MLS.Credential +import Wire.API.MLS.SubConversation +import Wire.API.User.Client + +type HasProposalActionEffects r = + ( Member BrigAccess r, + Member ConversationStore r, + Member (Error InternalError) r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (Error MLSProposalFailure) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'MLSUnsupportedProposal) r, + Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSSelfRemovalNotAllowed) r, + Member ExternalAccess r, + Member FederatorAccess r, + Member GundeckAccess r, + Member (Input Env) r, + Member (Input Opts) r, + Member (Input UTCTime) r, + Member LegalHoldStore r, + Member MemberStore r, + Member ProposalStore r, + Member SubConversationStore r, + Member TeamStore r, + Member TinyLog r + ) + +getCommitData :: + ( HasProposalEffects r, + Member (ErrorS 'MLSProposalNotFound) r + ) => + ClientIdentity -> + Local ConvOrSubConv -> + Epoch -> + Commit -> + Sem r ProposalAction +getCommitData senderIdentity lConvOrSub epoch commit = do + let convOrSub = tUnqualified lConvOrSub + mlsMeta = mlsMetaConvOrSub convOrSub + groupId = cnvmlsGroupId mlsMeta + + evalState (indexMapConvOrSub convOrSub) $ do + creatorAction <- + if epoch == Epoch 0 + then addProposedClient senderIdentity + else mempty + proposals <- traverse (derefOrCheckProposal mlsMeta groupId epoch) commit.proposals + action <- applyProposals mlsMeta groupId proposals + pure (creatorAction <> action) + +incrementEpoch :: + ( Member ConversationStore r, + Member (ErrorS 'ConvNotFound) r, + Member MemberStore r, + Member SubConversationStore r + ) => + ConvOrSubConv -> + Sem r ConvOrSubConv +incrementEpoch (Conv c) = do + let epoch' = succ (cnvmlsEpoch (mcMLSData c)) + setConversationEpoch (mcId c) epoch' + conv <- getConversation (mcId c) >>= noteS @'ConvNotFound + fmap Conv (mkMLSConversation conv >>= noteS @'ConvNotFound) +incrementEpoch (SubConv c s) = do + let epoch' = succ (cnvmlsEpoch (scMLSData s)) + setSubConversationEpoch (scParentConvId s) (scSubConvId s) epoch' + subconv <- + getSubConversation (mcId c) (scSubConvId s) >>= noteS @'ConvNotFound + pure (SubConv c subconv) + +getClientInfo :: + ( Member BrigAccess r, + Member FederatorAccess r + ) => + Local x -> + Qualified UserId -> + SignatureSchemeTag -> + Sem r (Set ClientInfo) +getClientInfo loc = foldQualified loc getLocalMLSClients getRemoteMLSClients + +getRemoteMLSClients :: + ( Member FederatorAccess r + ) => + Remote UserId -> + SignatureSchemeTag -> + Sem r (Set ClientInfo) +getRemoteMLSClients rusr ss = do + runFederated rusr $ + fedClient @'Brig @"get-mls-clients" $ + MLSClientsRequest + { mcrUserId = tUnqualified rusr, + mcrSignatureScheme = ss + } + +-------------------------------------------------------------------------------- +-- Error handling of proposal execution + +-- The following errors are caught by 'executeProposalAction' and wrapped in a +-- 'MLSProposalFailure'. This way errors caused by the execution of proposals are +-- separated from those caused by the commit processing itself. +type ProposalErrors = + '[ Error FederationError, + Error InvalidInput, + ErrorS ('ActionDenied 'AddConversationMember), + ErrorS ('ActionDenied 'LeaveConversation), + ErrorS ('ActionDenied 'RemoveConversationMember), + ErrorS 'ConvAccessDenied, + ErrorS 'InvalidOperation, + ErrorS 'NotATeamMember, + ErrorS 'NotConnected, + ErrorS 'TooManyMembers + ] + +class HandleMLSProposalFailures effs r where + handleMLSProposalFailures :: Sem (Append effs r) a -> Sem r a + +class HandleMLSProposalFailure eff r where + handleMLSProposalFailure :: Sem (eff ': r) a -> Sem r a + +instance HandleMLSProposalFailures '[] r where + handleMLSProposalFailures = id + +instance + ( HandleMLSProposalFailures effs r, + HandleMLSProposalFailure eff (Append effs r) + ) => + HandleMLSProposalFailures (eff ': effs) r + where + handleMLSProposalFailures = handleMLSProposalFailures @effs . handleMLSProposalFailure @eff + +instance + (APIError e, Member (Error MLSProposalFailure) r) => + HandleMLSProposalFailure (Error e) r + where + handleMLSProposalFailure = mapError (MLSProposalFailure . toWai) diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs new file mode 100644 index 0000000000..edb792d932 --- /dev/null +++ b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs @@ -0,0 +1,197 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.MLS.Commit.ExternalCommit + ( getExternalCommitData, + processExternalCommit, + ) +where + +import Control.Comonad +import Control.Lens (forOf_) +import qualified Data.Map as Map +import Data.Qualified +import qualified Data.Set as Set +import Galley.API.MLS.Commit.Core +import Galley.API.MLS.Proposal +import Galley.API.MLS.Removal +import Galley.API.MLS.Types +import Galley.API.MLS.Util +import Galley.Effects +import Galley.Effects.MemberStore +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Resource (Resource) +import Polysemy.State +import Wire.API.Conversation.Protocol +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.MLS.Commit +import Wire.API.MLS.Credential +import Wire.API.MLS.LeafNode +import Wire.API.MLS.Proposal +import Wire.API.MLS.ProposalTag +import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation +import Wire.API.MLS.Validation + +data ExternalCommitAction = ExternalCommitAction + { add :: LeafIndex, + remove :: Maybe LeafIndex + } + +getExternalCommitData :: + forall r. + ( Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSStaleMessage) r, + Member (ErrorS 'MLSUnsupportedProposal) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r + ) => + ClientIdentity -> + Local ConvOrSubConv -> + Epoch -> + Commit -> + Sem r ExternalCommitAction +getExternalCommitData senderIdentity lConvOrSub epoch commit = do + let convOrSub = tUnqualified lConvOrSub + mlsMeta = mlsMetaConvOrSub convOrSub + curEpoch = cnvmlsEpoch mlsMeta + groupId = cnvmlsGroupId mlsMeta + when (epoch /= curEpoch) $ throwS @'MLSStaleMessage + proposals <- traverse getInlineProposal commit.proposals + + -- According to the spec, an external commit must contain: + -- (https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol.html#section-12.2) + -- + -- > Exactly one ExternalInit + -- > At most one Remove proposal, with which the joiner removes an old + -- > version of themselves. + -- > Zero or more PreSharedKey proposals. + -- > No other proposals. + let counts = foldr (\x -> Map.insertWith (+) x.tag (1 :: Int)) mempty proposals + + unless (Map.lookup ExternalInitProposalTag counts == Just 1) $ + throw (mlsProtocolError "External commits must contain exactly one ExternalInit proposal") + unless (null (Map.keys counts \\ allowedProposals)) $ + throw (mlsProtocolError "Invalid proposal type in an external commit") + + evalState (indexMapConvOrSub convOrSub) $ do + -- process optional removal + propAction <- applyProposals mlsMeta groupId proposals + removedIndex <- case cmAssocs (paRemove propAction) of + [(cid, idx)] + | cid /= senderIdentity -> + throw $ mlsProtocolError "Only the self client can be removed by an external commit" + | otherwise -> pure (Just idx) + [] -> pure Nothing + _ -> throw (mlsProtocolError "External commits must contain at most one Remove proposal") + + -- add sender client + addedIndex <- gets imNextIndex + + pure + ExternalCommitAction + { add = addedIndex, + remove = removedIndex + } + where + allowedProposals = [ExternalInitProposalTag, RemoveProposalTag, PreSharedKeyProposalTag] + + getInlineProposal :: ProposalOrRef -> Sem r Proposal + getInlineProposal (Ref _) = + throw (mlsProtocolError "External commits cannot reference proposals") + getInlineProposal (Inline p) = pure p + +processExternalCommit :: + forall r. + ( Member (ErrorS 'MLSStaleMessage) r, + Member (ErrorS 'MLSSubConvClientNotInParent) r, + Member Resource r, + HasProposalActionEffects r + ) => + ClientIdentity -> + Local ConvOrSubConv -> + Epoch -> + ExternalCommitAction -> + Maybe UpdatePath -> + Sem r () +processExternalCommit senderIdentity lConvOrSub epoch action updatePath = do + let convOrSub = tUnqualified lConvOrSub + + -- only members can join a subconversation + forOf_ _SubConv convOrSub $ \(mlsConv, _) -> + unless (isClientMember senderIdentity (mcMembers mlsConv)) $ + throwS @'MLSSubConvClientNotInParent + + -- extract leaf node from update path and validate it + leafNode <- + (.leaf) + <$> note + (mlsProtocolError "External commits need an update path") + updatePath + let cs = cnvmlsCipherSuite (mlsMetaConvOrSub (tUnqualified lConvOrSub)) + let groupId = cnvmlsGroupId (mlsMetaConvOrSub convOrSub) + let extra = LeafNodeTBSExtraCommit groupId action.add + case validateLeafNode cs (Just senderIdentity) extra leafNode.value of + Left errMsg -> + throw $ + mlsProtocolError ("Tried to add invalid LeafNode: " <> errMsg) + Right _ -> pure () + + withCommitLock (fmap idForConvOrSub lConvOrSub) groupId epoch $ do + executeExternalCommitAction lConvOrSub senderIdentity action + + -- increment epoch number + lConvOrSub' <- for lConvOrSub incrementEpoch + + -- fetch backend remove proposals of the previous epoch + indicesInRemoveProposals <- + -- skip remove proposals of already removed by the external commit + (\\ toList action.remove) + <$> getPendingBackendRemoveProposals groupId epoch + + -- requeue backend remove proposals for the current epoch + let cm = membersConvOrSub (tUnqualified lConvOrSub') + createAndSendRemoveProposals + lConvOrSub' + indicesInRemoveProposals + (cidQualifiedUser senderIdentity) + cm + +executeExternalCommitAction :: + forall r. + HasProposalActionEffects r => + Local ConvOrSubConv -> + ClientIdentity -> + ExternalCommitAction -> + Sem r () +executeExternalCommitAction lconvOrSub senderIdentity action = do + let mlsMeta = mlsMetaConvOrSub $ tUnqualified lconvOrSub + + -- Remove deprecated sender client from conversation state. + for_ action.remove $ \_ -> + removeMLSClients + (cnvmlsGroupId mlsMeta) + (cidQualifiedUser senderIdentity) + (Set.singleton (ciClient senderIdentity)) + + -- Add new sender client to the conversation state. + addMLSClients + (cnvmlsGroupId mlsMeta) + (cidQualifiedUser senderIdentity) + (Set.singleton (ciClient senderIdentity, action.add)) diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs new file mode 100644 index 0000000000..24991a3d3b --- /dev/null +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -0,0 +1,269 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.MLS.Commit.InternalCommit (processInternalCommit) where + +import Control.Comonad +import Control.Error.Util (hush) +import Control.Lens (forOf_, preview) +import Control.Lens.Extras (is) +import Data.Id +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.Map as Map +import Data.Qualified +import qualified Data.Set as Set +import Data.Tuple.Extra +import Galley.API.Action +import Galley.API.MLS.Commit.Core +import Galley.API.MLS.Conversation +import Galley.API.MLS.Proposal +import Galley.API.MLS.Types +import Galley.API.MLS.Util +import Galley.Data.Conversation.Types hiding (Conversation) +import qualified Galley.Data.Conversation.Types as Data +import Galley.Effects +import Galley.Effects.FederatorAccess +import Galley.Effects.MemberStore +import Galley.Effects.ProposalStore +import Galley.Types.Conversations.Members +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Resource (Resource) +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Commit +import Wire.API.MLS.Credential +import qualified Wire.API.MLS.Proposal as Proposal +import Wire.API.MLS.SubConversation +import Wire.API.User.Client + +processInternalCommit :: + forall r. + ( HasProposalEffects r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'MLSCommitMissingReferences) r, + Member (ErrorS 'MLSSelfRemovalNotAllowed) r, + Member (ErrorS 'MLSStaleMessage) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member SubConversationStore r, + Member Resource r + ) => + ClientIdentity -> + Maybe ConnId -> + Local ConvOrSubConv -> + Epoch -> + ProposalAction -> + Commit -> + Sem r [LocalConversationUpdate] +processInternalCommit senderIdentity con lConvOrSub epoch action commit = do + let convOrSub = tUnqualified lConvOrSub + mlsMeta = mlsMetaConvOrSub convOrSub + qusr = cidQualifiedUser senderIdentity + cm = membersConvOrSub convOrSub + ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) + newUserClients = Map.assocs (paAdd action) + + -- check all pending proposals are referenced in the commit + allPendingProposals <- getAllPendingProposalRefs (cnvmlsGroupId mlsMeta) epoch + let referencedProposals = Set.fromList $ mapMaybe (\x -> preview Proposal._Ref x) commit.proposals + unless (all (`Set.member` referencedProposals) allPendingProposals) $ + throwS @'MLSCommitMissingReferences + + withCommitLock (fmap idForConvOrSub lConvOrSub) (cnvmlsGroupId (mlsMetaConvOrSub convOrSub)) epoch $ do + -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216 + foldQualified lConvOrSub (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr + + -- no client can be directly added to a subconversation + when (is _SubConv convOrSub && any ((senderIdentity /=) . fst) (cmAssocs (paAdd action))) $ + throw (mlsProtocolError "Add proposals in subconversations are not supported") + + -- Note [client removal] + -- We support two types of removals: + -- 1. when a user is removed from a group, all their clients have to be removed + -- 2. when a client is deleted, that particular client (but not necessarily + -- other clients of the same user) has to be removed. + -- + -- Type 2 requires no special processing on the backend, so here we filter + -- out all removals of that type, so that further checks and processing can + -- be applied only to type 1 removals. + -- + -- Furthermore, subconversation clients can be removed arbitrarily, so this + -- processing is only necessary for main conversations. In the + -- subconversation case, an empty list is returned. + membersToRemove <- case convOrSub of + SubConv _ _ -> pure [] + Conv _ -> mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ + \(qtarget, Map.keysSet -> clients) -> runError @() $ do + let clientsInConv = Map.keysSet (Map.findWithDefault mempty qtarget cm) + let removedClients = Set.intersection clients clientsInConv + + -- ignore user if none of their clients are being removed + when (Set.null removedClients) $ throw () + + -- return error if the user is trying to remove themself + when (cidQualifiedUser senderIdentity == qtarget) $ + throwS @'MLSSelfRemovalNotAllowed + + -- FUTUREWORK: add tests against this situation for conv v subconv + when (removedClients /= clientsInConv) $ do + -- FUTUREWORK: turn this error into a proper response + throwS @'MLSClientMismatch + + pure qtarget + + -- for each user, we compare their clients with the ones being added to the conversation + for_ newUserClients $ \(qtarget, newclients) -> case Map.lookup qtarget cm of + -- user is already present, skip check in this case + Just _ -> pure () + -- new user + Nothing -> do + -- final set of clients in the conversation + let clients = Map.keysSet (newclients <> Map.findWithDefault mempty qtarget cm) + -- get list of mls clients from brig + clientInfo <- getClientInfo lConvOrSub qtarget ss + let allClients = Set.map ciId clientInfo + let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) + -- We check the following condition: + -- allMLSClients ⊆ clients ⊆ allClients + -- i.e. + -- - if a client has at least 1 key package, it has to be added + -- - if a client is being added, it has to still exist + -- + -- The reason why we can't simply check that clients == allMLSClients is + -- that a client with no remaining key packages might be added by a user + -- who just fetched its last key package. + unless + ( Set.isSubsetOf allMLSClients clients + && Set.isSubsetOf clients allClients + ) + $ do + -- unless (Set.isSubsetOf allClients clients) $ do + -- FUTUREWORK: turn this error into a proper response + throwS @'MLSClientMismatch + + -- remove users from the conversation and send events + removeEvents <- + foldMap + (removeMembers qusr con lConvOrSub) + (nonEmpty membersToRemove) + + -- Remove clients from the conversation state. This includes client removals + -- of all types (see Note [client removal]). + for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do + removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Map.keysSet clients) + + -- if this is a new subconversation, call `on-new-remote-conversation` on all + -- the remote backends involved in the main conversation + forOf_ _SubConv convOrSub $ \(mlsConv, subConv) -> do + when (cnvmlsEpoch (scMLSData subConv) == Epoch 0) $ do + let remoteDomains = + Set.fromList + ( map + (void . rmId) + (mcRemoteMembers mlsConv) + ) + let nrc = + NewRemoteSubConversation + { nrscConvId = mcId mlsConv, + nrscSubConvId = scSubConvId subConv, + nrscMlsData = scMLSData subConv + } + runFederatedConcurrently_ (toList remoteDomains) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-subconversation" nrc + + -- add users to the conversation and send events + addEvents <- + foldMap (addMembers qusr con lConvOrSub) + . nonEmpty + . map fst + $ newUserClients + + -- add clients in the conversation state + for_ newUserClients $ \(qtarget, newClients) -> do + addMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.fromList (Map.assocs newClients)) + + -- increment epoch number + for_ lConvOrSub incrementEpoch + + pure (addEvents <> removeEvents) + +addMembers :: + HasProposalActionEffects r => + Qualified UserId -> + Maybe ConnId -> + Local ConvOrSubConv -> + NonEmpty (Qualified UserId) -> + Sem r [LocalConversationUpdate] +addMembers qusr con lConvOrSub users = case tUnqualified lConvOrSub of + Conv mlsConv -> do + let lconv = qualifyAs lConvOrSub (mcConv mlsConv) + -- FUTUREWORK: update key package ref mapping to reflect conversation membership + foldMap + ( handleNoChanges + . handleMLSProposalFailures @ProposalErrors + . fmap pure + . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con + . flip ConversationJoin roleNameWireMember + ) + . nonEmpty + . filter (flip Set.notMember (existingMembers lconv)) + . toList + $ users + SubConv _ _ -> pure [] + +removeMembers :: + HasProposalActionEffects r => + Qualified UserId -> + Maybe ConnId -> + Local ConvOrSubConv -> + NonEmpty (Qualified UserId) -> + Sem r [LocalConversationUpdate] +removeMembers qusr con lConvOrSub users = case tUnqualified lConvOrSub of + Conv mlsConv -> do + let lconv = qualifyAs lConvOrSub (mcConv mlsConv) + foldMap + ( handleNoChanges + . handleMLSProposalFailures @ProposalErrors + . fmap pure + . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con + ) + . nonEmpty + . filter (flip Set.member (existingMembers lconv)) + . toList + $ users + SubConv _ _ -> pure [] + +handleNoChanges :: Monoid a => Sem (Error NoChanges ': r) a -> Sem r a +handleNoChanges = fmap fold . runError + +existingLocalMembers :: Local Data.Conversation -> Set (Qualified UserId) +existingLocalMembers lconv = + (Set.fromList . map (fmap lmId . tUntagged)) (traverse convLocalMembers lconv) + +existingRemoteMembers :: Local Data.Conversation -> Set (Qualified UserId) +existingRemoteMembers lconv = + Set.fromList . map (tUntagged . rmId) . convRemoteMembers . tUnqualified $ + lconv + +existingMembers :: Local Data.Conversation -> Set (Qualified UserId) +existingMembers lconv = existingLocalMembers lconv <> existingRemoteMembers lconv diff --git a/services/galley/src/Galley/API/MLS/Conversation.hs b/services/galley/src/Galley/API/MLS/Conversation.hs index fb2396d9c8..5d91d1e4ba 100644 --- a/services/galley/src/Galley/API/MLS/Conversation.hs +++ b/services/galley/src/Galley/API/MLS/Conversation.hs @@ -34,7 +34,7 @@ mkMLSConversation :: Sem r (Maybe MLSConversation) mkMLSConversation conv = for (Data.mlsMetadata conv) $ \mlsData -> do - cm <- lookupMLSClients (cnvmlsGroupId mlsData) + (cm, im) <- lookupMLSClientLeafIndices (cnvmlsGroupId mlsData) pure MLSConversation { mcId = Data.convId conv, @@ -42,7 +42,8 @@ mkMLSConversation conv = mcLocalMembers = Data.convLocalMembers conv, mcRemoteMembers = Data.convRemoteMembers conv, mcMLSData = mlsData, - mcMembers = cm + mcMembers = cm, + mcIndexMap = im } mcConv :: MLSConversation -> Data.Conversation diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/services/galley/src/Galley/API/MLS/GroupInfo.hs index 34fed731c0..dfbe65f3c0 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/services/galley/src/Galley/API/MLS/GroupInfo.hs @@ -36,7 +36,7 @@ import Wire.API.Error.Galley import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation type MLSGroupInfoStaticErrors = @@ -55,7 +55,7 @@ getGroupInfo :: Members MLSGroupInfoStaticErrors r => Local UserId -> Qualified ConvId -> - Sem r OpaquePublicGroupState + Sem r GroupInfoData getGroupInfo lusr qcnvId = do assertMLSEnabled foldQualified @@ -71,10 +71,10 @@ getGroupInfoFromLocalConv :: Members MLSGroupInfoStaticErrors r => Qualified UserId -> Local ConvId -> - Sem r OpaquePublicGroupState + Sem r GroupInfoData getGroupInfoFromLocalConv qusr lcnvId = do void $ getLocalConvForUser qusr lcnvId - E.getPublicGroupState (tUnqualified lcnvId) + E.getGroupInfo (tUnqualified lcnvId) >>= noteS @'MLSMissingGroupInfo getGroupInfoFromRemoteConv :: @@ -84,7 +84,7 @@ getGroupInfoFromRemoteConv :: Members MLSGroupInfoStaticErrors r => Local UserId -> Remote ConvOrSubConvId -> - Sem r OpaquePublicGroupState + Sem r GroupInfoData getGroupInfoFromRemoteConv lusr rcnv = do let getRequest = GetGroupInfoRequest @@ -96,6 +96,6 @@ getGroupInfoFromRemoteConv lusr rcnv = do GetGroupInfoResponseError e -> rethrowErrors @MLSGroupInfoStaticErrors e GetGroupInfoResponseState s -> pure - . OpaquePublicGroupState + . GroupInfoData . fromBase64ByteString $ s diff --git a/services/galley/src/Galley/API/MLS/IncomingMessage.hs b/services/galley/src/Galley/API/MLS/IncomingMessage.hs new file mode 100644 index 0000000000..96b63cc697 --- /dev/null +++ b/services/galley/src/Galley/API/MLS/IncomingMessage.hs @@ -0,0 +1,131 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.MLS.IncomingMessage + ( IncomingMessage (..), + IncomingMessageContent (..), + IncomingPublicMessageContent (..), + IncomingBundle (..), + mkIncomingMessage, + incomingMessageAuthenticatedContent, + mkIncomingBundle, + ) +where + +import GHC.Records +import Imports +import Wire.API.MLS.AuthenticatedContent +import Wire.API.MLS.Commit +import Wire.API.MLS.CommitBundle +import Wire.API.MLS.Epoch +import Wire.API.MLS.Group +import Wire.API.MLS.GroupInfo +import Wire.API.MLS.Message +import Wire.API.MLS.Serialisation +import Wire.API.MLS.Welcome + +data IncomingMessage = IncomingMessage + { epoch :: Epoch, + groupId :: GroupId, + content :: IncomingMessageContent, + rawMessage :: RawMLS Message + } + +instance HasField "sender" IncomingMessage (Maybe Sender) where + getField msg = case msg.content of + IncomingMessageContentPublic pub -> Just pub.sender + _ -> Nothing + +data IncomingMessageContent + = IncomingMessageContentPublic IncomingPublicMessageContent + | IncomingMessageContentPrivate + +data IncomingPublicMessageContent = IncomingPublicMessageContent + { sender :: Sender, + content :: FramedContentData, + -- for verification + framedContent :: RawMLS FramedContent, + authData :: RawMLS FramedContentAuthData + } + +data IncomingBundle = IncomingBundle + { epoch :: Epoch, + groupId :: GroupId, + sender :: Sender, + commit :: RawMLS Commit, + rawMessage :: RawMLS Message, + welcome :: Maybe (RawMLS Welcome), + groupInfo :: GroupInfoData, + serialized :: ByteString + } + +mkIncomingMessage :: RawMLS Message -> Maybe IncomingMessage +mkIncomingMessage msg = case msg.value.content of + MessagePublic pmsg -> + Just + IncomingMessage + { epoch = pmsg.content.value.epoch, + groupId = pmsg.content.value.groupId, + content = + IncomingMessageContentPublic + IncomingPublicMessageContent + { sender = pmsg.content.value.sender, + content = pmsg.content.value.content, + framedContent = pmsg.content, + authData = pmsg.authData + }, + rawMessage = msg + } + MessagePrivate pmsg + | pmsg.value.tag == FramedContentApplicationDataTag -> + Just + IncomingMessage + { epoch = pmsg.value.epoch, + groupId = pmsg.value.groupId, + content = IncomingMessageContentPrivate, + rawMessage = msg + } + _ -> Nothing + +incomingMessageAuthenticatedContent :: IncomingPublicMessageContent -> AuthenticatedContent +incomingMessageAuthenticatedContent pmsg = + AuthenticatedContent + { wireFormat = WireFormatPublicTag, + content = pmsg.framedContent, + authData = pmsg.authData + } + +mkIncomingBundle :: RawMLS CommitBundle -> Maybe IncomingBundle +mkIncomingBundle bundle = do + imsg <- mkIncomingMessage bundle.value.commitMsg + content <- case imsg.content of + IncomingMessageContentPublic c -> pure c + _ -> Nothing + commit <- case content.content of + FramedContentCommit c -> pure c + _ -> Nothing + pure + IncomingBundle + { epoch = imsg.epoch, + groupId = imsg.groupId, + sender = content.sender, + commit = commit, + rawMessage = bundle.value.commitMsg, + welcome = bundle.value.welcome, + groupInfo = GroupInfoData bundle.value.groupInfo.raw, + serialized = bundle.raw + } diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 967c005baf..0667468126 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -16,53 +16,40 @@ -- with this program. If not, see . module Galley.API.MLS.Message - ( postMLSCommitBundle, + ( IncomingBundle (..), + mkIncomingBundle, + IncomingMessage (..), + mkIncomingMessage, + postMLSCommitBundle, postMLSCommitBundleFromLocalUser, postMLSMessageFromLocalUser, - postMLSMessageFromLocalUserV1, postMLSMessage, MLSMessageStaticErrors, MLSBundleStaticErrors, ) where -import Control.Arrow ((>>>)) import Control.Comonad -import Control.Error.Util (hush) -import Control.Lens (forOf_, preview) -import Control.Lens.Extras (is) import Data.Id import Data.Json.Util -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import qualified Data.Map as Map import Data.Qualified -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Time import Data.Tuple.Extra import Galley.API.Action -import Galley.API.Error +import Galley.API.MLS.Commit import Galley.API.MLS.Conversation import Galley.API.MLS.Enabled -import Galley.API.MLS.KeyPackage +import Galley.API.MLS.IncomingMessage import Galley.API.MLS.Propagate -import Galley.API.MLS.Removal +import Galley.API.MLS.Proposal import Galley.API.MLS.Types import Galley.API.MLS.Util -import Galley.API.MLS.Welcome (postMLSWelcome) +import Galley.API.MLS.Welcome (sendWelcomes) import Galley.API.Util -import Galley.Data.Conversation.Types hiding (Conversation) -import qualified Galley.Data.Conversation.Types as Data import Galley.Effects -import Galley.Effects.BrigAccess import Galley.Effects.ConversationStore import Galley.Effects.FederatorAccess import Galley.Effects.MemberStore -import Galley.Effects.ProposalStore import Galley.Effects.SubConversationStore -import Galley.Env -import Galley.Options -import Galley.Types.Conversations.Members import Imports import Polysemy import Polysemy.Error @@ -70,32 +57,25 @@ import Polysemy.Input import Polysemy.Internal import Polysemy.Resource (Resource) import Polysemy.TinyLog -import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Protocol -import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Event.Conversation import Wire.API.Federation.API -import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.CommitBundle import Wire.API.MLS.Credential -import Wire.API.MLS.GroupInfoBundle -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.GroupInfo import Wire.API.MLS.Message -import Wire.API.MLS.Proposal -import qualified Wire.API.MLS.Proposal as Proposal -import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation -import Wire.API.MLS.Welcome -import Wire.API.Message -import Wire.API.Routes.Internal.Brig -import Wire.API.User.Client + +-- FUTUREWORK +-- - Check that the capabilities of a leaf node in an add proposal contains all +-- the required_capabilities of the group context. This would require fetching +-- the group info from the DB in order to read the group context. +-- - Verify message signature, this also requires the group context. (see above) type MLSMessageStaticErrors = '[ ErrorS 'ConvAccessDenied, @@ -106,14 +86,13 @@ type MLSMessageStaticErrors = ErrorS 'MLSStaleMessage, ErrorS 'MLSProposalNotFound, ErrorS 'MissingLegalholdConsent, - ErrorS 'MLSKeyPackageRefNotFound, + ErrorS 'MLSInvalidLeafNodeIndex, ErrorS 'MLSClientMismatch, ErrorS 'MLSUnsupportedProposal, ErrorS 'MLSCommitMissingReferences, ErrorS 'MLSSelfRemovalNotAllowed, ErrorS 'MLSClientSenderUserMismatch, ErrorS 'MLSGroupConversationMismatch, - ErrorS 'MLSMissingSenderClient, ErrorS 'MLSSubConvClientNotInParent ] @@ -122,39 +101,6 @@ type MLSBundleStaticErrors = MLSMessageStaticErrors '[ErrorS 'MLSWelcomeMismatch] -postMLSMessageFromLocalUserV1 :: - ( HasProposalEffects r, - Member (Error FederationError) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'ConvMemberNotFound) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'MLSClientSenderUserMismatch) r, - Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSGroupConversationMismatch) r, - Member (ErrorS 'MLSMissingSenderClient) r, - Member (ErrorS 'MLSNotEnabled) r, - Member (ErrorS 'MLSProposalNotFound) r, - Member (ErrorS 'MLSSelfRemovalNotAllowed) r, - Member (ErrorS 'MLSStaleMessage) r, - Member (ErrorS 'MLSUnsupportedMessage) r, - Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member Resource r, - Member SubConversationStore r - ) => - Local UserId -> - Maybe ClientId -> - ConnId -> - RawMLS SomeMessage -> - Sem r [Event] -postMLSMessageFromLocalUserV1 lusr mc conn smsg = do - assertMLSEnabled - case rmValue smsg of - SomeMessage _ msg -> do - cnvOrSub <- lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound - fst . first (map lcuEvent) - <$> postMLSMessage lusr (tUntagged lusr) mc cnvOrSub (Just conn) smsg - postMLSMessageFromLocalUser :: ( HasProposalEffects r, Member (Error FederationError) r, @@ -165,29 +111,26 @@ postMLSMessageFromLocalUser :: Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, Member (ErrorS 'MLSGroupConversationMismatch) r, - Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MLSNotEnabled) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSUnsupportedMessage) r, Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member Resource r, Member SubConversationStore r ) => Local UserId -> - Maybe ClientId -> + ClientId -> ConnId -> - RawMLS SomeMessage -> + RawMLS Message -> Sem r MLSMessageSendingStatus -postMLSMessageFromLocalUser lusr mc conn smsg = do +postMLSMessageFromLocalUser lusr c conn smsg = do assertMLSEnabled + imsg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage smsg + cnvOrSub <- lookupConvByGroupId imsg.groupId >>= noteS @'ConvNotFound (events, unreachables) <- - case rmValue smsg of - SomeMessage _ msg -> do - cnvOrSub <- lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound - first (map lcuEvent) - <$> postMLSMessage lusr (tUntagged lusr) mc cnvOrSub (Just conn) smsg + first (map lcuEvent) + <$> postMLSMessage lusr (tUntagged lusr) c cnvOrSub (Just conn) imsg t <- toUTCTimeMillis <$> input pure $ MLSMessageSendingStatus events t unreachables @@ -200,16 +143,16 @@ postMLSCommitBundle :: ) => Local x -> Qualified UserId -> - Maybe ClientId -> + ClientId -> Qualified ConvOrSubConvId -> Maybe ConnId -> - CommitBundle -> + IncomingBundle -> Sem r ([LocalConversationUpdate], UnreachableUsers) -postMLSCommitBundle loc qusr mc qConvOrSub conn rawBundle = +postMLSCommitBundle loc qusr c qConvOrSub conn bundle = foldQualified loc - (postMLSCommitBundleToLocalConv qusr mc conn rawBundle) - (postMLSCommitBundleToRemoteConv loc qusr mc conn rawBundle) + (postMLSCommitBundleToLocalConv qusr c conn bundle) + (postMLSCommitBundleToRemoteConv loc qusr c conn bundle) qConvOrSub postMLSCommitBundleFromLocalUser :: @@ -220,17 +163,17 @@ postMLSCommitBundleFromLocalUser :: Member SubConversationStore r ) => Local UserId -> - Maybe ClientId -> + ClientId -> ConnId -> - CommitBundle -> + RawMLS CommitBundle -> Sem r MLSMessageSendingStatus -postMLSCommitBundleFromLocalUser lusr mc conn bundle = do +postMLSCommitBundleFromLocalUser lusr c conn bundle = do assertMLSEnabled - let msg = rmValue (cbCommitMsg bundle) - qConvOrSub <- lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound + ibundle <- noteS @'MLSUnsupportedMessage $ mkIncomingBundle bundle + qConvOrSub <- lookupConvByGroupId ibundle.groupId >>= noteS @'ConvNotFound (events, unreachables) <- first (map lcuEvent) - <$> postMLSCommitBundle lusr (tUntagged lusr) mc qConvOrSub (Just conn) bundle + <$> postMLSCommitBundle lusr (tUntagged lusr) c qConvOrSub (Just conn) ibundle t <- toUTCTimeMillis <$> input pure $ MLSMessageSendingStatus events t unreachables @@ -241,49 +184,44 @@ postMLSCommitBundleToLocalConv :: Member SubConversationStore r ) => Qualified UserId -> - Maybe ClientId -> + ClientId -> Maybe ConnId -> - CommitBundle -> + IncomingBundle -> Local ConvOrSubConvId -> Sem r ([LocalConversationUpdate], UnreachableUsers) -postMLSCommitBundleToLocalConv qusr mc conn bundle lConvOrSubId = do +postMLSCommitBundleToLocalConv qusr c conn bundle lConvOrSubId = do lConvOrSub <- fetchConvOrSub qusr lConvOrSubId - let msg = rmValue (cbCommitMsg bundle) - - senderClient <- fmap ciClient <$> getSenderIdentity qusr mc SMLSPlainText msg - - events <- case msgPayload msg of - CommitMessage commit -> - do - action <- getCommitData lConvOrSub (msgEpoch msg) commit - -- check that the welcome message matches the action - for_ (cbWelcome bundle) $ \welcome -> - when - ( Set.fromList (map gsNewMember (welSecrets (rmValue welcome))) - /= Set.fromList (map (snd . snd) (cmAssocs (paAdd action))) - ) - $ throwS @'MLSWelcomeMismatch - updates <- - processCommitWithAction - qusr - senderClient - conn - lConvOrSub - (msgEpoch msg) - action - (msgSender msg) - commit - storeGroupInfoBundle (idForConvOrSub . tUnqualified $ lConvOrSub) (cbGroupInfoBundle bundle) - pure updates - ApplicationMessage _ -> throwS @'MLSUnsupportedMessage - ProposalMessage _ -> throwS @'MLSUnsupportedMessage + senderIdentity <- getSenderIdentity qusr c bundle.sender lConvOrSub + + (events, newClients) <- case bundle.sender of + SenderMember _index -> do + action <- getCommitData senderIdentity lConvOrSub bundle.epoch bundle.commit.value + events <- + processInternalCommit + senderIdentity + conn + lConvOrSub + bundle.epoch + action + bundle.commit.value + pure (events, cmIdentities (paAdd action)) + SenderExternal _ -> throw (mlsProtocolError "Unexpected sender") + SenderNewMemberProposal -> throw (mlsProtocolError "Unexpected sender") + SenderNewMemberCommit -> do + action <- getExternalCommitData senderIdentity lConvOrSub bundle.epoch bundle.commit.value + processExternalCommit + senderIdentity + lConvOrSub + bundle.epoch + action + bundle.commit.value.path + pure ([], []) + + storeGroupInfo (idForConvOrSub . tUnqualified $ lConvOrSub) bundle.groupInfo let cm = membersConvOrSub (tUnqualified lConvOrSub) - unreachables <- propagateMessage qusr lConvOrSub conn (rmRaw (cbCommitMsg bundle)) cm - - for_ (cbWelcome bundle) $ - postMLSWelcome lConvOrSub conn - + unreachables <- propagateMessage qusr lConvOrSub conn bundle.rawMessage cm + traverse_ (sendWelcomes lConvOrSub conn newClients) bundle.welcome pure (events, unreachables) postMLSCommitBundleToRemoteConv :: @@ -301,34 +239,26 @@ postMLSCommitBundleToRemoteConv :: ) => Local x -> Qualified UserId -> - Maybe ClientId -> + ClientId -> Maybe ConnId -> - CommitBundle -> + IncomingBundle -> Remote ConvOrSubConvId -> Sem r ([LocalConversationUpdate], UnreachableUsers) -postMLSCommitBundleToRemoteConv loc qusr mc con bundle rConvOrSubId = do +postMLSCommitBundleToRemoteConv loc qusr c con bundle rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send commit bundles to a remote conversation flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) - senderIdentity <- - noteS @'MLSMissingSenderClient - =<< getSenderIdentity - qusr - mc - SMLSPlainText - (rmValue (cbCommitMsg bundle)) - resp <- runFederated rConvOrSubId $ fedClient @'Galley @"send-mls-commit-bundle" $ MLSMessageSendRequest { mmsrConvOrSubId = tUnqualified rConvOrSubId, mmsrSender = tUnqualified lusr, - mmsrSenderClient = ciClient senderIdentity, - mmsrRawMessage = Base64ByteString (serializeCommitBundle bundle) + mmsrSenderClient = c, + mmsrRawMessage = Base64ByteString bundle.serialized } case resp of MLSMessageResponseError e -> rethrowErrors @MLSBundleStaticErrors e @@ -351,119 +281,79 @@ postMLSMessage :: Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, Member (ErrorS 'MLSGroupConversationMismatch) r, - Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSUnsupportedMessage) r, Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member Resource r, Member SubConversationStore r ) => Local x -> Qualified UserId -> - Maybe ClientId -> + ClientId -> Qualified ConvOrSubConvId -> Maybe ConnId -> - RawMLS SomeMessage -> + IncomingMessage -> Sem r ([LocalConversationUpdate], UnreachableUsers) -postMLSMessage loc qusr mc qconvOrSub con smsg = case rmValue smsg of - SomeMessage tag msg -> do - mSender <- fmap ciClient <$> getSenderIdentity qusr mc tag msg - foldQualified - loc - (postMLSMessageToLocalConv qusr mSender con smsg) - (postMLSMessageToRemoteConv loc qusr mSender con smsg) - qconvOrSub - --- Check that the MLS client who created the message belongs to the user who --- is the sender of the REST request, identified by HTTP header. --- --- The check is skipped in case of conversation creation and encrypted messages. -getSenderClient :: - ( Member (ErrorS 'MLSKeyPackageRefNotFound) r, - Member (ErrorS 'MLSClientSenderUserMismatch) r, - Member BrigAccess r - ) => - Qualified UserId -> - SWireFormatTag tag -> - Message tag -> - Sem r (Maybe ClientId) -getSenderClient _ SMLSCipherText _ = pure Nothing -getSenderClient _ _ msg | msgEpoch msg == Epoch 0 = pure Nothing -getSenderClient qusr SMLSPlainText msg = case msgSender msg of - PreconfiguredSender _ -> pure Nothing - NewMemberSender -> pure Nothing - MemberSender ref -> do - cid <- derefKeyPackage ref - when (fmap fst (cidQualifiedClient cid) /= qusr) $ - throwS @'MLSClientSenderUserMismatch - pure (Just (ciClient cid)) +postMLSMessage loc qusr c qconvOrSub con msg = do + foldQualified + loc + (postMLSMessageToLocalConv qusr c con msg) + (postMLSMessageToRemoteConv loc qusr c con msg) + qconvOrSub --- FUTUREWORK: once we can assume that the Z-Client header is present (i.e. --- when v2 is dropped), remove the Maybe in the return type. getSenderIdentity :: - ( Member (ErrorS 'MLSKeyPackageRefNotFound) r, - Member (ErrorS 'MLSClientSenderUserMismatch) r, - Member BrigAccess r + ( Member (ErrorS 'MLSClientSenderUserMismatch) r, + Member (Error MLSProtocolError) r ) => Qualified UserId -> - Maybe ClientId -> - SWireFormatTag tag -> - Message tag -> - Sem r (Maybe ClientIdentity) -getSenderIdentity qusr mc fmt msg = do - mSender <- getSenderClient qusr fmt msg - -- At this point, mc is the client ID of the request, while mSender is the - -- one contained in the message. We throw an error if the two don't match. - when (((==) <$> mc <*> mSender) == Just False) $ - throwS @'MLSClientSenderUserMismatch - pure (mkClientIdentity qusr <$> (mc <|> mSender)) + ClientId -> + Sender -> + Local ConvOrSubConv -> + Sem r ClientIdentity +getSenderIdentity qusr c mSender lConvOrSubConv = do + let cid = mkClientIdentity qusr c + let idxMap = indexMapConvOrSub $ tUnqualified lConvOrSubConv + let epoch = epochNumber . cnvmlsEpoch . mlsMetaConvOrSub . tUnqualified $ lConvOrSubConv + case mSender of + SenderMember idx | epoch > 0 -> do + cid' <- note (mlsProtocolError "unknown sender leaf index") $ imLookup idxMap idx + unless (cid' == cid) $ throwS @'MLSClientSenderUserMismatch + _ -> pure () + pure cid postMLSMessageToLocalConv :: ( HasProposalEffects r, Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MLSClientSenderUserMismatch) r, - Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSMissingSenderClient) r, - Member (ErrorS 'MLSProposalNotFound) r, - Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSUnsupportedMessage) r, - Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member Resource r, Member SubConversationStore r ) => Qualified UserId -> - Maybe ClientId -> + ClientId -> Maybe ConnId -> - RawMLS SomeMessage -> + IncomingMessage -> Local ConvOrSubConvId -> Sem r ([LocalConversationUpdate], UnreachableUsers) -postMLSMessageToLocalConv qusr senderClient con smsg convOrSubId = - case rmValue smsg of - SomeMessage tag msg -> do - lConvOrSub <- fetchConvOrSub qusr convOrSubId +postMLSMessageToLocalConv qusr c con msg convOrSubId = do + lConvOrSub <- fetchConvOrSub qusr convOrSubId - -- validate message - events <- case tag of - SMLSPlainText -> case msgPayload msg of - CommitMessage c -> - processCommit qusr senderClient con lConvOrSub (msgEpoch msg) (msgSender msg) c - ApplicationMessage _ -> throwS @'MLSUnsupportedMessage - ProposalMessage prop -> - processProposal qusr lConvOrSub msg prop $> mempty - SMLSCipherText -> case toMLSEnum' (msgContentType (msgPayload msg)) of - Right CommitMessageTag -> throwS @'MLSUnsupportedMessage - Right ProposalMessageTag -> throwS @'MLSUnsupportedMessage - Right ApplicationMessageTag -> pure mempty - Left _ -> throwS @'MLSUnsupportedMessage + for_ msg.sender $ \sender -> + void $ getSenderIdentity qusr c sender lConvOrSub - let cm = membersConvOrSub (tUnqualified lConvOrSub) - -- forward message - unreachables <- propagateMessage qusr lConvOrSub con (rmRaw smsg) cm - pure (events, unreachables) + -- validate message + case msg.content of + IncomingMessageContentPublic pub -> case pub.content of + FramedContentCommit _commit -> throwS @'MLSUnsupportedMessage + FramedContentApplicationData _ -> throwS @'MLSUnsupportedMessage + FramedContentProposal prop -> + processProposal qusr lConvOrSub msg.groupId msg.epoch pub prop + IncomingMessageContentPrivate -> pure () + + let cm = membersConvOrSub (tUnqualified lConvOrSub) + unreachables <- propagateMessage qusr lConvOrSub con msg.rawMessage cm + pure ([], unreachables) postMLSMessageToRemoteConv :: ( Members MLSMessageStaticErrors r, @@ -474,18 +364,17 @@ postMLSMessageToRemoteConv :: ) => Local x -> Qualified UserId -> - Maybe ClientId -> + ClientId -> Maybe ConnId -> - RawMLS SomeMessage -> + IncomingMessage -> Remote ConvOrSubConvId -> Sem r ([LocalConversationUpdate], UnreachableUsers) -postMLSMessageToRemoteConv loc qusr mc con smsg rConvOrSubId = do +postMLSMessageToRemoteConv loc qusr senderClient con msg rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send messages to the remote conversation flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) - senderClient <- noteS @'MLSMissingSenderClient mc resp <- runFederated rConvOrSubId $ fedClient @'Galley @"send-mls-message" $ @@ -493,7 +382,7 @@ postMLSMessageToRemoteConv loc qusr mc con smsg rConvOrSubId = do { mmsrConvOrSubId = tUnqualified rConvOrSubId, mmsrSender = tUnqualified lusr, mmsrSenderClient = senderClient, - mmsrRawMessage = Base64ByteString (rmRaw smsg) + mmsrRawMessage = Base64ByteString msg.rawMessage.raw } case resp of MLSMessageResponseError e -> rethrowErrors @MLSMessageStaticErrors e @@ -506,885 +395,16 @@ postMLSMessageToRemoteConv loc qusr mc con smsg rConvOrSubId = do pure (LocalConversationUpdate e update) pure (lcus, unreachables) -type HasProposalEffects r = - ( Member BrigAccess r, - Member ConversationStore r, - Member (Error InternalError) r, - Member (Error MLSProposalFailure) r, - Member (Error MLSProtocolError) r, - Member (ErrorS 'MLSClientMismatch) r, - Member (ErrorS 'MLSKeyPackageRefNotFound) r, - Member (ErrorS 'MLSUnsupportedProposal) r, - Member ExternalAccess r, - Member FederatorAccess r, - Member GundeckAccess r, - Member (Input Env) r, - Member (Input (Local ())) r, - Member (Input Opts) r, - Member (Input UTCTime) r, - Member LegalHoldStore r, - Member MemberStore r, - Member ProposalStore r, - Member TeamStore r, - Member TeamStore r, - Member TinyLog r - ) - -data ProposalAction = ProposalAction - { paAdd :: ClientMap, - paRemove :: ClientMap, - -- The backend does not process external init proposals, but still it needs - -- to know if a commit has one when processing external commits - paExternalInit :: Any - } - deriving (Show) - -instance Semigroup ProposalAction where - ProposalAction add1 rem1 init1 <> ProposalAction add2 rem2 init2 = - ProposalAction - (Map.unionWith mappend add1 add2) - (Map.unionWith mappend rem1 rem2) - (init1 <> init2) - -instance Monoid ProposalAction where - mempty = ProposalAction mempty mempty mempty - -paAddClient :: Qualified (UserId, (ClientId, KeyPackageRef)) -> ProposalAction -paAddClient quc = mempty {paAdd = Map.singleton (fmap fst quc) (uncurry Map.singleton (snd (qUnqualified quc)))} - -paRemoveClient :: Qualified (UserId, (ClientId, KeyPackageRef)) -> ProposalAction -paRemoveClient quc = mempty {paRemove = Map.singleton (fmap fst quc) (uncurry Map.singleton (snd (qUnqualified quc)))} - -paExternalInitPresent :: ProposalAction -paExternalInitPresent = mempty {paExternalInit = Any True} - -getCommitData :: - ( HasProposalEffects r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MLSProposalNotFound) r, - Member (ErrorS 'MLSStaleMessage) r - ) => - Local ConvOrSubConv -> - Epoch -> - Commit -> - Sem r ProposalAction -getCommitData lConvOrSub epoch commit = do - let convOrSub = tUnqualified lConvOrSub - mlsMeta = mlsMetaConvOrSub convOrSub - curEpoch = cnvmlsEpoch mlsMeta - groupId = cnvmlsGroupId mlsMeta - suite = cnvmlsCipherSuite mlsMeta - - -- check epoch number - when (epoch /= curEpoch) $ throwS @'MLSStaleMessage - foldMap (applyProposalRef (idForConvOrSub convOrSub) mlsMeta groupId epoch suite) (cProposals commit) - -processCommit :: - ( HasProposalEffects r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'MLSClientSenderUserMismatch) r, - Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSMissingSenderClient) r, - Member (ErrorS 'MLSProposalNotFound) r, - Member (ErrorS 'MLSSelfRemovalNotAllowed) r, - Member (ErrorS 'MLSStaleMessage) r, - Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member Resource r, - Member SubConversationStore r - ) => - Qualified UserId -> - Maybe ClientId -> - Maybe ConnId -> - Local ConvOrSubConv -> - Epoch -> - Sender 'MLSPlainText -> - Commit -> - Sem r [LocalConversationUpdate] -processCommit qusr senderClient con lConvOrSub epoch sender commit = do - action <- getCommitData lConvOrSub epoch commit - processCommitWithAction qusr senderClient con lConvOrSub epoch action sender commit - -processExternalCommit :: - forall r. - ( Member BrigAccess r, - Member ConversationStore r, - Member (Error MLSProtocolError) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MLSClientSenderUserMismatch) r, - Member (ErrorS 'MLSKeyPackageRefNotFound) r, - Member (ErrorS 'MLSStaleMessage) r, - Member (ErrorS 'MLSMissingSenderClient) r, - Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member ExternalAccess r, - Member FederatorAccess r, - Member GundeckAccess r, - Member (Input Env) r, - Member (Input UTCTime) r, - Member MemberStore r, - Member ProposalStore r, - Member Resource r, - Member SubConversationStore r, - Member TinyLog r - ) => - Qualified UserId -> - Maybe ClientId -> - Local ConvOrSubConv -> - Epoch -> - ProposalAction -> - Maybe UpdatePath -> - Sem r () -processExternalCommit qusr mSenderClient lConvOrSub epoch action updatePath = - withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub) epoch $ do - let convOrSub = tUnqualified lConvOrSub - newKeyPackage <- - upLeaf - <$> note - (mlsProtocolError "External commits need an update path") - updatePath - when (paExternalInit action == mempty) $ - throw . mlsProtocolError $ - "The external commit is missing an external init proposal" - unless (paAdd action == mempty) $ - throw . mlsProtocolError $ - "The external commit must not have add proposals" - - newRef <- - kpRef' newKeyPackage - & note (mlsProtocolError "An invalid key package in the update path") - - -- validate and update mapping in brig - eithCid <- - nkpresClientIdentity - <$$> validateAndAddKeyPackageRef - NewKeyPackage - { nkpConversation = tUntagged (convOfConvOrSub . idForConvOrSub <$> lConvOrSub), - nkpKeyPackage = KeyPackageData (rmRaw newKeyPackage) - } - cid <- either (\errMsg -> throw (mlsProtocolError ("Tried to add invalid KeyPackage: " <> errMsg))) pure eithCid - - unless (cidQualifiedUser cid == qusr) $ - throw . mlsProtocolError $ - "The external commit attempts to add another user" - - senderClient <- noteS @'MLSMissingSenderClient mSenderClient - - unless (ciClient cid == senderClient) $ - throw . mlsProtocolError $ - "The external commit attempts to add another client of the user, it must only add itself" - - -- only members can join a subconversation - forOf_ _SubConv convOrSub $ \(mlsConv, _) -> - unless (isClientMember cid (mcMembers mlsConv)) $ - throwS @'MLSSubConvClientNotInParent - - -- check if there is a key package ref in the remove proposal - remRef <- - if Map.null (paRemove action) - then pure Nothing - else do - (remCid, r) <- derefUser (paRemove action) qusr - unless (cidQualifiedUser cid == cidQualifiedUser remCid) - . throw - . mlsProtocolError - $ "The external commit attempts to remove a client from a user other than themselves" - pure (Just r) - - updateKeyPackageMapping lConvOrSub qusr (ciClient cid) remRef newRef - - -- increment epoch number - lConvOrSub' <- for lConvOrSub incrementEpoch - - -- fetch backend remove proposals of the previous epoch - kpRefs <- - -- skip remove proposals of already removed by the external commit - filter (maybe (const True) (/=) remRef) - <$> getPendingBackendRemoveProposals (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub') epoch - -- requeue backend remove proposals for the current epoch - let cm = membersConvOrSub (tUnqualified lConvOrSub') - createAndSendRemoveProposals lConvOrSub' kpRefs qusr cm - where - derefUser :: ClientMap -> Qualified UserId -> Sem r (ClientIdentity, KeyPackageRef) - derefUser cm user = case Map.assocs cm of - [(u, clients)] -> do - unless (user == u) $ - throwS @'MLSClientSenderUserMismatch - ref <- ensureSingleton clients - ci <- derefKeyPackage ref - unless (cidQualifiedUser ci == user) $ - throwS @'MLSClientSenderUserMismatch - pure (ci, ref) - _ -> throwRemProposal - ensureSingleton :: Map k a -> Sem r a - ensureSingleton m = case Map.elems m of - [e] -> pure e - _ -> throwRemProposal - throwRemProposal = - throw . mlsProtocolError $ - "The external commit must have at most one remove proposal" - -processCommitWithAction :: - forall r. - ( HasProposalEffects r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'MLSClientSenderUserMismatch) r, - Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSMissingSenderClient) r, - Member (ErrorS 'MLSSelfRemovalNotAllowed) r, - Member (ErrorS 'MLSStaleMessage) r, - Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member Resource r, - Member SubConversationStore r - ) => - Qualified UserId -> - Maybe ClientId -> - Maybe ConnId -> - Local ConvOrSubConv -> - Epoch -> - ProposalAction -> - Sender 'MLSPlainText -> - Commit -> - Sem r [LocalConversationUpdate] -processCommitWithAction qusr senderClient con lConvOrSub epoch action sender commit = - case sender of - MemberSender ref -> processInternalCommit qusr senderClient con lConvOrSub epoch action ref commit - NewMemberSender -> processExternalCommit qusr senderClient lConvOrSub epoch action (cPath commit) $> [] - _ -> throw (mlsProtocolError "Unexpected sender") - -processInternalCommit :: - forall r. - ( HasProposalEffects r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSMissingSenderClient) r, - Member (ErrorS 'MLSSelfRemovalNotAllowed) r, - Member (ErrorS 'MLSStaleMessage) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'MLSSubConvClientNotInParent) r, - Member SubConversationStore r, - Member Resource r - ) => - Qualified UserId -> - Maybe ClientId -> - Maybe ConnId -> - Local ConvOrSubConv -> - Epoch -> - ProposalAction -> - KeyPackageRef -> - Commit -> - Sem r [LocalConversationUpdate] -processInternalCommit qusr senderClient con lConvOrSub epoch action senderRef commit = do - let convOrSub = tUnqualified lConvOrSub - mlsMeta = mlsMetaConvOrSub convOrSub - localSelf = isLocal lConvOrSub qusr - - updatePathRef <- - for - (cPath commit) - (upLeaf >>> kpRef' >>> note (mlsProtocolError "Could not compute key package ref")) - - withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub $ convOrSub) epoch $ do - postponedKeyPackageRefUpdate <- - if epoch == Epoch 0 - then do - let cType = cnvmType . mcMetadata . convOfConvOrSub $ convOrSub - case (localSelf, cType, cmAssocs . membersConvOrSub $ convOrSub, convOrSub) of - (True, SelfConv, [], Conv _) -> do - creatorClient <- noteS @'MLSMissingSenderClient senderClient - let creatorRef = fromMaybe senderRef updatePathRef - updateKeyPackageMapping lConvOrSub qusr creatorClient Nothing creatorRef - (True, SelfConv, _, _) -> - -- this is a newly created (sub)conversation, and it should - -- contain exactly one client (the creator) - throw (InternalErrorWithDescription "Unexpected creator client set") - (True, _, [(qu, (creatorClient, _))], Conv _) - | qu == qusr -> do - -- use update path as sender reference and if not existing fall back to sender - let creatorRef = fromMaybe senderRef updatePathRef - -- register the creator client - updateKeyPackageMapping - lConvOrSub - qusr - creatorClient - Nothing - creatorRef - -- remote clients cannot send the first commit - (False, _, _, _) -> throwS @'MLSStaleMessage - (True, _, [], SubConv parentConv _) -> do - creatorClient <- noteS @'MLSMissingSenderClient senderClient - unless (isClientMember (mkClientIdentity qusr creatorClient) (mcMembers parentConv)) $ - throwS @'MLSSubConvClientNotInParent - let creatorRef = fromMaybe senderRef updatePathRef - updateKeyPackageMapping lConvOrSub qusr creatorClient Nothing creatorRef - (_, _, _, _) -> - throw (InternalErrorWithDescription "Unexpected creator client set") - pure $ pure () -- no key package ref update necessary - else case updatePathRef of - Just updatedRef -> do - -- postpone key package ref update until other checks/processing passed - case senderClient of - Just cli -> - pure - ( updateKeyPackageMapping - lConvOrSub - qusr - cli - (Just senderRef) - updatedRef - ) - Nothing -> pure (pure ()) - Nothing -> pure (pure ()) -- ignore commits without update path - - -- check all pending proposals are referenced in the commit - allPendingProposals <- getAllPendingProposalRefs (cnvmlsGroupId mlsMeta) epoch - let referencedProposals = Set.fromList $ mapMaybe (\x -> preview Proposal._Ref x) (cProposals commit) - unless (all (`Set.member` referencedProposals) allPendingProposals) $ - throwS @'MLSCommitMissingReferences - - -- process and execute proposals - updates <- executeProposalAction qusr con lConvOrSub action - - -- update key package ref if necessary - postponedKeyPackageRefUpdate - -- increment epoch number - for_ lConvOrSub incrementEpoch - - pure updates - --- | Note: Use this only for KeyPackage that are already validated -updateKeyPackageMapping :: - ( Member BrigAccess r, - Member MemberStore r - ) => - Local ConvOrSubConv -> - Qualified UserId -> - ClientId -> - Maybe KeyPackageRef -> - KeyPackageRef -> - Sem r () -updateKeyPackageMapping lConvOrSub qusr cid mOld new = do - let qconv = tUntagged (convOfConvOrSub . idForConvOrSub <$> lConvOrSub) - -- update actual mapping in brig - case mOld of - Nothing -> - addKeyPackageRef new qusr cid qconv - Just old -> - updateKeyPackageRef - KeyPackageUpdate - { kpupPrevious = old, - kpupNext = new - } - let groupId = cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub - - -- remove old (client, key package) pair - removeMLSClients groupId qusr (Set.singleton cid) - -- add new (client, key package) pair - addMLSClients groupId qusr (Set.singleton (cid, new)) - -applyProposalRef :: - ( HasProposalEffects r, - ( Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MLSProposalNotFound) r, - Member (ErrorS 'MLSStaleMessage) r, - Member ProposalStore r - ) - ) => - ConvOrSubConvId -> - ConversationMLSData -> - GroupId -> - Epoch -> - CipherSuiteTag -> - ProposalOrRef -> - Sem r ProposalAction -applyProposalRef convOrSubConvId mlsMeta groupId epoch _suite (Ref ref) = do - p <- getProposal groupId epoch ref >>= noteS @'MLSProposalNotFound - checkEpoch epoch mlsMeta - checkGroup groupId mlsMeta - applyProposal convOrSubConvId groupId (rmValue p) -applyProposalRef convOrSubConvId _mlsMeta groupId _epoch suite (Inline p) = do - checkProposalCipherSuite suite p - applyProposal convOrSubConvId groupId p - -applyProposal :: - forall r. - HasProposalEffects r => - ConvOrSubConvId -> - GroupId -> - Proposal -> - Sem r ProposalAction -applyProposal convOrSubConvId groupId (AddProposal kp) = do - ref <- kpRef' kp & note (mlsProtocolError "Could not compute ref of a key package in an Add proposal") - mbClientIdentity <- getClientByKeyPackageRef ref - clientIdentity <- case mbClientIdentity of - Nothing -> do - -- external add proposal for a new key package unknown to the backend - lConvOrSubConvId <- qualifyLocal convOrSubConvId - addKeyPackageMapping lConvOrSubConvId ref (KeyPackageData (rmRaw kp)) - Just ci -> - -- ad-hoc add proposal in commit, the key package has been claimed before - pure ci - pure (paAddClient . (<$$>) (,ref) . cidQualifiedClient $ clientIdentity) - where - addKeyPackageMapping :: Local ConvOrSubConvId -> KeyPackageRef -> KeyPackageData -> Sem r ClientIdentity - addKeyPackageMapping lConvOrSubConvId ref kpdata = do - -- validate and update mapping in brig - eithCid <- - nkpresClientIdentity - <$$> validateAndAddKeyPackageRef - NewKeyPackage - { nkpConversation = tUntagged (convOfConvOrSub <$> lConvOrSubConvId), - nkpKeyPackage = kpdata - } - cid <- either (\errMsg -> throw (mlsProtocolError ("Tried to add invalid KeyPackage: " <> errMsg))) pure eithCid - let qcid = cidQualifiedClient cid - let qusr = fst <$> qcid - -- update mapping in galley - addMLSClients groupId qusr (Set.singleton (ciClient cid, ref)) - pure cid -applyProposal _convOrSubConvId _groupId (RemoveProposal ref) = do - qclient <- cidQualifiedClient <$> derefKeyPackage ref - pure (paRemoveClient ((,ref) <$$> qclient)) -applyProposal _convOrSubConvId _groupId (ExternalInitProposal _) = - -- only record the fact there was an external init proposal, but do not - -- process it in any way. - pure paExternalInitPresent -applyProposal _convOrSubConvId _groupId _ = pure mempty - -checkProposalCipherSuite :: - Member (Error MLSProtocolError) r => - CipherSuiteTag -> - Proposal -> - Sem r () -checkProposalCipherSuite suite (AddProposal kpRaw) = do - let kp = rmValue kpRaw - unless (kpCipherSuite kp == tagCipherSuite suite) - . throw - . mlsProtocolError - . T.pack - $ "The group's cipher suite " - <> show (cipherSuiteNumber (tagCipherSuite suite)) - <> " and the cipher suite of the proposal's key package " - <> show (cipherSuiteNumber (kpCipherSuite kp)) - <> " do not match." -checkProposalCipherSuite _suite _prop = pure () - -processProposal :: - HasProposalEffects r => - ( Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MLSStaleMessage) r - ) => - Qualified UserId -> - Local ConvOrSubConv -> - Message 'MLSPlainText -> - RawMLS Proposal -> - Sem r () -processProposal qusr lConvOrSub msg prop = do - let mlsMeta = mlsMetaConvOrSub (tUnqualified lConvOrSub) - checkEpoch (msgEpoch msg) mlsMeta - checkGroup (msgGroupId msg) mlsMeta - let suiteTag = cnvmlsCipherSuite mlsMeta - let cid = mcId . convOfConvOrSub . tUnqualified $ lConvOrSub - - -- validate the proposal - -- - -- is the user a member of the conversation? - loc <- qualifyLocal () - isMember' <- - foldQualified - loc - ( fmap isJust - . getLocalMember cid - . tUnqualified - ) - ( fmap isJust - . getRemoteMember cid - ) - qusr - unless isMember' $ throwS @'ConvNotFound - - -- FUTUREWORK: validate the member's conversation role - let propValue = rmValue prop - checkProposalCipherSuite suiteTag propValue - when (isExternalProposal msg) $ do - checkExternalProposalSignature suiteTag msg prop - checkExternalProposalUser qusr propValue - let propRef = proposalRef suiteTag prop - storeProposal (msgGroupId msg) (msgEpoch msg) propRef ProposalOriginClient prop - -checkExternalProposalSignature :: - Member (ErrorS 'MLSUnsupportedProposal) r => - CipherSuiteTag -> - Message 'MLSPlainText -> - RawMLS Proposal -> - Sem r () -checkExternalProposalSignature csTag msg prop = case rmValue prop of - AddProposal kp -> do - let pubKey = bcSignatureKey . kpCredential $ rmValue kp - unless (verifyMessageSignature csTag msg pubKey) $ throwS @'MLSUnsupportedProposal - _ -> pure () -- FUTUREWORK: check signature of other proposals as well - -isExternalProposal :: Message 'MLSPlainText -> Bool -isExternalProposal msg = case msgSender msg of - NewMemberSender -> True - PreconfiguredSender _ -> True - _ -> False - --- check owner/subject of the key package exists and belongs to the user -checkExternalProposalUser :: - ( Member BrigAccess r, - Member (ErrorS 'MLSUnsupportedProposal) r, - Member (Input (Local ())) r - ) => - Qualified UserId -> - Proposal -> - Sem r () -checkExternalProposalUser qusr prop = do - loc <- qualifyLocal () - foldQualified - loc - ( \lusr -> case prop of - AddProposal keyPackage -> do - ClientIdentity {ciUser, ciClient} <- - either - (const $ throwS @'MLSUnsupportedProposal) - pure - . kpIdentity - . rmValue - $ keyPackage - -- requesting user must match key package owner - when (tUnqualified lusr /= ciUser) $ throwS @'MLSUnsupportedProposal - -- client referenced in key package must be one of the user's clients - UserClients {userClients} <- lookupClients [ciUser] - maybe - (throwS @'MLSUnsupportedProposal) - (flip when (throwS @'MLSUnsupportedProposal) . Set.null . Set.filter (== ciClient)) - $ userClients Map.!? ciUser - _ -> throwS @'MLSUnsupportedProposal - ) - (const $ pure ()) -- FUTUREWORK: check external proposals from remote backends - qusr - -type HasProposalActionEffects r = - ( Member BrigAccess r, - Member ConversationStore r, - Member (Error InternalError) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'MLSClientMismatch) r, - Member (Error MLSProposalFailure) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'MLSUnsupportedProposal) r, - Member (Error MLSProtocolError) r, - Member (ErrorS 'MLSSelfRemovalNotAllowed) r, - Member ExternalAccess r, - Member FederatorAccess r, - Member GundeckAccess r, - Member (Input Env) r, - Member (Input Opts) r, - Member (Input UTCTime) r, - Member LegalHoldStore r, - Member MemberStore r, - Member ProposalStore r, - Member SubConversationStore r, - Member TeamStore r, - Member TinyLog r - ) - -executeProposalAction :: - forall r. - HasProposalActionEffects r => - Qualified UserId -> - Maybe ConnId -> - Local ConvOrSubConv -> - ProposalAction -> - Sem r [LocalConversationUpdate] -executeProposalAction qusr con lconvOrSub action = do - let convOrSub = tUnqualified lconvOrSub - mlsMeta = mlsMetaConvOrSub convOrSub - cm = membersConvOrSub convOrSub - ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) - newUserClients = Map.assocs (paAdd action) - - -- no client can be directly added to a subconversation - when (is _SubConv convOrSub && not (null newUserClients)) $ - throw (mlsProtocolError "Add proposals in subconversations are not supported") - - -- Note [client removal] - -- We support two types of removals: - -- 1. when a user is removed from a group, all their clients have to be removed - -- 2. when a client is deleted, that particular client (but not necessarily - -- other clients of the same user) has to be removed. - -- - -- Type 2 requires no special processing on the backend, so here we filter - -- out all removals of that type, so that further checks and processing can - -- be applied only to type 1 removals. - -- - -- Furthermore, subconversation clients can be removed arbitrarily, so this - -- processing is only necessary for main conversations. In the - -- subconversation case, an empty list is returned. - removedUsers <- case convOrSub of - SubConv _ _ -> pure [] - Conv _ -> mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ - \(qtarget, Map.keysSet -> clients) -> runError @() $ do - -- fetch clients from brig - clientInfo <- Set.map ciId <$> getClientInfo lconvOrSub qtarget ss - -- if the clients being removed don't exist, consider this as a removal of - -- type 2, and skip it - when (Set.null (clientInfo `Set.intersection` clients)) $ - throw () - pure (qtarget, clients) - - -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216 - foldQualified lconvOrSub (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr - - -- for each user, we compare their clients with the ones being added to the conversation - for_ newUserClients $ \(qtarget, newclients) -> case Map.lookup qtarget cm of - -- user is already present, skip check in this case - Just _ -> pure () - -- new user - Nothing -> do - -- final set of clients in the conversation - let clients = Map.keysSet (newclients <> Map.findWithDefault mempty qtarget cm) - -- get list of mls clients from brig - clientInfo <- getClientInfo lconvOrSub qtarget ss - let allClients = Set.map ciId clientInfo - let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) - -- We check the following condition: - -- allMLSClients ⊆ clients ⊆ allClients - -- i.e. - -- - if a client has at least 1 key package, it has to be added - -- - if a client is being added, it has to still exist - -- - -- The reason why we can't simply check that clients == allMLSClients is - -- that a client with no remaining key packages might be added by a user - -- who just fetched its last key package. - unless - ( Set.isSubsetOf allMLSClients clients - && Set.isSubsetOf clients allClients - ) - $ do - -- unless (Set.isSubsetOf allClients clients) $ do - -- FUTUREWORK: turn this error into a proper response - throwS @'MLSClientMismatch - - membersToRemove <- catMaybes <$> for removedUsers (uncurry (checkRemoval (is _SubConv convOrSub) cm)) - - -- add users to the conversation and send events - addEvents <- - foldMap (addMembers qusr con lconvOrSub) - . nonEmpty - . map fst - $ newUserClients - - -- add clients in the conversation state - for_ newUserClients $ \(qtarget, newClients) -> do - addMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.fromList (Map.assocs newClients)) - - -- remove users from the conversation and send events - removeEvents <- - foldMap - (removeMembers qusr con lconvOrSub) - (nonEmpty membersToRemove) - - -- Remove clients from the conversation state. This includes client removals - -- of all types (see Note [client removal]). - for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do - removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Map.keysSet clients) - - -- if this is a new subconversation, call `on-new-remote-conversation` on all - -- the remote backends involved in the main conversation - forOf_ _SubConv convOrSub $ \(mlsConv, subConv) -> do - when (cnvmlsEpoch (scMLSData subConv) == Epoch 0) $ do - let remoteDomains = - Set.fromList - ( map - (void . rmId) - (mcRemoteMembers mlsConv) - ) - let nrc = - NewRemoteSubConversation - { nrscConvId = mcId mlsConv, - nrscSubConvId = scSubConvId subConv, - nrscMlsData = scMLSData subConv - } - runFederatedConcurrently_ (toList remoteDomains) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-subconversation" nrc - - pure (addEvents <> removeEvents) - where - checkRemoval :: - Bool -> - ClientMap -> - Qualified UserId -> - Set ClientId -> - Sem r (Maybe (Qualified UserId)) - checkRemoval isSubConv cm qtarget clients = do - let clientsInConv = Map.keysSet (Map.findWithDefault mempty qtarget cm) - -- FUTUREWORK: add tests against this situation for conv v subconv - when (not isSubConv && clients /= clientsInConv) $ do - -- FUTUREWORK: turn this error into a proper response - throwS @'MLSClientMismatch - when (qusr == qtarget) $ - throwS @'MLSSelfRemovalNotAllowed - pure (Just qtarget) - -existingLocalMembers :: Local Data.Conversation -> Set (Qualified UserId) -existingLocalMembers lconv = - (Set.fromList . map (fmap lmId . tUntagged)) (traverse convLocalMembers lconv) - -existingRemoteMembers :: Local Data.Conversation -> Set (Qualified UserId) -existingRemoteMembers lconv = - Set.fromList . map (tUntagged . rmId) . convRemoteMembers . tUnqualified $ - lconv - -existingMembers :: Local Data.Conversation -> Set (Qualified UserId) -existingMembers lconv = existingLocalMembers lconv <> existingRemoteMembers lconv - -addMembers :: - HasProposalActionEffects r => - Qualified UserId -> - Maybe ConnId -> - Local ConvOrSubConv -> - NonEmpty (Qualified UserId) -> - Sem r [LocalConversationUpdate] -addMembers qusr con lconvOrSub users = case tUnqualified lconvOrSub of - Conv mlsConv -> do - let lconv = qualifyAs lconvOrSub (mcConv mlsConv) - -- FUTUREWORK: update key package ref mapping to reflect conversation membership - foldMap - ( handleNoChanges - . handleMLSProposalFailures @ProposalErrors - . fmap pure - . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con - . flip ConversationJoin roleNameWireMember - ) - . nonEmpty - . filter (flip Set.notMember (existingMembers lconv)) - . toList - $ users - SubConv _ _ -> pure [] - -removeMembers :: - HasProposalActionEffects r => - Qualified UserId -> - Maybe ConnId -> - Local ConvOrSubConv -> - NonEmpty (Qualified UserId) -> - Sem r [LocalConversationUpdate] -removeMembers qusr con lconvOrSub users = case tUnqualified lconvOrSub of - Conv mlsConv -> do - let lconv = qualifyAs lconvOrSub (mcConv mlsConv) - foldMap - ( handleNoChanges - . handleMLSProposalFailures @ProposalErrors - . fmap pure - . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con - ) - . nonEmpty - . filter (flip Set.member (existingMembers lconv)) - . toList - $ users - SubConv _ _ -> pure [] - -handleNoChanges :: Monoid a => Sem (Error NoChanges ': r) a -> Sem r a -handleNoChanges = fmap fold . runError - -getClientInfo :: - ( Member BrigAccess r, - Member FederatorAccess r - ) => - Local x -> - Qualified UserId -> - SignatureSchemeTag -> - Sem r (Set ClientInfo) -getClientInfo loc = foldQualified loc getLocalMLSClients getRemoteMLSClients - -getRemoteMLSClients :: - ( Member FederatorAccess r - ) => - Remote UserId -> - SignatureSchemeTag -> - Sem r (Set ClientInfo) -getRemoteMLSClients rusr ss = do - runFederated rusr $ - fedClient @'Brig @"get-mls-clients" $ - MLSClientsRequest - { mcrUserId = tUnqualified rusr, - mcrSignatureScheme = ss - } - --- | Check if the epoch number matches that of a conversation -checkEpoch :: - Member (ErrorS 'MLSStaleMessage) r => - Epoch -> - ConversationMLSData -> - Sem r () -checkEpoch epoch mlsMeta = do - unless (epoch == cnvmlsEpoch mlsMeta) $ throwS @'MLSStaleMessage - --- | Check if the group ID matches that of a conversation -checkGroup :: - Member (ErrorS 'ConvNotFound) r => - GroupId -> - ConversationMLSData -> - Sem r () -checkGroup gId mlsMeta = do - unless (gId == cnvmlsGroupId mlsMeta) $ throwS @'ConvNotFound - --------------------------------------------------------------------------------- --- Error handling of proposal execution - --- The following errors are caught by 'executeProposalAction' and wrapped in a --- 'MLSProposalFailure'. This way errors caused by the execution of proposals are --- separated from those caused by the commit processing itself. -type ProposalErrors = - '[ Error FederationError, - Error InvalidInput, - ErrorS ('ActionDenied 'AddConversationMember), - ErrorS ('ActionDenied 'LeaveConversation), - ErrorS ('ActionDenied 'RemoveConversationMember), - ErrorS 'ConvAccessDenied, - ErrorS 'InvalidOperation, - ErrorS 'NotATeamMember, - ErrorS 'NotConnected, - ErrorS 'TooManyMembers - ] - -class HandleMLSProposalFailures effs r where - handleMLSProposalFailures :: Sem (Append effs r) a -> Sem r a - -class HandleMLSProposalFailure eff r where - handleMLSProposalFailure :: Sem (eff ': r) a -> Sem r a - -instance HandleMLSProposalFailures '[] r where - handleMLSProposalFailures = id - -instance - ( HandleMLSProposalFailures effs r, - HandleMLSProposalFailure eff (Append effs r) - ) => - HandleMLSProposalFailures (eff ': effs) r - where - handleMLSProposalFailures = handleMLSProposalFailures @effs . handleMLSProposalFailure @eff - -instance - (APIError e, Member (Error MLSProposalFailure) r) => - HandleMLSProposalFailure (Error e) r - where - handleMLSProposalFailure = mapError (MLSProposalFailure . toWai) - -storeGroupInfoBundle :: +storeGroupInfo :: ( Member ConversationStore r, Member SubConversationStore r ) => ConvOrSubConvId -> - GroupInfoBundle -> + GroupInfoData -> Sem r () -storeGroupInfoBundle convOrSub bundle = do - let gs = toOpaquePublicGroupState (gipGroupState bundle) - case convOrSub of - Conv cid -> setPublicGroupState cid gs - SubConv cid subconvid -> setSubConversationPublicGroupState cid subconvid (Just gs) +storeGroupInfo convOrSub ginfo = case convOrSub of + Conv cid -> setGroupInfo cid ginfo + SubConv cid subconvid -> setSubConversationGroupInfo cid subconvid (Just ginfo) fetchConvOrSub :: forall r. @@ -1409,23 +429,3 @@ fetchConvOrSub qusr convOrSubId = for convOrSubId $ \case getLocalConvForUser u >=> mkMLSConversation >=> noteS @'ConvNotFound - -incrementEpoch :: - ( Member ConversationStore r, - Member (ErrorS 'ConvNotFound) r, - Member MemberStore r, - Member SubConversationStore r - ) => - ConvOrSubConv -> - Sem r ConvOrSubConv -incrementEpoch (Conv c) = do - let epoch' = succ (cnvmlsEpoch (mcMLSData c)) - setConversationEpoch (mcId c) epoch' - conv <- getConversation (mcId c) >>= noteS @'ConvNotFound - fmap Conv (mkMLSConversation conv >>= noteS @'ConvNotFound) -incrementEpoch (SubConv c s) = do - let epoch' = succ (cnvmlsEpoch (scMLSData s)) - setSubConversationEpoch (scParentConvId s) (scSubConvId s) epoch' - subconv <- - getSubConversation (mcId c) (scSubConvId s) >>= noteS @'ConvNotFound - pure (SubConv c subconv) diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 31a60d97eb..10d0dcedeb 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -44,6 +44,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.MLS.Message +import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.Message @@ -58,10 +59,10 @@ propagateMessage :: Qualified UserId -> Local ConvOrSubConv -> Maybe ConnId -> - ByteString -> + RawMLS Message -> ClientMap -> Sem r UnreachableUsers -propagateMessage qusr lConvOrSub con raw cm = do +propagateMessage qusr lConvOrSub con msg cm = do now <- input @UTCTime let mlsConv = convOfConvOrSub <$> lConvOrSub lmems = mcLocalMembers . tUnqualified $ mlsConv @@ -77,7 +78,7 @@ propagateMessage qusr lConvOrSub con raw cm = do SubConv c s -> (mcId c, Just (scSubConvId s)) qcnv = fst <$> qt sconv = snd (qUnqualified qt) - e = Event qcnv sconv qusr now $ EdMLSMessage raw + e = Event qcnv sconv qusr now $ EdMLSMessage msg.raw mkPush :: UserId -> ClientId -> MessagePush 'NormalMessage mkPush u c = newMessagePush mlsConv botMap con mm (u, c) e runMessagePush mlsConv (Just qcnv) $ @@ -95,7 +96,7 @@ propagateMessage qusr lConvOrSub con raw cm = do rmmMetadata = mm, rmmConversation = qUnqualified qcnv, rmmRecipients = rs >>= remoteMemberMLSClients, - rmmMessage = Base64ByteString raw + rmmMessage = Base64ByteString msg.raw } where localMemberMLSClients :: Local x -> LocalMember -> [(UserId, ClientId)] diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs new file mode 100644 index 0000000000..437e1cba42 --- /dev/null +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -0,0 +1,295 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.MLS.Proposal + ( -- * Proposal processing + derefOrCheckProposal, + checkProposal, + processProposal, + proposalProcessingStage, + addProposedClient, + applyProposals, + + -- * Proposal actions + paAddClient, + paRemoveClient, + + -- * Types + ProposalAction (..), + HasProposalEffects, + ) +where + +import Data.Id +import qualified Data.Map as Map +import Data.Qualified +import qualified Data.Set as Set +import Data.Time +import Galley.API.Error +import Galley.API.MLS.IncomingMessage +import Galley.API.MLS.Types +import Galley.API.Util +import Galley.Effects +import Galley.Effects.BrigAccess +import Galley.Effects.ProposalStore +import Galley.Env +import Galley.Options +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.State +import Polysemy.TinyLog +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation.Protocol +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.MLS.AuthenticatedContent +import Wire.API.MLS.Credential +import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode +import Wire.API.MLS.Message +import Wire.API.MLS.Proposal +import Wire.API.MLS.Serialisation +import Wire.API.MLS.Validation +import Wire.API.Message + +data ProposalAction = ProposalAction + { paAdd :: ClientMap, + paRemove :: ClientMap + } + deriving (Show) + +instance Semigroup ProposalAction where + ProposalAction add1 rem1 <> ProposalAction add2 rem2 = + ProposalAction + (Map.unionWith mappend add1 add2) + (Map.unionWith mappend rem1 rem2) + +instance Monoid ProposalAction where + mempty = ProposalAction mempty mempty + +paAddClient :: ClientIdentity -> LeafIndex -> ProposalAction +paAddClient cid idx = mempty {paAdd = cmSingleton cid idx} + +paRemoveClient :: ClientIdentity -> LeafIndex -> ProposalAction +paRemoveClient cid idx = mempty {paRemove = cmSingleton cid idx} + +-- | This is used to sort proposals into the correct processing order, as defined by the spec +data ProposalProcessingStage + = ProposalProcessingStageExtensions + | ProposalProcessingStageUpdate + | ProposalProcessingStageRemove + | ProposalProcessingStageAdd + | ProposalProcessingStagePreSharedKey + | ProposalProcessingStageExternalInit + | ProposalProcessingStageReInit + deriving (Eq, Ord) + +proposalProcessingStage :: Proposal -> ProposalProcessingStage +proposalProcessingStage (AddProposal _) = ProposalProcessingStageAdd +proposalProcessingStage (RemoveProposal _) = ProposalProcessingStageRemove +proposalProcessingStage (UpdateProposal _) = ProposalProcessingStageUpdate +proposalProcessingStage (PreSharedKeyProposal _) = ProposalProcessingStagePreSharedKey +proposalProcessingStage (ReInitProposal _) = ProposalProcessingStageReInit +proposalProcessingStage (ExternalInitProposal _) = ProposalProcessingStageExternalInit +proposalProcessingStage (GroupContextExtensionsProposal _) = ProposalProcessingStageExtensions + +type HasProposalEffects r = + ( Member BrigAccess r, + Member ConversationStore r, + Member (Error InternalError) r, + Member (Error MLSProposalFailure) r, + Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member (ErrorS 'MLSUnsupportedProposal) r, + Member ExternalAccess r, + Member FederatorAccess r, + Member GundeckAccess r, + Member (Input Env) r, + Member (Input (Local ())) r, + Member (Input Opts) r, + Member (Input UTCTime) r, + Member LegalHoldStore r, + Member MemberStore r, + Member ProposalStore r, + Member TeamStore r, + Member TeamStore r, + Member TinyLog r + ) + +derefOrCheckProposal :: + ( Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member ProposalStore r, + Member (State IndexMap) r, + Member (ErrorS 'MLSProposalNotFound) r + ) => + ConversationMLSData -> + GroupId -> + Epoch -> + ProposalOrRef -> + Sem r Proposal +derefOrCheckProposal _mlsMeta groupId epoch (Ref ref) = do + p <- getProposal groupId epoch ref >>= noteS @'MLSProposalNotFound + pure p.value +derefOrCheckProposal mlsMeta _ _ (Inline p) = do + im <- get + checkProposal mlsMeta im p + pure p + +checkProposal :: + ( Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r + ) => + ConversationMLSData -> + IndexMap -> + Proposal -> + Sem r () +checkProposal mlsMeta im p = + case p of + AddProposal kp -> do + (cs, _lifetime) <- + either + (\msg -> throw (mlsProtocolError ("Invalid key package in Add proposal: " <> msg))) + pure + $ validateKeyPackage Nothing kp.value + -- we are not checking lifetime constraints here + unless (mlsMeta.cnvmlsCipherSuite == cs) $ + throw (mlsProtocolError "Key package ciphersuite does not match conversation") + RemoveProposal idx -> do + void $ noteS @'MLSInvalidLeafNodeIndex $ imLookup im idx + _ -> pure () + +addProposedClient :: Member (State IndexMap) r => ClientIdentity -> Sem r ProposalAction +addProposedClient cid = do + im <- get + let (idx, im') = imAddClient im cid + put im' + pure (paAddClient cid idx) + +applyProposals :: + ( Member (State IndexMap) r, + Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSUnsupportedProposal) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r + ) => + ConversationMLSData -> + GroupId -> + [Proposal] -> + Sem r ProposalAction +applyProposals mlsMeta groupId = + -- proposals are sorted before processing + foldMap (applyProposal mlsMeta groupId) + . sortOn proposalProcessingStage + +applyProposal :: + ( Member (State IndexMap) r, + Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSUnsupportedProposal) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r + ) => + ConversationMLSData -> + GroupId -> + Proposal -> + Sem r ProposalAction +applyProposal mlsMeta _groupId (AddProposal kp) = do + (cs, _lifetime) <- + either + (\msg -> throw (mlsProtocolError ("Invalid key package in Add proposal: " <> msg))) + pure + $ validateKeyPackage Nothing kp.value + unless (mlsMeta.cnvmlsCipherSuite == cs) $ + throw (mlsProtocolError "Key package ciphersuite does not match conversation") + -- we are not checking lifetime constraints here + cid <- getKeyPackageIdentity kp.value + addProposedClient cid +applyProposal _mlsMeta _groupId (RemoveProposal idx) = do + im <- get + (cid, im') <- noteS @'MLSInvalidLeafNodeIndex $ imRemoveClient im idx + put im' + pure (paRemoveClient cid idx) +applyProposal _mlsMeta _groupId _ = pure mempty + +processProposal :: + HasProposalEffects r => + ( Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'MLSStaleMessage) r + ) => + Qualified UserId -> + Local ConvOrSubConv -> + GroupId -> + Epoch -> + IncomingPublicMessageContent -> + RawMLS Proposal -> + Sem r () +processProposal qusr lConvOrSub groupId epoch pub prop = do + let mlsMeta = mlsMetaConvOrSub (tUnqualified lConvOrSub) + -- Check if the epoch number matches that of a conversation + unless (epoch == cnvmlsEpoch mlsMeta) $ throwS @'MLSStaleMessage + -- Check if the group ID matches that of a conversation + unless (groupId == cnvmlsGroupId mlsMeta) $ throwS @'ConvNotFound + let suiteTag = cnvmlsCipherSuite mlsMeta + + -- FUTUREWORK: validate the member's conversation role + let im = indexMapConvOrSub $ tUnqualified lConvOrSub + checkProposal mlsMeta im prop.value + when (isExternal pub.sender) $ checkExternalProposalUser qusr prop.value + let propRef = authContentRef suiteTag (incomingMessageAuthenticatedContent pub) + storeProposal groupId epoch propRef ProposalOriginClient prop + +getKeyPackageIdentity :: + Member (ErrorS 'MLSUnsupportedProposal) r => + KeyPackage -> + Sem r ClientIdentity +getKeyPackageIdentity = + either (\_ -> throwS @'MLSUnsupportedProposal) pure + . keyPackageIdentity + +isExternal :: Sender -> Bool +isExternal (SenderMember _) = False +isExternal _ = True + +-- check owner/subject of the key package exists and belongs to the user +checkExternalProposalUser :: + ( Member BrigAccess r, + Member (ErrorS 'MLSUnsupportedProposal) r, + Member (Input (Local ())) r + ) => + Qualified UserId -> + Proposal -> + Sem r () +checkExternalProposalUser qusr prop = do + loc <- qualifyLocal () + foldQualified + loc + ( \lusr -> case prop of + AddProposal kp -> do + ClientIdentity {ciUser, ciClient} <- getKeyPackageIdentity kp.value + -- requesting user must match key package owner + when (tUnqualified lusr /= ciUser) $ throwS @'MLSUnsupportedProposal + -- client referenced in key package must be one of the user's clients + UserClients {userClients} <- lookupClients [ciUser] + maybe + (throwS @'MLSUnsupportedProposal) + (flip when (throwS @'MLSUnsupportedProposal) . Set.null . Set.filter (== ciClient)) + $ userClients Map.!? ciUser + _ -> throwS @'MLSUnsupportedProposal + ) + (const $ pure ()) -- FUTUREWORK: check external proposals from remote backends + qusr diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index 27d314ef68..f801bf06b5 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -22,6 +22,7 @@ module Galley.API.MLS.Removal ) where +import Data.Bifunctor import Data.Id import qualified Data.Map as Map import Data.Qualified @@ -32,9 +33,9 @@ import Galley.API.MLS.Propagate import Galley.API.MLS.Types import qualified Galley.Data.Conversation.Types as Data import Galley.Effects +import Galley.Effects.MemberStore import Galley.Effects.ProposalStore import Galley.Effects.SubConversationStore -import qualified Galley.Effects.SubConversationStore as E import Galley.Env import Imports import Polysemy @@ -42,8 +43,9 @@ import Polysemy.Input import Polysemy.TinyLog import qualified System.Logger as Log import Wire.API.Conversation.Protocol +import Wire.API.MLS.AuthenticatedContent import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation @@ -61,7 +63,7 @@ createAndSendRemoveProposals :: Foldable t ) => Local ConvOrSubConv -> - t KeyPackageRef -> + t LeafIndex -> Qualified UserId -> -- | The client map that has all the recipients of the message. This is an -- argument, and not constructed within the function, because of a special @@ -71,24 +73,31 @@ createAndSendRemoveProposals :: -- conversation/subconversation client maps. ClientMap -> Sem r () -createAndSendRemoveProposals lConvOrSubConv cs qusr cm = do +createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do let meta = mlsMetaConvOrSub (tUnqualified lConvOrSubConv) mKeyPair <- getMLSRemovalKey case mKeyPair of Nothing -> do warn $ Log.msg ("No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Not able to remove client from MLS conversation." :: Text) Just (secKey, pubKey) -> do - for_ cs $ \kpref -> do - let proposal = mkRemoveProposal kpref - msg = mkSignedMessage secKey pubKey (cnvmlsGroupId meta) (cnvmlsEpoch meta) (ProposalMessage proposal) - msgEncoded = encodeMLS' msg + for_ indices $ \idx -> do + let proposal = mkRawMLS (RemoveProposal idx) + pmsg = + mkSignedPublicMessage + secKey + pubKey + (cnvmlsGroupId meta) + (cnvmlsEpoch meta) + (TaggedSenderExternal 0) + (FramedContentProposal proposal) + msg = mkRawMLS (mkMessage (MessagePublic pmsg)) storeProposal (cnvmlsGroupId meta) (cnvmlsEpoch meta) - (proposalRef (cnvmlsCipherSuite meta) proposal) + (publicMessageRef (cnvmlsCipherSuite meta) pmsg) ProposalOriginBackend proposal - propagateMessage qusr lConvOrSubConv Nothing msgEncoded cm + propagateMessage qusr lConvOrSubConv Nothing msg cm removeClientsWithClientMapRecursively :: ( Members @@ -97,30 +106,41 @@ removeClientsWithClientMapRecursively :: ExternalAccess, FederatorAccess, GundeckAccess, + MemberStore, ProposalStore, SubConversationStore, Input Env ] r, + Functor f, Foldable f ) => Local MLSConversation -> - (ConvOrSubConv -> f KeyPackageRef) -> + (ConvOrSubConv -> f (ClientIdentity, LeafIndex)) -> + -- | Originating user. The resulting proposals will appear to be sent by this user. Qualified UserId -> Sem r () -removeClientsWithClientMapRecursively lMlsConv getKPs qusr = do +removeClientsWithClientMapRecursively lMlsConv getClients qusr = do let mainConv = fmap Conv lMlsConv cm = mcMembers (tUnqualified lMlsConv) - createAndSendRemoveProposals mainConv (getKPs (tUnqualified mainConv)) qusr cm + do + let gid = cnvmlsGroupId . mcMLSData . tUnqualified $ lMlsConv + clients = getClients (tUnqualified mainConv) + + planClientRemoval gid (fmap fst clients) + createAndSendRemoveProposals mainConv (fmap snd clients) qusr cm -- remove this client from all subconversations subs <- listSubConversations' (mcId (tUnqualified lMlsConv)) for_ subs $ \sub -> do let subConv = fmap (flip SubConv sub) lMlsConv + sgid = cnvmlsGroupId . scMLSData $ sub + clients = getClients (tUnqualified subConv) + planClientRemoval sgid (fmap fst clients) createAndSendRemoveProposals subConv - (getKPs (tUnqualified subConv)) + (fmap snd clients) qusr cm @@ -140,11 +160,12 @@ removeClient :: Qualified UserId -> ClientId -> Sem r () -removeClient lc qusr cid = do +removeClient lc qusr c = do mMlsConv <- mkMLSConversation (tUnqualified lc) for_ mMlsConv $ \mlsConv -> do - let getKPs = cmLookupRef (mkClientIdentity qusr cid) . membersConvOrSub - removeClientsWithClientMapRecursively (qualifyAs lc mlsConv) getKPs qusr + let cid = mkClientIdentity qusr c + let getClients = fmap (cid,) . cmLookupIndex cid . membersConvOrSub + removeClientsWithClientMapRecursively (qualifyAs lc mlsConv) getClients qusr -- | Send remove proposals for all clients of the user to the local conversation. removeUser :: @@ -164,8 +185,13 @@ removeUser :: removeUser lc qusr = do mMlsConv <- mkMLSConversation (tUnqualified lc) for_ mMlsConv $ \mlsConv -> do - let getKPs = Map.findWithDefault mempty qusr . membersConvOrSub - removeClientsWithClientMapRecursively (qualifyAs lc mlsConv) getKPs qusr + let getClients :: ConvOrSubConv -> [(ClientIdentity, LeafIndex)] + getClients = + map (first (mkClientIdentity qusr)) + . Map.assocs + . Map.findWithDefault mempty qusr + . membersConvOrSub + removeClientsWithClientMapRecursively (qualifyAs lc mlsConv) getClients qusr -- | Convert cassandra subconv maps into SubConversations listSubConversations' :: @@ -173,7 +199,7 @@ listSubConversations' :: ConvId -> Sem r [SubConversation] listSubConversations' cid = do - subs <- E.listSubConversations cid + subs <- listSubConversations cid msubs <- for (Map.assocs subs) $ \(subId, _) -> do getSubConversation cid subId pure (catMaybes msubs) diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index d22bad99d5..461836174d 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -35,7 +35,6 @@ import Control.Arrow import Data.Id import qualified Data.Map as Map import Data.Qualified -import qualified Data.Set as Set import Data.Time.Clock import Galley.API.MLS import Galley.API.MLS.Conversation @@ -69,7 +68,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.MLS.Credential -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation type MLSGetSubConvStaticErrors = @@ -142,7 +141,8 @@ getLocalSubConversation qusr lconv sconv = do cnvmlsEpochTimestamp = Nothing, cnvmlsCipherSuite = suite }, - scMembers = mkClientMap [] + scMembers = mkClientMap [], + scIndexMap = mempty } pure sub Just sub -> pure sub @@ -192,7 +192,7 @@ getSubConversationGroupInfo :: Local UserId -> Qualified ConvId -> SubConvId -> - Sem r OpaquePublicGroupState + Sem r GroupInfoData getSubConversationGroupInfo lusr qcnvId subconv = do assertMLSEnabled foldQualified @@ -212,10 +212,10 @@ getSubConversationGroupInfoFromLocalConv :: Qualified UserId -> SubConvId -> Local ConvId -> - Sem r OpaquePublicGroupState + Sem r GroupInfoData getSubConversationGroupInfoFromLocalConv qusr subConvId lcnvId = do void $ getLocalConvForUser qusr lcnvId - Eff.getSubConversationPublicGroupState (tUnqualified lcnvId) subConvId + Eff.getSubConversationGroupInfo (tUnqualified lcnvId) subConvId >>= noteS @'MLSMissingGroupInfo type MLSDeleteSubConvStaticErrors = @@ -279,9 +279,10 @@ deleteLocalSubConversation :: deleteLocalSubConversation qusr lcnvId scnvId dsc = do assertMLSEnabled let cnvId = tUnqualified lcnvId + lConvOrSubId = qualifyAs lcnvId (SubConv cnvId scnvId) cnv <- getConversationAndCheckMembership qusr lcnvId cs <- cnvmlsCipherSuite <$> noteS @'ConvNotFound (mlsMetadata cnv) - (mlsData, oldGid) <- withCommitLock (dscGroupId dsc) (dscEpoch dsc) $ do + (mlsData, oldGid) <- withCommitLock lConvOrSubId (dscGroupId dsc) (dscEpoch dsc) $ do sconv <- Eff.getSubConversation cnvId scnvId >>= noteS @'ConvNotFound @@ -423,12 +424,12 @@ leaveLocalSubConversation cid lcnv sub = do subConv <- noteS @'ConvNotFound =<< Eff.getSubConversation (tUnqualified lcnv) sub - kp <- + idx <- note (mlsProtocolError "Client is not a member of the subconversation") $ - cmLookupRef cid (scMembers subConv) - -- remove the leaver from the member list + cmLookupIndex cid (scMembers subConv) let (gid, epoch) = (cnvmlsGroupId &&& cnvmlsEpoch) (scMLSData subConv) - Eff.removeMLSClients gid (cidQualifiedUser cid) . Set.singleton . ciClient $ cid + -- plan to remove the leaver from the member list + Eff.planClientRemoval gid (Identity cid) let cm = cmRemoveClient cid (scMembers subConv) if Map.null cm then do @@ -440,7 +441,7 @@ leaveLocalSubConversation cid lcnv sub = do else createAndSendRemoveProposals (qualifyAs lcnv (SubConv mlsConv subConv)) - (Identity kp) + (Identity idx) (cidQualifiedUser cid) cm diff --git a/services/galley/src/Galley/API/MLS/Types.hs b/services/galley/src/Galley/API/MLS/Types.hs index 69f0f795a0..59cdbe327b 100644 --- a/services/galley/src/Galley/API/MLS/Types.hs +++ b/services/galley/src/Galley/API/MLS/Types.hs @@ -20,6 +20,8 @@ module Galley.API.MLS.Types where import Data.Domain import Data.Id +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Qualified import Galley.Types.Conversations.Members @@ -27,20 +29,64 @@ import Imports import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.SubConversation -type ClientMap = Map (Qualified UserId) (Map ClientId KeyPackageRef) +-- | A map of leaf index to members. +-- +-- This is used to reconstruct client +-- identities from leaf indices in remove proposals, as well as to allocate new +-- indices for added clients. +-- +-- Note that clients that are in the process of being removed from a group +-- (i.e. there is a pending remove proposals for them) are included in this +-- mapping. +newtype IndexMap = IndexMap {unIndexMap :: IntMap ClientIdentity} + deriving (Eq, Show) + deriving newtype (Semigroup, Monoid) + +mkIndexMap :: [(Domain, UserId, ClientId, Int32, Bool)] -> IndexMap +mkIndexMap = IndexMap . foldr addEntry mempty + where + addEntry (dom, usr, c, leafidx, _pending_removal) = + IntMap.insert (fromIntegral leafidx) (ClientIdentity dom usr c) + +imLookup :: IndexMap -> LeafIndex -> Maybe ClientIdentity +imLookup m i = IntMap.lookup (fromIntegral i) (unIndexMap m) + +imNextIndex :: IndexMap -> LeafIndex +imNextIndex im = + fromIntegral . fromJust $ + find (\n -> not $ IntMap.member n (unIndexMap im)) [0 ..] + +imAddClient :: IndexMap -> ClientIdentity -> (LeafIndex, IndexMap) +imAddClient im cid = let idx = imNextIndex im in (idx, IndexMap $ IntMap.insert (fromIntegral idx) cid $ unIndexMap im) -mkClientMap :: [(Domain, UserId, ClientId, KeyPackageRef)] -> ClientMap +imRemoveClient :: IndexMap -> LeafIndex -> Maybe (ClientIdentity, IndexMap) +imRemoveClient im idx = do + cid <- imLookup im idx + pure (cid, IndexMap . IntMap.delete (fromIntegral idx) $ unIndexMap im) + +-- | A two-level map of users to clients to leaf indices. +-- +-- This is used to keep track of the state of an MLS group for e.g. propagating +-- a message to all the clients that are supposed to receive it. +-- +-- Note that clients that are in the process of being removed from a group +-- (i.e. there is a pending remove proposals for them) are __not__ included in +-- this mapping. +type ClientMap = Map (Qualified UserId) (Map ClientId LeafIndex) + +mkClientMap :: [(Domain, UserId, ClientId, Int32, Bool)] -> ClientMap mkClientMap = foldr addEntry mempty where - addEntry :: (Domain, UserId, ClientId, KeyPackageRef) -> ClientMap -> ClientMap - addEntry (dom, usr, c, kpr) = - Map.insertWith (<>) (Qualified usr dom) (Map.singleton c kpr) + addEntry :: (Domain, UserId, ClientId, Int32, Bool) -> ClientMap -> ClientMap + addEntry (dom, usr, c, leafidx, pending_removal) + | pending_removal = id -- treat as removed, don't add to ClientMap + | otherwise = Map.insertWith (<>) (Qualified usr dom) (Map.singleton c (fromIntegral leafidx)) -cmLookupRef :: ClientIdentity -> ClientMap -> Maybe KeyPackageRef -cmLookupRef cid cm = do +cmLookupIndex :: ClientIdentity -> ClientMap -> Maybe LeafIndex +cmLookupIndex cid cm = do clients <- Map.lookup (cidQualifiedUser cid) cm Map.lookup (ciClient cid) clients @@ -54,13 +100,22 @@ cmRemoveClient cid cm = case Map.lookup (cidQualifiedUser cid) cm of else Map.insert (cidQualifiedUser cid) clients' cm isClientMember :: ClientIdentity -> ClientMap -> Bool -isClientMember ci = isJust . cmLookupRef ci +isClientMember ci = isJust . cmLookupIndex ci -cmAssocs :: ClientMap -> [(Qualified UserId, (ClientId, KeyPackageRef))] +cmAssocs :: ClientMap -> [(ClientIdentity, LeafIndex)] cmAssocs cm = do (quid, clients) <- Map.assocs cm - (clientId, ref) <- Map.assocs clients - pure (quid, (clientId, ref)) + (clientId, idx) <- Map.assocs clients + pure (mkClientIdentity quid clientId, idx) + +cmIdentities :: ClientMap -> [ClientIdentity] +cmIdentities = map fst . cmAssocs + +cmSingleton :: ClientIdentity -> LeafIndex -> ClientMap +cmSingleton cid idx = + Map.singleton + (cidQualifiedUser cid) + (Map.singleton (ciClient cid) idx) -- | Inform a handler for 'POST /conversations/list-ids' if the MLS global team -- conversation and the MLS self-conversation should be included in the @@ -74,7 +129,8 @@ data MLSConversation = MLSConversation mcMLSData :: ConversationMLSData, mcLocalMembers :: [LocalMember], mcRemoteMembers :: [RemoteMember], - mcMembers :: ClientMap + mcMembers :: ClientMap, + mcIndexMap :: IndexMap } deriving (Show) @@ -82,13 +138,14 @@ data SubConversation = SubConversation { scParentConvId :: ConvId, scSubConvId :: SubConvId, scMLSData :: ConversationMLSData, - scMembers :: ClientMap + scMembers :: ClientMap, + scIndexMap :: IndexMap } deriving (Eq, Show) toPublicSubConv :: Qualified SubConversation -> PublicSubConversation toPublicSubConv (Qualified (SubConversation {..}) domain) = - let members = fmap (\(quid, (cid, _kp)) -> mkClientIdentity quid cid) (cmAssocs scMembers) + let members = map fst (cmAssocs scMembers) in PublicSubConversation { pscParentConvId = Qualified scParentConvId domain, pscSubConvId = scSubConvId, @@ -109,6 +166,10 @@ membersConvOrSub :: ConvOrSubConv -> ClientMap membersConvOrSub (Conv c) = mcMembers c membersConvOrSub (SubConv _ s) = scMembers s +indexMapConvOrSub :: ConvOrSubConv -> IndexMap +indexMapConvOrSub (Conv c) = mcIndexMap c +indexMapConvOrSub (SubConv _ s) = scIndexMap s + convOfConvOrSub :: ConvOrSubChoice c s -> c convOfConvOrSub (Conv c) = c convOfConvOrSub (SubConv c _) = c diff --git a/services/galley/src/Galley/API/MLS/Util.hs b/services/galley/src/Galley/API/MLS/Util.hs index 61d2445bf5..7091a4989c 100644 --- a/services/galley/src/Galley/API/MLS/Util.hs +++ b/services/galley/src/Galley/API/MLS/Util.hs @@ -27,6 +27,7 @@ import Galley.Effects import Galley.Effects.ConversationStore import Galley.Effects.MemberStore import Galley.Effects.ProposalStore +import Galley.Effects.SubConversationStore import Imports import Polysemy import Polysemy.Resource (Resource, bracket) @@ -37,9 +38,10 @@ import Wire.API.Error import Wire.API.Error.Galley import Wire.API.MLS.Epoch import Wire.API.MLS.Group -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation getLocalConvForUser :: ( Member (ErrorS 'ConvNotFound) r, @@ -72,15 +74,15 @@ getPendingBackendRemoveProposals :: ) => GroupId -> Epoch -> - Sem r [KeyPackageRef] + Sem r [LeafIndex] getPendingBackendRemoveProposals gid epoch = do proposals <- getAllPendingProposals gid epoch catMaybes <$> for proposals ( \case - (Just ProposalOriginBackend, proposal) -> case rmValue proposal of - RemoveProposal kp -> pure . Just $ kp + (Just ProposalOriginBackend, proposal) -> case value proposal of + RemoveProposal i -> pure (Just i) _ -> pure Nothing (Just ProposalOriginClient, _) -> pure Nothing (Nothing, _) -> do @@ -93,15 +95,17 @@ withCommitLock :: ( Members '[ Resource, ConversationStore, - ErrorS 'MLSStaleMessage + ErrorS 'MLSStaleMessage, + SubConversationStore ] r ) => + Local ConvOrSubConvId -> GroupId -> Epoch -> Sem r a -> Sem r a -withCommitLock gid epoch action = +withCommitLock lConvOrSubId gid epoch action = bracket ( acquireCommitLock gid epoch ttl >>= \lockAcquired -> when (lockAcquired == NotAcquired) $ @@ -109,7 +113,11 @@ withCommitLock gid epoch action = ) (const $ releaseCommitLock gid epoch) $ \_ -> do - -- FUTUREWORK: fetch epoch again and check that is matches + actualEpoch <- + fromMaybe (Epoch 0) <$> case tUnqualified lConvOrSubId of + Conv cnv -> getConversationEpoch cnv + SubConv cnv sub -> getSubConversationEpoch cnv sub + unless (actualEpoch == epoch) $ throwS @'MLSStaleMessage action where ttl = fromIntegral (600 :: Int) -- 10 minutes diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/services/galley/src/Galley/API/MLS/Welcome.hs index 936855d15a..213ad9a865 100644 --- a/services/galley/src/Galley/API/MLS/Welcome.hs +++ b/services/galley/src/Galley/API/MLS/Welcome.hs @@ -16,26 +16,20 @@ -- with this program. If not, see . module Galley.API.MLS.Welcome - ( postMLSWelcome, - postMLSWelcomeFromLocalUser, + ( sendWelcomes, sendLocalWelcomes, ) where -import Control.Comonad import Data.Domain import Data.Id import Data.Json.Util import Data.Qualified import Data.Time -import Galley.API.MLS.Enabled -import Galley.API.MLS.KeyPackage import Galley.API.Push import Galley.Data.Conversation -import Galley.Effects.BrigAccess import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess -import Galley.Env import Imports import qualified Network.Wai.Utilities.Error as Wai import Network.Wai.Utilities.Server @@ -50,69 +44,37 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.MLS.Credential +import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.Welcome import Wire.API.Message -postMLSWelcome :: - ( Member BrigAccess r, - Member FederatorAccess r, +sendWelcomes :: + ( Member FederatorAccess r, Member GundeckAccess r, - Member (ErrorS 'MLSKeyPackageRefNotFound) r, - Member (Input UTCTime) r, - Member P.TinyLog r + Member P.TinyLog r, + Member (Input UTCTime) r ) => Local x -> Maybe ConnId -> + [ClientIdentity] -> RawMLS Welcome -> Sem r () -postMLSWelcome loc con wel = do +sendWelcomes loc con cids welcome = do now <- input - rcpts <- welcomeRecipients (rmValue wel) - let (locals, remotes) = partitionQualified loc rcpts - sendLocalWelcomes con now (rmRaw wel) (qualifyAs loc locals) - sendRemoteWelcomes (rmRaw wel) remotes - -postMLSWelcomeFromLocalUser :: - ( Member BrigAccess r, - Member FederatorAccess r, - Member GundeckAccess r, - Member (ErrorS 'MLSKeyPackageRefNotFound) r, - Member (ErrorS 'MLSNotEnabled) r, - Member (Input UTCTime) r, - Member (Input Env) r, - Member P.TinyLog r - ) => - Local x -> - ConnId -> - RawMLS Welcome -> - Sem r () -postMLSWelcomeFromLocalUser loc con wel = do - assertMLSEnabled - postMLSWelcome loc (Just con) wel - -welcomeRecipients :: - ( Member BrigAccess r, - Member (ErrorS 'MLSKeyPackageRefNotFound) r - ) => - Welcome -> - Sem r [Qualified (UserId, ClientId)] -welcomeRecipients = - traverse - ( fmap cidQualifiedClient - . derefKeyPackage - . gsNewMember - ) - . welSecrets + let (locals, remotes) = partitionQualified loc (map cidQualifiedClient cids) + let msg = mkRawMLS $ mkMessage (MessageWelcome welcome) + sendLocalWelcomes con now msg (qualifyAs loc locals) + sendRemoteWelcomes msg remotes sendLocalWelcomes :: Member GundeckAccess r => Maybe ConnId -> UTCTime -> - ByteString -> + RawMLS Message -> Local [(UserId, ClientId)] -> Sem r () -sendLocalWelcomes con now rawWelcome lclients = do +sendLocalWelcomes con now welcome lclients = do runMessagePush lclients Nothing $ foldMap (uncurry mkPush) (tUnqualified lclients) where @@ -121,21 +83,24 @@ sendLocalWelcomes con now rawWelcome lclients = do -- FUTUREWORK: use the conversation ID stored in the key package mapping table let lcnv = qualifyAs lclients (selfConv u) lusr = qualifyAs lclients u - e = Event (tUntagged lcnv) Nothing (tUntagged lusr) now $ EdMLSWelcome rawWelcome + e = Event (tUntagged lcnv) Nothing (tUntagged lusr) now $ EdMLSWelcome welcome.raw in newMessagePush lclients mempty con defMessageMetadata (u, c) e sendRemoteWelcomes :: ( Member FederatorAccess r, Member P.TinyLog r ) => - ByteString -> + RawMLS Message -> [Remote (UserId, ClientId)] -> Sem r () -sendRemoteWelcomes rawWelcome clients = do - let req = MLSWelcomeRequest . Base64ByteString $ rawWelcome - rpc = fedClient @'Galley @"mls-welcome" req - traverse_ handleError <=< runFederatedConcurrentlyEither clients $ - const rpc +sendRemoteWelcomes welcome clients = do + let msg = Base64ByteString welcome.raw + traverse_ handleError <=< runFederatedConcurrentlyEither clients $ \rcpts -> + fedClient @'Galley @"mls-welcome" + MLSWelcomeRequest + { welcomeMessage = msg, + recipients = tUnqualified rcpts + } where handleError :: Member P.TinyLog r => diff --git a/services/galley/src/Galley/API/Public/MLS.hs b/services/galley/src/Galley/API/Public/MLS.hs index 73187b06da..7de0a232ac 100644 --- a/services/galley/src/Galley/API/Public/MLS.hs +++ b/services/galley/src/Galley/API/Public/MLS.hs @@ -25,8 +25,6 @@ import Wire.API.Routes.Public.Galley.MLS mlsAPI :: API MLSAPI GalleyEffects mlsAPI = - mkNamedAPI @"mls-welcome-message" (callsFed (exposeAnnotations postMLSWelcomeFromLocalUser)) - <@> mkNamedAPI @"mls-message-v1" (callsFed (exposeAnnotations postMLSMessageFromLocalUserV1)) - <@> mkNamedAPI @"mls-message" (callsFed (exposeAnnotations postMLSMessageFromLocalUser)) + mkNamedAPI @"mls-message" (callsFed (exposeAnnotations postMLSMessageFromLocalUser)) <@> mkNamedAPI @"mls-commit-bundle" (callsFed (exposeAnnotations postMLSCommitBundleFromLocalUser)) <@> mkNamedAPI @"mls-public-keys" getMLSPublicKeys diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 45c36abf16..39297cf6b2 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -86,7 +86,6 @@ import Data.Time import Galley.API.Action import Galley.API.Error import Galley.API.Federation (onConversationUpdated) -import Galley.API.MLS.KeyPackage (nullKeyPackageRef) import Galley.API.Mapping import Galley.API.Message import qualified Galley.API.Query as Query @@ -135,7 +134,6 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.MLS.CipherSuite -import Wire.API.MLS.Group import Wire.API.Message import Wire.API.Password (mkSafePassword) import Wire.API.Provider.Service (ServiceRef) @@ -690,19 +688,17 @@ updateConversationProtocolWithLocalUser :: Member (ErrorS 'ConvInvalidProtocolTransition) r, Member (ErrorS 'ConvMemberNotFound) r, Member (Error FederationError) r, - Member MemberStore r, Member ConversationStore r ) => Local UserId -> - ClientId -> ConnId -> Qualified ConvId -> ProtocolUpdate -> Sem r () -updateConversationProtocolWithLocalUser lusr client conn qcnv update = +updateConversationProtocolWithLocalUser lusr _conn qcnv update = foldQualified lusr - (\lcnv -> updateLocalConversationProtocol (tUntagged lusr) client (Just conn) lcnv update) + (\lcnv -> updateLocalConversationProtocol (tUntagged lusr) lcnv update) (\_rcnv -> throw FederationNotImplemented) qcnv @@ -711,22 +707,18 @@ updateLocalConversationProtocol :: ( Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvInvalidProtocolTransition) r, Member (ErrorS 'ConvMemberNotFound) r, - Member MemberStore r, Member ConversationStore r ) => Qualified UserId -> - ClientId -> - Maybe ConnId -> Local ConvId -> ProtocolUpdate -> Sem r () -updateLocalConversationProtocol qusr client _mconn lcnv (ProtocolUpdate newProtocol) = do +updateLocalConversationProtocol qusr lcnv (ProtocolUpdate newProtocol) = do conv <- E.getConversation (tUnqualified lcnv) >>= noteS @'ConvNotFound void $ ensureOtherMember lcnv qusr conv case (protocolTag (convProtocol conv), newProtocol) of - (ProtocolProteusTag, ProtocolMixedTag) -> do + (ProtocolProteusTag, ProtocolMixedTag) -> E.updateToMixedProtocol lcnv MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 - E.addMLSClients (convToGroupId lcnv) qusr (Set.singleton (client, nullKeyPackageRef)) (ProtocolProteusTag, ProtocolProteusTag) -> pure () (ProtocolMixedTag, ProtocolMixedTag) -> diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 520cd3ea9c..98000e9523 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -58,7 +58,7 @@ import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation createMLSSelfConversation :: @@ -199,16 +199,15 @@ conversationMeta conv = accessRoles = maybeRole t $ parseAccessRoles r mbAccessRolesV2 pure $ ConversationMetadata t c (defAccess t a) accessRoles n i mt rm -getPublicGroupState :: ConvId -> Client (Maybe OpaquePublicGroupState) -getPublicGroupState cid = do - fmap join $ - runIdentity - <$$> retry - x1 - ( query1 - Cql.selectPublicGroupState - (params LocalQuorum (Identity cid)) - ) +getGroupInfo :: ConvId -> Client (Maybe GroupInfoData) +getGroupInfo cid = do + runIdentity + <$$> retry + x1 + ( query1 + Cql.selectGroupInfo + (params LocalQuorum (Identity cid)) + ) isConvAlive :: ConvId -> Client Bool isConvAlive cid = do @@ -238,12 +237,19 @@ updateConvReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMo updateConvMessageTimer :: ConvId -> Maybe Milliseconds -> Client () updateConvMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params LocalQuorum (mtimer, cid)) +getConvEpoch :: ConvId -> Client (Maybe Epoch) +getConvEpoch cid = + (runIdentity =<<) + <$> retry + x1 + (query1 Cql.getConvEpoch (params LocalQuorum (Identity cid))) + updateConvEpoch :: ConvId -> Epoch -> Client () updateConvEpoch cid epoch = retry x5 $ write Cql.updateConvEpoch (params LocalQuorum (epoch, cid)) -setPublicGroupState :: ConvId -> OpaquePublicGroupState -> Client () -setPublicGroupState conv gib = - write Cql.updatePublicGroupState (params LocalQuorum (gib, conv)) +setGroupInfo :: ConvId -> GroupInfoData -> Client () +setGroupInfo conv gid = + write Cql.updateGroupInfo (params LocalQuorum (gid, conv)) getConversation :: ConvId -> Client (Maybe Conversation) getConversation conv = do @@ -460,10 +466,11 @@ interpretConversationStoreToCassandra = interpret $ \case CreateConversation loc nc -> embedClient $ createConversation loc nc CreateMLSSelfConversation lusr -> embedClient $ createMLSSelfConversation lusr GetConversation cid -> embedClient $ getConversation cid + GetConversationEpoch cid -> embedClient $ getConvEpoch cid LookupConvByGroupId gId -> embedClient $ lookupConvByGroupId gId GetConversations cids -> localConversations cids GetConversationMetadata cid -> embedClient $ conversationMeta cid - GetPublicGroupState cid -> embedClient $ getPublicGroupState cid + GetGroupInfo cid -> embedClient $ getGroupInfo cid IsConversationAlive cid -> embedClient $ isConvAlive cid SelectConversations uid cids -> embedClient $ localConversationIdsOf uid cids GetRemoteConversationStatus uid cids -> embedClient $ remoteConversationStatus uid cids @@ -476,7 +483,7 @@ interpretConversationStoreToCassandra = interpret $ \case DeleteConversation cid -> embedClient $ deleteConversation cid SetGroupIdForConversation gId cid -> embedClient $ setGroupIdForConversation gId cid DeleteGroupIdForConversation gId -> embedClient $ deleteGroupIdForConversation gId - SetPublicGroupState cid gib -> embedClient $ setPublicGroupState cid gib + SetGroupInfo cid gib -> embedClient $ setGroupInfo cid gib AcquireCommitLock gId epoch ttl -> embedClient $ acquireCommitLock gId epoch ttl ReleaseCommitLock gId epoch -> embedClient $ releaseCommitLock gId epoch DeleteGroupIds gIds -> deleteGroupIds gIds diff --git a/services/galley/src/Galley/Cassandra/Conversation/MLS.hs b/services/galley/src/Galley/Cassandra/Conversation/MLS.hs index 7ca5f89d35..06e2e65d91 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/MLS.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/MLS.hs @@ -19,11 +19,13 @@ module Galley.Cassandra.Conversation.MLS ( acquireCommitLock, releaseCommitLock, lookupMLSClients, + lookupMLSClientLeafIndices, ) where import Cassandra import Cassandra.Settings (fromRow) +import Control.Arrow import Data.Time import Galley.API.MLS.Types import qualified Galley.Cassandra.Queries as Cql @@ -61,9 +63,10 @@ checkTransSuccess :: [Row] -> Bool checkTransSuccess [] = False checkTransSuccess (row : _) = either (const False) (fromMaybe False) $ fromRow 0 row +lookupMLSClientLeafIndices :: GroupId -> Client (ClientMap, IndexMap) +lookupMLSClientLeafIndices groupId = do + entries <- retry x5 (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) + pure $ (mkClientMap &&& mkIndexMap) entries + lookupMLSClients :: GroupId -> Client ClientMap -lookupMLSClients groupId = - mkClientMap - <$> retry - x5 - (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) +lookupMLSClients = fmap fst . lookupMLSClientLeafIndices diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 7665edb26e..da67f5e52f 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -32,7 +32,7 @@ import qualified Data.List.Extra as List import Data.Monoid import Data.Qualified import qualified Data.Set as Set -import Galley.Cassandra.Conversation.MLS (lookupMLSClients) +import Galley.Cassandra.Conversation.MLS import Galley.Cassandra.Instances () import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Services @@ -47,8 +47,9 @@ import Polysemy.Input import qualified UnliftIO import Wire.API.Conversation.Member hiding (Member) import Wire.API.Conversation.Role +import Wire.API.MLS.Credential import Wire.API.MLS.Group -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode (LeafIndex) import Wire.API.Provider.Service -- | Add members to a local conversation. @@ -342,12 +343,22 @@ removeLocalMembersFromRemoteConv (tUntagged -> Qualified conv convDomain) victim setConsistency LocalQuorum for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) -addMLSClients :: GroupId -> Qualified UserId -> Set.Set (ClientId, KeyPackageRef) -> Client () +addMLSClients :: GroupId -> Qualified UserId -> Set.Set (ClientId, LeafIndex) -> Client () addMLSClients groupId (Qualified usr domain) cs = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - for_ cs $ \(c, kpr) -> - addPrepQuery Cql.addMLSClient (groupId, domain, usr, c, kpr) + for_ cs $ \(c, idx) -> + addPrepQuery Cql.addMLSClient (groupId, domain, usr, c, fromIntegral idx) + +planMLSClientRemoval :: Foldable f => GroupId -> f ClientIdentity -> Client () +planMLSClientRemoval groupId cids = + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ cids $ \cid -> do + addPrepQuery + Cql.planMLSClientRemoval + (groupId, ciDomain cid, ciUser cid, ciClient cid) removeMLSClients :: GroupId -> Qualified UserId -> Set.Set ClientId -> Client () removeMLSClients groupId (Qualified usr domain) cs = retry x5 . batch $ do @@ -385,6 +396,8 @@ interpretMemberStoreToCassandra = interpret $ \case embedClient $ removeLocalMembersFromRemoteConv rcnv uids AddMLSClients lcnv quid cs -> embedClient $ addMLSClients lcnv quid cs + PlanClientRemoval lcnv cids -> embedClient $ planMLSClientRemoval lcnv cids RemoveMLSClients lcnv quid cs -> embedClient $ removeMLSClients lcnv quid cs RemoveAllMLSClients gid -> embedClient $ removeAllMLSClients gid LookupMLSClients lcnv -> embedClient $ lookupMLSClients lcnv + LookupMLSClientLeafIndices lcnv -> embedClient $ lookupMLSClientLeafIndices lcnv diff --git a/services/galley/src/Galley/Cassandra/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs index 4610857013..eaeaa87505 100644 --- a/services/galley/src/Galley/Cassandra/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -37,8 +37,8 @@ import Wire.API.Asset (AssetKey, assetKeyToText) import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite +import Wire.API.MLS.GroupInfo import Wire.API.MLS.Proposal -import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.Routes.Internal.Galley.TeamsIntra @@ -201,12 +201,12 @@ instance Cql GroupId where fromCql (CqlBlob b) = Right . GroupId . LBS.toStrict $ b fromCql _ = Left "group_id: blob expected" -instance Cql OpaquePublicGroupState where +instance Cql GroupInfoData where ctype = Tagged BlobColumn - toCql = CqlBlob . LBS.fromStrict . unOpaquePublicGroupState - fromCql (CqlBlob b) = Right $ OpaquePublicGroupState (LBS.toStrict b) - fromCql _ = Left "OpaquePublicGroupState: blob expected" + toCql = CqlBlob . LBS.fromStrict . unGroupInfoData + fromCql (CqlBlob b) = Right $ GroupInfoData (LBS.toStrict b) + fromCql _ = Left "GroupInfoData: blob expected" instance Cql Icon where ctype = Tagged TextColumn @@ -244,7 +244,7 @@ instance Cql ProposalRef where instance Cql (RawMLS Proposal) where ctype = Tagged BlobColumn - toCql = CqlBlob . LBS.fromStrict . rmRaw + toCql = CqlBlob . LBS.fromStrict . raw fromCql (CqlBlob b) = mapLeft T.unpack $ decodeMLS b fromCql _ = Left "Proposal: blob expected" diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index c838ddd00f..7e491df366 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -34,8 +34,7 @@ import Wire.API.Conversation.Code import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.MLS.CipherSuite -import Wire.API.MLS.KeyPackage -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation import Wire.API.Password (Password) import Wire.API.Provider @@ -276,6 +275,9 @@ updateConvName = "update conversation set name = ? where conv = ?" updateConvType :: PrepQuery W (ConvType, ConvId) () updateConvType = "update conversation set type = ? where conv = ?" +getConvEpoch :: PrepQuery R (Identity ConvId) (Identity (Maybe Epoch)) +getConvEpoch = "select epoch from conversation where conv = ?" + updateConvEpoch :: PrepQuery W (Epoch, ConvId) () updateConvEpoch = "update conversation set epoch = ? where conv = ?" @@ -285,11 +287,11 @@ deleteConv = "delete from conversation using timestamp 32503680000000000 where c markConvDeleted :: PrepQuery W (Identity ConvId) () markConvDeleted = "update conversation set deleted = true where conv = ?" -selectPublicGroupState :: PrepQuery R (Identity ConvId) (Identity (Maybe OpaquePublicGroupState)) -selectPublicGroupState = "select public_group_state from conversation where conv = ?" +selectGroupInfo :: PrepQuery R (Identity ConvId) (Identity GroupInfoData) +selectGroupInfo = "select public_group_state from conversation where conv = ?" -updatePublicGroupState :: PrepQuery W (OpaquePublicGroupState, ConvId) () -updatePublicGroupState = "update conversation set public_group_state = ? where conv = ?" +updateGroupInfo :: PrepQuery W (GroupInfoData, ConvId) () +updateGroupInfo = "update conversation set public_group_state = ? where conv = ?" -- Conversations accessible by code ----------------------------------------- @@ -332,14 +334,17 @@ lookupGroupId = "SELECT conv_id, domain, subconv_id from group_id_conv_id where selectSubConversation :: PrepQuery R (ConvId, SubConvId) (CipherSuiteTag, Epoch, Writetime Epoch, GroupId) selectSubConversation = "SELECT cipher_suite, epoch, WRITETIME(epoch), group_id FROM subconversation WHERE conv_id = ? and subconv_id = ?" -insertSubConversation :: PrepQuery W (ConvId, SubConvId, CipherSuiteTag, Epoch, GroupId, Maybe OpaquePublicGroupState) () +insertSubConversation :: PrepQuery W (ConvId, SubConvId, CipherSuiteTag, Epoch, GroupId, Maybe GroupInfoData) () insertSubConversation = "INSERT INTO subconversation (conv_id, subconv_id, cipher_suite, epoch, group_id, public_group_state) VALUES (?, ?, ?, ?, ?, ?)" -updateSubConvPublicGroupState :: PrepQuery W (ConvId, SubConvId, Maybe OpaquePublicGroupState) () -updateSubConvPublicGroupState = "INSERT INTO subconversation (conv_id, subconv_id, public_group_state) VALUES (?, ?, ?)" +updateSubConvGroupInfo :: PrepQuery W (ConvId, SubConvId, Maybe GroupInfoData) () +updateSubConvGroupInfo = "INSERT INTO subconversation (conv_id, subconv_id, public_group_state) VALUES (?, ?, ?)" + +selectSubConvGroupInfo :: PrepQuery R (ConvId, SubConvId) (Identity (Maybe GroupInfoData)) +selectSubConvGroupInfo = "SELECT public_group_state FROM subconversation WHERE conv_id = ? AND subconv_id = ?" -selectSubConvPublicGroupState :: PrepQuery R (ConvId, SubConvId) (Identity (Maybe OpaquePublicGroupState)) -selectSubConvPublicGroupState = "SELECT public_group_state FROM subconversation WHERE conv_id = ? AND subconv_id = ?" +selectSubConvEpoch :: PrepQuery R (ConvId, SubConvId) (Identity (Maybe Epoch)) +selectSubConvEpoch = "SELECT epoch FROM subconversation WHERE conv_id = ? AND subconv_id = ?" deleteGroupId :: PrepQuery W (Identity GroupId) () deleteGroupId = "DELETE FROM group_id_conv_id WHERE group_id = ?" @@ -462,8 +467,11 @@ rmMemberClient c = -- MLS Clients -------------------------------------------------------------- -addMLSClient :: PrepQuery W (GroupId, Domain, UserId, ClientId, KeyPackageRef) () -addMLSClient = "insert into mls_group_member_client (group_id, user_domain, user, client, key_package_ref) values (?, ?, ?, ?, ?)" +addMLSClient :: PrepQuery W (GroupId, Domain, UserId, ClientId, Int32) () +addMLSClient = "insert into mls_group_member_client (group_id, user_domain, user, client, leaf_node_index, removal_pending) values (?, ?, ?, ?, ?, false)" + +planMLSClientRemoval :: PrepQuery W (GroupId, Domain, UserId, ClientId) () +planMLSClientRemoval = "update mls_group_member_client set removal_pending = true where group_id = ? and user_domain = ? and user = ? and client = ?" removeMLSClient :: PrepQuery W (GroupId, Domain, UserId, ClientId) () removeMLSClient = "delete from mls_group_member_client where group_id = ? and user_domain = ? and user = ? and client = ?" @@ -471,8 +479,8 @@ removeMLSClient = "delete from mls_group_member_client where group_id = ? and us removeAllMLSClients :: PrepQuery W (Identity GroupId) () removeAllMLSClients = "DELETE FROM mls_group_member_client WHERE group_id = ?" -lookupMLSClients :: PrepQuery R (Identity GroupId) (Domain, UserId, ClientId, KeyPackageRef) -lookupMLSClients = "select user_domain, user, client, key_package_ref from mls_group_member_client where group_id = ?" +lookupMLSClients :: PrepQuery R (Identity GroupId) (Domain, UserId, ClientId, Int32, Bool) +lookupMLSClients = "select user_domain, user, client, leaf_node_index, removal_pending from mls_group_member_client where group_id = ?" acquireCommitLock :: PrepQuery W (GroupId, Epoch, Int32) Row acquireCommitLock = "insert into mls_commit_locks (group_id, epoch) values (?, ?) if not exists using ttl ?" diff --git a/services/galley/src/Galley/Cassandra/SubConversation.hs b/services/galley/src/Galley/Cassandra/SubConversation.hs index ad14312114..9dd9dd02d0 100644 --- a/services/galley/src/Galley/Cassandra/SubConversation.hs +++ b/services/galley/src/Galley/Cassandra/SubConversation.hs @@ -26,8 +26,8 @@ import Data.Id import qualified Data.Map as Map import Data.Qualified import Data.Time.Clock -import Galley.API.MLS.Types (SubConversation (..)) -import Galley.Cassandra.Conversation.MLS (lookupMLSClients) +import Galley.API.MLS.Types +import Galley.Cassandra.Conversation.MLS import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store (embedClient) import Galley.Effects.SubConversationStore (SubConversationStore (..)) @@ -37,14 +37,14 @@ import Polysemy.Input import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation selectSubConversation :: ConvId -> SubConvId -> Client (Maybe SubConversation) selectSubConversation convId subConvId = do m <- retry x5 (query1 Cql.selectSubConversation (params LocalQuorum (convId, subConvId))) for m $ \(suite, epoch, epochWritetime, groupId) -> do - cm <- lookupMLSClients groupId + (cm, im) <- lookupMLSClientLeafIndices groupId pure $ SubConversation { scParentConvId = convId, @@ -56,20 +56,32 @@ selectSubConversation convId subConvId = do cnvmlsEpochTimestamp = epochTimestamp epoch epochWritetime, cnvmlsCipherSuite = suite }, - scMembers = cm + scMembers = cm, + scIndexMap = im } -insertSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Epoch -> GroupId -> Maybe OpaquePublicGroupState -> Client () -insertSubConversation convId subConvId suite epoch groupId mPgs = - retry x5 (write Cql.insertSubConversation (params LocalQuorum (convId, subConvId, suite, epoch, groupId, mPgs))) +insertSubConversation :: + ConvId -> + SubConvId -> + CipherSuiteTag -> + Epoch -> + GroupId -> + Maybe GroupInfoData -> + Client () +insertSubConversation convId subConvId suite epoch groupId mGroupInfo = + retry x5 (write Cql.insertSubConversation (params LocalQuorum (convId, subConvId, suite, epoch, groupId, mGroupInfo))) -updateSubConvPublicGroupState :: ConvId -> SubConvId -> Maybe OpaquePublicGroupState -> Client () -updateSubConvPublicGroupState convId subConvId mPgs = - retry x5 (write Cql.updateSubConvPublicGroupState (params LocalQuorum (convId, subConvId, mPgs))) +updateSubConvGroupInfo :: ConvId -> SubConvId -> Maybe GroupInfoData -> Client () +updateSubConvGroupInfo convId subConvId mGroupInfo = + retry x5 (write Cql.updateSubConvGroupInfo (params LocalQuorum (convId, subConvId, mGroupInfo))) -selectSubConvPublicGroupState :: ConvId -> SubConvId -> Client (Maybe OpaquePublicGroupState) -selectSubConvPublicGroupState convId subConvId = - (runIdentity =<<) <$> retry x5 (query1 Cql.selectSubConvPublicGroupState (params LocalQuorum (convId, subConvId))) +selectSubConvGroupInfo :: ConvId -> SubConvId -> Client (Maybe GroupInfoData) +selectSubConvGroupInfo convId subConvId = + (runIdentity =<<) <$> retry x5 (query1 Cql.selectSubConvGroupInfo (params LocalQuorum (convId, subConvId))) + +selectSubConvEpoch :: ConvId -> SubConvId -> Client (Maybe Epoch) +selectSubConvEpoch convId subConvId = + (runIdentity =<<) <$> retry x5 (query1 Cql.selectSubConvEpoch (params LocalQuorum (convId, subConvId))) setGroupIdForSubConversation :: GroupId -> Qualified ConvId -> SubConvId -> Client () setGroupIdForSubConversation groupId qconv sconv = @@ -107,10 +119,12 @@ interpretSubConversationStoreToCassandra :: Sem (SubConversationStore ': r) a -> Sem r a interpretSubConversationStoreToCassandra = interpret $ \case - CreateSubConversation convId subConvId suite epoch groupId mPgs -> embedClient (insertSubConversation convId subConvId suite epoch groupId mPgs) + CreateSubConversation convId subConvId suite epoch groupId mGroupInfo -> + embedClient (insertSubConversation convId subConvId suite epoch groupId mGroupInfo) GetSubConversation convId subConvId -> embedClient (selectSubConversation convId subConvId) - GetSubConversationPublicGroupState convId subConvId -> embedClient (selectSubConvPublicGroupState convId subConvId) - SetSubConversationPublicGroupState convId subConvId mPgs -> embedClient (updateSubConvPublicGroupState convId subConvId mPgs) + GetSubConversationGroupInfo convId subConvId -> embedClient (selectSubConvGroupInfo convId subConvId) + GetSubConversationEpoch convId subConvId -> embedClient (selectSubConvEpoch convId subConvId) + SetSubConversationGroupInfo convId subConvId mPgs -> embedClient (updateSubConvGroupInfo convId subConvId mPgs) SetGroupIdForSubConversation gId cid sconv -> embedClient $ setGroupIdForSubConversation gId cid sconv SetSubConversationEpoch cid sconv epoch -> embedClient $ setEpochForSubConversation cid sconv epoch DeleteGroupIdForSubConversation groupId -> embedClient $ deleteGroupId groupId diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs index be713c6fbc..8631ef1f7d 100644 --- a/services/galley/src/Galley/Effects/BrigAccess.hs +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -48,12 +48,7 @@ module Galley.Effects.BrigAccess removeLegalHoldClientFromUser, -- * MLS - getClientByKeyPackageRef, getLocalMLSClients, - addKeyPackageRef, - validateAndAddKeyPackageRef, - updateKeyPackageRef, - deleteKeyPackageRefs, -- * Features getAccountConferenceCallingConfigClient, @@ -73,9 +68,7 @@ import Polysemy import Polysemy.Error import Wire.API.Connection import Wire.API.Error.Galley -import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage -import Wire.API.Routes.Internal.Brig +import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi import Wire.API.Team.Feature @@ -130,12 +123,7 @@ data BrigAccess m a where BrigAccess m (Either AuthenticationError ClientId) RemoveLegalHoldClientFromUser :: UserId -> BrigAccess m () GetAccountConferenceCallingConfigClient :: UserId -> BrigAccess m (WithStatusNoLock ConferenceCallingConfig) - GetClientByKeyPackageRef :: KeyPackageRef -> BrigAccess m (Maybe ClientIdentity) GetLocalMLSClients :: Local UserId -> SignatureSchemeTag -> BrigAccess m (Set ClientInfo) - AddKeyPackageRef :: KeyPackageRef -> Qualified UserId -> ClientId -> Qualified ConvId -> BrigAccess m () - ValidateAndAddKeyPackageRef :: NewKeyPackage -> BrigAccess m (Either Text NewKeyPackageResult) - UpdateKeyPackageRef :: KeyPackageUpdate -> BrigAccess m () - DeleteKeyPackageRefs :: [KeyPackageRef] -> BrigAccess m () UpdateSearchVisibilityInbound :: Multi.TeamStatus SearchVisibilityInboundConfig -> BrigAccess m () diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs index 5d9fa1d51c..fe47bb376c 100644 --- a/services/galley/src/Galley/Effects/ConversationStore.hs +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -28,10 +28,11 @@ module Galley.Effects.ConversationStore -- * Read conversation getConversation, + getConversationEpoch, lookupConvByGroupId, getConversations, getConversationMetadata, - getPublicGroupState, + getGroupInfo, isConversationAlive, getRemoteConversationStatus, selectConversations, @@ -46,7 +47,7 @@ module Galley.Effects.ConversationStore acceptConnectConversation, setGroupIdForConversation, deleteGroupIdForConversation, - setPublicGroupState, + setGroupInfo, deleteGroupIds, updateToMixedProtocol, @@ -72,7 +73,7 @@ import Polysemy import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.MLS.CipherSuite (CipherSuiteTag) import Wire.API.MLS.Epoch -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation data ConversationStore m a where @@ -83,12 +84,11 @@ data ConversationStore m a where ConversationStore m Conversation DeleteConversation :: ConvId -> ConversationStore m () GetConversation :: ConvId -> ConversationStore m (Maybe Conversation) + GetConversationEpoch :: ConvId -> ConversationStore m (Maybe Epoch) LookupConvByGroupId :: GroupId -> ConversationStore m (Maybe (Qualified ConvOrSubConvId)) GetConversations :: [ConvId] -> ConversationStore m [Conversation] GetConversationMetadata :: ConvId -> ConversationStore m (Maybe ConversationMetadata) - GetPublicGroupState :: - ConvId -> - ConversationStore m (Maybe OpaquePublicGroupState) + GetGroupInfo :: ConvId -> ConversationStore m (Maybe GroupInfoData) IsConversationAlive :: ConvId -> ConversationStore m Bool GetRemoteConversationStatus :: UserId -> @@ -103,10 +103,7 @@ data ConversationStore m a where SetConversationEpoch :: ConvId -> Epoch -> ConversationStore m () SetGroupIdForConversation :: GroupId -> Qualified ConvId -> ConversationStore m () DeleteGroupIdForConversation :: GroupId -> ConversationStore m () - SetPublicGroupState :: - ConvId -> - OpaquePublicGroupState -> - ConversationStore m () + SetGroupInfo :: ConvId -> GroupInfoData -> ConversationStore m () AcquireCommitLock :: GroupId -> Epoch -> NominalDiffTime -> ConversationStore m LockAcquired ReleaseCommitLock :: GroupId -> Epoch -> ConversationStore m () DeleteGroupIds :: [GroupId] -> ConversationStore m () diff --git a/services/galley/src/Galley/Effects/MemberStore.hs b/services/galley/src/Galley/Effects/MemberStore.hs index bdc61c9016..bb8d1c6c33 100644 --- a/services/galley/src/Galley/Effects/MemberStore.hs +++ b/services/galley/src/Galley/Effects/MemberStore.hs @@ -39,9 +39,11 @@ module Galley.Effects.MemberStore setSelfMember, setOtherMember, addMLSClients, + planClientRemoval, removeMLSClients, removeAllMLSClients, lookupMLSClients, + lookupMLSClientLeafIndices, -- * Delete members deleteMembers, @@ -59,8 +61,9 @@ import Galley.Types.UserList import Imports import Polysemy import Wire.API.Conversation.Member hiding (Member) +import Wire.API.MLS.Credential import Wire.API.MLS.Group -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.Provider.Service data MemberStore m a where @@ -77,10 +80,12 @@ data MemberStore m a where SetOtherMember :: Local ConvId -> Qualified UserId -> OtherMemberUpdate -> MemberStore m () DeleteMembers :: ConvId -> UserList UserId -> MemberStore m () DeleteMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () - AddMLSClients :: GroupId -> Qualified UserId -> Set (ClientId, KeyPackageRef) -> MemberStore m () + AddMLSClients :: GroupId -> Qualified UserId -> Set (ClientId, LeafIndex) -> MemberStore m () + PlanClientRemoval :: Foldable f => GroupId -> f ClientIdentity -> MemberStore m () RemoveMLSClients :: GroupId -> Qualified UserId -> Set ClientId -> MemberStore m () RemoveAllMLSClients :: GroupId -> MemberStore m () LookupMLSClients :: GroupId -> MemberStore m ClientMap + LookupMLSClientLeafIndices :: GroupId -> MemberStore m (ClientMap, IndexMap) makeSem ''MemberStore diff --git a/services/galley/src/Galley/Effects/SubConversationStore.hs b/services/galley/src/Galley/Effects/SubConversationStore.hs index 056eec34d8..4dff138c6a 100644 --- a/services/galley/src/Galley/Effects/SubConversationStore.hs +++ b/services/galley/src/Galley/Effects/SubConversationStore.hs @@ -27,14 +27,15 @@ import Polysemy import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group -import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation data SubConversationStore m a where - CreateSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Epoch -> GroupId -> Maybe OpaquePublicGroupState -> SubConversationStore m () + CreateSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Epoch -> GroupId -> Maybe GroupInfoData -> SubConversationStore m () GetSubConversation :: ConvId -> SubConvId -> SubConversationStore m (Maybe SubConversation) - GetSubConversationPublicGroupState :: ConvId -> SubConvId -> SubConversationStore m (Maybe OpaquePublicGroupState) - SetSubConversationPublicGroupState :: ConvId -> SubConvId -> Maybe OpaquePublicGroupState -> SubConversationStore m () + GetSubConversationGroupInfo :: ConvId -> SubConvId -> SubConversationStore m (Maybe GroupInfoData) + GetSubConversationEpoch :: ConvId -> SubConvId -> SubConversationStore m (Maybe Epoch) + SetSubConversationGroupInfo :: ConvId -> SubConvId -> Maybe GroupInfoData -> SubConversationStore m () SetGroupIdForSubConversation :: GroupId -> Qualified ConvId -> SubConvId -> SubConversationStore m () SetSubConversationEpoch :: ConvId -> SubConvId -> Epoch -> SubConversationStore m () DeleteGroupIdForSubConversation :: GroupId -> SubConversationStore m () diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index 697c588465..96cce82ece 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -22,12 +22,7 @@ module Galley.Intra.Client addLegalHoldClientToUser, removeLegalHoldClientFromUser, getLegalHoldAuthToken, - getClientByKeyPackageRef, getLocalMLSClients, - addKeyPackageRef, - updateKeyPackageRef, - validateAndAddKeyPackageRef, - deleteKeyPackageRefs, ) where @@ -35,14 +30,12 @@ import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) -import Control.Monad.Catch import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Misc import Data.Qualified import qualified Data.Set as Set import Data.Text.Encoding -import Data.Text.Lazy (toStrict) import Galley.API.Error import Galley.Effects import Galley.Env @@ -50,22 +43,16 @@ import Galley.External.LegalHoldService.Types import Galley.Intra.Util import Galley.Monad import Imports -import qualified Network.HTTP.Client as Rq -import qualified Network.HTTP.Types as HTTP import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error hiding (Error) -import qualified Network.Wai.Utilities.Error as Error import Polysemy import Polysemy.Error import Polysemy.Input import qualified Polysemy.TinyLog as P -import Servant import qualified System.Logger.Class as Logger import Wire.API.Error.Galley -import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage -import Wire.API.Routes.Internal.Brig +import Wire.API.MLS.CipherSuite import Wire.API.User.Auth.LegalHold import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -183,18 +170,6 @@ brigAddClient uid connId client = do then Right <$> parseResponse (mkError status502 "server-error") r else pure (Left ReAuthFailed) --- | Calls 'Brig.API.Internal.getClientByKeyPackageRef'. -getClientByKeyPackageRef :: KeyPackageRef -> App (Maybe ClientIdentity) -getClientByKeyPackageRef ref = do - r <- - call Brig $ - method GET - . paths ["i", "mls", "key-packages", toHeader ref] - . expectStatus (flip elem [200, 404]) - if statusCode (responseStatus r) == 200 - then Just <$> parseResponse (mkError status502 "server-error") r - else pure Nothing - -- | Calls 'Brig.API.Internal.getMLSClients'. getLocalMLSClients :: Local UserId -> SignatureSchemeTag -> App (Set ClientInfo) getLocalMLSClients lusr ss = @@ -211,53 +186,3 @@ getLocalMLSClients lusr ss = . expect2xx ) >>= parseResponse (mkError status502 "server-error") - -deleteKeyPackageRefs :: [KeyPackageRef] -> App () -deleteKeyPackageRefs refs = - void $ - call - Brig - ( method DELETE - . paths ["i", "mls", "key-packages"] - . json (DeleteKeyPackageRefsRequest refs) - . expect2xx - ) - -addKeyPackageRef :: KeyPackageRef -> Qualified UserId -> ClientId -> Qualified ConvId -> App () -addKeyPackageRef ref qusr cl qcnv = - void $ - call - Brig - ( method PUT - . paths ["i", "mls", "key-packages", toHeader ref] - . json (NewKeyPackageRef qusr cl qcnv) - . expect2xx - ) - -updateKeyPackageRef :: KeyPackageUpdate -> App () -updateKeyPackageRef keyPackageRef = - void $ - call - Brig - ( method POST - . paths ["i", "mls", "key-packages", toHeader $ kpupPrevious keyPackageRef] - . json (kpupNext keyPackageRef) - . expect2xx - ) - -validateAndAddKeyPackageRef :: NewKeyPackage -> App (Either Text NewKeyPackageResult) -validateAndAddKeyPackageRef nkp = do - res <- - call - Brig - ( method PUT - . paths ["i", "mls", "key-package-add"] - . json nkp - ) - let statusCode = HTTP.statusCode (Rq.responseStatus res) - if - | statusCode `div` 100 == 2 -> Right <$> parseResponse (mkError status502 "server-error") res - | statusCode `div` 100 == 4 -> do - err <- parseResponse (mkError status502 "server-error") res - pure (Left ("Error validating keypackage: " <> toStrict (Error.label err) <> ": " <> toStrict (Error.message err))) - | otherwise -> throwM (mkError status502 "server-error" "Unexpected http status returned from /i/mls/key-packages/add") diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs index 3d38b4b5c6..782228140c 100644 --- a/services/galley/src/Galley/Intra/Effects.hs +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -80,21 +80,7 @@ interpretBrigAccess = interpret $ \case embedApp $ removeLegalHoldClientFromUser uid GetAccountConferenceCallingConfigClient uid -> embedApp $ getAccountConferenceCallingConfigClient uid - GetClientByKeyPackageRef ref -> - embedApp $ getClientByKeyPackageRef ref GetLocalMLSClients qusr ss -> embedApp $ getLocalMLSClients qusr ss - AddKeyPackageRef ref qusr cl qcnv -> - embedApp $ - addKeyPackageRef ref qusr cl qcnv - ValidateAndAddKeyPackageRef nkp -> - embedApp $ - validateAndAddKeyPackageRef nkp - UpdateKeyPackageRef update -> - embedApp $ - updateKeyPackageRef update - DeleteKeyPackageRefs refs -> - embedApp $ - deleteKeyPackageRefs refs UpdateSearchVisibilityInbound status -> embedApp $ updateSearchVisibilityInbound status diff --git a/services/galley/src/Galley/Keys.hs b/services/galley/src/Galley/Keys.hs index 129b42396a..287191f53e 100644 --- a/services/galley/src/Galley/Keys.hs +++ b/services/galley/src/Galley/Keys.hs @@ -33,6 +33,7 @@ import qualified Data.Map as Map import Data.PEM import Data.X509 import Imports +import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential import Wire.API.MLS.Keys diff --git a/services/galley/test/integration.hs b/services/galley/test/integration.hs new file mode 100644 index 0000000000..a26473d24e --- /dev/null +++ b/services/galley/test/integration.hs @@ -0,0 +1 @@ +import Run diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index b6c6bd1023..d25796947d 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -32,8 +32,6 @@ import qualified Control.Monad.State as State import Crypto.Error import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Data.Aeson as Aeson -import Data.Binary.Put -import qualified Data.ByteString.Lazy as LBS import Data.Domain import Data.Id import Data.Json.Util hiding ((#)) @@ -64,13 +62,14 @@ import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley +import Wire.API.MLS.AuthenticatedContent import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential import Wire.API.MLS.Keys import Wire.API.MLS.Message +import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation -import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version @@ -88,10 +87,7 @@ tests s = testGroup "Welcome" [ test s "local welcome" testLocalWelcome, - test s "local welcome (client with no public key)" testWelcomeNoKey, - test s "remote welcome" testRemoteWelcome, - test s "post a remote MLS welcome message" sendRemoteMLSWelcome, - test s "post a remote MLS welcome message (key package ref not found)" sendRemoteMLSWelcomeKPNotFound + test s "post a remote MLS welcome message" sendRemoteMLSWelcome ], testGroup "Creation" @@ -100,12 +96,11 @@ tests s = ], testGroup "Deletion" - [ test s "delete a MLS conversation" testDeleteMLSConv + [ test s "delete an MLS conversation" testDeleteMLSConv ], testGroup "Commit" [ test s "add user to a conversation" testAddUser, - test s "add user with an incomplete welcome" testAddUserWithBundleIncompleteWelcome, test s "add user (not connected)" testAddUserNotConnected, test s "add user (partial client list)" testAddUserPartial, test s "add client of existing user" testAddClientPartial, @@ -257,7 +252,7 @@ tests s = test s "client of a remote user joins subconversation" testRemoteUserJoinSubConv, test s "delete subconversation as a remote member" (testRemoteMemberDeleteSubConv True), test s "delete subconversation as a remote non-member" (testRemoteMemberDeleteSubConv False), - test s "delete parent conversation of a remote subconveration" testDeleteRemoteParentOfSubConv + test s "delete parent conversation of a remote subconversation" testDeleteRemoteParentOfSubConv ] ], testGroup @@ -342,7 +337,7 @@ testLocalWelcome = do Nothing -> assertFailure "Expected welcome message" Just w -> pure w events <- mlsBracket [bob1] $ \wss -> do - es <- sendAndConsumeCommit commit + es <- sendAndConsumeCommitBundle commit WS.assertMatchN_ (5 # Second) wss $ wsAssertMLSWelcome (cidQualifiedUser bob1) welcome @@ -352,50 +347,6 @@ testLocalWelcome = do event <- assertOne events liftIO $ assertJoinEvent qcnv alice [bob] roleNameWireMember event -testWelcomeNoKey :: TestM () -testWelcomeNoKey = do - users <- createAndConnectUsers [Nothing, Nothing] - runMLSTest $ do - [alice1, bob1] <- traverse createMLSClient users - void $ setupMLSGroup alice1 - - -- add bob using an "out-of-band" key package - (_, ref) <- generateKeyPackage bob1 - kp <- keyPackageFile bob1 ref - commit <- createAddCommitWithKeyPackages alice1 [(bob1, kp)] - welcome <- liftIO $ case mpWelcome commit of - Nothing -> assertFailure "Expected welcome message" - Just w -> pure w - - err <- - responseJsonError - =<< postWelcome (ciUser alice1) welcome - assertFailure "Expected welcome message" - Just w -> pure w - (_, reqs) <- - withTempMockFederator' welcomeMock $ - postWelcome (ciUser (mpSender commit)) welcome - !!! const 201 === statusCode - consumeWelcome welcome - fedWelcome <- assertOne (filter ((== "mls-welcome") . frRPC) reqs) - let req :: Maybe MLSWelcomeRequest = Aeson.decode (frBody fedWelcome) - liftIO $ req @?= (Just . MLSWelcomeRequest . Base64ByteString) welcome - testAddUserWithBundle :: TestM () testAddUserWithBundle = do [alice, bob] <- createAndConnectUsers [Nothing, Nothing] @@ -426,35 +377,8 @@ testAddUserWithBundle = do (qcnv `elem` map cnvQualifiedId convs) returnedGS <- getGroupInfo alice (fmap Conv qcnv) - liftIO $ assertBool "Commit does not contain a public group State" (isJust (mpPublicGroupState commit)) - liftIO $ mpPublicGroupState commit @?= Just returnedGS - -testAddUserWithBundleIncompleteWelcome :: TestM () -testAddUserWithBundleIncompleteWelcome = do - [alice, bob] <- createAndConnectUsers [Nothing, Nothing] - - runMLSTest $ do - (alice1 : bobClients) <- traverse createMLSClient [alice, bob, bob] - traverse_ uploadNewKeyPackage bobClients - void $ setupMLSGroup alice1 - - -- create commit, but remove first recipient from welcome message - commit <- do - commit <- createAddCommit alice1 [bob] - liftIO $ do - welcome <- assertJust (mpWelcome commit) - w <- either (assertFailure . T.unpack) pure $ decodeMLS' welcome - let w' = w {welSecrets = take 1 (welSecrets w)} - welcome' = encodeMLS' w' - commit' = commit {mpWelcome = Just welcome'} - pure commit' - - bundle <- createBundle commit - err <- - responseJsonError - =<< localPostCommitBundle (mpSender commit) bundle - >= sendAndConsumeCommit + events <- createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle event <- assertOne events liftIO $ assertJoinEvent qcnv alice [bob] roleNameWireMember event pure qcnv @@ -486,10 +412,11 @@ testAddUserNotConnected = do void $ setupMLSGroup alice1 -- add unconnected user with a commit commit <- createAddCommit alice1 [bob] + bundle <- createBundle commit err <- mlsBracket [alice1, bob1] $ \wss -> do err <- responseJsonError - =<< postMessage (mpSender commit) (mpMessage commit) + =<< localPostCommitBundle (mpSender commit) bundle >= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle testAddUserPartial :: TestM () testAddUserPartial = do @@ -534,9 +461,10 @@ testAddUserPartial = do void $ uploadNewKeyPackage bob3 -- alice sends a commit now, and should get a conflict error + bundle <- createBundle commit err <- responseJsonError - =<< postMessage (mpSender commit) (mpMessage commit) + =<< localPostCommitBundle (mpSender commit) bundle >= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle -- now bob2 and bob3 upload key packages, and alice adds bob2 only - kp <- uploadNewKeyPackage bob2 >>= keyPackageFile bob2 + kp <- uploadNewKeyPackage bob2 void $ uploadNewKeyPackage bob3 void $ - createAddCommitWithKeyPackages alice1 [(bob2, kp)] - >>= sendAndConsumeCommit + createAddCommitWithKeyPackages alice1 [(bob2, kp.raw)] + >>= sendAndConsumeCommitBundle testSendAnotherUsersCommit :: TestM () testSendAnotherUsersCommit = do @@ -573,7 +501,7 @@ testSendAnotherUsersCommit = do -- create group with alice1 and bob1 void $ setupMLSGroup alice1 - createAddCommit alice1 [bob] >>= void . sendAndConsumeCommit + createAddCommit alice1 [bob] >>= void . sendAndConsumeCommitBundle -- Alice creates a commit that adds bob2 bob2 <- createMLSClient bob @@ -583,7 +511,7 @@ testSendAnotherUsersCommit = do -- and the corresponding commit is sent from Bob instead of Alice err <- responseJsonError - =<< postMessage bob1 (mpMessage mp) + =<< (localPostCommitBundle bob1 =<< createBundle mp) setupMLSGroup alice1 - createAddCommit alice1 [bob] >>= void . sendAndConsumeCommit + createAddCommit alice1 [bob] >>= void . sendAndConsumeCommitBundle e <- responseJsonError =<< postMembers @@ -626,7 +555,7 @@ testRemoveUsersDirectly = do [alice1, bob1] <- traverse createMLSClient [alice, bob] void $ uploadNewKeyPackage bob1 qcnv <- snd <$> setupMLSGroup alice1 - createAddCommit alice1 [bob] >>= void . sendAndConsumeCommit + createAddCommit alice1 [bob] >>= void . sendAndConsumeCommitBundle e <- responseJsonError =<< deleteMemberQualified @@ -643,7 +572,7 @@ testProteusMessage = do [alice1, bob1] <- traverse createMLSClient [alice, bob] void $ uploadNewKeyPackage bob1 qcnv <- snd <$> setupMLSGroup alice1 - createAddCommit alice1 [bob] >>= void . sendAndConsumeCommit + createAddCommit alice1 [bob] >>= void . sendAndConsumeCommitBundle e <- responseJsonError =<< postProteusMessageQualified @@ -669,15 +598,16 @@ testStaleCommit = do gsBackup <- getClientGroupState alice1 -- add the first batch of users to the conversation - void $ createAddCommit alice1 users1 >>= sendAndConsumeCommit + void $ createAddCommit alice1 users1 >>= sendAndConsumeCommitBundle -- now roll back alice1 and try to add the second batch of users setClientGroupState alice1 gsBackup commit <- createAddCommit alice1 users2 + bundle <- createBundle commit err <- responseJsonError - =<< postMessage (mpSender commit) (mpMessage commit) + =<< localPostCommitBundle (mpSender commit) bundle welcomeMock) $ - sendAndConsumeCommit commit + sendAndConsumeCommitBundle commit pure (events, reqs, qcnv) liftIO $ do @@ -725,10 +655,10 @@ testCommitLock = do traverse_ uploadNewKeyPackage [bob1, charlie1, dee1] -- alice adds add bob - void $ createAddCommit alice1 [cidQualifiedUser bob1] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [cidQualifiedUser bob1] >>= sendAndConsumeCommitBundle -- alice adds charlie - void $ createAddCommit alice1 [cidQualifiedUser charlie1] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [cidQualifiedUser charlie1] >>= sendAndConsumeCommitBundle -- simulate concurrent commit by blocking epoch casClient <- view tsCass @@ -737,9 +667,10 @@ testCommitLock = do -- commit should fail due to competing lock do commit <- createAddCommit alice1 [cidQualifiedUser dee1] + bundle <- createBundle commit err <- responseJsonError - =<< postMessage alice1 (mpMessage commit) + =<< localPostCommitBundle alice1 bundle >= traverse_ sendAndConsumeMessage commit <- createPendingProposalCommit alice1 void $ assertJust (mpWelcome commit) - void $ sendAndConsumeCommit commit + void $ sendAndConsumeCommitBundle commit -- check that bob can now see the conversation liftTest $ do @@ -790,9 +721,10 @@ testUnknownProposalRefCommit = do commit <- createPendingProposalCommit alice1 -- send commit before proposal + bundle <- createBundle commit err <- responseJsonError - =<< postMessage alice1 (mpMessage commit) + =<< localPostCommitBundle alice1 bundle >= sendAndConsumeCommit - events <- createRemoveCommit alice1 [bob1, bob2] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle + events <- createRemoveCommit alice1 [bob1, bob2] >>= sendAndConsumeCommitBundle pure (qcnv, events) liftIO $ assertOne events >>= assertLeaveEvent qcnv alice [bob] @@ -855,12 +788,13 @@ testRemoveClientsIncomplete = do [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] void $ setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle commit <- createRemoveCommit alice1 [bob1] + bundle <- createBundle commit err <- responseJsonError - =<< postMessage alice1 (mpMessage commit) + =<< localPostCommitBundle alice1 bundle messageSentMock <|> welcomeMock ((message, events), reqs) <- withTempMockFederator' mock $ do - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle message <- createApplicationMessage alice1 "hello" (events, _) <- sendAndConsumeMessage message pure (message, events) @@ -998,7 +932,8 @@ testLocalToRemoteNonMember = do . paths ["mls", "messages"] . zUser (qUnqualified bob) . zConn "conn" - . content "message/mls" + . zClient (ciClient bob1) + . Bilge.content "message/mls" . bytes (mpMessage message) ) !!! do @@ -1078,7 +1013,7 @@ testExternalCommitNewClientResendBackendProposal = do forM_ [bob1, bob2] uploadNewKeyPackage (_, qcnv) <- setupMLSGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle - Just (_, kpBob2) <- find (\(ci, _) -> ci == bob2) <$> getClientsFromGroupState alice1 bob + Just (_, bobIdx2) <- find (\(ci, _) -> ci == bob2) <$> getClientsFromGroupState alice1 bob mlsBracket [alice1, bob1] $ \[wsA, wsB] -> do liftTest $ @@ -1093,7 +1028,7 @@ testExternalCommitNewClientResendBackendProposal = do } WS.assertMatchN_ (5 # WS.Second) [wsA, wsB] $ - wsAssertBackendRemoveProposalWithEpoch bob qcnv kpBob2 (Epoch 1) + wsAssertBackendRemoveProposalWithEpoch bob qcnv bobIdx2 (Epoch 1) [bob3, bob4] <- for [bob, bob] $ \qusr' -> do ci <- createMLSClient qusr' @@ -1104,6 +1039,7 @@ testExternalCommitNewClientResendBackendProposal = do void $ createExternalAddProposal bob3 >>= sendAndConsumeMessage + WS.assertMatchN_ (5 # WS.Second) [wsA, wsB] $ void . wsAssertAddProposal bob qcnv @@ -1111,6 +1047,7 @@ testExternalCommitNewClientResendBackendProposal = do ecEvents <- sendAndConsumeCommitBundle mp liftIO $ assertBool "No events after external commit expected" (null ecEvents) + WS.assertMatchN_ (5 # WS.Second) [wsA, wsB] $ wsAssertMLSMessage (fmap Conv qcnv) bob (mpMessage mp) @@ -1118,7 +1055,7 @@ testExternalCommitNewClientResendBackendProposal = do -- proposal for bob3 has to replayed by the client and is thus not found -- here. WS.assertMatchN_ (5 # WS.Second) [wsA, wsB] $ - wsAssertBackendRemoveProposalWithEpoch bob qcnv kpBob2 (Epoch 2) + wsAssertBackendRemoveProposalWithEpoch bob qcnv bobIdx2 (Epoch 2) WS.assertNoEvent (2 # WS.Second) [wsA, wsB] testAppMessage :: TestM () @@ -1129,7 +1066,7 @@ testAppMessage = do clients@(alice1 : _) <- traverse createMLSClient users traverse_ uploadNewKeyPackage (tail clients) (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 (tail users) >>= sendAndConsumeCommit + void $ createAddCommit alice1 (tail users) >>= sendAndConsumeCommitBundle message <- createApplicationMessage alice1 "some text" mlsBracket clients $ \wss -> do @@ -1154,7 +1091,7 @@ testAppMessage2 = do -- create group with alice1 and other clients conversation <- snd <$> setupMLSGroup alice1 mp <- createAddCommit alice1 [bob, charlie] - void $ sendAndConsumeCommit mp + void $ sendAndConsumeCommitBundle mp traverse_ consumeWelcome (mpWelcome mp) @@ -1191,7 +1128,7 @@ testAppMessageSomeReachable = do <|> welcomeMock ([event], _) <- withTempMockFederator' mocks $ do - sendAndConsumeCommit commit + sendAndConsumeCommitBundle commit let unreachables = Set.singleton (Domain "charlie.example.com") withTempMockFederator' (mockUnreachableFor unreachables) $ do @@ -1222,7 +1159,7 @@ testAppMessageUnreachable = do commit <- createAddCommit alice1 [bob] ([event], _) <- withTempMockFederator' (receiveCommitMock [bob1] <|> welcomeMock) $ - sendAndConsumeCommit commit + sendAndConsumeCommitBundle commit message <- createApplicationMessage alice1 "hi, bob!" (_, us) <- sendAndConsumeMessage message @@ -1310,7 +1247,7 @@ testRemoteToLocal = do let mock = receiveCommitMock [bob1] <|> welcomeMock <|> claimKeyPackagesMock kpb void . withTempMockFederator' mock $ - sendAndConsumeCommit mp + sendAndConsumeCommitBundle mp traverse_ consumeWelcome (mpWelcome mp) message <- createApplicationMessage bob1 "hello from another backend" @@ -1355,7 +1292,7 @@ testRemoteToLocalWrongConversation = do mp <- createAddCommit alice1 [bob] let mock = receiveCommitMock [bob1] <|> welcomeMock - void . withTempMockFederator' mock $ sendAndConsumeCommit mp + void . withTempMockFederator' mock $ sendAndConsumeCommitBundle mp traverse_ consumeWelcome (mpWelcome mp) message <- createApplicationMessage bob1 "hello from another backend" @@ -1445,7 +1382,7 @@ propInvalidEpoch = do -- Add bob -> epoch 1 void $ uploadNewKeyPackage bob1 gsBackup <- getClientGroupState alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle gsBackup2 <- getClientGroupState alice1 -- try to send a proposal from an old epoch (0) @@ -1463,14 +1400,14 @@ propInvalidEpoch = do do void $ uploadNewKeyPackage dee1 void $ uploadNewKeyPackage charlie1 - setClientGroupState alice1 gsBackup - void $ createAddCommit alice1 [charlie] + setClientGroupState alice1 gsBackup2 + void $ createAddCommit alice1 [charlie] -- --> epoch 2 [prop] <- createAddProposals alice1 [dee] err <- responseJsonError =<< postMessage alice1 (mpMessage prop) - mls {mlsNewMembers = mempty} @@ -1478,7 +1415,7 @@ propInvalidEpoch = do void $ uploadNewKeyPackage dee1 setClientGroupState alice1 gsBackup2 createAddProposals alice1 [dee] >>= traverse_ sendAndConsumeMessage - void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommit + void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle -- scenario: -- alice1 creates a group and adds bob1 @@ -1505,7 +1442,7 @@ testExternalAddProposal = do (_, qcnv) <- setupMLSGroup alice1 void $ createAddCommit alice1 [bob] - >>= sendAndConsumeCommit + >>= sendAndConsumeCommitBundle -- bob joins with an external proposal bob2 <- createMLSClient bob @@ -1519,7 +1456,7 @@ testExternalAddProposal = do void $ createPendingProposalCommit alice1 - >>= sendAndConsumeCommit + >>= sendAndConsumeCommitBundle -- alice sends a message do @@ -1538,7 +1475,7 @@ testExternalAddProposal = do qcnv !!! const 200 === statusCode createAddCommit bob2 [charlie] - >>= sendAndConsumeCommit + >>= sendAndConsumeCommitBundle testExternalAddProposalNonAdminCommit :: TestM () testExternalAddProposalNonAdminCommit = do @@ -1560,7 +1497,7 @@ testExternalAddProposalNonAdminCommit = do (_, qcnv) <- setupMLSGroup alice1 void $ createAddCommit alice1 [bob] - >>= sendAndConsumeCommit + >>= sendAndConsumeCommitBundle -- bob joins with an external proposal mlsBracket [alice1, bob1] $ \wss -> do @@ -1574,7 +1511,7 @@ testExternalAddProposalNonAdminCommit = do -- bob1 commits void $ createPendingProposalCommit bob1 - >>= sendAndConsumeCommit + >>= sendAndConsumeCommitBundle -- scenario: -- alice adds bob and charlie @@ -1596,7 +1533,7 @@ testExternalAddProposalWrongClient = do void $ setupMLSGroup alice1 void $ createAddCommit alice1 [bob, charlie] - >>= sendAndConsumeCommit + >>= sendAndConsumeCommitBundle prop <- createExternalAddProposal bob2 postMessage charlie1 (mpMessage prop) @@ -1619,7 +1556,7 @@ testExternalAddProposalWrongUser = do void $ setupMLSGroup alice1 void $ createAddCommit alice1 [bob] - >>= sendAndConsumeCommit + >>= sendAndConsumeCommitBundle prop <- createExternalAddProposal charlie1 postMessage charlie1 (mpMessage prop) @@ -1650,10 +1587,9 @@ testPublicKeys = do ) @?= [Ed25519] --- | The test manually reads from mls-test-cli's store and extracts a private --- key. The key is needed for signing an AppAck proposal, which as of August 24, --- 2022 only gets forwarded by the backend, i.e., there's no action taken by the --- backend. +--- | The test manually reads from mls-test-cli's store and extracts a private +--- key. The key is needed for signing an unsupported proposal, which is then +-- forwarded by the backend without being inspected. propUnsupported :: TestM () propUnsupported = do users@[_alice, bob] <- createAndConnectUsers (replicate 2 Nothing) @@ -1661,26 +1597,26 @@ propUnsupported = do [alice1, bob1] <- traverse createMLSClient users void $ uploadNewKeyPackage bob1 (gid, _) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit - - mems <- readGroupState <$> getClientGroupState alice1 + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle - (_, ref) <- assertJust $ find ((== alice1) . fst) mems (priv, pub) <- clientKeyPair alice1 - msg <- - assertJust $ - maybeCryptoError $ - mkAppAckProposalMessage - gid - (Epoch 1) - ref - [] - <$> Ed25519.secretKey priv - <*> Ed25519.publicKey pub - let msgData = LBS.toStrict (runPut (serialiseMLS msg)) - - -- we cannot use sendAndConsumeMessage here, because openmls does not yet - -- support AppAck proposals + pmsg <- + liftIO . throwCryptoErrorIO $ + mkSignedPublicMessage + <$> Ed25519.secretKey priv + <*> Ed25519.publicKey pub + <*> pure gid + <*> pure (Epoch 1) + <*> pure (TaggedSenderMember 0 "foo") + <*> pure + ( FramedContentProposal + (mkRawMLS (GroupContextExtensionsProposal [])) + ) + + let msg = mkMessage (MessagePublic pmsg) + let msgData = encodeMLS' msg + + -- we cannot consume this message, because the membership tag is fake postMessage alice1 msgData !!! const 201 === statusCode testBackendRemoveProposalRecreateClient :: TestM () @@ -1694,7 +1630,7 @@ testBackendRemoveProposalRecreateClient = do void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle - (_, ref) <- assertOne =<< getClientsFromGroupState alice1 alice + (_, idx) <- assertOne =<< getClientsFromGroupState alice1 alice liftTest $ deleteClient (qUnqualified alice) (ciClient alice1) (Just defPassword) @@ -1706,11 +1642,13 @@ testBackendRemoveProposalRecreateClient = do alice2 <- createMLSClient alice proposal <- mlsBracket [alice2] $ \[wsA] -> do + -- alice2 joins the conversation, causing the external remove proposal to + -- be re-established void $ createExternalCommit alice2 Nothing cnv >>= sendAndConsumeCommitBundle WS.assertMatch (5 # WS.Second) wsA $ - wsAssertBackendRemoveProposal alice (Conv <$> qcnv) ref + wsAssertBackendRemoveProposal alice (Conv <$> qcnv) idx consumeMessage1 alice2 proposal void $ createPendingProposalCommit alice2 >>= sendAndConsumeCommitBundle @@ -1724,7 +1662,7 @@ testBackendRemoveProposalLocalConvLocalUser = do [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle bobClients <- getClientsFromGroupState alice1 bob mlsBracket [alice1] $ \wss -> void $ do @@ -1735,13 +1673,13 @@ testBackendRemoveProposalLocalConvLocalUser = do { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [bob1, bob2]) } - for bobClients $ \(_, ref) -> do + for bobClients $ \(_, idx) -> do [msg] <- WS.assertMatchN (5 # Second) wss $ \n -> - wsAssertBackendRemoveProposal bob (Conv <$> qcnv) ref n + wsAssertBackendRemoveProposal bob (Conv <$> qcnv) idx n consumeMessage1 alice1 msg -- alice commits the external proposals - events <- createPendingProposalCommit alice1 >>= sendAndConsumeCommit + events <- createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle liftIO $ events @?= [] testBackendRemoveProposalLocalConvRemoteUser :: TestM () @@ -1755,7 +1693,7 @@ testBackendRemoveProposalLocalConvRemoteUser = do let mock = receiveCommitMock [bob1, bob2] <|> welcomeMock <|> messageSentMock void . withTempMockFederator' mock $ do mlsBracket [alice1] $ \[wsA] -> do - void $ sendAndConsumeCommit commit + void $ sendAndConsumeCommitBundle commit bobClients <- getClientsFromGroupState alice1 bob fedGalleyClient <- view tsFedGalleyClient @@ -1770,19 +1708,20 @@ testBackendRemoveProposalLocalConvRemoteUser = do } ) - for_ bobClients $ \(_, ref) -> + for_ bobClients $ \(_, idx) -> WS.assertMatch (5 # WS.Second) wsA $ - wsAssertBackendRemoveProposal bob (Conv <$> qcnv) ref + wsAssertBackendRemoveProposal bob (Conv <$> qcnv) idx sendRemoteMLSWelcome :: TestM () sendRemoteMLSWelcome = do -- Alice is from the originating domain and Bob is local, i.e., on the receiving domain [alice, bob] <- createAndConnectUsers [Just "alice.example.com", Nothing] - commit <- runMLSTest $ do + (commit, bob1) <- runMLSTest $ do [alice1, bob1] <- traverse createMLSClient [alice, bob] void $ setupFakeMLSGroup alice1 void $ uploadNewKeyPackage bob1 - createAddCommit alice1 [bob] + commit <- createAddCommit alice1 [bob] + pure (commit, bob1) welcome <- assertJust (mpWelcome commit) @@ -1795,35 +1734,13 @@ sendRemoteMLSWelcome = do runFedClient @"mls-welcome" fedGalleyClient (qDomain alice) $ MLSWelcomeRequest (Base64ByteString welcome) + [qUnqualified (cidQualifiedClient bob1)] -- check that the corresponding event is received liftIO $ do WS.assertMatch_ (5 # WS.Second) wsB $ wsAssertMLSWelcome bob welcome -sendRemoteMLSWelcomeKPNotFound :: TestM () -sendRemoteMLSWelcomeKPNotFound = do - [alice, bob] <- createAndConnectUsers [Just "alice.example.com", Nothing] - commit <- runMLSTest $ do - [alice1, bob1] <- traverse createMLSClient [alice, bob] - void $ setupFakeMLSGroup alice1 - kp <- generateKeyPackage bob1 >>= keyPackageFile bob1 . snd - createAddCommitWithKeyPackages alice1 [(bob1, kp)] - welcome <- assertJust (mpWelcome commit) - - fedGalleyClient <- view tsFedGalleyClient - cannon <- view tsCannon - WS.bracketR cannon (qUnqualified bob) $ \wsB -> do - -- send welcome message - void $ - runFedClient @"mls-welcome" fedGalleyClient (qDomain alice) $ - MLSWelcomeRequest - (Base64ByteString welcome) - - liftIO $ do - -- check that no event is received - WS.assertNoEvent (1 # Second) [wsB] - testBackendRemoveProposalLocalConvLocalLeaverCreator :: TestM () testBackendRemoveProposalLocalConvLocalLeaverCreator = do [alice, bob] <- createAndConnectUsers (replicate 2 Nothing) @@ -1832,7 +1749,7 @@ testBackendRemoveProposalLocalConvLocalLeaverCreator = do [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle aliceClients <- getClientsFromGroupState alice1 alice mlsBracket [alice1, bob1, bob2] $ \wss -> void $ do @@ -1845,10 +1762,10 @@ testBackendRemoveProposalLocalConvLocalLeaverCreator = do { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [alice1]) } - for_ aliceClients $ \(_, ref) -> do + for_ aliceClients $ \(_, idx) -> do -- only bob's clients should receive the external proposals msgs <- WS.assertMatchN (5 # Second) (drop 1 wss) $ \n -> - wsAssertBackendRemoveProposal alice (Conv <$> qcnv) ref n + wsAssertBackendRemoveProposal alice (Conv <$> qcnv) idx n traverse_ (uncurry consumeMessage1) (zip [bob1, bob2] msgs) -- but everyone should receive leave events @@ -1860,7 +1777,7 @@ testBackendRemoveProposalLocalConvLocalLeaverCreator = do WS.assertNoEvent (1 # WS.Second) wss -- bob commits the external proposals - events <- createPendingProposalCommit bob1 >>= sendAndConsumeCommit + events <- createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle liftIO $ events @?= [] testBackendRemoveProposalLocalConvLocalLeaverCommitter :: TestM () @@ -1871,13 +1788,13 @@ testBackendRemoveProposalLocalConvLocalLeaverCommitter = do [alice1, bob1, bob2, charlie1] <- traverse createMLSClient [alice, bob, bob, charlie] traverse_ uploadNewKeyPackage [bob1, bob2, charlie1] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle -- promote bob putOtherMemberQualified (ciUser alice1) bob (OtherMemberUpdate (Just roleNameWireAdmin)) qcnv !!! const 200 === statusCode - void $ createAddCommit bob1 [charlie] >>= sendAndConsumeCommit + void $ createAddCommit bob1 [charlie] >>= sendAndConsumeCommitBundle bobClients <- getClientsFromGroupState alice1 bob mlsBracket [alice1, charlie1, bob1, bob2] $ \wss -> void $ do @@ -1890,10 +1807,10 @@ testBackendRemoveProposalLocalConvLocalLeaverCommitter = do { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [bob1, bob2]) } - for_ bobClients $ \(_, ref) -> do + for_ bobClients $ \(_, idx) -> do -- only alice and charlie should receive the external proposals msgs <- WS.assertMatchN (5 # Second) (take 2 wss) $ \n -> - wsAssertBackendRemoveProposal bob (Conv <$> qcnv) ref n + wsAssertBackendRemoveProposal bob (Conv <$> qcnv) idx n traverse_ (uncurry consumeMessage1) (zip [alice1, charlie1] msgs) -- but everyone should receive leave events @@ -1905,7 +1822,7 @@ testBackendRemoveProposalLocalConvLocalLeaverCommitter = do WS.assertNoEvent (1 # WS.Second) wss -- alice commits the external proposals - events <- createPendingProposalCommit alice1 >>= sendAndConsumeCommit + events <- createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle liftIO $ events @?= [] testBackendRemoveProposalLocalConvRemoteLeaver :: TestM () @@ -1921,7 +1838,7 @@ testBackendRemoveProposalLocalConvRemoteLeaver = do bobClients <- getClientsFromGroupState alice1 bob void . withTempMockFederator' mock $ do mlsBracket [alice1] $ \[wsA] -> void $ do - void $ sendAndConsumeCommit commit + void $ sendAndConsumeCommitBundle commit fedGalleyClient <- view tsFedGalleyClient void $ runFedClient @@ -1934,9 +1851,9 @@ testBackendRemoveProposalLocalConvRemoteLeaver = do curAction = SomeConversationAction SConversationLeaveTag () } - for_ bobClients $ \(_, ref) -> + for_ bobClients $ \(_, idx) -> WS.assertMatch_ (5 # WS.Second) wsA $ - wsAssertBackendRemoveProposal bob (Conv <$> qcnv) ref + wsAssertBackendRemoveProposal bob (Conv <$> qcnv) idx testBackendRemoveProposalLocalConvLocalClient :: TestM () testBackendRemoveProposalLocalConvLocalClient = do @@ -1946,10 +1863,10 @@ testBackendRemoveProposalLocalConvLocalClient = do [alice1, bob1, bob2, charlie1] <- traverse createMLSClient [alice, bob, bob, charlie] traverse_ uploadNewKeyPackage [bob1, bob2, charlie1] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommit - Just (_, kpBob1) <- find (\(ci, _) -> ci == bob1) <$> getClientsFromGroupState alice1 bob + void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommitBundle + Just (_, idxBob1) <- find (\(ci, _) -> ci == bob1) <$> getClientsFromGroupState alice1 bob - mlsBracket [alice1, bob1] $ \[wsA, wsB] -> do + mlsBracket [alice1, bob1, charlie1] $ \[wsA, wsB, wsC] -> do liftTest $ deleteClient (ciUser bob1) (ciClient bob1) (Just defPassword) !!! statusCode === const 200 @@ -1963,15 +1880,15 @@ testBackendRemoveProposalLocalConvLocalClient = do wsAssertClientRemoved (ciClient bob1) msg <- WS.assertMatch (5 # WS.Second) wsA $ \notification -> do - wsAssertBackendRemoveProposal bob (Conv <$> qcnv) kpBob1 notification + wsAssertBackendRemoveProposal bob (Conv <$> qcnv) idxBob1 notification for_ [alice1, bob2, charlie1] $ flip consumeMessage1 msg mp <- createPendingProposalCommit charlie1 - events <- sendAndConsumeCommit mp + events <- sendAndConsumeCommitBundle mp liftIO $ events @?= [] - WS.assertMatchN_ (5 # WS.Second) [wsA, wsB] $ \n -> do + WS.assertMatchN_ (5 # WS.Second) [wsA, wsC] $ \n -> do wsAssertMLSMessage (Conv <$> qcnv) charlie (mpMessage mp) n testBackendRemoveProposalLocalConvRemoteClient :: TestM () @@ -1983,11 +1900,11 @@ testBackendRemoveProposalLocalConvRemoteClient = do (_, qcnv) <- setupMLSGroup alice1 commit <- createAddCommit alice1 [bob] - [(_, bob1KP)] <- getClientsFromGroupState alice1 bob + [(_, idxBob1)] <- getClientsFromGroupState alice1 bob let mock = receiveCommitMock [bob1] <|> welcomeMock <|> messageSentMock void . withTempMockFederator' mock $ do mlsBracket [alice1] $ \[wsA] -> void $ do - void $ sendAndConsumeCommit commit + void $ sendAndConsumeCommitBundle commit fedGalleyClient <- view tsFedGalleyClient void $ @@ -1999,7 +1916,7 @@ testBackendRemoveProposalLocalConvRemoteClient = do WS.assertMatch_ (5 # WS.Second) wsA $ \notification -> - void $ wsAssertBackendRemoveProposal bob (Conv <$> qcnv) bob1KP notification + void $ wsAssertBackendRemoveProposal bob (Conv <$> qcnv) idxBob1 notification testGetGroupInfoOfLocalConv :: TestM () testGetGroupInfoOfLocalConv = do @@ -2014,7 +1931,7 @@ testGetGroupInfoOfLocalConv = do void $ sendAndConsumeCommitBundle commit -- check the group info matches - gs <- assertJust (mpPublicGroupState commit) + gs <- assertJust (mpGroupInfo commit) returnedGS <- liftTest $ getGroupInfo alice (fmap Conv qcnv) liftIO $ gs @=? returnedGS @@ -2057,7 +1974,7 @@ testFederatedGetGroupInfo = do [alice1, bob1] <- traverse createMLSClient [alice, bob] (_, qcnv) <- setupMLSGroup alice1 commit <- createAddCommit alice1 [bob] - groupState <- assertJust (mpPublicGroupState commit) + groupState <- assertJust (mpGroupInfo commit) let mock = receiveCommitMock [bob1] <|> welcomeMock void . withTempMockFederator' mock $ do @@ -2165,7 +2082,7 @@ testRemoteUserPostsCommitBundle = do void $ do let mock = receiveCommitMock [bob1] <|> welcomeMock withTempMockFederator' mock $ do - void $ sendAndConsumeCommit commit + void $ sendAndConsumeCommitBundle commit putOtherMemberQualified (qUnqualified alice) bob (OtherMemberUpdate (Just roleNameWireAdmin)) qcnv !!! const 200 === statusCode @@ -2253,8 +2170,9 @@ testSelfConversationOtherUser = do void $ uploadNewKeyPackage bob1 void $ setupMLSSelfGroup alice1 commit <- createAddCommit alice1 [bob] + bundle <- createBundle commit mlsBracket [alice1, bob1] $ \wss -> do - postMessage (mpSender commit) (mpMessage commit) + localPostCommitBundle (mpSender commit) bundle !!! do const 403 === statusCode const (Just "invalid-op") === fmap Wai.label . responseJsonError @@ -2267,7 +2185,7 @@ testSelfConversationLeave = do clients@(creator : others) <- traverse createMLSClient (replicate 3 alice) traverse_ uploadNewKeyPackage others (_, qcnv) <- setupMLSSelfGroup creator - void $ createAddCommit creator [alice] >>= sendAndConsumeCommit + void $ createAddCommit creator [alice] >>= sendAndConsumeCommitBundle mlsBracket clients $ \wss -> do liftTest $ deleteMemberQualified (qUnqualified alice) alice qcnv @@ -2299,8 +2217,9 @@ postMLSMessageDisabled = do void $ uploadNewKeyPackage bob1 void $ setupMLSGroup alice1 mp <- createAddCommit alice1 [bob] + bundle <- createBundle mp withMLSDisabled $ - postMessage (mpSender mp) (mpMessage mp) + localPostCommitBundle (mpSender mp) bundle !!! assertMLSNotEnabled postMLSBundleDisabled :: TestM () @@ -2323,7 +2242,7 @@ getGroupInfoDisabled = do [alice1, bob1] <- traverse createMLSClient [alice, bob] void $ uploadNewKeyPackage bob1 (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle withMLSDisabled $ localGetGroupInfo (qUnqualified alice) (fmap Conv qcnv) @@ -2384,7 +2303,7 @@ testJoinSubConv = do [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle let subId = SubConvId "conference" sub <- @@ -2395,7 +2314,6 @@ testJoinSubConv = do resetGroup bob1 (fmap (flip SubConv subId) qcnv) (pscGroupId sub) - bobRefsBefore <- getClientsFromGroupState bob1 bob -- bob adds his first client to the subconversation void $ createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle @@ -2404,11 +2322,7 @@ testJoinSubConv = do responseJsonError =<< getSubConv (qUnqualified bob) qcnv subId >= sendAndConsumeCommitBundle - Just (_, kpBob1) <- find (\(ci, _) -> ci == bob1) <$> getClientsFromGroupState alice1 bob + Just (_, idxBob1) <- find (\(ci, _) -> ci == bob1) <$> getClientsFromGroupState alice1 bob -- bob1 leaves and immediately rejoins mlsBracket [alice1, bob1] $ \[wsA, wsB] -> do void $ leaveCurrentConv bob1 qsub WS.assertMatchN_ (5 # WS.Second) [wsA] $ - wsAssertBackendRemoveProposal bob qsub kpBob1 + wsAssertBackendRemoveProposal bob qsub idxBob1 void $ createExternalCommit bob1 Nothing qsub >>= sendAndConsumeCommitBundle @@ -2457,7 +2371,7 @@ testJoinSubNonMemberClient = do traverse createMLSClient [alice, alice, bob] traverse_ uploadNewKeyPackage [bob1, alice2] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [alice] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [alice] >>= sendAndConsumeCommitBundle qcs <- createSubConv qcnv alice1 (SubConvId "conference") @@ -2474,7 +2388,7 @@ testAddClientSubConvFailure = do [alice1, bob1] <- traverse createMLSClient [alice, bob] void $ uploadNewKeyPackage bob1 (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle let subId = SubConvId "conference" void $ createSubConv qcnv alice1 subId @@ -2534,7 +2448,7 @@ testJoinRemoteSubConv = do receiveNewRemoteConv qcs subGroupId -- bob joins subconversation - let pgs = mpPublicGroupState initialCommit + let pgs = mpGroupInfo initialCommit let mock = ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers [])) <|> queryGroupStateMock (fold pgs) bob @@ -2597,7 +2511,7 @@ testRemoteUserJoinSubConv = do void $ do commit <- createAddCommit alice1 [bob] withTempMockFederator' (receiveCommitMock [bob1] <|> welcomeMock) $ - sendAndConsumeCommit commit + sendAndConsumeCommitBundle commit let mock = asum @@ -2650,7 +2564,7 @@ testSendMessageSubConv = do [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle qcs <- createSubConv qcnv bob1 (SubConvId "conference") @@ -2716,7 +2630,7 @@ testRemoteMemberGetSubConv isAMember = do let mock = receiveCommitMock [bob1] <|> welcomeMock <|> claimKeyPackagesMock kpb void . withTempMockFederator' mock $ - sendAndConsumeCommit mp + sendAndConsumeCommitBundle mp let subconv = SubConvId "conference" @@ -2765,7 +2679,7 @@ testRemoteMemberDeleteSubConv isAMember = do mp <- createAddCommit alice1 [bob] let mock = receiveCommitMock [bob1] <|> welcomeMock - void . withTempMockFederator' mock . sendAndConsumeCommit $ mp + void . withTempMockFederator' mock . sendAndConsumeCommitBundle $ mp sub <- liftTest $ @@ -2953,7 +2867,7 @@ testDeleteParentOfSubConv = do (parentGroupId, qcnv) <- setupMLSGroup alice1 (qcs, _) <- withTempMockFederator' (receiveCommitMock [bob1]) $ do - void $ createAddCommit alice1 [arthur, bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [arthur, bob] >>= sendAndConsumeCommitBundle createSubConv qcnv alice1 sconv subGid <- getCurrentGroupId @@ -3014,7 +2928,7 @@ testDeleteRemoteParentOfSubConv = do -- inform backend about the subconversation receiveNewRemoteConv qcs subGroupId - let pgs = mpPublicGroupState initialCommit + let pgs = mpGroupInfo initialCommit let mock = ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers [])) <|> queryGroupStateMock (fold pgs) bob @@ -3134,7 +3048,7 @@ testLeaveSubConv isSubConvCreator = do <|> ("on-mls-message-sent" ~> RemoteMLSMessageOk) ) $ do - void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommitBundle qsub <- createSubConv qcnv bob1 subId void $ createExternalCommit alice1 Nothing qsub >>= sendAndConsumeCommitBundle @@ -3144,7 +3058,7 @@ testLeaveSubConv isSubConvCreator = do let firstLeaver = if isSubConvCreator then bob1 else alice1 -- a member leaves the subconversation - [firstLeaverKP] <- + [idxFirstLeaver] <- map snd . filter (\(cid, _) -> cid == firstLeaver) <$> getClientsFromGroupState alice1 @@ -3169,7 +3083,7 @@ testLeaveSubConv isSubConvCreator = do wsAssertBackendRemoveProposal (cidQualifiedUser firstLeaver) (Conv <$> qcnv) - firstLeaverKP + idxFirstLeaver traverse_ (uncurry consumeMessage1) (zip others msgs) -- assert the leaver gets no proposal or event void . liftIO $ WS.assertNoEvent (5 # WS.Second) [wsLeaver] @@ -3178,7 +3092,7 @@ testLeaveSubConv isSubConvCreator = do do leaveCommit <- createPendingProposalCommit (head others) mlsBracket (firstLeaver : others) $ \(wsLeaver : wss) -> do - events <- sendAndConsumeCommit leaveCommit + events <- sendAndConsumeCommitBundle leaveCommit liftIO $ events @?= [] WS.assertMatchN_ (5 # WS.Second) wss $ \n -> do wsAssertMLSMessage qsub (cidQualifiedUser . head $ others) (mpMessage leaveCommit) n @@ -3205,7 +3119,7 @@ testLeaveSubConv isSubConvCreator = do liftIO $ length (pscMembers psc) @?= 3 -- charlie1 leaves - [charlie1KP] <- + [idxCharlie1] <- map snd . filter (\(cid, _) -> cid == charlie1) <$> getClientsFromGroupState (head others) charlie mlsBracket others $ \wss -> do @@ -3213,7 +3127,7 @@ testLeaveSubConv isSubConvCreator = do msgs <- WS.assertMatchN (5 # WS.Second) wss $ - wsAssertBackendRemoveProposal charlie (Conv <$> qcnv) charlie1KP + wsAssertBackendRemoveProposal charlie (Conv <$> qcnv) idxCharlie1 traverse_ (uncurry consumeMessage1) (zip others msgs) -- a member commits the pending proposal @@ -3239,7 +3153,7 @@ testLeaveSubConvNonMember = do [alice1, bob1] <- traverse createMLSClient [alice, bob] void $ uploadNewKeyPackage bob1 (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle let subId = SubConvId "conference" _qsub <- createSubConv qcnv bob1 subId @@ -3284,7 +3198,7 @@ testLeaveRemoteSubConv = do -- inform backend about the subconversation receiveNewRemoteConv qcs subGroupId - let pgs = mpPublicGroupState initialCommit + let pgs = mpGroupInfo initialCommit let mock = ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers [])) <|> queryGroupStateMock (fold pgs) bob @@ -3305,18 +3219,18 @@ testLeaveRemoteSubConv = do testRemoveUserParent :: TestM () testRemoveUserParent = do [alice, bob, charlie] <- createAndConnectUsers [Nothing, Nothing, Nothing] + let subname = SubConvId "conference" - runMLSTest $ + (qcnv, [alice1, bob1, bob2, _charlie1, _charlie2]) <- runMLSTest $ do - [alice1, bob1, bob2, charlie1, charlie2] <- + clients@[alice1, bob1, bob2, charlie1, charlie2] <- traverse createMLSClient [alice, bob, bob, charlie, charlie] traverse_ uploadNewKeyPackage [bob1, bob2, charlie1, charlie2] (_, qcnv) <- setupMLSGroup alice1 - void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommit + void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommitBundle - let subname = SubConvId "conference" void $ createSubConv qcnv bob1 subname let qcs = fmap (flip SubConv subname) qcnv @@ -3324,61 +3238,40 @@ testRemoveUserParent = do for_ [alice1, bob2, charlie1, charlie2] $ \c -> void $ createExternalCommit c Nothing qcs >>= sendAndConsumeCommitBundle - [(_, kpref1), (_, kpref2)] <- getClientsFromGroupState alice1 charlie - - -- charlie leaves the main conversation - mlsBracket [alice1, bob1, bob2] $ \wss -> do - liftTest $ do - deleteMemberQualified (qUnqualified charlie) charlie qcnv - !!! const 200 === statusCode - - -- Remove charlie from our state as well - State.modify $ \mls -> - mls - { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [charlie1, charlie2]) - } - - msg1 <- WS.assertMatchN (5 # Second) wss $ \n -> - wsAssertBackendRemoveProposal charlie (Conv <$> qcnv) kpref1 n - - traverse_ (uncurry consumeMessage1) (zip [alice1, bob1, bob2] msg1) - - msg2 <- WS.assertMatchN (5 # Second) wss $ \n -> - wsAssertBackendRemoveProposal charlie (Conv <$> qcnv) kpref2 n + pure (qcnv, clients) - traverse_ (uncurry consumeMessage1) (zip [alice1, bob1, bob2] msg2) + -- charlie leaves the main conversation + deleteMemberQualified (qUnqualified charlie) charlie qcnv + !!! const 200 === statusCode - void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle + getSubConv (qUnqualified charlie) qcnv subname + !!! const 403 === statusCode - liftTest $ do - getSubConv (qUnqualified charlie) qcnv (SubConvId "conference") - !!! const 403 === statusCode - - sub :: PublicSubConversation <- - responseJsonError - =<< getSubConv (qUnqualified bob) qcnv (SubConvId "conference") - >= sendAndConsumeCommit + void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommitBundle - let subname = SubConvId "conference" void $ createSubConv qcnv alice1 subname let qcs = fmap (flip SubConv subname) qcnv @@ -3386,54 +3279,36 @@ testRemoveCreatorParent = do for_ [bob1, bob2, charlie1, charlie2] $ \c -> void $ createExternalCommit c Nothing qcs >>= sendAndConsumeCommitBundle - [(_, kpref1)] <- getClientsFromGroupState alice1 alice - - -- creator leaves the main conversation - mlsBracket [bob1, bob2, charlie1, charlie2] $ \wss -> do - liftTest $ do - deleteMemberQualified (qUnqualified alice) alice qcnv - !!! const 200 === statusCode - - -- Remove alice1 from our state as well - State.modify $ \mls -> - mls - { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [alice1]) - } + pure (qcnv, clients) - msg <- WS.assertMatchN (5 # Second) wss $ \n -> - -- Checks proposal for subconv, parent doesn't get one - -- since alice is not notified of her own removal - wsAssertBackendRemoveProposal alice (Conv <$> qcnv) kpref1 n + -- creator leaves the main conversation + deleteMemberQualified (qUnqualified alice) alice qcnv + !!! const 200 === statusCode - traverse_ (uncurry consumeMessage1) (zip [bob1, bob2, charlie1, charlie2] msg) + getSubConv (qUnqualified alice) qcnv subname + !!! const 403 === statusCode - void $ createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle - - liftTest $ do - getSubConv (qUnqualified alice) qcnv subname - !!! const 403 === statusCode - - -- charlie sees updated memberlist - sub :: PublicSubConversation <- - responseJsonError - =<< getSubConv (qUnqualified charlie) qcnv subname - >= sendAndConsumeCommit + void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommitBundle stateParent <- State.get @@ -3474,13 +3349,13 @@ testCreatorRemovesUserFromParent = do State.put stateSub -- Get client state for alice and fetch bob client identities - [(_, kprefBob1), (_, kprefBob2)] <- getClientsFromGroupState alice1 bob + [(_, idxBob1), (_, idxBob2)] <- getClientsFromGroupState alice1 bob -- handle bob1 removal msgs <- WS.assertMatchN (5 # Second) wss $ \n -> do -- it was an alice proposal for the parent, -- but it's a backend proposal for the sub - wsAssertBackendRemoveProposal bob qcs kprefBob1 n + wsAssertBackendRemoveProposal bob qcs idxBob1 n traverse_ (uncurry consumeMessage1) (zip [alice1, charlie1, charlie2] msgs) @@ -3488,7 +3363,7 @@ testCreatorRemovesUserFromParent = do msgs2 <- WS.assertMatchN (5 # Second) wss $ \n -> do -- it was an alice proposal for the parent, -- but it's a backend proposal for the sub - wsAssertBackendRemoveProposal bob qcs kprefBob2 n + wsAssertBackendRemoveProposal bob qcs idxBob2 n traverse_ (uncurry consumeMessage1) (zip [alice1, charlie1, charlie2] msgs2) diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index bb59cb8cdb..542f3e6cd6 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -26,21 +26,22 @@ import Bilge import Bilge.Assert import Control.Arrow ((&&&)) import Control.Error.Util -import Control.Lens (preview, to, view, (.~), (^..)) +import Control.Lens (preview, to, view, (.~), (^..), (^?)) import Control.Monad.Catch +import Control.Monad.Cont import Control.Monad.State (StateT, evalStateT) import qualified Control.Monad.State as State import Control.Monad.Trans.Maybe -import Crypto.PubKey.Ed25519 import Data.Aeson.Lens +import Data.Bifunctor import Data.Binary.Builder (toLazyByteString) +import Data.Binary.Get import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.URL as B64U import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LBS import Data.Domain -import Data.Hex import Data.Id import Data.Json.Util hiding ((#)) import qualified Data.Map as Map @@ -75,11 +76,10 @@ import Wire.API.Federation.API.Galley import Wire.API.MLS.CipherSuite import Wire.API.MLS.CommitBundle import Wire.API.MLS.Credential -import Wire.API.MLS.GroupInfoBundle import Wire.API.MLS.KeyPackage import Wire.API.MLS.Keys +import Wire.API.MLS.LeafNode import Wire.API.MLS.Message -import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.User.Client @@ -89,24 +89,10 @@ cid2Str :: ClientIdentity -> String cid2Str cid = show (ciUser cid) <> ":" - <> T.unpack (client . ciClient $ cid) + <> T.unpack cid.ciClient.client <> "@" <> T.unpack (domainText (ciDomain cid)) -mapRemoteKeyPackageRef :: - (MonadIO m, MonadHttp m, MonadCatch m) => - (Request -> Request) -> - KeyPackageBundle -> - m () -mapRemoteKeyPackageRef brig bundle = - void $ - put - ( brig - . paths ["i", "mls", "key-package-refs"] - . json bundle - ) - !!! const 204 === statusCode - postMessage :: ( HasCallStack, MonadIO m, @@ -124,7 +110,7 @@ postMessage sender msg = do . zUser (ciUser sender) . zClient (ciClient sender) . zConn "conn" - . content "message/mls" + . Bilge.content "message/mls" . bytes msg ) @@ -145,7 +131,7 @@ localPostCommitBundle sender bundle = do . zUser (ciUser sender) . zClient (ciClient sender) . zConn "conn" - . content "application/x-protobuf" + . Bilge.content "message/mls" . bytes bundle ) @@ -201,49 +187,6 @@ postCommitBundle sender qcs bundle = do (\rsender -> remotePostCommitBundle rsender qcs bundle) (cidQualifiedUser sender $> sender) --- FUTUREWORK: remove this and start using commit bundles everywhere in tests -postWelcome :: - ( MonadIO m, - MonadHttp m, - MonadReader TestSetup m, - HasCallStack - ) => - UserId -> - ByteString -> - m ResponseLBS -postWelcome uid welcome = do - galley <- view tsUnversionedGalley - post - ( galley - . paths ["v2", "mls", "welcome"] - . zUser uid - . zConn "conn" - . content "message/mls" - . bytes welcome - ) - -mkAppAckProposalMessage :: - GroupId -> - Epoch -> - KeyPackageRef -> - [MessageRange] -> - SecretKey -> - PublicKey -> - Message 'MLSPlainText -mkAppAckProposalMessage gid epoch ref mrs priv pub = do - let tbs = - mkRawMLS $ - MessageTBS - { tbsMsgFormat = KnownFormatTag, - tbsMsgGroupId = gid, - tbsMsgEpoch = epoch, - tbsMsgAuthData = mempty, - tbsMsgSender = MemberSender ref, - tbsMsgPayload = ProposalMessage (mkAppAckProposal mrs) - } - sig = BA.convert $ sign priv pub (rmRaw tbs) - in Message tbs (MessageExtraFields sig Nothing Nothing) - saveRemovalKey :: FilePath -> TestM () saveRemovalKey fp = do keys <- fromJust <$> view (tsGConf . optSettings . setMlsPrivateKeyPaths) @@ -316,7 +259,7 @@ data MessagePackage = MessagePackage { mpSender :: ClientIdentity, mpMessage :: ByteString, mpWelcome :: Maybe ByteString, - mpPublicGroupState :: Maybe ByteString + mpGroupInfo :: Maybe ByteString } deriving (Show) @@ -424,7 +367,7 @@ createFakeMLSClient qusr = do pure cid -- | create and upload to backend -uploadNewKeyPackage :: HasCallStack => ClientIdentity -> MLSTest KeyPackageRef +uploadNewKeyPackage :: HasCallStack => ClientIdentity -> MLSTest (RawMLS KeyPackage) uploadNewKeyPackage qcid = do (kp, _) <- generateKeyPackage qcid @@ -437,14 +380,13 @@ uploadNewKeyPackage qcid = do . json (KeyPackageUpload [kp]) ) !!! const 201 === statusCode - pure $ fromJust (kpRef' kp) + pure kp generateKeyPackage :: HasCallStack => ClientIdentity -> MLSTest (RawMLS KeyPackage, KeyPackageRef) generateKeyPackage qcid = do - kp <- liftIO . decodeMLSError =<< mlscli qcid ["key-package", "create"] Nothing + kpData <- mlscli qcid ["key-package", "create"] Nothing + kp <- liftIO $ decodeMLSError kpData let ref = fromJust (kpRef' kp) - fp <- keyPackageFile qcid ref - liftIO $ BS.writeFile fp (rmRaw kp) pure (kp, ref) setClientGroupState :: HasCallStack => ClientIdentity -> ByteString -> MLSTest () @@ -530,7 +472,17 @@ resetGroup cid qcs gid = do resetClientGroup :: ClientIdentity -> GroupId -> MLSTest () resetClientGroup cid gid = do - groupJSON <- mlscli cid ["group", "create", T.unpack (toBase64Text (unGroupId gid))] Nothing + bd <- State.gets mlsBaseDir + groupJSON <- + mlscli + cid + [ "group", + "create", + "--removal-key", + bd "removal.key", + T.unpack (toBase64Text (unGroupId gid)) + ] + Nothing setClientGroupState cid groupJSON getConvId :: MLSTest (Qualified ConvOrSubConvId) @@ -572,13 +524,6 @@ fakeGroupId = liftIO $ fmap (GroupId . BS.pack) (replicateM 32 (generate arbitrary)) -keyPackageFile :: HasCallStack => ClientIdentity -> KeyPackageRef -> MLSTest FilePath -keyPackageFile qcid ref = - State.gets $ \mls -> - mlsBaseDir mls - cid2Str qcid - T.unpack (T.decodeUtf8 (hex (unKeyPackageRef ref))) - claimLocalKeyPackages :: HasCallStack => ClientIdentity -> Local UserId -> MLSTest KeyPackageBundle claimLocalKeyPackages qcid lusr = do brig <- viewBrig @@ -604,20 +549,17 @@ getUserClients qusr = do -- | Generate one key package for each client of a remote user claimRemoteKeyPackages :: HasCallStack => Remote UserId -> MLSTest KeyPackageBundle claimRemoteKeyPackages (tUntagged -> qusr) = do - brig <- viewBrig clients <- getUserClients qusr - bundle <- fmap (KeyPackageBundle . Set.fromList) $ + fmap (KeyPackageBundle . Set.fromList) $ for clients $ \cid -> do (kp, ref) <- generateKeyPackage cid pure $ KeyPackageBundleEntry - { kpbeUser = qusr, - kpbeClient = ciClient cid, - kpbeRef = ref, - kpbeKeyPackage = KeyPackageData (rmRaw kp) + { user = qusr, + client = ciClient cid, + ref = ref, + keyPackage = KeyPackageData (raw kp) } - mapRemoteKeyPackageRef brig bundle - pure bundle -- | Claim key package for a local user, or generate and map key packages for remote ones. claimKeyPackages :: @@ -629,16 +571,13 @@ claimKeyPackages cid qusr = do loc <- liftTest $ qualifyLocal () foldQualified loc (claimLocalKeyPackages cid) claimRemoteKeyPackages qusr -bundleKeyPackages :: KeyPackageBundle -> MLSTest [(ClientIdentity, FilePath)] -bundleKeyPackages bundle = do - let bundleEntries = kpbEntries bundle - entryIdentity be = mkClientIdentity (kpbeUser be) (kpbeClient be) - for (toList bundleEntries) $ \be -> do - let d = kpData . kpbeKeyPackage $ be - qcid = entryIdentity be - fn <- keyPackageFile qcid (kpbeRef be) - liftIO $ BS.writeFile fn d - pure (qcid, fn) +bundleKeyPackages :: KeyPackageBundle -> [(ClientIdentity, ByteString)] +bundleKeyPackages bundle = + let getEntry be = + ( mkClientIdentity be.user be.client, + kpData be.keyPackage + ) + in map getEntry (toList bundle.entries) -- | Claim keypackages and create a commit/welcome pair on a given client. -- Note that this alters the state of the group immediately. If we want to test @@ -646,7 +585,7 @@ bundleKeyPackages bundle = do -- group to the previous state by using an older version of the group file. createAddCommit :: HasCallStack => ClientIdentity -> [Qualified UserId] -> MLSTest MessagePackage createAddCommit cid users = do - kps <- concat <$> traverse (bundleKeyPackages <=< claimKeyPackages cid) users + kps <- fmap (concatMap bundleKeyPackages) . traverse (claimKeyPackages cid) $ users liftIO $ assertBool "no key packages could be claimed" (not (null kps)) createAddCommitWithKeyPackages cid kps @@ -666,9 +605,9 @@ createExternalCommit qcid mpgs qcs = do mlscli qcid [ "external-commit", - "--group-state-in", + "--group-info-in", "-", - "--group-state-out", + "--group-info-out", pgsFile, "--group-out", "" @@ -677,8 +616,8 @@ createExternalCommit qcid mpgs qcs = do State.modify $ \mls -> mls - { mlsNewMembers = Set.singleton qcid -- This might be a different client - -- than those that have been in the + { mlsNewMembers = Set.singleton qcid + -- This might be a different client than those that have been in the -- group from before. } @@ -688,12 +627,12 @@ createExternalCommit qcid mpgs qcs = do { mpSender = qcid, mpMessage = commit, mpWelcome = Nothing, - mpPublicGroupState = Just newPgs + mpGroupInfo = Just newPgs } createAddProposals :: HasCallStack => ClientIdentity -> [Qualified UserId] -> MLSTest [MessagePackage] createAddProposals cid users = do - kps <- concat <$> traverse (bundleKeyPackages <=< claimKeyPackages cid) users + kps <- fmap (concatMap bundleKeyPackages) . traverse (claimKeyPackages cid) $ users traverse (createAddProposalWithKeyPackage cid) kps -- | Create an application message. @@ -714,18 +653,19 @@ createApplicationMessage cid messageContent = do { mpSender = cid, mpMessage = message, mpWelcome = Nothing, - mpPublicGroupState = Nothing + mpGroupInfo = Nothing } createAddCommitWithKeyPackages :: ClientIdentity -> - [(ClientIdentity, FilePath)] -> + [(ClientIdentity, ByteString)] -> MLSTest MessagePackage createAddCommitWithKeyPackages qcid clientsAndKeyPackages = do bd <- State.gets mlsBaseDir welcomeFile <- liftIO $ emptyTempFile bd "welcome" - pgsFile <- liftIO $ emptyTempFile bd "pgs" - commit <- + giFile <- liftIO $ emptyTempFile bd "gi" + + commit <- runContT (traverse (withTempKeyPackageFile . snd) clientsAndKeyPackages) $ \kpFiles -> mlscli qcid ( [ "member", @@ -734,12 +674,12 @@ createAddCommitWithKeyPackages qcid clientsAndKeyPackages = do "", "--welcome-out", welcomeFile, - "--group-state-out", - pgsFile, + "--group-info-out", + giFile, "--group-out", "" ] - <> map snd clientsAndKeyPackages + <> kpFiles ) Nothing @@ -749,31 +689,31 @@ createAddCommitWithKeyPackages qcid clientsAndKeyPackages = do } welcome <- liftIO $ BS.readFile welcomeFile - pgs <- liftIO $ BS.readFile pgsFile + gi <- liftIO $ BS.readFile giFile pure $ MessagePackage { mpSender = qcid, mpMessage = commit, mpWelcome = Just welcome, - mpPublicGroupState = Just pgs + mpGroupInfo = Just gi } createAddProposalWithKeyPackage :: ClientIdentity -> - (ClientIdentity, FilePath) -> + (ClientIdentity, ByteString) -> MLSTest MessagePackage createAddProposalWithKeyPackage cid (_, kp) = do - prop <- + prop <- runContT (withTempKeyPackageFile kp) $ \kpFile -> mlscli cid - ["proposal", "--group-in", "", "--group-out", "", "add", kp] + ["proposal", "--group-in", "", "--group-out", "", "add", kpFile] Nothing pure MessagePackage { mpSender = cid, mpMessage = prop, mpWelcome = Nothing, - mpPublicGroupState = Nothing + mpGroupInfo = Nothing } createPendingProposalCommit :: HasCallStack => ClientIdentity -> MLSTest MessagePackage @@ -791,7 +731,7 @@ createPendingProposalCommit qcid = do "", "--welcome-out", welcomeFile, - "--group-state-out", + "--group-info-out", pgsFile ] Nothing @@ -803,7 +743,7 @@ createPendingProposalCommit qcid = do { mpSender = qcid, mpMessage = commit, mpWelcome = welcome, - mpPublicGroupState = Just pgs + mpGroupInfo = Just pgs } readWelcome :: FilePath -> IO (Maybe ByteString) @@ -821,10 +761,8 @@ createRemoveCommit cid targets = do g <- getClientGroupState cid - let kprefByClient = Map.fromList (readGroupState g) - let fetchKeyPackage c = keyPackageFile c (kprefByClient Map.! c) - kps <- traverse fetchKeyPackage targets - + let groupStateMap = Map.fromList (readGroupState g) + let indices = map (fromMaybe (error "could not find target") . flip Map.lookup groupStateMap) targets commit <- mlscli cid @@ -836,10 +774,10 @@ createRemoveCommit cid targets = do "", "--welcome-out", welcomeFile, - "--group-state-out", + "--group-info-out", pgsFile ] - <> kps + <> map show indices ) Nothing welcome <- liftIO $ readWelcome welcomeFile @@ -849,7 +787,7 @@ createRemoveCommit cid targets = do { mpSender = cid, mpMessage = commit, mpWelcome = welcome, - mpPublicGroupState = Just pgs + mpGroupInfo = Just pgs } createExternalAddProposal :: HasCallStack => ClientIdentity -> MLSTest MessagePackage @@ -862,7 +800,7 @@ createExternalAddProposal joiner = do proposal <- mlscli joiner - [ "proposal-external", + [ "external-proposal", "--group-id", T.unpack (toBase64Text (unGroupId groupId)), "--epoch", @@ -880,7 +818,7 @@ createExternalAddProposal joiner = do { mpSender = joiner, mpMessage = proposal, mpWelcome = Nothing, - mpPublicGroupState = Nothing + mpGroupInfo = Nothing } consumeWelcome :: HasCallStack => ByteString -> MLSTest () @@ -888,7 +826,7 @@ consumeWelcome welcome = do qcids <- State.gets mlsNewMembers for_ qcids $ \qcid -> do hasState <- hasClientGroupState qcid - liftIO $ assertBool "Existing clients in a conversation should not consume commits" (not hasState) + liftIO $ assertBool "Existing clients in a conversation should not consume welcomes" (not hasState) void $ mlscli qcid @@ -908,8 +846,7 @@ consumeMessage msg = do consumeMessage1 cid (mpMessage msg) consumeMessage1 :: HasCallStack => ClientIdentity -> ByteString -> MLSTest () -consumeMessage1 cid msg = do - bd <- State.gets mlsBaseDir +consumeMessage1 cid msg = void $ mlscli cid @@ -918,8 +855,6 @@ consumeMessage1 cid msg = do "", "--group-out", "", - "--signer-key", - bd "removal.key", "-" ] (Just msg) @@ -928,55 +863,33 @@ consumeMessage1 cid msg = do -- commit, the 'sendAndConsumeCommit' function should be used instead. sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], UnreachableUsers) sendAndConsumeMessage mp = do + for_ mp.mpWelcome $ \_ -> liftIO $ assertFailure "use sendAndConsumeCommitBundle" res <- fmap (mmssEvents Tuple.&&& mmssUnreachableUsers) $ responseJsonError =<< postMessage (mpSender mp) (mpMessage mp) do - postWelcome (ciUser (mpSender mp)) welcome - !!! const 201 === statusCode - consumeWelcome welcome - pure res --- | Send an MLS commit message, simulate clients receiving it, and update the --- test state accordingly. -sendAndConsumeCommit :: - HasCallStack => - MessagePackage -> - MLSTest [Event] -sendAndConsumeCommit mp = do - (events, _) <- sendAndConsumeMessage mp - - -- increment epoch and add new clients - State.modify $ \mls -> - mls - { mlsEpoch = mlsEpoch mls + 1, - mlsMembers = mlsMembers mls <> mlsNewMembers mls, - mlsNewMembers = mempty - } - - pure events - mkBundle :: MessagePackage -> Either Text CommitBundle mkBundle mp = do - commitB <- decodeMLS' (mpMessage mp) - welcomeB <- traverse decodeMLS' (mpWelcome mp) - pgs <- note "public group state unavailable" (mpPublicGroupState mp) - pgsB <- decodeMLS' pgs - pure $ - CommitBundle commitB welcomeB $ - GroupInfoBundle UnencryptedGroupInfo TreeFull pgsB - -createBundle :: MonadIO m => MessagePackage -> m ByteString + commitB <- first ("Commit: " <>) $ decodeMLS' (mpMessage mp) + welcomeB <- first ("Welcome: " <>) $ for (mpWelcome mp) $ \m -> do + w <- decodeMLS' @Message m + case w.content of + MessageWelcome welcomeB -> pure welcomeB + _ -> Left "expected welcome" + ginfo <- note "group info unavailable" (mpGroupInfo mp) + ginfoB <- first ("GroupInfo: " <>) $ decodeMLS' ginfo + pure $ CommitBundle commitB welcomeB ginfoB + +createBundle :: (HasCallStack, MonadIO m) => MessagePackage -> m ByteString createBundle mp = do bundle <- either (liftIO . assertFailure . T.unpack) pure $ mkBundle mp - pure (serializeCommitBundle bundle) + pure (encodeMLS' bundle) sendAndConsumeCommitBundle :: HasCallStack => @@ -1008,20 +921,23 @@ mlsBracket clients k = do c <- view tsCannon WS.bracketAsClientRN c (map (ciUser &&& ciClient) clients) k -readGroupState :: ByteString -> [(ClientIdentity, KeyPackageRef)] +readGroupState :: ByteString -> [(ClientIdentity, LeafIndex)] readGroupState j = do - node <- j ^.. key "group" . key "tree" . key "tree" . key "nodes" . _Array . traverse - leafNode <- node ^.. key "node" . key "LeafNode" - identity <- - either (const []) pure . decodeMLS' . BS.pack . map fromIntegral $ - leafNode ^.. key "key_package" . key "payload" . key "credential" . key "credential" . key "Basic" . key "identity" . key "vec" . _Array . traverse . _Integer - kpr <- (unhexM . T.encodeUtf8 =<<) $ leafNode ^.. key "key_package_ref" . _String - pure (identity, KeyPackageRef kpr) + (node, n) <- zip (j ^.. key "group" . key "public_group" . key "treesync" . key "tree" . key "leaf_nodes" . _Array . traverse) [0 ..] + case node ^? key "node" of + Just leafNode -> do + identityBytes <- leafNode ^.. key "payload" . key "credential" . key "credential" . key "Basic" . key "identity" . key "vec" + let identity = BS.pack (identityBytes ^.. _Array . traverse . _Integer . to fromIntegral) + cid <- case decodeMLS' identity of + Left _ -> [] + Right x -> pure x + pure (cid, n) + Nothing -> [] getClientsFromGroupState :: ClientIdentity -> Qualified UserId -> - MLSTest [(ClientIdentity, KeyPackageRef)] + MLSTest [(ClientIdentity, LeafIndex)] getClientsFromGroupState cid u = do groupState <- readGroupState <$> getClientGroupState cid pure $ filter (\(cid', _) -> cidQualifiedUser cid' == u) groupState @@ -1032,11 +948,11 @@ clientKeyPair cid = do credential <- liftIO . BS.readFile $ bd cid2Str cid "store" T.unpack (T.decodeUtf8 (B64U.encode "self")) - let s = - credential ^.. key "signature_private_key" . key "value" . _Array . traverse . _Integer - & fmap fromIntegral - & BS.pack - pure $ BS.splitAt 32 s + case runGetOrFail + ((,) <$> parseMLSBytes @VarInt <*> parseMLSBytes @VarInt) + (LBS.fromStrict credential) of + Left (_, _, msg) -> liftIO $ assertFailure msg + Right (_, _, keys) -> pure keys receiveNewRemoteConv :: (MonadReader TestSetup m, MonadIO m) => @@ -1313,3 +1229,14 @@ getCurrentGroupId = do State.gets mlsGroupId >>= \case Nothing -> liftIO $ assertFailure "Creating add proposal for non-existing group" Just g -> pure g + +withTempKeyPackageFile :: ByteString -> ContT a MLSTest FilePath +withTempKeyPackageFile bs = do + bd <- State.gets mlsBaseDir + ContT $ \k -> + bracket + (liftIO (openBinaryTempFile bd "kp")) + (\(fp, _) -> liftIO (removeFile fp)) + $ \(fp, h) -> do + liftIO $ BS.hPut h bs `finally` hClose h + k fp diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 0d35e8fafe..d00521efdd 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -121,7 +121,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Domain (originDomainHeaderName) import Wire.API.Internal.Notification hiding (target) -import Wire.API.MLS.KeyPackage +import Wire.API.MLS.LeafNode import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation @@ -2899,32 +2899,33 @@ wsAssertConvReceiptModeUpdate conv usr new n = do evtFrom e @?= usr evtData e @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate new) -wsAssertBackendRemoveProposalWithEpoch :: HasCallStack => Qualified UserId -> Qualified ConvId -> KeyPackageRef -> Epoch -> Notification -> IO ByteString -wsAssertBackendRemoveProposalWithEpoch fromUser convId kpref epoch n = do - bs <- wsAssertBackendRemoveProposal fromUser (Conv <$> convId) kpref n - let msg = fromRight (error "Failed to parse Message 'MLSPlaintext") $ decodeMLS' @(Message 'MLSPlainText) bs - let tbs = rmValue . msgTBS $ msg - tbsMsgEpoch tbs @?= epoch +wsAssertBackendRemoveProposalWithEpoch :: HasCallStack => Qualified UserId -> Qualified ConvId -> LeafIndex -> Epoch -> Notification -> IO ByteString +wsAssertBackendRemoveProposalWithEpoch fromUser convId idx epoch n = do + bs <- wsAssertBackendRemoveProposal fromUser (Conv <$> convId) idx n + let msg = fromRight (error "Failed to parse Message") $ decodeMLS' @Message bs + case msg.content of + MessagePublic pmsg -> liftIO $ pmsg.content.value.epoch @?= epoch + _ -> assertFailure "unexpected message content" pure bs -wsAssertBackendRemoveProposal :: HasCallStack => Qualified UserId -> Qualified ConvOrSubConvId -> KeyPackageRef -> Notification -> IO ByteString -wsAssertBackendRemoveProposal fromUser cnvOrSubCnv kpref n = do +wsAssertBackendRemoveProposal :: HasCallStack => Qualified UserId -> Qualified ConvOrSubConvId -> LeafIndex -> Notification -> IO ByteString +wsAssertBackendRemoveProposal fromUser cnvOrSubCnv idx n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False evtConv e @?= convOfConvOrSub <$> cnvOrSubCnv evtType e @?= MLSMessageAdd evtFrom e @?= fromUser let bs = getMLSMessageData (evtData e) - let msg = fromRight (error "Failed to parse Message 'MLSPlaintext") $ decodeMLS' bs - let tbs = rmValue . msgTBS $ msg - tbsMsgSender tbs @?= PreconfiguredSender 0 - case tbsMsgPayload tbs of - ProposalMessage rp -> - case rmValue rp of - RemoveProposal kpRefRemove -> - kpRefRemove @?= kpref - otherProp -> assertFailure $ "Expected RemoveProposal but got " <> show otherProp - otherPayload -> assertFailure $ "Expected ProposalMessage but got " <> show otherPayload + let msg = fromRight (error "Failed to parse Message") $ decodeMLS' @Message bs + liftIO $ case msg.content of + MessagePublic pmsg -> do + pmsg.content.value.sender @?= SenderExternal 0 + case pmsg.content.value.content of + FramedContentProposal prop -> case prop.value of + RemoveProposal removedIdx -> removedIdx @?= idx + otherProp -> assertFailure $ "Expected RemoveProposal but got " <> show otherProp + otherPayload -> assertFailure $ "Expected ProposalMessage but got " <> show otherPayload + _ -> assertFailure $ "Expected PublicMessage" pure bs where getMLSMessageData :: Conv.EventData -> ByteString @@ -2944,19 +2945,16 @@ wsAssertAddProposal fromUser convId n = do evtType e @?= MLSMessageAdd evtFrom e @?= fromUser let bs = getMLSMessageData (evtData e) - let msg = fromRight (error "Failed to parse Message 'MLSPlaintext") $ decodeMLS' bs - let tbs = rmValue . msgTBS $ msg - tbsMsgSender tbs @?= NewMemberSender - case tbsMsgPayload tbs of - ProposalMessage rp -> - case rmValue rp of - AddProposal _ -> pure () - otherProp -> - assertFailure $ - "Expected AddProposal but got " <> show otherProp - otherPayload -> - assertFailure $ - "Expected ProposalMessage but got " <> show otherPayload + let msg = fromRight (error "Failed to parse Message 'MLSPlaintext") $ decodeMLS' @Message bs + liftIO $ case msg.content of + MessagePublic pmsg -> do + pmsg.content.value.sender @?= SenderNewMemberProposal + case pmsg.content.value.content of + FramedContentProposal prop -> case prop.value of + AddProposal _ -> pure () + otherProp -> assertFailure $ "Expected AddProposal but got " <> show otherProp + otherPayload -> assertFailure $ "Expected ProposalMessage but got " <> show otherPayload + _ -> assertFailure $ "Expected PublicMessage" pure bs where getMLSMessageData :: Conv.EventData -> ByteString diff --git a/services/galley/test/integration/Main.hs b/services/galley/test/integration/Run.hs similarity index 99% rename from services/galley/test/integration/Main.hs rename to services/galley/test/integration/Run.hs index c67d355dfa..c35edc8d5e 100644 --- a/services/galley/test/integration/Main.hs +++ b/services/galley/test/integration/Run.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main +module Run ( main, ) where diff --git a/services/galley/test/unit.hs b/services/galley/test/unit.hs new file mode 100644 index 0000000000..a26473d24e --- /dev/null +++ b/services/galley/test/unit.hs @@ -0,0 +1 @@ +import Run diff --git a/services/galley/test/unit/Main.hs b/services/galley/test/unit/Run.hs similarity index 99% rename from services/galley/test/unit/Main.hs rename to services/galley/test/unit/Run.hs index fbf969775e..57963cefef 100644 --- a/services/galley/test/unit/Main.hs +++ b/services/galley/test/unit/Run.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Main +module Run ( main, ) where diff --git a/services/nginz/integration-test/conf/nginz/README.md b/services/nginz/integration-test/conf/nginz/README.md new file mode 100644 index 0000000000..c8e81957c6 --- /dev/null +++ b/services/nginz/integration-test/conf/nginz/README.md @@ -0,0 +1,7 @@ +# How to regenerate certificates in this directory + +Run from this directory: + +```bash +../../../../../hack/bin/selfsigned.sh +``` diff --git a/services/nginz/integration-test/conf/nginz/integration-ca-key.pem b/services/nginz/integration-test/conf/nginz/integration-ca-key.pem index 961e87aa67..774b9d30c9 100644 --- a/services/nginz/integration-test/conf/nginz/integration-ca-key.pem +++ b/services/nginz/integration-test/conf/nginz/integration-ca-key.pem @@ -1,27 +1,27 @@ -----BEGIN RSA PRIVATE KEY----- -MIIEpQIBAAKCAQEApwf/2d2YraQDpCipPVtYR+7BNu47AgkD7kFvGhoxJhDP7CsU -VdpqU5gsVVo8kvhkh4k1tsJyuWWeKn6piNSXxUCFIc80KkUPgsYf5v+RBXr73Fdg -ezHQNhNi0dRZCh+YG/hN7pOX46+B0PyKwUEMTeUqizkmFU5tILPMMyDAGx1Bp2LB -oJi4u+48fzTDMaWSXnCVF04G9+A4LDzw0fPdDMgKLEiXJ8GPoPs0cNs6MJoFDgpe -gzy1mv7X7otmRVTaafZGd4TTo6lGC2VVSS5tpj4Qfz/PxyCLK7tf5033HNWEJzAw -6izRXp849VferHuYEbP+2lexNk9tl45BsFhkrwIDAQABAoIBAQCFkzYeSsJginuG -+iVttfEBhYPqo9V4qTEFhjqNS0jmwiclHMZkagkB1P4PO9yZRB9Q7H+SKiqI7STx -ot19WVYOHqzY/tUewJ/I2xyEJPkawuFLsmyr2IhD1nj+iKy0FdQU+huIoWukX6SX -Nn7YUWa/nHbLY+Z6v38x2deBQ72dcBtDcOh1vtUR3fVfsiX5uzCcfvNZAw4cCyB2 -j8ySDIiP10Ic81da3FIeCm8g2yp3DrnvTa77xsr0IfSykB3UcSrGqDwZxs9pS82Q -1fog//4xAfBYC9LEcnQrCvz2kqLSLICtjkgK+dlzgvY3rZMq9c/OY1nR7Wp2BIyp -kKB5AEnRAoGBANTM3fq4YGzUodf+Xla4MDvQFJsYjQuig/CJboQ7JSFZi2uLnSHX -+7JDiHtQd3uifYMhzSxXXKV82CK7SsJOQlIVoCZ5eTsyYGyAu1fUqfBvfHYN4Gbr -3QyZJE0Hut2rvn5DaT/dpgh7Uy9QWKhpAsmxzhKa/iADUTiNAO8pxxRFAoGBAMjw -iZV43XWLvzP90P5jANHuk9tR/B5cM9zK40aWglNsMlK9cUgW3ovohMzTFce/LQWy -zGZ1WZZcUUcR/pHot3fyjWKeJadZhSZ/7hN/0d/UDuFY5nQ8eGQoy2qrrtY+6MMU -Eiz09EFnKKA7hUoDnbhOH1hCKsfrOVse55RDkTZjAoGABrzRzm1mCCwXT7prDD3a -sRoefOajGJo1qTkAuckRnOOz6VzLRdYLzxIaUSU0E0MKzEsWru+5LDgus7LQZCSM -LwMmRfGUqA4pRWYyCE7gbo9pFmfMEhYnso1qu9Gh1gDpECBcRbxj1GLrOFVH6VUh -1Hb/ulET+LmCKdM1E110Qy0CgYEAimbDHSUGxHPg2pq0XMMsSWyegq3RjcfMIQPN -z0zTr0oSz1KUuCaoWo1pCvtJQS+4fvhMOTYS4rHreZw3T6CO3hs+rvJm1QGf6Iit -HtknYZfaN/TXprAP7Ez87xgZcJAcGmG0syp1Iqc/ID5e7D/ZXpzQkiXg+ZpXAyAi -OcjgOCkCgYEAmsCsqtPn5vgB+/vr0n28UsFS4Of9whlgEPYndNss3nAmVEohQJRg -QlBlJd2iDa7R0TrJZCuAwuqK7TxB/RoHL8UkryUt2nag39GYAyE+lfPM558/AWyt -9yyLQNfiJnqTC2Ne2j7EyicBLha4J9NoBeNE5UqLlzrH4LRJ3fRX9Ps= +MIIEpAIBAAKCAQEAoYyNk0aNoe2AYoWa4ey6P4LR4BxKGk0A9LeFiCP4tWqbU/aZ +DzDATytklxaQiDMDbZQboFngf5/X0S+pjSiZ+LSgIR30/g0yoDEubfUXvF+q+rEh +Om91OHnkwwNoSN1EK687N1nATFXd7YL6Lv2SOrMcyOCtqwnGFwRrH8MR3z87nL+H +vuot2ciXvyeJ3q4RG2G9t8UTjqo1jK/NJHyNZYSY4vGTGZTwGi1BCuNlizi6xzmI +Mh3HS/px/kihR7wLkQ7NpovqjfQVef3JwiJutrRYG6lJT9xXpNu2gKg8KKiZJUgb +gqnPWl+4IdRdZ/q/12Jsg9qAf8tbS+tQ2CnlLQIDAQABAoIBAQCJKkrm+me1Tm/M +tz4bh6FX3Z6Pl9V/YVRndA9n2YsJljvOXbn1wOH4FpLxChKr4gyOFMwkKUvJcRGQ +ptRia0/YcJzpoYLr1o7enwOaDxkZM218L7tT32D7E9wdjJ4WB/Ei2kUAKS9yYRHu +4V/FWD25o2zUTpiGeeT8lB7UuA9Lqg529dGlJcanlZjMe0Wj92ec1jjelERGuGdr +lujikHl8whZRwxCGC09WM48myWnsCVdJ1oqGhYM8nzqImsiMc10K6/8CmVrl3aXV +KrExPLtxCRK3pe5olyCLIkPn3OwSc/ZPSkxVQF4j/PwatqqHE98TQBi5bzKIF2JE +17+DBVxNAoGBAM4lR1WRAtXvAe6/jl5zYHr/v2D69o7v85PuXrnmSLK29h3ACSDM +svTsIkoPIZ/lotM8O/OpOHKWmbXH7MOIu9mRKQAKFlTKtw4xl36SPynegq1H5JBv +bd8N8pQtf8pLuh8qxZvZplBsg9HJHBPlbZo/dMQa8oYDI4BakMyYJEMbAoGBAMie +PyHPgI7RpE5GPXcl/rOxeMF++7qOsOX5XGUhoGoH2feYzj19V2/ptx4KdmD+M3NF +dT1ucmQKqocrE6U3sEMok3BmgajGoGOLQMPXsK18bs0VowI+mmt+uL2BwOr9hHPK +IuZrzwm9vtLYldBU3sdxGA1sLXPB2oUZalwCf7VXAoGAZo77X2GmtIKVRo98qBbk +sCzerMQOuGw+laFo9TnRf0AxT/nDUNMmUV3NbWT7yI45pLf5566Py8qLLHoLm/hB +5OsoJ8Hc/FBiJCieAzWFQTJXdxgmaYlWczuALSI5yo5ESc9AwtnUuXxTVKKmWmux +TKU3VX1GnU+gcPIdyfwDRnMCgYAWg8P8DGiWHqr86d8eDxKNoh42QQUJQ9hQhvK6 +mtKA886fffOvbPCyK52UboIokn69sg7dTRbjaVsH/mqfASfz8YrSc36brWb0pP0o +vX0jizJ4K7R2nQYBiGA9TGGVPcxunkHacED1C+ltikcN8WhrI6MaZoiXVCstAtQv +7Uvd0wKBgQDCC9xoSTr7kFiwp76f7dIBdxLKBiL1tZM/qJIP3lnX9TnLhBiHNxoR +4DbIF5yEdRRNBVfS4rJLa1zAAY3d5u4LENaZEvf7fmsjHTLEIf3gJVviHZSBMP6C +kSPQbfcNTNZaEt/40GAZzgjNiO0rTpsLLI4fGDiHeaMMBHEzAiXJmw== -----END RSA PRIVATE KEY----- diff --git a/services/nginz/integration-test/conf/nginz/integration-ca.pem b/services/nginz/integration-test/conf/nginz/integration-ca.pem index f9479d65a0..2aff84d758 100644 --- a/services/nginz/integration-test/conf/nginz/integration-ca.pem +++ b/services/nginz/integration-test/conf/nginz/integration-ca.pem @@ -1,19 +1,19 @@ -----BEGIN CERTIFICATE----- -MIIDAjCCAeqgAwIBAgIUBTz/WN3KPdXZnUyhrinjprCSy2QwDQYJKoZIhvcNAQEL -BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjIwNDIwMTMyMDAwWhcN -MjcwNDE5MTMyMDAwWjAZMRcwFQYDVQQDEw5jYS5leGFtcGxlLmNvbTCCASIwDQYJ -KoZIhvcNAQEBBQADggEPADCCAQoCggEBALfeLu+by+cSkuhiB2eJJpFb0OUTNBzT -YiNK5yfLhHhfQRUkWJQMn9+Zis+thgJDUOuiZ7A6OaDNGNRnlJL62Wz7OgpUFWdt -kdHvmRK+rfAbYeCTOjTWTRBbMrqmRX1WO6tqn6EBttIcS4ND+Bl0tjpf2i8JR+AV -37yHuj/zoBtWHtEFhkCs2vYS09KWuYYBaaj90QKt16f1+Mp3s6OUreB/YzxsCb7d -C4aPPKrloBcI/HZu71AYiQb6WPO1LjyMFMvpYz/ty6V+l69tupYIBJUyoZ+mrY2F -XemRd/Xv3HcJRCBrwx70gER5XNg/IO5vAuRQ9DZqsbEsZApArSbM9RMCAwEAAaNC -MEAwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFCiX -sxgN51cGwv39O8DGk6bVuL4aMA0GCSqGSIb3DQEBCwUAA4IBAQBvQU5dywshZbUp -8/MJI36hrI3IGsf9Asc9Yb3g9Zdc1npWY7F4Mtb6wsaQt1QUWgGcZ2Om6aYQu2iH -TN5a7D1Lxm99BgSLBWeGky/Wgl3XaGKV/2ch9n2eYyz1ukiOF1yvghsNovBvQF11 -nnHLTKZQLtEvawicYB/wdRJOiGp30Ze8DjOeoiPEHHolQa/a1DFlO58tPU1TAr+b -BLmxIEPP6BiIbZHZVQY8aosITMqvY1MCZKTtlXxzRZpxNfQNPYAVjA9D/UWfxpPS -b45eCIIQmctfL5smaY32QFuYsmqOH6OiVm7wm/hkGZCTqfumPR7MpJmJ4LYhpSC4 -IZ1eInXn +MIIDAjCCAeqgAwIBAgIUaq5Rk0z4WRqKc9dEtkxgVdL0LBIwDQYJKoZIhvcNAQEL +BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjMwNDI0MDkzMTAwWhcN +MjgwNDIyMDkzMTAwWjAZMRcwFQYDVQQDEw5jYS5leGFtcGxlLmNvbTCCASIwDQYJ +KoZIhvcNAQEBBQADggEPADCCAQoCggEBAKGMjZNGjaHtgGKFmuHsuj+C0eAcShpN +APS3hYgj+LVqm1P2mQ8wwE8rZJcWkIgzA22UG6BZ4H+f19EvqY0omfi0oCEd9P4N +MqAxLm31F7xfqvqxITpvdTh55MMDaEjdRCuvOzdZwExV3e2C+i79kjqzHMjgrasJ +xhcEax/DEd8/O5y/h77qLdnIl78nid6uERthvbfFE46qNYyvzSR8jWWEmOLxkxmU +8BotQQrjZYs4usc5iDIdx0v6cf5IoUe8C5EOzaaL6o30FXn9ycIibra0WBupSU/c +V6TbtoCoPCiomSVIG4Kpz1pfuCHUXWf6v9dibIPagH/LW0vrUNgp5S0CAwEAAaNC +MEAwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFBuq +33I+JaC5KOsrFeHkzhBuFqtzMA0GCSqGSIb3DQEBCwUAA4IBAQBaOq1YyLjpMz+O +mxw0yRpROgPaPt0QMsSbUCeNXPrlMFi+7QarmKfz0EGoGJEfU8Eu22+mqnAC2tTO +iSLy89tlR21i0+x+0V+qedzZCQfMlm00SS29wzbXomeUunQxlHNuGuRzkzh7g80G ++wIJuIZRvs+qgGofd4yp2BGGQNOlNRhPmc0LP5DSB+snmIscx+sDnVUn7MWunH80 +Doj+CL6wSbP79hfJXeK5LxSBmAtQU8dpZlgNaRCO5TAU10xgzFNCKWbKJ7nf4wC5 +cMGhRWFYP3babARd42KWViRYLZ7bxTtNBnKOvo7AtQJ3YIOUwk1ofq3/PhLHDxiG +XWlMKqrV -----END CERTIFICATE----- diff --git a/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem b/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem index 1e25ca85b5..b1718af2d0 100644 --- a/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem +++ b/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem @@ -1,27 +1,27 @@ -----BEGIN RSA PRIVATE KEY----- -MIIEpAIBAAKCAQEA1iDPn3gxH1jNo5zzYqOJX664NeaPcbPZXPx29CAj+fLN8u8g -rknfVTve+JvqplZiJkf1hw82HnDUdOjCVRl9C0J6uRnncq2G+y13fzL05T751WJA -6S/HCc4oRzWSLMvW36ULiehESkriM91MMXlOltZjgbOLxXJbmN8JTer/yhDnnDXe -TmhoaCqB6WaLnLIMMHYbvWqgdeaANUJSQ2aVIK78eFSM/5yIHyTR3zXIojfSvSBA -H2fItdGxlvr+TmjnpUNGWPlbWddnNnOPc/2ezXh9Hz0z2Qp66Go7pDAhZULV4mUO -QwE/EIpDTCq1pn6BW+Pdc2neasHjPhQ+wt5PfwIDAQABAoIBAQCQaFRdcct/Hn6g -xuqFLVEqDEUDZNh8kBQZV9JJVZutp4gpPAfIQt2xN81p0IzxXPSYaJM3YJTY9rLx -nT/h8GyaOV1WlBe5CTotDz61tAHg0RXgSIEKQkRzYmtbis9oEph4/2/Gs7PKfrIK -1EXcX7kWlMNK53Ft2W/YqyI1QDT9aikgyR3NlNczIgWNB2fKIDKrJACj9sb3KZBz -ePXxDvIy2JcRo6o2B3023AKNdIA+PUMUAGgLnGXQv3bf8n3N+E984PdB5oWLHOg3 -RF9wjedIj7alfHSH9/4x1xhP6lmUF4U27FGN7jC6AcF0iV8QdPlSpa877tjeSrN6 -BnOuhCKxAoGBAPNQv7AMAtxYn7Rt6Qj4W147f3T30Muu3Kg2U5znU9rcQPSDFPYX -QFmBC4VrA31bgqzJ06mjutmn5hCtw0LzaWtA/JQIj42GMV5+hcAOMA6n2oMAT8FC -bpo93rdLpLhy8b3FJUaD9Qc7wtICu1XTyJv5gSe9nC9YJzl6MYRVEdFFAoGBAOFK -iJKzxJFsozrX0pp2O8DO6r5/IDPxPJurtAC/74n8RFzzQGymb5oGSrtjOyVqJYrd -a2bQWozQPRFiwGdyu8GK7hxxoGdaz5FCxjAe41qdDm4GlSn/wYaBzq511lb3GzVW -tauVZG2gkO4j2dvhMMthQY5xG8TAc4V3slHFdS/zAoGAF3Aa1vGBQQqEb9P6k7Og -0YX3tCO/CC/S7500FrQt3rJCy4ro9P+uYjDNFFAHqQasospaSkgMUrUas1aZrZRW -/k7nRbdBZMedb9XOOn7jYDYJFX9tL1ef4dm933g46M+hu78G5TEG5Gh8TtCWjSD2 -fRfeuh5IskLSnHXJ2U58heUCgYBENY6369l9tgiNjj5jKZzZuUv1NQQI9ebFsuyi -tXnOqyP/iF5fBt0PIwyJQ3fq0gJf0r3ruPVRYNK8asuaBnC2HlwNHJHV+PaTIkZi -11c6Xga6ZR/QQXDUSoTK6T5lwhboxUHnmyl2z4BRuWUCX2Gokd+JQtGHdkUDicPh -Ygki5QKBgQCNAkPMUEP5e44IXmecnIh1XCv9see7+jYyyjHfDmDCVNt7qwMLn1vT -sqoZtDWsTG2Dvp5ctYTfI5bOsNa2sEU/VSeccf6lHjiw2N+NhCQXffYZTLGMyAVH -78s8Xq7glmd4k08YkPpsOYpXUqB3DDQEV6v2XpDN2LI9RnYWewOF7g== +MIIEowIBAAKCAQEAr8i0VsoPb1ITTQO1O+uZ4b3+19F42kwXSpaBmgGwK9PQMjiw ++mNGKQf0AM8HISPAEWN3+7ildrl7o9gaFW6e6L00LGyRrKr9hJ46yWNhLb7auJi6 +sq5WK6Wjt+BDMWHmokfKDGOTyh4d+Q5R3uoY/Smi+QQLxUb8VkAESy6lLvff1HXy +jmcvoHigCMedOX0ipgoDg0OOMUiwDaJslsKnJ+Irn7VpfUjmIPPz4J8VRRlqxK6u +tSktq8uzZEUP03elZvlDYGuKEar5qLwgVENJKjgWWG6+gSJniQRNFKIOEvMsybip +wGdA/+da/s27NLBZvnMCLfSKVe15PnBfcEi3FwIDAQABAoIBABM4gO+UfIeRk+ax +5xk8M8FJQxpaHzrPYySWvGkYkijYqkUzibZ3MG7AHeAQwxjOjevY0n/FuuH2ehx6 +Pq/lPp74QUIyRON6duoPWyI2KaQU4Fma6Z8sDOQM4o/yh6ZYrB1GeENOiBRrop9e +/3i+ZCkaamWMGbVig6jyqwWFfi5aYZmL9BB3g7mMYz+DAnSD9eAI0Fl+dCjY3PLq +I5+BjnjHDdA9ixjyNhobBPUN67qAQLox7b5+joM+dW9TD2+2wLF8ubBP/ZjZxJpR +WRGG9tikdyR0ojC9cx4hg9+tN1OV9lAfOgWZO4ZwgCMsDFrKCf76DpG8nNbGMkUi +D8mGmhECgYEA6M6mlQuax9jvd7PhN/E5pqgDDr9gT0+6i9JRSNdX2zGxcH8QPMuE +WQN9gIT+HGfgZQR9r7DvEtl58IzMadF3Jj+zq2C1UMQujWktTp2wA+Lj+JTmSkSx +OdhFwOnouWqeHacdrP+LDahrxTAoQLWkFY7gbzYJARhT8U+MD17yFOMCgYEAwUvG +KY2H4SHqA2V3gjxjaGpj01D4Q4zaK4cDdLYofkkEIECbDXQ0MBPrhEng0bH/P4ld +8H9Sbsfaave/kdTpQunrGRG6cUnLG2/b3NPwf2FcROJ6bVP2JjQLSHZroV1WNLbO +WokoLn61AllkjHisyHjgeBx1oCBE08OVCyJ43z0CgYEAvbUHkZSvQALKwGRYNlnf +fKqUM0RHmtmBTcbIbe7srLVFvkIMXT4KTu7FKiE1YLhU5nxOXwhzCI0nDJnvSJtj +2Es4gYKAvZvfw2Pdg56De+c7lajgL8ziDhzqWlVBSzZSOh+f0wU5rpt7lmezpWde +miKfSIBjvfyxCoajvzLDWbkCgYBtFY8yeg3ZzqLa4dNM6zmKfqfxZHuG26Fv+RTJ +M9esVRaAARW/xPmCvGsoT+0RSitrNuGNzLy/igfIYCJ7cTVmrs4farLWJjf6NulU +OUM7D73bnhhLRJvgOXS4oyPgf+UbgKL50vebLaSHO92TrLKNvDGpdx4mjK9q9rBR +BVZDXQKBgBxHESayFWS0tAyV67GlOaiy3mbjVvxpRT7IGwXZAX+3NMvRmCzN8sIB +zkYMuRC3P/9RAZkBQ2qp8Fu0W8G7b32ImWyP7/HJb0hnBIfwBnePSUA1nS8jEkMp +IkrYAiU2viJTMiHNcqoVuJUY/FmxiZPPewqnJwQYAE4nrUD/oU8F -----END RSA PRIVATE KEY----- diff --git a/services/nginz/integration-test/conf/nginz/integration-leaf.pem b/services/nginz/integration-test/conf/nginz/integration-leaf.pem index 123b522f08..120d96cda5 100644 --- a/services/nginz/integration-test/conf/nginz/integration-leaf.pem +++ b/services/nginz/integration-test/conf/nginz/integration-leaf.pem @@ -1,20 +1,20 @@ -----BEGIN CERTIFICATE----- -MIIDXDCCAkSgAwIBAgIUey3LIX14eyWd2sth8HsSSDbhnYcwDQYJKoZIhvcNAQEL -BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjIwNDIwMTMyMDAwWhcN -MjMwNDIwMTMyMDAwWjAAMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA -1iDPn3gxH1jNo5zzYqOJX664NeaPcbPZXPx29CAj+fLN8u8grknfVTve+JvqplZi -Jkf1hw82HnDUdOjCVRl9C0J6uRnncq2G+y13fzL05T751WJA6S/HCc4oRzWSLMvW -36ULiehESkriM91MMXlOltZjgbOLxXJbmN8JTer/yhDnnDXeTmhoaCqB6WaLnLIM -MHYbvWqgdeaANUJSQ2aVIK78eFSM/5yIHyTR3zXIojfSvSBAH2fItdGxlvr+Tmjn -pUNGWPlbWddnNnOPc/2ezXh9Hz0z2Qp66Go7pDAhZULV4mUOQwE/EIpDTCq1pn6B -W+Pdc2neasHjPhQ+wt5PfwIDAQABo4G0MIGxMA4GA1UdDwEB/wQEAwIFoDAdBgNV +MIIDXDCCAkSgAwIBAgIUV3PHvpBx77MqGBo+PM2RIuIcBfAwDQYJKoZIhvcNAQEL +BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjMwNDI0MDkzMTAwWhcN +MjQwNDIzMDkzMTAwWjAAMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA +r8i0VsoPb1ITTQO1O+uZ4b3+19F42kwXSpaBmgGwK9PQMjiw+mNGKQf0AM8HISPA +EWN3+7ildrl7o9gaFW6e6L00LGyRrKr9hJ46yWNhLb7auJi6sq5WK6Wjt+BDMWHm +okfKDGOTyh4d+Q5R3uoY/Smi+QQLxUb8VkAESy6lLvff1HXyjmcvoHigCMedOX0i +pgoDg0OOMUiwDaJslsKnJ+Irn7VpfUjmIPPz4J8VRRlqxK6utSktq8uzZEUP03el +ZvlDYGuKEar5qLwgVENJKjgWWG6+gSJniQRNFKIOEvMsybipwGdA/+da/s27NLBZ +vnMCLfSKVe15PnBfcEi3FwIDAQABo4G0MIGxMA4GA1UdDwEB/wQEAwIFoDAdBgNV HSUEFjAUBggrBgEFBQcDAQYIKwYBBQUHAwIwDAYDVR0TAQH/BAIwADAdBgNVHQ4E -FgQU9WPYeYNlDXrG0S2iYHZ81js6IYswHwYDVR0jBBgwFoAUKJezGA3nVwbC/f07 -wMaTptW4vhowMgYDVR0RAQH/BCgwJoIZKi5pbnRlZ3JhdGlvbi5leGFtcGxlLmNv -bYIJbG9jYWxob3N0MA0GCSqGSIb3DQEBCwUAA4IBAQBoRgeD+blaKlqqKRXGQoEV -7u7H+YvFQOrrF/sx7XOH9qs14SBNt16HwW4U5w6VM5PhIQkz+PaYXYjLltYQMNbT -d5A+g0Tc0zpZkYa1JjW4hKEJ5RnimbrDNzIfe40tQPyz/beg1fVwj8vEGM9Nr+1W -IhVjCFvlgzUXgVZnO++IbZU4MJpI63HHxQKJtmK/N+Ees33SUY8uTt+NPB9w0KiY -9RwDfQO5ux4Xb2ZI3hp8jI3NO08ILHcl2fwifBfexc6OkGVTP8jAZWUhzfCaZ4FQ -BZ6rKYxLbFPHy27dmq/EGcpqzuqHy/GUidXdwidxNC38oxe0uEBEJhYOPJcBctcv +FgQUa7feIJTIqMh5UjDi0UR7Ub5MrvcwHwYDVR0jBBgwFoAUG6rfcj4loLko6ysV +4eTOEG4Wq3MwMgYDVR0RAQH/BCgwJoIZKi5pbnRlZ3JhdGlvbi5leGFtcGxlLmNv +bYIJbG9jYWxob3N0MA0GCSqGSIb3DQEBCwUAA4IBAQAIfB/q/+jHWbN5goGMaPh8 +CL8kynzf0dmkwOs6f6sqDIRo+9BQneWCWVOTLbO3LK6ITsZhVTFmKT3bkEmj04sy +ZUnXfqi9CqDHjQKZU9OxIWoCgbe6r4siInI46K3rSYGsmP37x9jWop1fbJBLl1HC +ray3LR8zanzsR9ksbyfA9VbNmWY1nWxTkZZ5RM+IAlU0/8qRgo5Ypsl35Gd9RJiN +DtbU3+rU9bYQ1YgYDk0h1s2woEberjp1xnvGBJLhDjewv9jXXaQXr1GlwfnJBenO +TV+GWqTeXwPclK0mSKDGs/Ixh+dH3J+8GGCGd8CJTnQfCzGZIBf4I7re8QkeNsVb -----END CERTIFICATE-----