From 9effafbd62f3bb618a7ef6f9a69c0dbd425dda21 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 22 Jan 2026 11:50:09 +0100 Subject: [PATCH 1/4] Failing integration test. --- integration/test/Test/Connection.hs | 24 ++++++++++ integration/test/Test/Conversation.hs | 48 +++++++++++++++++++ services/brig/src/Brig/API/MLS/KeyPackages.hs | 1 + 3 files changed, 73 insertions(+) diff --git a/integration/test/Test/Connection.hs b/integration/test/Test/Connection.hs index c0468db6a39..ae292b5e01f 100644 --- a/integration/test/Test/Connection.hs +++ b/integration/test/Test/Connection.hs @@ -17,6 +17,7 @@ module Test.Connection where import API.Brig (getConnection, postConnection, putConnection) +import qualified API.Brig as Brig import API.BrigInternal import API.Galley import Notifications @@ -25,6 +26,29 @@ import Testlib.Prelude import Testlib.VersionedFed import UnliftIO.Async (forConcurrently_) +-- TODO: move this to a better location? +-- TODO: brig probably shouldn't be so loud in this test? `[brig@example.com] E, IO Exception occurred, message=Error {code = Status {statusCode = 404, statusMessage = "Not Found"}, label = "not-found", message = "User not found", errorData = Nothing, innerError = Nothing} HasCallStack backtrace: collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:169:13 in ghc-internal:GHC.Internal.Exception toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO throwIO, called at libraries/exceptions/src/Control/Monad/Catch.hs:308:12 in exceptions-0.10.9-46ff:Control.Monad.Catch throwM, called at src/Brig/App.hs:502:21 in brig-2.0-inplace:Brig.App throwM, called at libraries/exceptions/src/Control/Monad/Catch.hs:614:19 in exceptions-0.10.9-46ff:Control.Monad.Catch throwM, called at src/Brig/API/Connection.hs:213:16 in brig-2.0-inplace:Brig.API.Connection , request=ebae05b9-b856-459b-b64f-f12d5a107823` +testAppConnection :: (HasCallStack) => App () +testAppConnection = do + domain <- make OwnDomain + (owner, tid, [mem1]) <- createTeam domain 2 + let newApp :: Brig.NewApp + newApp = + def + { Brig.name = "chappie", + Brig.description = "some description of this app", + Brig.category = "ai" + } + (app, _cookie) <- bindResponse (Brig.createApp owner tid newApp) $ \resp -> do + resp.status `shouldMatchInt` 200 + app <- resp.json %. "user" + cookie <- resp.json %. "cookie" & asString + pure (app, cookie) + appId <- app %. "qualified_id" + + postConnection mem1 appId `bindResponse` \resp -> do + resp.status `shouldMatchInt` 404 + testConnectWithRemoteUser :: (HasCallStack) => OneOf Domain AnyFedDomain -> App () testConnectWithRemoteUser owningDomain = do let otherDomain = case owningDomain of diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs index dfd5a9d96c9..c0bf30df18e 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -31,6 +31,7 @@ import Control.Monad.Reader import qualified Data.Aeson as Aeson import qualified Data.Text as T import GHC.Stack +import MLS.Util import Notifications import SetupHelpers hiding (deleteUser) import Testlib.One2One (generateRemoteAndConvIdWithDomain) @@ -38,6 +39,53 @@ import Testlib.Prelude import Testlib.ResourcePool import Testlib.VersionedFed +testConversationWithApp :: (HasCallStack) => App () +testConversationWithApp = do + domain <- make OwnDomain + (owner, tid, [mem1, mem2]) <- createTeam domain 3 + let newApp :: NewApp + newApp = + def + { name = "chappie", + description = "some description of this app", + category = "ai" + } + app <- bindResponse (createApp owner tid newApp) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + -- proteus + do + conv <- postConversation mem1 defProteus >>= getJSON 201 + addMembers mem1 conv (def {users = [mem2]}) >>= assertSuccess + addMembers mem1 conv (def {users = [app]}) >>= assertLabel 403 "access-denied" -- apps don't support proteus. + + -- mls + do + [mem1c, mem2c, appc] <- traverse (createMLSClient def) [mem1, mem2, app] + traverse_ (uploadNewKeyPackage def) [mem1c, mem2c, appc] + + let runCheck :: (HasCallStack) => Value -> ClientIdentity -> Value -> App () + runCheck from fromc to = do + conv <- postConversation from defMLS {team = Just tid} >>= getJSON 201 + convId <- objConvId conv + + createGroup def fromc convId + msg1 <- createAddCommit fromc convId [to] + void (sendAndConsumeCommitBundle msg1) + + msg2 <- createApplicationMessage convId fromc "hi new guy!" + void (sendAndConsumeMessage msg2) + + -- regular to app + runCheck mem1 mem1c app + + -- app to regular + runCheck app appc mem2 + + -- regular to regular + runCheck mem1 mem1c mem2 + testFederatedConversation :: (HasCallStack) => App () testFederatedConversation = do -- This test was created to verify that the false positive log message: diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index 96d3f1d820e..4f03e82147f 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -139,6 +139,7 @@ claimLocalKeyPackages qusr skipOwn suite target = do uncurry (KeyPackageBundleEntry (tUntagged target) c) <$> wrapClientM (Data.claimKeyPackage target c suite) + -- FUTUREWORK: shouldn't this be defined elsewhere for general use? assertUserNotUnderLegalHold :: ExceptT ClientError (AppT r) () assertUserNotUnderLegalHold = do -- this is okay because there can only be one StoredUser per UserId From 0394101b10bcd3d9ddaf49f1f34cd19bc5c64b36 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Sun, 25 Jan 2026 15:09:08 +0100 Subject: [PATCH 2/4] Fix: apps are team members, too! --- libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index 9daedd390b0..d591ecbc44f 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -19,6 +19,7 @@ module Wire.AppSubsystem.Interpreter where import Data.ByteString.Conversion import Data.Id +import Data.Json.Util import Data.Map qualified as Map import Data.Qualified import Data.RetryAfter @@ -35,6 +36,7 @@ import System.Logger.Message qualified as Log import Wire.API.App qualified as Apps import Wire.API.Event.Team import Wire.API.Team.Member qualified as T +import Wire.API.Team.Role qualified as R import Wire.API.User import Wire.API.User.Auth import Wire.AppStore (AppStore, StoredApp (..)) @@ -116,6 +118,8 @@ createAppImpl lusr tid (Apps.NewApp new password6) = do -- create app and user entries Store.createApp app Store.createUser u Nothing + now <- toUTCTimeMillis <$> get + void $ addTeamMember u.id tid (Just (tUnqualified lusr, now)) R.RoleMember internalUpdateSearchIndex u.id -- generate a team event From e5baf6893e67ed7c124de3d26041d34768d1130c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 28 Jan 2026 16:16:23 +0100 Subject: [PATCH 3/4] Inject printf debugging stubs. --- services/galley/src/Galley/API/Action.hs | 23 +++++++++++++++++++++++ services/galley/src/Galley/API/Util.hs | 19 ++++++++++++++++++- 2 files changed, 41 insertions(+), 1 deletion(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 10474662d9a..c01a033781e 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -86,6 +86,7 @@ import Polysemy.Input import Polysemy.Resource import Polysemy.TinyLog import Polysemy.TinyLog qualified as P +import System.IO.Unsafe (unsafePerformIO) import System.Logger qualified as Log import Wire.API.Connection (Relation (Accepted)) import Wire.API.Conversation hiding (Conversation, Member) @@ -674,11 +675,33 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do [UserId] -> Sem r () checkLocals lusr (Just tid) newUsers = do + unsafePerformIO + ( do + appendFile "/tmp/x" "\n>>>>>>>>>>>>>>> checkLocals [in]\n" + ) + `seq` pure () + tms <- Map.fromList . map (view Wire.API.Team.Member.userId &&& Imports.id) <$> TeamSubsystem.internalSelectTeamMembers tid newUsers let userMembershipMap = map (Imports.id &&& flip Map.lookup tms) newUsers + unsafePerformIO + ( do + appendFile "/tmp/x" "\n>>>>>>>>>>>>>>> checkLocals [1]\n" + appendFile "/tmp/x" $ show userMembershipMap <> "\n\n" + -- conv has [TeamMemberAccessRole, NonTeamMemberAccessRole, ServiceAccessRole] + -- what do apps have? + -- do we need to add AppAccessRole, or should we reuse ServiceAccessRole? + ) + `seq` pure () + ensureAccessRole (convAccessRoles conv) userMembershipMap + unsafePerformIO + ( do + appendFile "/tmp/x" "\n>>>>>>>>>>>>>>> checkLocals [2]\n" + ) + `seq` pure () + ensureConnectedToLocalsOrSameTeam lusr newUsers checkLocals lusr Nothing newUsers = do ensureAccessRole (convAccessRoles conv) (map (,Nothing) newUsers) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index d8a1143b9ef..a8d15ecbc95 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -54,6 +54,7 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P +import System.IO.Unsafe import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -121,11 +122,27 @@ ensureAccessRole roles users = do when (any (isNothing . snd) users) $ throwS @'NotATeamMember unless (Set.fromList [GuestAccessRole, ServiceAccessRole] `Set.isSubsetOf` roles) $ do - activated <- lookupActivatedUsers (fst <$> users) + activated <- lookupActivatedUsers (fst <$> users) -- this doesn't find the app let guestsExist = length activated /= length users + unsafePerformIO + ( do + appendFile "/tmp/x" "\n>>>>>>>>>>>>>>> ensureAccessRole [3] REACHED\n" + appendFile "/tmp/x" $ show (guestsExist, activated, users) + ) + `seq` pure () unless (not guestsExist || GuestAccessRole `Set.member` roles) $ throwS @'ConvAccessDenied + unsafePerformIO + ( do + appendFile "/tmp/x" "\n>>>>>>>>>>>>>>> ensureAccessRole [4] NOT REACHED\n" + ) + `seq` pure () let botsExist = any (isJust . userService) activated unless (not botsExist || ServiceAccessRole `Set.member` roles) $ throwS @'ConvAccessDenied + unsafePerformIO + ( do + appendFile "/tmp/x" "\n>>>>>>>>>>>>>>> ensureAccessRole [5]\n" + ) + `seq` pure () -- | Check that the given user is either part of the same team as the other -- users OR that there is a connection. From 9d436c06451438aa57f0cc63f427dbc9ba052192 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 28 Jan 2026 16:26:16 +0100 Subject: [PATCH 4/4] Extend UserIdentity to apps. [WIP] --- libs/wire-api/src/Wire/API/User/Identity.hs | 4 ++++ services/brig/src/Brig/User/Auth.hs | 1 + 2 files changed, 5 insertions(+) diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 97a3c503e59..12860b65124 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -54,6 +54,7 @@ import Data.Aeson qualified as A import Data.Aeson.Types qualified as A import Data.ByteString (fromStrict, toStrict) import Data.ByteString.UTF8 qualified as UTF8 +import Data.Id import Data.OpenApi qualified as S import Data.Schema import Data.Text qualified as Text @@ -84,6 +85,7 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) data UserIdentity = EmailIdentity EmailAddress | SSOIdentity UserSSOId (Maybe EmailAddress) + | AppIdentity UserId deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform UserIdentity) @@ -117,6 +119,7 @@ maybeUserIdentityToComponents :: Maybe UserIdentity -> UserIdentityComponents maybeUserIdentityToComponents Nothing = (Nothing, Nothing) maybeUserIdentityToComponents (Just (EmailIdentity email)) = (Just email, Nothing) maybeUserIdentityToComponents (Just (SSOIdentity ssoid m_email)) = (m_email, Just ssoid) +maybeUserIdentityToComponents (Just (AppIdentity uid)) = (Nothing, Nothing) newIdentity :: Maybe EmailAddress -> Maybe UserSSOId -> Maybe UserIdentity newIdentity email (Just sso) = Just $! SSOIdentity sso email @@ -127,6 +130,7 @@ emailIdentity :: UserIdentity -> Maybe EmailAddress emailIdentity (EmailIdentity email) = Just email emailIdentity (SSOIdentity _ (Just email)) = Just email emailIdentity (SSOIdentity _ _) = Nothing +emailIdentity (AppIdentity _) = Nothing ssoIdentity :: UserIdentity -> Maybe UserSSOId ssoIdentity (SSOIdentity ssoid _) = Just ssoid diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 847e93114a0..eb4035b785c 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -387,6 +387,7 @@ isPendingActivation ident = case ident of in statusAdmitsPending && case i of Just (EmailIdentity e) -> mkEmailKey e /= k Just SSOIdentity {} -> False -- sso-created users are activated immediately. + Just AppIdentity {} -> False -- apps are activated immediately. Nothing -> True -- | Validate a list of (User/LH) tokens potentially with an associated access token.