Initial MLS configuration for new teams

changelog.d/2-features/new-teams-mls

@@ -0,0 +1 @@
+Add `initialConfig` setting for the `mls` feature flag

docs/src/developer/reference/config-options.md

@@ -307,6 +307,19 @@ mls:
 
 This default configuration can be overriden on a per-team basis through the [feature config API](../developer/features.md)
 
+This flag also supports setting an `initialConfig` value, which is applied when a team is created:
+
+```yaml
+# galley.yaml
+mls:
+  initialConfig:
+    protocolToggleUsers: []
+    defaultProtocol: mls
+    supportedProtocols: [proteus, mls] # must contain defaultProtocol
+    allowedCipherSuites: [1]
+    defaultCipherSuite: 1
+```
+
 ### MLS End-to-End Identity
 
 The MLS end-to-end identity team feature adds an extra level of security and practicability. If turned on, automatic device authentication ensures that team members know they are communicating with people using authenticated devices. Team members get a certificate on all their devices.

integration/integration.cabal

@@ -123,6 +123,7 @@ library
     Test.Errors
     Test.ExternalPartner
     Test.FeatureFlags
+    Test.FeatureFlags.Initialisation
     Test.FeatureFlags.User
     Test.FeatureFlags.Util
     Test.Federation

integration/test/SetupHelpers.hs

@@ -41,8 +41,7 @@ deleteUser user = bindResponse (API.Brig.deleteUser user) $ \resp -> do
 -- | returns (owner, team id, members)
 createTeam :: (HasCallStack, MakesValue domain) => domain -> Int -> App (Value, String, [Value])
 createTeam domain memberCount = do
-  res <- createUser domain def {team = True}
-  owner <- res.json
+  owner <- createUser domain def {team = True} >>= getJSON 201
   tid <- owner %. "team" & asString
   members <- for [2 .. memberCount] $ \_ -> createTeamMember owner tid
   pure (owner, tid, members)

integration/test/Test/FeatureFlags/Initialisation.hs

@@ -0,0 +1,68 @@
+module Test.FeatureFlags.Initialisation where
+
+import API.GalleyInternal
+import Control.Monad.Codensity
+import Control.Monad.Extra
+import Control.Monad.Reader
+import SetupHelpers
+import Testlib.Prelude
+import Testlib.ResourcePool
+
+testMLSInitialisation :: (HasCallStack) => App ()
+testMLSInitialisation = do
+  let override =
+        def
+          { galleyCfg =
+              setField
+                "settings.featureFlags.mls"
+                ( object
+                    [ "initialConfig"
+                        .= object
+                          [ "protocolToggleUsers" .= ([] :: [Int]),
+                            "defaultProtocol" .= "mls",
+                            "allowedCipherSuites" .= [1, 2 :: Int],
+                            "defaultCipherSuite" .= (1 :: Int),
+                            "supportedProtocols" .= ["mls", "proteus"]
+                          ]
+                    ]
+                )
+                >=> removeField "settings.featureFlags.mlsMigration"
+          }
+
+  pool <- asks (.resourcePool)
+  lowerCodensity do
+    [resource] <- acquireResources 1 pool
+
+    (alice, aliceTeam) <- lift $ lowerCodensity do
+      -- start a dynamic backend with default configuration
+      domain <- startDynamicBackend resource def
+
+      -- create a team
+      lift do
+        (alice, tid, _) <- createTeam domain 0
+        feat <- getTeamFeature alice tid "mls" >>= getJSON 200
+        feat %. "config.defaultProtocol" `shouldMatch` "proteus"
+        pure (alice, tid)
+
+    lift $ lowerCodensity do
+      -- now start the backend again, this time with an initial mls
+      -- configuration set
+      domain <- startDynamicBackend resource override
+
+      -- a pre-existing team should get the default configuration
+      lift do
+        feat <- getTeamFeature alice aliceTeam "mls" >>= getJSON 200
+        feat %. "config.defaultProtocol" `shouldMatch` "proteus"
+
+      -- a new team should get the initial mls configuration
+      lift do
+        (bob, tid, _) <- createTeam domain 0
+        feat <- getTeamFeature bob tid "mls" >>= getJSON 200
+        feat %. "config.defaultProtocol" `shouldMatch` "mls"
+
+        -- if the mls feature is locked, the config reverts back to default
+        void
+          $ patchTeamFeature bob tid "mls" (object ["lockStatus" .= "locked"])
+          >>= getJSON 200
+        feat' <- getTeamFeature bob tid "mls" >>= getJSON 200
+        feat' %. "config.defaultProtocol" `shouldMatch` "proteus"

integration/test/Testlib/ModService.hs

@@ -124,11 +124,14 @@ startDynamicBackends beOverrides k =
       when (Prelude.length beOverrides > 3) $ lift $ failApp "Too many backends. Currently only 3 are supported."
       pool <- asks (.resourcePool)
       resources <- acquireResources (Prelude.length beOverrides) pool
-      void $ traverseConcurrentlyCodensity (uncurry startDynamicBackend) (zip resources beOverrides)
+      void $
+        traverseConcurrentlyCodensity
+          (void . uncurry startDynamicBackend)
+          (zip resources beOverrides)
       pure $ map (.berDomain) resources
     k
 
-startDynamicBackend :: BackendResource -> ServiceOverrides -> Codensity App ()
+startDynamicBackend :: BackendResource -> ServiceOverrides -> Codensity App String
 startDynamicBackend resource beOverrides = do
   let overrides =
         mconcat
@@ -141,6 +144,7 @@ startDynamicBackend resource beOverrides = do
             beOverrides
           ]
   startBackend resource overrides
+  pure resource.berDomain
   where
     setAwsConfigs :: ServiceOverrides
     setAwsConfigs =

integration/test/Testlib/RunServices.hs

@@ -57,6 +57,6 @@ main = do
       $ do
         _modifyEnv <-
           traverseConcurrentlyCodensity
-            (\r -> startDynamicBackend r mempty)
+            (\r -> void $ startDynamicBackend r mempty)
             [backendA, backendB]
         liftIO run

libs/galley-types/default.nix

@@ -16,6 +16,7 @@
 , lens
 , lib
 , memory
+, schema-profunctor
 , sop-core
 , text
 , types-common
@@ -39,6 +40,7 @@ mkDerivation {
     imports
     lens
     memory
+    schema-profunctor
     sop-core
     text
     types-common

libs/galley-types/galley-types.cabal

@@ -80,6 +80,7 @@ library
     , imports
     , lens                   >=4.12
     , memory
+    , schema-profunctor
     , sop-core
     , text                   >=0.11
     , types-common           >=0.16

libs/galley-types/src/Galley/Types/Teams.hs

@@ -29,6 +29,8 @@ module Galley.Types.Teams
     GetFeatureDefaults (..),
     FeatureDefaults (..),
     FeatureFlags,
+    DefaultsInitial (..),
+    initialFeature,
     featureDefaults,
     notTeamMember,
     findTeamMember,
@@ -47,6 +49,7 @@ import Data.ByteString.UTF8 qualified as UTF8
 import Data.Default
 import Data.Id (UserId)
 import Data.SOP
+import Data.Schema qualified as S
 import Data.Set qualified as Set
 import Imports
 import Wire.API.Team.Feature
@@ -214,10 +217,10 @@ newtype instance FeatureDefaults SndFactorPasswordChallengeConfig
   deriving (FromJSON) via Defaults (LockableFeature SndFactorPasswordChallengeConfig)
   deriving (ParseFeatureDefaults) via OptionalField SndFactorPasswordChallengeConfig
 
-newtype instance FeatureDefaults MLSConfig = MLSDefaults (LockableFeature MLSConfig)
+newtype instance FeatureDefaults MLSConfig = MLSDefaults (DefaultsInitial MLSConfig)
   deriving stock (Eq, Show)
   deriving newtype (Default, GetFeatureDefaults)
-  deriving (FromJSON) via Defaults (LockableFeature MLSConfig)
+  deriving (FromJSON) via DefaultsInitial MLSConfig
   deriving (ParseFeatureDefaults) via OptionalField MLSConfig
 
 data instance FeatureDefaults ExposeInvitationURLsToTeamAdminConfig
@@ -328,6 +331,31 @@ instance (FromJSON a) => FromJSON (Defaults a) where
   parseJSON = withObject "default object" $ \ob ->
     Defaults <$> (ob .: "defaults")
 
+data DefaultsInitial cfg = DefaultsInitial
+  { defFeature :: LockableFeature cfg,
+    initial :: cfg
+  }
+  deriving (Eq, Show)
+
+instance (IsFeatureConfig cfg) => Default (DefaultsInitial cfg) where
+  def = DefaultsInitial def def
+
+type instance ConfigOf (DefaultsInitial cfg) = cfg
+
+instance GetFeatureDefaults (DefaultsInitial cfg) where
+  featureDefaults1 = defFeature
+
+instance (IsFeatureConfig cfg) => FromJSON (DefaultsInitial cfg) where
+  parseJSON = withObject "default with initial" $ \ob -> do
+    feat <- ob .:? "defaults" .!= def
+    mc <-
+      fromMaybe feat.config
+        <$> A.explicitParseFieldMaybe S.schemaParseJSON ob "initialConfig"
+    pure $ DefaultsInitial feat mc
+
+initialFeature :: DefaultsInitial cfg -> LockableFeature cfg
+initialFeature d = d.defFeature {config = d.initial}
+
 makeLenses ''TeamCreationTime
 
 notTeamMember :: [UserId] -> [TeamMember] -> [UserId]

services/galley/src/Galley/API/Teams.hs

@@ -87,6 +87,7 @@ import Data.Time.Clock (UTCTime)
 import Galley.API.Action
 import Galley.API.Error as Galley
 import Galley.API.LegalHold.Team
+import Galley.API.Teams.Features
 import Galley.API.Teams.Features.Get
 import Galley.API.Teams.Notifications qualified as APITeamQueue
 import Galley.API.Update qualified as API
@@ -240,6 +241,8 @@ createNonBindingTeamH _ _ _ = do
 createBindingTeam ::
   ( Member NotificationSubsystem r,
     Member (Input UTCTime) r,
+    Member (Input Opts) r,
+    Member TeamFeatureStore r,
     Member TeamStore r
   ) =>
   TeamId ->
@@ -250,7 +253,13 @@ createBindingTeam tid zusr body = do
   let owner = Public.mkTeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus
   team <-
     E.createTeam (Just tid) zusr body.newTeamName body.newTeamIcon body.newTeamIconKey Binding
-  finishCreateTeam team owner [] Nothing
+  initialiseTeamFeatures tid
+
+  E.createTeamMember tid owner
+  now <- input
+  let e = newEvent tid now (EdTeamCreate team)
+  pushNotifications
+    [newPushLocal1 zusr (toJSONObject e) (userRecipient zusr :| [])]
   pure tid
 
 updateTeamStatus ::
@@ -1314,28 +1323,6 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do
   APITeamQueue.pushTeamEvent tid e
   pure sizeBeforeAdd
 
-finishCreateTeam ::
-  ( Member NotificationSubsystem r,
-    Member (Input UTCTime) r,
-    Member TeamStore r
-  ) =>
-  Team ->
-  TeamMember ->
-  [TeamMember] ->
-  Maybe ConnId ->
-  Sem r ()
-finishCreateTeam team owner others zcon = do
-  let zusr = owner ^. userId
-  for_ (owner : others) $
-    E.createTeamMember (team ^. teamId)
-  now <- input
-  let e = newEvent (team ^. teamId) now (EdTeamCreate team)
-  let r = membersToRecipients Nothing others
-  pushNotifications
-    [ newPushLocal1 zusr (toJSONObject e) (userRecipient zusr :| r)
-        & pushConn .~ zcon
-    ]
-
 getBindingTeamMembers ::
   ( Member (ErrorS 'TeamNotFound) r,
     Member (ErrorS 'NonBindingTeam) r,

services/galley/src/Galley/API/Teams/Features.hs

@@ -30,6 +30,7 @@ module Galley.API.Teams.Features
     guardSecondFactorDisabled,
     featureEnabledForTeam,
     guardMlsE2EIdConfig,
+    initialiseTeamFeatures,
   )
 where
 
@@ -43,7 +44,7 @@ import Data.Qualified (Local)
 import Data.Time (UTCTime)
 import Galley.API.Error (InternalError)
 import Galley.API.LegalHold qualified as LegalHold
-import Galley.API.Teams (ensureNotTooLargeToActivateLegalHold)
+import Galley.API.LegalHold.Team qualified as LegalHold
 import Galley.API.Teams.Features.Get
 import Galley.API.Util (assertTeamExists, getTeamMembersForFanout, membersToRecipients, permissionCheck)
 import Galley.App
@@ -243,6 +244,21 @@ setFeatureForTeam tid feat = do
   pushFeatureEvent tid (mkUpdateEvent newFeat)
   pure newFeat
 
+initialiseTeamFeatures ::
+  ( Member (Input Opts) r,
+    Member TeamFeatureStore r
+  ) =>
+  TeamId ->
+  Sem r ()
+initialiseTeamFeatures tid = do
+  flags :: FeatureFlags <- inputs $ view (settings . featureFlags)
+
+  -- set MLS initial config
+  let MLSDefaults fdef = npProject flags
+  let feat = initialFeature fdef
+  setDbFeature tid feat
+  pure ()
+
 -------------------------------------------------------------------------------
 -- SetFeatureConfig instances
 
@@ -349,7 +365,7 @@ instance SetFeatureConfig LegalholdConfig where
 
     case feat.status of
       FeatureStatusDisabled -> LegalHold.removeSettings' @InternalPaging tid
-      FeatureStatusEnabled -> ensureNotTooLargeToActivateLegalHold tid
+      FeatureStatusEnabled -> LegalHold.ensureNotTooLargeToActivateLegalHold tid
     pure feat
 
 instance SetFeatureConfig FileSharingConfig