Fix processing of external add proposals

changelog.d/5-internal/FS-921

@@ -0,0 +1 @@
+Allow external add proposals without previously uploading key packages.

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

@@ -29,6 +29,7 @@ module Wire.API.MLS.KeyPackage
     kpInitKey,
     kpCredential,
     kpExtensions,
+    kpIdentity,
     kpRef,
     kpRef',
     KeyPackageTBS (..),
@@ -188,6 +189,9 @@ data KeyPackage = KeyPackage
   }
   deriving stock (Eq, Show)
 
+instance S.ToSchema KeyPackage where
+  declareNamedSchema _ = pure (mlsSwagger "KeyPackage")
+
 kpProtocolVersion :: KeyPackage -> ProtocolVersion
 kpProtocolVersion = kpuProtocolVersion . rmValue . kpTBS
 
@@ -203,6 +207,9 @@ kpCredential = kpuCredential . rmValue . kpTBS
 kpExtensions :: KeyPackage -> [Extension]
 kpExtensions = kpuExtensions . rmValue . kpTBS
 
+kpIdentity :: KeyPackage -> Either Text ClientIdentity
+kpIdentity = decodeMLS' @ClientIdentity . bcIdentity . kpCredential
+
 rawKeyPackageSchema :: ValueSchema NamedSwaggerDoc (RawMLS KeyPackage)
 rawKeyPackageSchema =
   rawMLSSchema "KeyPackage" decodeMLS'

libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs

@@ -30,6 +30,8 @@ module Wire.API.Routes.Internal.Brig
     swaggerDoc,
     module Wire.API.Routes.Internal.Brig.EJPD,
     NewKeyPackageRef (..),
+    NewKeyPackage (..),
+    NewKeyPackageResult (..),
   )
 where
 
@@ -155,6 +157,7 @@ type AccountAPI =
                :> MultiVerb 'POST '[Servant.JSON] CreateUserSparInternalResponses (Either CreateUserSparError SelfProfile)
            )
 
+-- | The missing ref is implicit by the capture
 data NewKeyPackageRef = NewKeyPackageRef
   { nkprUserId :: Qualified UserId,
     nkprClientId :: ClientId,
@@ -171,6 +174,34 @@ 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
+
 type MLSAPI =
   "mls"
     :> ( ( "key-packages" :> Capture "ref" KeyPackageRef
@@ -214,6 +245,15 @@ type MLSAPI =
          )
            :<|> 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 =

services/brig/src/Brig/API/Internal.hs

@@ -28,6 +28,7 @@ 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.Types
 import qualified Brig.API.User as API
 import qualified Brig.API.User as Api
@@ -86,7 +87,8 @@ import Wire.API.Error
 import qualified Wire.API.Error.Brig as E
 import Wire.API.MLS.Credential
 import Wire.API.MLS.KeyPackage
-import Wire.API.Routes.Internal.Brig (NewKeyPackageRef)
+import Wire.API.MLS.Serialisation
+import Wire.API.Routes.Internal.Brig
 import qualified Wire.API.Routes.Internal.Brig as BrigIRoutes
 import Wire.API.Routes.Internal.Brig.Connection
 import Wire.API.Routes.Named
@@ -130,6 +132,7 @@ mlsAPI =
   )
     :<|> getMLSClients
     :<|> mapKeyPackageRefsInternal
+    :<|> Named @"put-key-package-add" upsertKeyPackage
 
 accountAPI ::
   Members
@@ -184,6 +187,39 @@ getConvIdByKeyPackageRef = runMaybeT . mapMaybeT wrapClientE . Data.keyPackageRe
 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
+
 getMLSClients :: UserId -> SignatureSchemeTag -> Handler r (Set ClientInfo)
 getMLSClients usr _ss = do
   -- FUTUREWORK: check existence of key packages with a given ciphersuite
@@ -198,8 +234,8 @@ getMLSClients usr _ss = do
       | otherwise = getResult rs
 
     getValidity lusr cid =
-      fmap ((cid,) . (> 0)) $
-        Data.countKeyPackages lusr cid
+      (cid,) . (> 0)
+        <$> Data.countKeyPackages lusr cid
 
 mapKeyPackageRefsInternal :: KeyPackageBundle -> Handler r ()
 mapKeyPackageRefsInternal bundle = do

services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs

@@ -19,6 +19,7 @@ module Brig.API.MLS.KeyPackages.Validation
   ( -- * Main key package validation function
     validateKeyPackage,
     reLifetime,
+    mlsProtocolError,
 
     -- * Exported for unit tests
     findExtensions,

services/galley/src/Galley/API/MLS/Message.hs

@@ -84,6 +84,7 @@ import Wire.API.MLS.Proposal
 import qualified Wire.API.MLS.Proposal as Proposal
 import Wire.API.MLS.Serialisation
 import Wire.API.Message
+import Wire.API.Routes.Internal.Brig
 import Wire.API.User.Client
 
 type MLSMessageStaticErrors =
@@ -348,7 +349,8 @@ type HasProposalEffects r =
     Member (Input UTCTime) r,
     Member LegalHoldStore r,
     Member MemberStore r,
-    Member TeamStore r
+    Member TeamStore r,
+    Member (Input (Local ())) r
   )
 
 type ClientMap = Map (Qualified UserId) (Set (ClientId, KeyPackageRef))
@@ -465,6 +467,7 @@ processCommit qusr senderClient con lconv epoch sender commit = do
 
     pure updates
 
+-- | Note: Use this only for KeyPackage that are already validated
 updateKeyPackageMapping ::
   Members '[BrigAccess, MemberStore] r =>
   Local Data.Conversation ->
@@ -511,25 +514,52 @@ applyProposalRef conv groupId epoch (Ref ref) = do
   p <- getProposal groupId epoch ref >>= noteS @'MLSProposalNotFound
   checkEpoch epoch conv
   checkGroup groupId conv
-  applyProposal (rmValue p)
+  applyProposal (convId conv) (rmValue p)
 applyProposalRef conv _groupId _epoch (Inline p) = do
   suite <-
     preview (to convProtocol . _ProtocolMLS . to cnvmlsCipherSuite) conv
       & noteS @'ConvNotFound
   checkProposalCipherSuite suite p
-  applyProposal p
+  applyProposal (convId conv) p
 
-applyProposal :: HasProposalEffects r => Proposal -> Sem r ProposalAction
-applyProposal (AddProposal kp) = do
-  ref <-
-    kpRef' kp
-      & note (mlsProtocolError "Could not compute ref of a key package in an Add proposal")
-  qclient <- cidQualifiedClient <$> derefKeyPackage ref
-  pure (paAddClient ((,ref) <$$> qclient))
-applyProposal (RemoveProposal ref) = do
+applyProposal ::
+  HasProposalEffects r =>
+  ConvId ->
+  Proposal ->
+  Sem r ProposalAction
+applyProposal convId (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
+      lconvId <- qualifyLocal convId
+      ci <- addKeyPackageMapping lconvId ref (KeyPackageData (rmRaw kp))
+      pure ci
+    Just ci ->
+      -- ad-hoc add proposal in commit, the key package has been claimed before
+      pure ci
+  pure (paAddClient . (<$$>) (,ref) . cidQualifiedClient $ clientIdentity)
+  where
+    addKeyPackageMapping lconv ref kpdata = do
+      -- validate and update mapping in brig
+      mCid <-
+        nkpresClientIdentity
+          <$$> validateAndAddKeyPackageRef
+            NewKeyPackage
+              { nkpConversation = qUntagged lconv,
+                nkpKeyPackage = kpdata
+              }
+      cid <- mCid & note (mlsProtocolError "Tried to add invalid KeyPackage")
+      let qcid = cidQualifiedClient cid
+      let qusr = fst <$> qcid
+      -- update mapping in galley
+      addMLSClients lconv qusr (Set.singleton (ciClient cid, ref))
+      pure cid
+applyProposal _conv (RemoveProposal ref) = do
   qclient <- cidQualifiedClient <$> derefKeyPackage ref
   pure (paRemoveClient ((,ref) <$$> qclient))
-applyProposal _ = pure mempty
+applyProposal _conv _ = pure mempty
 
 checkProposalCipherSuite ::
   Members
@@ -643,7 +673,9 @@ checkExternalProposalUser qusr prop = do
             either
               (const $ throwS @'MLSUnsupportedProposal)
               pure
-              $ decodeMLS' @ClientIdentity (bcIdentity . kpCredential . rmValue $ keyPackage)
+              . 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

services/galley/src/Galley/Effects/BrigAccess.hs

@@ -51,6 +51,7 @@ module Galley.Effects.BrigAccess
     getClientByKeyPackageRef,
     getLocalMLSClients,
     addKeyPackageRef,
+    validateAndAddKeyPackageRef,
     updateKeyPackageRef,
 
     -- * Features
@@ -73,6 +74,7 @@ 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.Routes.Internal.Brig.Connection
 import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi
 import Wire.API.Team.Feature
@@ -129,6 +131,7 @@ data BrigAccess m a where
   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 (Maybe NewKeyPackageResult)
   UpdateKeyPackageRef :: KeyPackageUpdate -> BrigAccess m ()
   UpdateSearchVisibilityInbound ::
     Multi.TeamStatus SearchVisibilityInboundConfig ->

services/galley/src/Galley/Intra/Client.hs

@@ -26,6 +26,7 @@ module Galley.Intra.Client
     getLocalMLSClients,
     addKeyPackageRef,
     updateKeyPackageRef,
+    validateAndAddKeyPackageRef,
   )
 where
 
@@ -34,6 +35,7 @@ import Bilge.RPC
 import Brig.Types.Intra
 import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..))
 import Brig.Types.User.Auth (LegalHoldLogin (..))
+import Control.Monad.Catch
 import Data.ByteString.Conversion (toByteString')
 import Data.Id
 import Data.Misc
@@ -47,6 +49,8 @@ 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)
@@ -222,3 +226,18 @@ updateKeyPackageRef keyPackageRef =
           . json (kpupNext keyPackageRef)
           . expect2xx
       )
+
+validateAndAddKeyPackageRef :: NewKeyPackage -> App (Maybe 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 -> Just <$> parseResponse (mkError status502 "server-error") res
+      | statusCode `div` 100 == 4 -> pure Nothing
+      | otherwise -> throwM (mkError status502 "server-error" "Unexpected http status returned from /i/mls/key-packages/add")

services/galley/src/Galley/Intra/Effects.hs

@@ -82,6 +82,9 @@ interpretBrigAccess = interpret $ \case
   AddKeyPackageRef ref qusr cl qcnv ->
     embedApp $
       addKeyPackageRef ref qusr cl qcnv
+  ValidateAndAddKeyPackageRef nkp ->
+    embedApp $
+      validateAndAddKeyPackageRef nkp
   UpdateKeyPackageRef update ->
     embedApp $
       updateKeyPackageRef update