From 995f28cd1a95c3fac11a0b053f9bab7900bff3aa Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 25 Aug 2023 11:18:47 +0200 Subject: [PATCH] Support x509 credentials (#3532) * Add options to createMLSClient * Add failing test with x509 key packages * Support x509 credentials * Add CHANGELOG entry * Upgrade mls-test-cli to version supporting x509 --- changelog.d/1-api-changes/mls-x509 | 1 + integration/test/MLS/Util.hs | 30 +++++++-- integration/test/Test/MLS.hs | 64 ++++++++++---------- integration/test/Test/MLS/KeyPackage.hs | 6 +- integration/test/Test/MLS/One2One.hs | 2 +- integration/test/Test/MLS/SubConversation.hs | 6 +- libs/wire-api/src/Wire/API/MLS/Credential.hs | 33 +++++++--- libs/wire-api/src/Wire/API/MLS/KeyPackage.hs | 42 ++++++++++++- libs/wire-api/src/Wire/API/MLS/Validation.hs | 13 ++-- nix/pkgs/mls-test-cli/default.nix | 8 +-- 10 files changed, 140 insertions(+), 65 deletions(-) create mode 100644 changelog.d/1-api-changes/mls-x509 diff --git a/changelog.d/1-api-changes/mls-x509 b/changelog.d/1-api-changes/mls-x509 new file mode 100644 index 00000000000..5f07ef57782 --- /dev/null +++ b/changelog.d/1-api-changes/mls-x509 @@ -0,0 +1 @@ +Key packages and leaf nodes with x509 credentials are now supported diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index 969e954f6ed..bff7fbf29f1 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -128,18 +128,36 @@ createWireClient u = do c <- addClient u def {lastPrekey = Just lpk} >>= getJSON 201 mkClientIdentity u c -initMLSClient :: HasCallStack => ClientIdentity -> App () -initMLSClient cid = do +data CredentialType = BasicCredentialType | X509CredentialType + +instance MakesValue CredentialType where + make BasicCredentialType = make "basic" + make X509CredentialType = make "x509" + +instance HasTests x => HasTests (CredentialType -> x) where + mkTests m n s f x = + mkTests m (n <> "[ctype=basic]") s f (x BasicCredentialType) + <> mkTests m (n <> "[ctype=x509]") s f (x X509CredentialType) + +data InitMLSClient = InitMLSClient + {credType :: CredentialType} + +instance Default InitMLSClient where + def = InitMLSClient {credType = BasicCredentialType} + +initMLSClient :: HasCallStack => InitMLSClient -> ClientIdentity -> App () +initMLSClient opts cid = do bd <- getBaseDir mls <- getMLSState liftIO $ createDirectory (bd cid2Str cid) - void $ mlscli cid ["init", "--ciphersuite", mls.ciphersuite.code, cid2Str cid] Nothing + ctype <- make opts.credType & asString + void $ mlscli cid ["init", "--ciphersuite", mls.ciphersuite.code, "-t", ctype, cid2Str cid] Nothing -- | Create new mls client and register with backend. -createMLSClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity -createMLSClient u = do +createMLSClient :: (MakesValue u, HasCallStack) => InitMLSClient -> u -> App ClientIdentity +createMLSClient opts u = do cid <- createWireClient u - initMLSClient cid + initMLSClient opts cid -- set public key pkey <- mlscli cid ["public-key"] Nothing diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index bbab5479dcd..82de95fa190 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -14,7 +14,7 @@ import Testlib.Prelude testSendMessageNoReturnToSender :: HasCallStack => App () testSendMessageNoReturnToSender = do [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] - [alice1, alice2, bob1, bob2] <- traverse createMLSClient [alice, alice, bob, bob] + [alice1, alice2, bob1, bob2] <- traverse (createMLSClient def) [alice, alice, bob, bob] traverse_ uploadNewKeyPackage [alice2, bob1, bob2] void $ createNewGroup alice1 void $ createAddCommit alice1 [alice, bob] >>= sendAndConsumeCommitBundle @@ -43,7 +43,7 @@ testStaleApplicationMessage :: HasCallStack => Domain -> App () testStaleApplicationMessage otherDomain = do [alice, bob, charlie, dave, eve] <- createAndConnectUsers [OwnDomain, otherDomain, OwnDomain, OwnDomain, OwnDomain] - [alice1, bob1, charlie1] <- traverse createMLSClient [alice, bob, charlie] + [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie] traverse_ uploadNewKeyPackage [bob1, charlie1] void $ createNewGroup alice1 @@ -130,7 +130,7 @@ testMixedProtocolAddUsers secondDomain = do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 @@ -158,7 +158,7 @@ testMixedProtocolUserLeaves secondDomain = do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 @@ -193,7 +193,7 @@ testMixedProtocolAddPartialClients secondDomain = do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 - [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob] bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 @@ -231,7 +231,7 @@ testMixedProtocolRemovePartialClients secondDomain = do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 - [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob] bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 @@ -256,7 +256,7 @@ testMixedProtocolAppMessagesAreDenied secondDomain = do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] traverse_ uploadNewKeyPackage [bob1] @@ -277,7 +277,7 @@ testMLSProtocolUpgrade secondDomain = do charlie <- randomUser OwnDomain def -- alice creates MLS group and bob joins - [alice1, bob1, charlie1] <- traverse createMLSClient [alice, bob, charlie] + [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie] createGroup alice1 conv void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle void $ createExternalCommit bob1 Nothing >>= sendAndConsumeCommitBundle @@ -311,12 +311,12 @@ testMLSProtocolUpgrade secondDomain = do resp.status `shouldMatchInt` 200 resp.json %. "protocol" `shouldMatch` "mls" -testAddUserSimple :: HasCallStack => Ciphersuite -> App () -testAddUserSimple suite = do +testAddUserSimple :: HasCallStack => Ciphersuite -> CredentialType -> App () +testAddUserSimple suite ctype = do setMLSCiphersuite suite - [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] - [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + [alice1, bob1, bob2] <- traverse (createMLSClient def {credType = ctype}) [alice, bob, bob] + traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- createNewGroup alice1 @@ -343,7 +343,7 @@ testAddUserSimple suite = do testRemoteAddUser :: HasCallStack => App () testRemoteAddUser = do [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OtherDomain, OwnDomain] - [alice1, bob1, charlie1] <- traverse createMLSClient [alice, bob, charlie] + [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie] traverse_ uploadNewKeyPackage [bob1, charlie1] (_, conv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -360,7 +360,7 @@ testRemoteAddUser = do testRemoteRemoveClient :: HasCallStack => App () testRemoteRemoveClient = do [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] void $ uploadNewKeyPackage bob1 (_, conv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -381,7 +381,7 @@ testCreateSubConv :: HasCallStack => Ciphersuite -> App () testCreateSubConv suite = do setMLSCiphersuite suite alice <- randomUser OwnDomain def - alice1 <- createMLSClient alice + alice1 <- createMLSClient def alice (_, conv) <- createNewGroup alice1 bindResponse (getSubConversation alice conv "conference") $ \resp -> do resp.status `shouldMatchInt` 200 @@ -403,7 +403,7 @@ testCreateSubConvProteus = do testSelfConversation :: App () testSelfConversation = do alice <- randomUser OwnDomain def - creator : others <- traverse createMLSClient (replicate 3 alice) + creator : others <- traverse (createMLSClient def) (replicate 3 alice) traverse_ uploadNewKeyPackage others (_, cnv) <- createSelfGroup creator commit <- createAddCommit creator [alice] @@ -421,7 +421,7 @@ testSelfConversation = do testJoinSubConv :: App () testJoinSubConv = do [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] - [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -445,7 +445,7 @@ testDeleteParentOfSubConv secondDomain = do bob <- randomUser secondDomain def connectUsers [alice, bob] - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] traverse_ uploadNewKeyPackage [alice1, bob1] (_, qcnv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -494,7 +494,7 @@ testFirstCommitAllowsPartialAdds :: HasCallStack => App () testFirstCommitAllowsPartialAdds = do alice <- randomUser OwnDomain def - [alice1, alice2, alice3] <- traverse createMLSClient [alice, alice, alice] + [alice1, alice2, alice3] <- traverse (createMLSClient def) [alice, alice, alice] traverse_ uploadNewKeyPackage [alice1, alice2, alice2, alice3, alice3] (_, _qcnv) <- createNewGroup alice1 @@ -513,9 +513,9 @@ testAddUserPartial = do [alice, bob, charlie] <- createAndConnectUsers (replicate 3 OwnDomain) -- Bob has 3 clients, Charlie has 2 - alice1 <- createMLSClient alice - bobClients@[_bob1, _bob2, bob3] <- replicateM 3 (createMLSClient bob) - charlieClients <- replicateM 2 (createMLSClient charlie) + alice1 <- createMLSClient def alice + bobClients@[_bob1, _bob2, bob3] <- replicateM 3 (createMLSClient def bob) + charlieClients <- replicateM 2 (createMLSClient def charlie) -- Only the first 2 clients of Bob's have uploaded key packages traverse_ uploadNewKeyPackage (take 2 bobClients <> charlieClients) @@ -540,7 +540,7 @@ testRemoveClientsIncomplete :: HasCallStack => App () testRemoveClientsIncomplete = do [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] - [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] void $ createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -552,7 +552,7 @@ testRemoveClientsIncomplete = do testAdminRemovesUserFromConv :: HasCallStack => App () testAdminRemovesUserFromConv = do [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] - [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob] void $ createWireClient bob traverse_ uploadNewKeyPackage [bob1, bob2] (gid, qcnv) <- createNewGroup alice1 @@ -582,7 +582,7 @@ testLocalWelcome :: HasCallStack => App () testLocalWelcome = do users@[alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] - [alice1, bob1] <- traverse createMLSClient users + [alice1, bob1] <- traverse (createMLSClient def) users void $ uploadNewKeyPackage bob1 @@ -613,7 +613,7 @@ testStaleCommit = do (alice : users) <- createAndConnectUsers (replicate 5 OwnDomain) let (users1, users2) = splitAt 2 users - (alice1 : clients) <- traverse createMLSClient (alice : users) + (alice1 : clients) <- traverse (createMLSClient def) (alice : users) traverse_ uploadNewKeyPackage clients void $ createNewGroup alice1 @@ -633,7 +633,7 @@ testStaleCommit = do testPropInvalidEpoch :: HasCallStack => App () testPropInvalidEpoch = do users@[_alice, bob, charlie, dee] <- createAndConnectUsers (replicate 4 OwnDomain) - [alice1, bob1, charlie1, dee1] <- traverse createMLSClient users + [alice1, bob1, charlie1, dee1] <- traverse (createMLSClient def) users void $ createNewGroup alice1 -- Add bob -> epoch 1 @@ -675,7 +675,7 @@ testPropInvalidEpoch = do testPropUnsupported :: HasCallStack => App () testPropUnsupported = do users@[_alice, bob] <- createAndConnectUsers (replicate 2 OwnDomain) - [alice1, bob1] <- traverse createMLSClient users + [alice1, bob1] <- traverse (createMLSClient def) users void $ uploadNewKeyPackage bob1 void $ createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -688,7 +688,7 @@ testPropUnsupported = do testAddUserBareProposalCommit :: HasCallStack => App () testAddUserBareProposalCommit = do [alice, bob] <- createAndConnectUsers (replicate 2 OwnDomain) - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] (_, qcnv) <- createNewGroup alice1 void $ uploadNewKeyPackage bob1 void $ createAddCommit alice1 [] >>= sendAndConsumeCommitBundle @@ -710,7 +710,7 @@ testAddUserBareProposalCommit = do testPropExistingConv :: HasCallStack => App () testPropExistingConv = do [alice, bob] <- createAndConnectUsers (replicate 2 OwnDomain) - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] void $ uploadNewKeyPackage bob1 void $ createNewGroup alice1 void $ createAddCommit alice1 [] >>= sendAndConsumeCommitBundle @@ -721,7 +721,7 @@ testCommitNotReferencingAllProposals :: HasCallStack => App () testCommitNotReferencingAllProposals = do users@[_alice, bob, charlie] <- createAndConnectUsers (replicate 3 OwnDomain) - [alice1, bob1, charlie1] <- traverse createMLSClient users + [alice1, bob1, charlie1] <- traverse (createMLSClient def) users void $ createNewGroup alice1 traverse_ uploadNewKeyPackage [bob1, charlie1] void $ createAddCommit alice1 [] >>= sendAndConsumeCommitBundle @@ -745,7 +745,7 @@ testUnsupportedCiphersuite :: HasCallStack => App () testUnsupportedCiphersuite = do setMLSCiphersuite (Ciphersuite "0x0002") alice <- randomUser OwnDomain def - alice1 <- createMLSClient alice + alice1 <- createMLSClient def alice void $ createNewGroup alice1 mp <- createPendingProposalCommit alice1 diff --git a/integration/test/Test/MLS/KeyPackage.hs b/integration/test/Test/MLS/KeyPackage.hs index 40760527d1c..2da06e14a98 100644 --- a/integration/test/Test/MLS/KeyPackage.hs +++ b/integration/test/Test/MLS/KeyPackage.hs @@ -8,7 +8,7 @@ import Testlib.Prelude testDeleteKeyPackages :: App () testDeleteKeyPackages = do alice <- randomUser OwnDomain def - alice1 <- createMLSClient alice + alice1 <- createMLSClient def alice kps <- replicateM 3 (uploadNewKeyPackage alice1) -- add an extra non-existing key package to the delete request @@ -24,7 +24,7 @@ testDeleteKeyPackages = do testKeyPackageMultipleCiphersuites :: App () testKeyPackageMultipleCiphersuites = do alice <- randomUser OwnDomain def - [alice1, alice2] <- replicateM 2 (createMLSClient alice) + [alice1, alice2] <- replicateM 2 (createMLSClient def alice) kp <- uploadNewKeyPackage alice2 @@ -51,7 +51,7 @@ testUnsupportedCiphersuite :: HasCallStack => App () testUnsupportedCiphersuite = do setMLSCiphersuite (Ciphersuite "0x0002") bob <- randomUser OwnDomain def - bob1 <- createMLSClient bob + bob1 <- createMLSClient def bob (kp, _) <- generateKeyPackage bob1 bindResponse (uploadKeyPackage bob1 kp) $ \resp -> do resp.status `shouldMatchInt` 400 diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index a7cf895498e..a7de9fe5837 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -71,7 +71,7 @@ testMLSOne2One scenario = do let otherDomain = one2OneScenarioDomain scenario convDomain = one2OneScenarioConvDomain scenario bob <- createMLSOne2OnePartner otherDomain alice convDomain - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] traverse_ uploadNewKeyPackage [bob1] conv <- getMLSOne2OneConversation alice bob >>= getJSON 200 diff --git a/integration/test/Test/MLS/SubConversation.hs b/integration/test/Test/MLS/SubConversation.hs index 0524560e640..e86c01b4129 100644 --- a/integration/test/Test/MLS/SubConversation.hs +++ b/integration/test/Test/MLS/SubConversation.hs @@ -8,7 +8,7 @@ import Testlib.Prelude testJoinSubConv :: App () testJoinSubConv = do [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] - [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -32,7 +32,7 @@ testDeleteParentOfSubConv secondDomain = do bob <- randomUser secondDomain def connectUsers [alice, bob] - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] traverse_ uploadNewKeyPackage [alice1, bob1] (_, qcnv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle @@ -80,7 +80,7 @@ testDeleteSubConversation :: HasCallStack => Domain -> App () testDeleteSubConversation otherDomain = do [alice, bob] <- createAndConnectUsers [OwnDomain, otherDomain] charlie <- randomUser OwnDomain def - [alice1, bob1] <- traverse createMLSClient [alice, bob] + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] void $ uploadNewKeyPackage bob1 (_, qcnv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index 2a10d9516ea..ecfda8810ba 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -28,6 +28,8 @@ import Data.Binary.Get import Data.Binary.Parser import Data.Binary.Parser.Char8 import Data.Binary.Put +import Data.ByteString.Base64.URL qualified as B64URL +import Data.ByteString.Lazy qualified as L import Data.Domain import Data.Id import Data.Qualified @@ -36,7 +38,6 @@ import Data.Swagger qualified as S import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.UUID -import GHC.Records import Imports import Web.HttpApiData import Wire.API.MLS.Serialisation @@ -44,14 +45,12 @@ import Wire.Arbitrary -- | An MLS credential. -- --- Only the @BasicCredential@ type is supported. -- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-5.3-3 -data Credential = BasicCredential ByteString +data Credential = BasicCredential ByteString | X509Credential [ByteString] deriving stock (Eq, Show, Generic) deriving (Arbitrary) via GenericUniform Credential -data CredentialTag where - BasicCredentialTag :: CredentialTag +data CredentialTag = BasicCredentialTag | X509CredentialTag deriving stock (Enum, Bounded, Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform CredentialTag) @@ -67,17 +66,21 @@ instance ParseMLS Credential where BasicCredentialTag -> BasicCredential <$> parseMLSBytes @VarInt + X509CredentialTag -> + X509Credential + <$> parseMLSVector @VarInt (parseMLSBytes @VarInt) instance SerialiseMLS Credential where serialiseMLS (BasicCredential i) = do serialiseMLS BasicCredentialTag serialiseMLSBytes @VarInt i + serialiseMLS (X509Credential certs) = do + serialiseMLS X509CredentialTag + serialiseMLSVector @VarInt (serialiseMLSBytes @VarInt) certs credentialTag :: Credential -> CredentialTag -credentialTag BasicCredential {} = BasicCredentialTag - -instance HasField "identityData" Credential ByteString where - getField (BasicCredential i) = i +credentialTag (BasicCredential _) = BasicCredentialTag +credentialTag (X509Credential _) = X509CredentialTag data ClientIdentity = ClientIdentity { ciDomain :: Domain, @@ -132,6 +135,18 @@ instance ParseMLS ClientIdentity where either fail pure . (mkDomain . T.pack) =<< many' anyChar pure $ ClientIdentity dom uid cid +parseX509ClientIdentity :: Get ClientIdentity +parseX509ClientIdentity = do + b64uuid <- getByteString 22 + uidBytes <- either fail pure $ B64URL.decodeUnpadded b64uuid + uid <- maybe (fail "Invalid UUID") (pure . Id) $ fromByteString (L.fromStrict uidBytes) + char '/' + cid <- newClientId <$> hexadecimal + char '@' + dom <- + 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)) diff --git a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs index a0cd183109f..568943c0262 100644 --- a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs +++ b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs @@ -23,6 +23,7 @@ module Wire.API.MLS.KeyPackage KeyPackageData (..), DeleteKeyPackages (..), KeyPackage (..), + credentialIdentity, keyPackageIdentity, kpRef, kpRef', @@ -35,6 +36,7 @@ import Cassandra.CQL hiding (Set) import Control.Applicative import Control.Lens hiding (set, (.=)) import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor import Data.ByteString.Lazy qualified as LBS import Data.Id import Data.Json.Util @@ -42,6 +44,9 @@ import Data.Qualified import Data.Range import Data.Schema hiding (HasField) import Data.Swagger qualified as S +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.X509 qualified as X509 import GHC.Records import Imports hiding (cs) import Test.QuickCheck @@ -226,8 +231,43 @@ instance HasField "extensions" KeyPackage [Extension] where instance HasField "leafNode" KeyPackage LeafNode where getField = (.tbs.value.leafNode) +credentialIdentity :: Credential -> Either Text ClientIdentity +credentialIdentity (BasicCredential i) = decodeMLS' i +credentialIdentity (X509Credential certs) = do + bs <- case certs of + [] -> Left "Invalid x509 certificate chain" + (c : _) -> pure c + signed <- + first (\e -> "Failed to decode x509 certificate: " <> T.pack e) $ + X509.decodeSignedCertificate bs + -- FUTUREWORK: verify signature + let cert = X509.getCertificate signed + certificateIdentity cert + keyPackageIdentity :: KeyPackage -> Either Text ClientIdentity -keyPackageIdentity = decodeMLS' @ClientIdentity . (.leafNode.credential.identityData) +keyPackageIdentity kp = credentialIdentity kp.leafNode.credential + +certificateIdentity :: X509.Certificate -> Either Text ClientIdentity +certificateIdentity cert = + let getNames (X509.ExtSubjectAltName names) = names + getURI (X509.AltNameURI u) = Just u + getURI _ = Nothing + altNames = maybe [] getNames (X509.extensionGet (X509.certExtensions cert)) + ids = map sanIdentity (mapMaybe getURI altNames) + in case partitionEithers ids of + (_, (cid : _)) -> pure cid + ((e : _), []) -> Left e + _ -> Left "No SAN URIs found" + +sanIdentity :: String -> Either Text ClientIdentity +sanIdentity s = case break (== '=') s of + ("im:wireapp", '=' : s') -> + first (\e -> e <> " (while parsing identity string " <> T.pack (show s') <> ")") + . decodeMLSWith' parseX509ClientIdentity + . T.encodeUtf8 + . T.pack + $ s' + _ -> Left "No im:wireapp label found" rawKeyPackageSchema :: ValueSchema NamedSwaggerDoc (RawMLS KeyPackage) rawKeyPackageSchema = diff --git a/libs/wire-api/src/Wire/API/MLS/Validation.hs b/libs/wire-api/src/Wire/API/MLS/Validation.hs index eadc3442f27..f97e7fc0218 100644 --- a/libs/wire-api/src/Wire/API/MLS/Validation.hs +++ b/libs/wire-api/src/Wire/API/MLS/Validation.hs @@ -99,13 +99,14 @@ validateLeafNode cs mIdentity extra leafNode = do validateCredential mIdentity leafNode.credential validateSource extra.tag leafNode.source - validateCapabilities leafNode.capabilities + validateCapabilities (credentialTag leafNode.credential) leafNode.capabilities validateCredential :: Maybe ClientIdentity -> Credential -> Either Text () -validateCredential mIdentity (BasicCredential cred) = do +validateCredential mIdentity cred = do + -- FUTUREWORK: check signature in the case of an x509 credential identity <- either credentialError pure $ - decodeMLS' cred + credentialIdentity cred unless (maybe True (identity ==) mIdentity) $ Left "client identity does not match credential identity" where @@ -126,7 +127,7 @@ validateSource t s = do <> t'.name <> "'" -validateCapabilities :: Capabilities -> Either Text () -validateCapabilities caps = - unless (fromMLSEnum BasicCredentialTag `elem` caps.credentials) $ +validateCapabilities :: CredentialTag -> Capabilities -> Either Text () +validateCapabilities ctag caps = + unless (fromMLSEnum ctag `elem` caps.credentials) $ Left "missing BasicCredential capability" diff --git a/nix/pkgs/mls-test-cli/default.nix b/nix/pkgs/mls-test-cli/default.nix index 1e38ca6039c..bbaab19f303 100644 --- a/nix/pkgs/mls-test-cli/default.nix +++ b/nix/pkgs/mls-test-cli/default.nix @@ -13,8 +13,8 @@ let src = fetchFromGitHub { owner = "wireapp"; repo = "mls-test-cli"; - rev = "cc815d71a1d9485265b7ae158daf7b27badedee6"; - sha256 = "sha256-CJoc20pOtsxAQNCA3qhv8NtPbzZ4yCIMvuhlgcqPrds="; + rev = "d16b4e9d4e93b731e81cd04a00620f2c6a36e696"; + sha256 = "sha256-2p5m6R80dnyJShAvjmO+ZbX8wxMtuFmvPnp9uX4eezc="; }; cargoLockFile = builtins.toFile "cargo.lock" (builtins.readFile "${src}/Cargo.lock"); in rustPlatform.buildRustPackage rec { @@ -24,8 +24,8 @@ in rustPlatform.buildRustPackage rec { cargoLock = { lockFile = cargoLockFile; outputHashes = { - "hpke-0.10.0" = "sha256-6zyTb2c2DU4mXn9vRQe+lXNaeQ3JOVUz+BS15Xb2E+Y="; - "openmls-0.20.2" = "sha256-QgQb5Ts8TB2nwfxMss4qHCz096ijMXBxyq7q2ITyEGg="; + "hpke-0.10.0" = "sha256-T1+BFwX6allljNZ/8T3mrWhOejnUU27BiWQetqU+0fY="; + "openmls-1.0.0" = "sha256-s1ejM/aicFGvsKY7ajEun1Mc645/k8QVrE8YSbyD3Fg="; "safe_pqc_kyber-0.6.0" = "sha256-Ch1LA+by+ezf5RV0LDSQGC1o+IWKXk8IPvkwSrAos68="; "tls_codec-0.3.0" = "sha256-IO6tenXKkC14EoUDp/+DtFNOVzDfOlLu8K1EJI7sOzs="; };