From 596e0f6aa112233d8e09aff042d615aab7001ee6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 16 Sep 2022 10:34:45 +0200 Subject: [PATCH 1/7] Provide a custom Show instance for ClientIdentity --- libs/wire-api/src/Wire/API/MLS/Credential.hs | 10 +++++++++- services/brig/test/integration/API/MLS/Util.hs | 13 +++---------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index f24926280f..4b7d62f99e 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -139,9 +139,17 @@ data ClientIdentity = ClientIdentity ciUser :: UserId, ciClient :: ClientId } - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Generic) deriving (FromJSON, ToJSON, S.ToSchema) via Schema ClientIdentity +instance Show ClientIdentity where + show (ClientIdentity dom u c) = + show u + <> ":" + <> T.unpack (client c) + <> "@" + <> T.unpack (domainText dom) + cidQualifiedClient :: ClientIdentity -> Qualified (UserId, ClientId) cidQualifiedClient cid = Qualified (ciUser cid, ciClient cid) (ciDomain cid) diff --git a/services/brig/test/integration/API/MLS/Util.hs b/services/brig/test/integration/API/MLS/Util.hs index 65dae9bdec..608d745945 100644 --- a/services/brig/test/integration/API/MLS/Util.hs +++ b/services/brig/test/integration/API/MLS/Util.hs @@ -23,12 +23,10 @@ import Bilge.Assert import Data.Aeson (object, toJSON, (.=)) import Data.ByteString.Conversion import Data.Default -import Data.Domain import Data.Id import Data.Json.Util import qualified Data.Map as Map import Data.Qualified -import qualified Data.Text as T import Data.Timeout import Imports import System.FilePath @@ -59,15 +57,10 @@ uploadKeyPackages :: Int -> Http () uploadKeyPackages brig tmp KeyingInfo {..} u c n = do - let cmd0 = ["mls-test-cli", "--store", tmp (clientId <> ".db")] - clientId = - show (qUnqualified u) - <> ":" - <> T.unpack (client c) - <> "@" - <> T.unpack (domainText (qDomain u)) + let cmd0 = ["mls-test-cli", "--store", tmp (show cid <> ".db")] + cid = mkClientIdentity u c void . liftIO . flip spawn Nothing . shell . unwords $ - cmd0 <> ["init", clientId] + cmd0 <> ["init", show cid] kps <- replicateM n . liftIO . flip spawn Nothing . shell . unwords $ cmd0 From b3ab8796803c2d57a91b5bf446d1110d807b2336 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 15 Sep 2022 17:14:27 +0200 Subject: [PATCH 2/7] Align function types in KeyPackages and Validation --- services/brig/src/Brig/API/MLS/KeyPackages.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index 342eafd953..0219570cce 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -57,12 +57,11 @@ claimKeyPackages :: Maybe ClientId -> Handler r KeyPackageBundle claimKeyPackages lusr target skipOwn = - withExceptT clientError $ - foldQualified - lusr - (claimLocalKeyPackages (qUntagged lusr) skipOwn) - (claimRemoteKeyPackages lusr) - target + foldQualified + lusr + (withExceptT clientError . claimLocalKeyPackages (qUntagged lusr) skipOwn) + (claimRemoteKeyPackages lusr) + target claimLocalKeyPackages :: Qualified UserId -> @@ -96,11 +95,12 @@ claimLocalKeyPackages qusr skipOwn target = do claimRemoteKeyPackages :: Local UserId -> Remote UserId -> - ExceptT ClientError (AppT r) KeyPackageBundle + Handler r KeyPackageBundle claimRemoteKeyPackages lusr target = do bundle <- - (handleFailure =<<) $ - withExceptT ClientFederationError $ + withExceptT clientError + . (handleFailure =<<) + $ withExceptT ClientFederationError $ runBrigFederatorClient (tDomain target) $ fedClient @'Brig @"claim-key-packages" $ ClaimKeyPackageRequest From d78421c584dc1449069c169257e49c4978be8075 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 15 Sep 2022 18:34:03 +0200 Subject: [PATCH 3/7] Validate remotely claimed key packages --- libs/wire-api/src/Wire/API/Error/Brig.hs | 6 ++++++ services/brig/src/Brig/API/Error.hs | 2 ++ services/brig/src/Brig/API/MLS/KeyPackages.hs | 21 +++++++++++++++---- services/brig/src/Brig/Data/Client.hs | 2 ++ 4 files changed, 27 insertions(+), 4 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index 544a3755cd..6e5e8a03eb 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -64,6 +64,8 @@ data BrigError | PasswordAuthenticationFailed | TooManyTeamInvitations | InsufficientTeamPermissions + | KeyPackageDecodingError + | InvalidKeyPackageRef instance KnownError (MapError e) => IsSwaggerError (e :: BrigError) where addToSwagger = addStaticErrorToSwagger @(MapError e) @@ -172,3 +174,7 @@ type instance MapError 'PasswordAuthenticationFailed = 'StaticError 403 "passwor type instance MapError 'TooManyTeamInvitations = 'StaticError 403 "too-many-team-invitations" "Too many team invitations for this team" type instance MapError 'InsufficientTeamPermissions = 'StaticError 403 "insufficient-permissions" "Insufficient team permissions" + +type instance MapError 'KeyPackageDecodingError = 'StaticError 409 "decoding-error" "Key package could not be TLS-decoded" + +type instance MapError 'InvalidKeyPackageRef = 'StaticError 409 "invalid-reference" "Key package's reference does not match its data" diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index c3e8341498..6c5f09a4be 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -182,6 +182,8 @@ clientDataError (ClientReAuthError e) = reauthError e clientDataError ClientMissingAuth = StdError (errorToWai @'E.MissingAuth) clientDataError MalformedPrekeys = StdError (errorToWai @'E.MalformedPrekeys) clientDataError MLSPublicKeyDuplicate = StdError (errorToWai @'E.MLSDuplicatePublicKey) +clientDataError KeyPackageDecodingError = StdError (errorToWai @'E.KeyPackageDecodingError) +clientDataError InvalidKeyPackageRef = StdError (errorToWai @'E.InvalidKeyPackageRef) deleteUserError :: DeleteUserError -> Error deleteUserError DeleteUserInvalid = StdError (errorToWai @'E.InvalidUser) diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index 0219570cce..49cd60de86 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -42,6 +42,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Serialisation import Wire.API.Team.LegalHold import Wire.API.User.Client @@ -108,10 +109,22 @@ claimRemoteKeyPackages lusr target = do ckprTarget = tUnqualified target } - -- set up mappings for all claimed key packages - wrapClientE $ - for_ (kpbEntries bundle) $ \e -> - Data.mapKeyPackageRef (kpbeRef e) (kpbeUser e) (kpbeClient e) + -- validate and set up mappings for all claimed key packages + for_ (kpbEntries bundle) $ \e -> do + let cid = mkClientIdentity (kpbeUser e) (kpbeClient e) + kpRaw <- + withExceptT (const . clientDataError $ KeyPackageDecodingError) + . except + . decodeMLS' + . kpData + . kpbeKeyPackage + $ e + (refVal, _) <- validateKeyPackage cid kpRaw + unless (refVal == kpbeRef e) + . throwE + . clientDataError + $ InvalidKeyPackageRef + wrapClientE $ Data.mapKeyPackageRef (kpbeRef e) (kpbeUser e) (kpbeClient e) pure bundle where diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 9453071a5f..480f8bebf7 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -97,6 +97,8 @@ data ClientDataError | ClientMissingAuth | MalformedPrekeys | MLSPublicKeyDuplicate + | KeyPackageDecodingError + | InvalidKeyPackageRef -- | Re-authentication policy. -- From ce33618d13307ceef8d48395921c797e8cbfe31f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 16 Sep 2022 16:36:05 +0200 Subject: [PATCH 4/7] Restrict validation of MLS public keys to locals --- .../Brig/API/MLS/KeyPackages/Validation.hs | 42 +++++++++++++------ 1 file changed, 30 insertions(+), 12 deletions(-) diff --git a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs index 8b64dc030b..186328a7f1 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs @@ -35,6 +35,7 @@ import Brig.Options import Control.Applicative import Control.Lens (view) import qualified Data.ByteString.Lazy as LBS +import Data.Qualified import Data.Time.Clock import Data.Time.Clock.POSIX import Imports @@ -46,8 +47,12 @@ import Wire.API.MLS.Extension import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation -validateKeyPackage :: ClientIdentity -> RawMLS KeyPackage -> Handler r (KeyPackageRef, KeyPackageData) +validateKeyPackage :: + ClientIdentity -> + RawMLS KeyPackage -> + Handler r (KeyPackageRef, KeyPackageData) validateKeyPackage identity (RawMLS (KeyPackageData -> kpd) kp) = do + loc <- qualifyLocal () -- get ciphersuite cs <- maybe @@ -60,19 +65,32 @@ validateKeyPackage identity (RawMLS (KeyPackageData -> kpd) kp) = do when (signatureScheme ss /= bcSignatureScheme (kpCredential kp)) $ mlsProtocolError "Signature scheme incompatible with ciphersuite" - -- authenticate signature key - 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)) $ - mlsProtocolError "Unrecognised signature key" + -- Authenticate signature key. This is performed only upon uploading a key + -- package for a local client. + 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)) $ + mlsProtocolError "Unrecognised signature key" + ) + (pure . const ()) + (cidQualifiedClient identity) -- validate signature - unless (csVerifySignature cs key (rmRaw (kpTBS kp)) (kpSignature kp)) $ - mlsProtocolError "Invalid signature" + unless + ( csVerifySignature + cs + (bcSignatureKey (kpCredential kp)) + (rmRaw (kpTBS kp)) + (kpSignature kp) + ) + $ mlsProtocolError "Invalid signature" -- validate protocol version maybe (mlsProtocolError "Unsupported protocol version") From b03917eaf6f3050aabfd876d48eb907cc5a2e7b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 16 Sep 2022 11:24:06 +0200 Subject: [PATCH 5/7] Update Brig integration test utils --- .../brig/test/integration/API/MLS/Util.hs | 54 +++++++++++++++---- 1 file changed, 45 insertions(+), 9 deletions(-) diff --git a/services/brig/test/integration/API/MLS/Util.hs b/services/brig/test/integration/API/MLS/Util.hs index 608d745945..0671af1c65 100644 --- a/services/brig/test/integration/API/MLS/Util.hs +++ b/services/brig/test/integration/API/MLS/Util.hs @@ -27,13 +27,16 @@ import Data.Id import Data.Json.Util import qualified Data.Map as Map import Data.Qualified +import qualified Data.Text as Text import Data.Timeout import Imports import System.FilePath import System.Process +import Test.Tasty.HUnit import Util import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Serialisation import Wire.API.User.Client data SetKey = SetKey | DontSetKey @@ -47,6 +50,39 @@ data KeyingInfo = KeyingInfo instance Default KeyingInfo where def = KeyingInfo SetKey Nothing +cliCmd :: FilePath -> ClientIdentity -> [String] +cliCmd tmp qcid = + ["mls-test-cli", "--store", tmp (show qcid <> ".db")] + +initStore :: + HasCallStack => + MonadIO m => + FilePath -> + ClientIdentity -> + m () +initStore tmp qcid = do + let cmd0 = cliCmd tmp qcid + void . liftIO . flip spawn Nothing . shell . unwords $ + cmd0 <> ["init", show qcid] + +generateKeyPackage :: + HasCallStack => + MonadIO m => + FilePath -> + ClientIdentity -> + Maybe Timeout -> + m (RawMLS KeyPackage, KeyPackageRef) +generateKeyPackage tmp qcid lifetime = do + let cmd0 = cliCmd tmp qcid + kp <- + liftIO $ + decodeMLSError <=< (flip spawn Nothing . shell . unwords) $ + cmd0 + <> ["key-package", "create"] + <> (("--lifetime " <>) . show . (#> Second) <$> maybeToList lifetime) + let ref = fromJust (kpRef' kp) + pure (kp, ref) + uploadKeyPackages :: HasCallStack => Brig -> @@ -57,15 +93,10 @@ uploadKeyPackages :: Int -> Http () uploadKeyPackages brig tmp KeyingInfo {..} u c n = do - let cmd0 = ["mls-test-cli", "--store", tmp (show cid <> ".db")] + let cmd0 = cliCmd tmp cid cid = mkClientIdentity u c - void . liftIO . flip spawn Nothing . shell . unwords $ - cmd0 <> ["init", show cid] - kps <- - replicateM n . liftIO . flip spawn Nothing . shell . unwords $ - cmd0 - <> ["key-package", "create"] - <> (("--lifetime " <>) . show . (#> Second) <$> maybeToList kiLifetime) + initStore tmp cid + kps <- replicateM n (fst <$> generateKeyPackage tmp cid kiLifetime) when (kiSetKey == SetKey) $ do pk <- @@ -78,7 +109,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 kps)] + let upload = object ["key_packages" .= toJSON (map (Base64ByteString . rmRaw) kps)] post ( brig . paths ["mls", "key-packages", "self", toByteString' c] @@ -95,3 +126,8 @@ getKeyPackageCount brig u c = . zUser (qUnqualified u) ) ByteString -> IO a +decodeMLSError s = case decodeMLS' s of + Left e -> assertFailure ("Could not parse MLS object: " <> Text.unpack e) + Right x -> pure x From 7d9ef983441e30364395caaae0db62e260aa2fda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 16 Sep 2022 12:04:13 +0200 Subject: [PATCH 6/7] Update the remote key package claim test --- services/brig/test/integration/API/MLS.hs | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/services/brig/test/integration/API/MLS.hs b/services/brig/test/integration/API/MLS.hs index b71cca2873..cbd5fa5697 100644 --- a/services/brig/test/integration/API/MLS.hs +++ b/services/brig/test/integration/API/MLS.hs @@ -23,7 +23,6 @@ import Bilge.Assert import Brig.Options import Control.Timeout import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS import Data.ByteString.Conversion import Data.Default import Data.Id @@ -32,7 +31,6 @@ import qualified Data.Set as Set import Data.Timeout import Federation.Util import Imports -import Test.QuickCheck hiding ((===)) import Test.Tasty import Test.Tasty.HUnit import UnliftIO.Temporary @@ -40,6 +38,7 @@ import Util import Web.HttpApiData import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Serialisation import Wire.API.User import Wire.API.User.Client @@ -186,13 +185,18 @@ testKeyPackageRemoteClaim opts brig = do u' <- userQualifiedId <$> randomUser brig - entries <- - liftIO . replicateM 2 . generate $ - -- claimed key packages are not validated by the backend, so it is fine to - -- make up some random data here - KeyPackageBundleEntry u <$> arbitrary - <*> (KeyPackageRef . BS.pack <$> vector 32) - <*> (KeyPackageData . BS.pack <$> vector 64) + qcid <- mkClientIdentity u <$> randomClient + entries <- withSystemTempDirectory "mls" $ \tmp -> do + initStore tmp qcid + replicateM 2 $ do + (r, kp) <- generateKeyPackage tmp qcid Nothing + pure $ + KeyPackageBundleEntry + { kpbeUser = u, + kpbeClient = ciClient qcid, + kpbeRef = kp, + kpbeKeyPackage = KeyPackageData . rmRaw $ r + } let mockBundle = KeyPackageBundle (Set.fromList entries) (bundle :: KeyPackageBundle, _reqs) <- liftIO . withTempMockFederator opts (Aeson.encode mockBundle) $ From c5643543f9e781f128f6cde43983734d1b76ada2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 16 Sep 2022 16:40:35 +0200 Subject: [PATCH 7/7] Add a change log --- changelog.d/1-api-changes/validate-remotely-claimed-key-packages | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/1-api-changes/validate-remotely-claimed-key-packages diff --git a/changelog.d/1-api-changes/validate-remotely-claimed-key-packages b/changelog.d/1-api-changes/validate-remotely-claimed-key-packages new file mode 100644 index 0000000000..dadf82918a --- /dev/null +++ b/changelog.d/1-api-changes/validate-remotely-claimed-key-packages @@ -0,0 +1 @@ +Validate remotely claimed key packages