diff --git a/changelog.d/5-internal/fed-connections-data b/changelog.d/5-internal/fed-connections-data new file mode 100644 index 0000000000..ece769f80e --- /dev/null +++ b/changelog.d/5-internal/fed-connections-data @@ -0,0 +1 @@ +Make connection DB functions work with Qualified IDs diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 7aff982fc2..0fafc20c83 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: d5382afdfc45e225067c7848e99d40349897ddd6eeb69be59038373e57ada716 +-- hash: 74882d161b7ecee96907491a40139775942d4f15987cbe1aa30d13b30fc79e0e name: brig version: 1.35.0 @@ -173,6 +173,7 @@ library , metrics-wai >=0.3 , mime , mime-mail >=0.4 + , mmorph , mtl >=2.1 , mu-grpc-client , multihash >=0.1.3 @@ -207,6 +208,7 @@ library , string-conversions , swagger >=0.1 , swagger2 + , tagged , template >=0.2 , text >=0.11 , text-icu-translit >=0.1 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 7a78afb759..ff6f5a8574 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -72,6 +72,7 @@ library: - mime - mime-mail >=0.4 - MonadRandom >=0.5 + - mmorph - mtl >=2.1 - mu-grpc-client - multihash >=0.1.3 @@ -106,6 +107,7 @@ library: - string-conversions - swagger >=0.1 - swagger2 + - tagged - template >=0.2 - text >=0.11 - text-icu-translit >=0.1 diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 78c7e047ab..d8c7b4b97e 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -26,7 +26,6 @@ module Brig.API.Connection updateConnection, UpdateConnectionsInternal (..), updateConnectionInternal, - lookupLocalConnection, lookupConnections, Data.lookupConnectionStatus, Data.lookupConnectionStatus', @@ -38,7 +37,6 @@ import Brig.API.Error (errorDescriptionTypeToWai) import Brig.API.Types import Brig.API.User (getLegalHoldStatus) import Brig.App -import Brig.Data.Connection (LocalConnection (..), localToUserConn) import qualified Brig.Data.Connection as Data import Brig.Data.Types (resultHasMore, resultList) import qualified Brig.Data.User as Data @@ -52,84 +50,83 @@ import Control.Monad.Catch (throwM) import Data.Id as Id import qualified Data.LegalHold as LH import Data.Proxy (Proxy (Proxy)) -import Data.Qualified (Qualified (Qualified)) +import Data.Qualified import Data.Range +import Data.Tagged import Galley.Types (ConvType (..), cnvType) import Imports import qualified System.Logger.Class as Log import System.Logger.Message import Wire.API.Connection (RelationWithHistory (..)) -import qualified Wire.API.Conversation as Conv import Wire.API.ErrorDescription +import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -lookupLocalConnection :: UserId -> UserId -> AppIO (Maybe UserConnection) -lookupLocalConnection uid1 uid2 = do - localDomain <- viewFederationDomain - Data.localToUserConn localDomain <$$> Data.lookupLocalConnection uid1 uid2 +type ConnectionM = ExceptT ConnectionError AppIO createConnection :: - UserId -> - ConnectionRequest -> + Local UserId -> ConnId -> - ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) -createConnection self req conn = - createConnectionToLocalUser self (crUser req) req conn + Qualified UserId -> + ConnectionM (ResponseForExistedCreated UserConnection) +createConnection lusr con = + foldQualified + lusr + (createConnectionToLocalUser lusr con) + (createConnectionToRemoteUser lusr con) createConnectionToLocalUser :: - UserId -> - UserId -> - ConnectionRequest -> + Local UserId -> ConnId -> - ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) -createConnectionToLocalUser self crUser ConnectionRequest {crName} conn = do - when (self == crUser) $ - throwE $ - InvalidUser crUser - selfActive <- lift $ Data.isActivated self + Local UserId -> + ConnectionM (ResponseForExistedCreated UserConnection) +createConnectionToLocalUser self conn target = do + when (self == target) $ + throwE (InvalidUser (unTagged target)) + selfActive <- lift $ Data.isActivated (lUnqualified self) unless selfActive $ throwE ConnectNoIdentity - otherActive <- lift $ Data.isActivated crUser + otherActive <- lift $ Data.isActivated (lUnqualified target) unless otherActive $ - throwE $ - InvalidUser crUser - checkLegalholdPolicyConflict self crUser + throwE (InvalidUser (unTagged target)) + checkLegalholdPolicyConflict (lUnqualified self) (lUnqualified target) -- Users belonging to the same team are always treated as connected, so creating a -- connection between them is useless. {#RefConnectionTeam} sameTeam <- lift belongSameTeam when sameTeam $ throwE ConnectSameBindingTeamUsers - s2o <- lift $ Data.lookupLocalConnection self crUser - o2s <- lift $ Data.lookupLocalConnection crUser self - localDomain <- viewFederationDomain + s2o <- lift $ Data.lookupConnection self (unTagged target) + o2s <- lift $ Data.lookupConnection target (unTagged self) + case update <$> s2o <*> o2s of - Just rs -> localToUserConn localDomain <$$> rs + Just rs -> rs Nothing -> do checkLimit self - Created . localToUserConn localDomain <$> insert Nothing Nothing + Created <$> insert Nothing Nothing where - insert :: Maybe LocalConnection -> Maybe LocalConnection -> ExceptT ConnectionError AppIO LocalConnection + insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError AppIO UserConnection insert s2o o2s = lift $ do - localDomain <- viewFederationDomain Log.info $ - logConnection self (Qualified crUser localDomain) + logConnection (lUnqualified self) (unTagged target) . msg (val "Creating connection") - cnv <- Intra.createConnectConv self crUser (Just (fromRange crName)) (Just conn) - s2o' <- Data.insertLocalConnection self crUser SentWithHistory cnv - o2s' <- Data.insertLocalConnection crUser self PendingWithHistory cnv - e2o <- ConnectionUpdated (localToUserConn localDomain o2s') (lcStatus <$> o2s) <$> Data.lookupName self - let e2s = ConnectionUpdated (localToUserConn localDomain s2o') (lcStatus <$> s2o) Nothing - mapM_ (Intra.onConnectionEvent self (Just conn)) [e2o, e2s] + qcnv <- Intra.createConnectConv self (unTagged target) Nothing (Just conn) + s2o' <- Data.insertConnection self (unTagged target) SentWithHistory qcnv + o2s' <- Data.insertConnection target (unTagged self) PendingWithHistory qcnv + e2o <- + ConnectionUpdated o2s' (ucStatus <$> o2s) + <$> Data.lookupName (lUnqualified self) + let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing + mapM_ (Intra.onConnectionEvent (lUnqualified self) (Just conn)) [e2o, e2s] return s2o' - update :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) - update s2o o2s = case (lcStatus s2o, lcStatus o2s) of - (MissingLegalholdConsent, _) -> throwE $ InvalidTransition self Sent - (_, MissingLegalholdConsent) -> throwE $ InvalidTransition self Sent + update :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + update s2o o2s = case (ucStatus s2o, ucStatus o2s) of + (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) Sent + (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) Sent (Accepted, Accepted) -> return $ Existed s2o (Accepted, Blocked) -> return $ Existed s2o (Sent, Blocked) -> return $ Existed s2o - (Blocked, _) -> throwE $ InvalidTransition self Sent + (Blocked, _) -> throwE $ InvalidTransition (lUnqualified self) Sent (_, Blocked) -> change s2o SentWithHistory (_, Sent) -> accept s2o o2s (_, Accepted) -> accept s2o o2s @@ -137,45 +134,54 @@ createConnectionToLocalUser self crUser ConnectionRequest {crName} conn = do (_, Pending) -> resend s2o o2s (_, Cancelled) -> resend s2o o2s - accept :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) accept s2o o2s = do - localDomain <- viewFederationDomain - when (lcStatus s2o `notElem` [Sent, Accepted]) $ + when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") - cnv <- lift $ for (lcConv s2o) $ Intra.acceptConnectConv self (Just conn) - s2o' <- lift $ Data.updateLocalConnection s2o AcceptedWithHistory + cnv <- lift $ for (ucConvId s2o) $ Intra.acceptConnectConv self (Just conn) + s2o' <- lift $ Data.updateConnection s2o AcceptedWithHistory o2s' <- lift $ if (cnvType <$> cnv) == Just ConnectConv - then Data.updateLocalConnection o2s BlockedWithHistory - else Data.updateLocalConnection o2s AcceptedWithHistory - e2o <- lift $ ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) <$> Data.lookupName self - let e2s = ConnectionUpdated (localToUserConn localDomain s2o') (Just $ lcStatus s2o) Nothing - lift $ mapM_ (Intra.onConnectionEvent self (Just conn)) [e2o, e2s] + then Data.updateConnection o2s BlockedWithHistory + else Data.updateConnection o2s AcceptedWithHistory + e2o <- + lift $ + ConnectionUpdated o2s' (Just $ ucStatus o2s) + <$> Data.lookupName (lUnqualified self) + let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing + lift $ mapM_ (Intra.onConnectionEvent (lUnqualified self) (Just conn)) [e2o, e2s] return $ Existed s2o' - resend :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) + resend :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) resend s2o o2s = do - when (lcStatus s2o `notElem` [Sent, Accepted]) $ + when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Resending connection request") s2o' <- insert (Just s2o) (Just o2s) return $ Existed s2o' - change :: LocalConnection -> RelationWithHistory -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) - change c s = Existed <$> lift (Data.updateLocalConnection c s) + change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + change c s = Existed <$> lift (Data.updateConnection c s) belongSameTeam :: AppIO Bool belongSameTeam = do - selfTeam <- Intra.getTeamId self - crTeam <- Intra.getTeamId crUser + selfTeam <- Intra.getTeamId (lUnqualified self) + crTeam <- Intra.getTeamId (lUnqualified target) pure $ isJust selfTeam && selfTeam == crTeam +createConnectionToRemoteUser :: + Local UserId -> + ConnId -> + Remote UserId -> + ConnectionM (ResponseForExistedCreated UserConnection) +createConnectionToRemoteUser _ _ _ = throwM federationNotImplemented + -- | Throw error if one user has a LH device and the other status `no_consent` or vice versa. -- -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for @@ -209,9 +215,9 @@ checkLegalholdPolicyConflict uid1 uid2 = do -- {#RefConnectionTeam} updateConnection :: -- | From - UserId -> + Local UserId -> -- | To - UserId -> + Local UserId -> -- | Desired relation status Relation -> -- | Acting device connection ID @@ -220,11 +226,11 @@ updateConnection :: updateConnection self other newStatus conn = do s2o <- localConnection self other o2s <- localConnection other self - s2o' <- case (lcStatus s2o, lcStatus o2s, newStatus) of + s2o' <- case (ucStatus s2o, ucStatus o2s, newStatus) of -- missing legalhold consent: call 'updateConectionInternal' instead. - (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition self newStatus - (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition self newStatus - (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition self newStatus + (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (lUnqualified self) newStatus + (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) newStatus + (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) newStatus -- Pending -> {Blocked, Ignored, Accepted} (Pending, _, Blocked) -> block s2o (Pending, _, Ignored) -> change s2o Ignored @@ -260,84 +266,88 @@ updateConnection self other newStatus conn = do -- no change (old, _, new) | old == new -> return Nothing -- invalid - _ -> throwE $ InvalidTransition self newStatus - localDomain <- viewFederationDomain - let s2oUserConn = Data.localToUserConn localDomain <$> s2o' + _ -> throwE $ InvalidTransition (lUnqualified self) newStatus + let s2oUserConn = s2o' lift . for_ s2oUserConn $ \c -> - let e2s = ConnectionUpdated c (Just $ lcStatus s2o) Nothing - in Intra.onConnectionEvent self conn e2s + let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing + in Intra.onConnectionEvent (lUnqualified self) conn e2s return s2oUserConn where - accept :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) accept s2o o2s = do - localDomain <- viewFederationDomain checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") - cnv <- lift . for (lcConv s2o) $ Intra.acceptConnectConv self conn + cnv <- lift $ traverse (Intra.acceptConnectConv self conn) (ucConvId s2o) -- Note: The check for @Pending@ accounts for situations in which both -- sides are pending, which can occur due to rare race conditions -- when sending mutual connection requests, combined with untimely -- crashes. - when (lcStatus o2s `elem` [Sent, Pending]) . lift $ do + when (ucStatus o2s `elem` [Sent, Pending]) . lift $ do o2s' <- if (cnvType <$> cnv) /= Just ConnectConv - then Data.updateLocalConnection o2s AcceptedWithHistory - else Data.updateLocalConnection o2s BlockedWithHistory - e2o <- ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) <$> Data.lookupName self - Intra.onConnectionEvent self conn e2o - lift $ Just <$> Data.updateLocalConnection s2o AcceptedWithHistory + then Data.updateConnection o2s AcceptedWithHistory + else Data.updateConnection o2s BlockedWithHistory + e2o <- + ConnectionUpdated o2s' (Just $ ucStatus o2s) + <$> Data.lookupName (lUnqualified self) + Intra.onConnectionEvent (lUnqualified self) conn e2o + lift $ Just <$> Data.updateConnection s2o AcceptedWithHistory - block :: LocalConnection -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + block :: UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) block s2o = lift $ do Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Blocking connection") - for_ (lcConv s2o) $ Intra.blockConv (lcFrom s2o) conn - Just <$> Data.updateLocalConnection s2o BlockedWithHistory + traverse_ (Intra.blockConv self conn) (ucConvId s2o) + Just <$> Data.updateConnection s2o BlockedWithHistory - unblock :: LocalConnection -> LocalConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) unblock s2o o2s new = do - localDomain <- viewFederationDomain -- FUTUREWORK: new is always in [Sent, Accepted]. Refactor to total function. when (new `elem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Unblocking connection") - cnv :: Maybe Conv.Conversation <- lift . for (lcConv s2o) $ Intra.unblockConv (lcFrom s2o) conn - when (lcStatus o2s == Sent && new == Accepted) . lift $ do + cnv <- lift $ traverse (Intra.unblockConv self conn) (ucConvId s2o) + when (ucStatus o2s == Sent && new == Accepted) . lift $ do o2s' <- if (cnvType <$> cnv) /= Just ConnectConv - then Data.updateLocalConnection o2s AcceptedWithHistory - else Data.updateLocalConnection o2s BlockedWithHistory - e2o :: ConnectionEvent <- ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) <$> Data.lookupName self + then Data.updateConnection o2s AcceptedWithHistory + else Data.updateConnection o2s BlockedWithHistory + e2o :: ConnectionEvent <- + ConnectionUpdated o2s' (Just $ ucStatus o2s) + <$> Data.lookupName (lUnqualified self) -- TODO: is this correct? shouldnt o2s be sent to other? - Intra.onConnectionEvent self conn e2o - lift $ Just <$> Data.updateLocalConnection s2o (mkRelationWithHistory (error "impossible") new) + Intra.onConnectionEvent (lUnqualified self) conn e2o + lift $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) - cancel :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) cancel s2o o2s = do - localDomain <- viewFederationDomain Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Cancelling connection") - lift . for_ (lcConv s2o) $ Intra.blockConv (lcFrom s2o) conn - o2s' <- lift $ Data.updateLocalConnection o2s CancelledWithHistory - let e2o = ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) Nothing - lift $ Intra.onConnectionEvent self conn e2o + lfrom <- qualifyLocal (ucFrom s2o) + lift $ traverse_ (Intra.blockConv lfrom conn) (ucConvId s2o) + o2s' <- lift $ Data.updateConnection o2s CancelledWithHistory + let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing + lift $ Intra.onConnectionEvent (lUnqualified self) conn e2o change s2o Cancelled - change :: LocalConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + change :: UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) change c s = do -- FUTUREWORK: refactor to total function. Gets only called with either Ignored, Accepted, Cancelled - lift $ Just <$> Data.updateLocalConnection c (mkRelationWithHistory (error "impossible") s) + lift $ Just <$> Data.updateConnection c (mkRelationWithHistory (error "impossible") s) -localConnection :: UserId -> UserId -> ExceptT ConnectionError AppIO LocalConnection -localConnection a b = do - lift (Data.lookupLocalConnection a b) - >>= tryJust (NotConnected a b) +localConnection :: + Local UserId -> + Local UserId -> + ExceptT ConnectionError AppIO UserConnection +localConnection la lb = do + lift (Data.lookupConnection la (unTagged lb)) + >>= tryJust (NotConnected (lUnqualified la) (unTagged lb)) mkRelationWithHistory :: HasCallStack => Relation -> Relation -> RelationWithHistory mkRelationWithHistory oldRel = \case @@ -361,42 +371,44 @@ updateConnectionInternal :: UpdateConnectionsInternal -> ExceptT ConnectionError AppIO () updateConnectionInternal = \case - BlockForMissingLHConsent uid others -> blockForMissingLegalholdConsent uid others - RemoveLHBlocksInvolving uid -> removeLHBlocksInvolving uid + BlockForMissingLHConsent uid others -> do + self <- qualifyLocal uid + blockForMissingLegalholdConsent self others + RemoveLHBlocksInvolving uid -> removeLHBlocksInvolving =<< qualifyLocal uid where -- inspired by @block@ in 'updateConnection'. - blockForMissingLegalholdConsent :: UserId -> [UserId] -> ExceptT ConnectionError AppIO () + blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError AppIO () blockForMissingLegalholdConsent self others = do - localDomain <- viewFederationDomain - for_ others $ \other -> do + for_ others $ \(qualifyAs self -> other) -> do Log.info $ - logConnection self (Qualified other localDomain) + logConnection (lUnqualified self) (unTagged other) . msg (val "Blocking connection (legalhold device present, but missing consent)") s2o <- localConnection self other o2s <- localConnection other self - for_ [s2o, o2s] $ \(uconn :: LocalConnection) -> lift $ do - Intra.blockConv (lcFrom uconn) Nothing `mapM_` lcConv uconn - uconn' <- Data.updateLocalConnection uconn (mkRelationWithHistory (lcStatus uconn) MissingLegalholdConsent) - let ev = ConnectionUpdated (Data.localToUserConn localDomain uconn') (Just $ lcStatus uconn) Nothing - Intra.onConnectionEvent self Nothing ev + for_ [s2o, o2s] $ \(uconn :: UserConnection) -> lift $ do + lfrom <- qualifyLocal (ucFrom uconn) + traverse_ (Intra.blockConv lfrom Nothing) (ucConvId uconn) + uconn' <- Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) + let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing + Intra.onConnectionEvent (lUnqualified self) Nothing ev - removeLHBlocksInvolving :: UserId -> ExceptT ConnectionError AppIO () + removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError AppIO () removeLHBlocksInvolving self = iterateConnections self (toRange (Proxy @500)) $ \conns -> do - localDomain <- viewFederationDomain for_ conns $ \s2o -> - when (Data.lcStatus s2o == MissingLegalholdConsent) $ do + when (ucStatus s2o == MissingLegalholdConsent) $ do -- (this implies @ucStatus o2s == MissingLegalholdConsent@) - let other = Data.lcTo s2o + -- Here we are using the fact that s2o is a local connection + other <- qualifyLocal (qUnqualified (ucTo s2o)) o2s <- localConnection other self Log.info $ - logConnection (Data.lcFrom s2o) (Qualified (Data.lcTo s2o) localDomain) + logConnection (ucFrom s2o) (ucTo s2o) . msg (val "Unblocking connection (legalhold device removed or consent given)") unblockDirected s2o o2s unblockDirected o2s s2o where - iterateConnections :: UserId -> Range 1 500 Int32 -> ([Data.LocalConnection] -> ExceptT ConnectionError AppIO ()) -> ExceptT ConnectionError AppIO () + iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError AppIO ()) -> ExceptT ConnectionError AppIO () iterateConnections user pageSize handleConns = go Nothing where go :: Maybe UserId -> ExceptT ConnectionError (AppT IO) () @@ -406,26 +418,29 @@ updateConnectionInternal = \case case resultList page of (conn : rest) -> if resultHasMore page - then go (Just (maximum (Data.lcTo <$> (conn : rest)))) + then go (Just (maximum (qUnqualified . ucTo <$> (conn : rest)))) else pure () [] -> pure () - unblockDirected :: Data.LocalConnection -> Data.LocalConnection -> ExceptT ConnectionError AppIO () + unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO () unblockDirected uconn uconnRev = do - void . lift . for (Data.lcConv uconn) $ Intra.unblockConv (Data.lcFrom uconn) Nothing - uconnRevRel :: RelationWithHistory <- relationWithHistory (Data.lcFrom uconnRev) (Data.lcTo uconnRev) - uconnRev' <- lift $ Data.updateLocalConnection uconnRev (undoRelationHistory uconnRevRel) - localDomain <- viewFederationDomain - connName <- lift $ Data.lookupName (Data.lcFrom uconn) + lfrom <- qualifyLocal (ucFrom uconnRev) + void . lift . for (ucConvId uconn) $ Intra.unblockConv lfrom Nothing + uconnRevRel :: RelationWithHistory <- relationWithHistory lfrom (ucTo uconnRev) + uconnRev' <- lift $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel) + connName <- lift $ Data.lookupName (lUnqualified lfrom) let connEvent = ConnectionUpdated - { ucConn = Data.localToUserConn localDomain uconnRev', - ucPrev = Just $ Data.lcStatus uconnRev, + { ucConn = uconnRev', + ucPrev = Just $ ucStatus uconnRev, ucName = connName } - lift $ Intra.onConnectionEvent (Data.lcFrom uconn) Nothing connEvent - relationWithHistory :: UserId -> UserId -> ExceptT ConnectionError AppIO RelationWithHistory - relationWithHistory a b = lift (Data.lookupRelationWithHistory a b) >>= tryJust (NotConnected a b) + lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent + + relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError AppIO RelationWithHistory + relationWithHistory self target = + lift (Data.lookupRelationWithHistory self target) + >>= tryJust (NotConnected (lUnqualified self) target) undoRelationHistory :: RelationWithHistory -> RelationWithHistory undoRelationHistory = \case @@ -446,16 +461,16 @@ updateConnectionInternal = \case lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO UserConnectionList lookupConnections from start size = do - rs <- Data.lookupLocalConnections from start size - localDomain <- viewFederationDomain - return $! UserConnectionList (Data.localToUserConn localDomain <$> Data.resultList rs) (Data.resultHasMore rs) + lusr <- qualifyLocal from + rs <- Data.lookupLocalConnections lusr start size + return $! UserConnectionList (Data.resultList rs) (Data.resultHasMore rs) -- Helpers -checkLimit :: UserId -> ExceptT ConnectionError AppIO () +checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () checkLimit u = do n <- lift $ Data.countConnections u [Accepted, Sent] l <- setUserMaxConnections <$> view settings unless (n < l) $ throwE $ - TooManyConnections u + TooManyConnections (lUnqualified u) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 7d607552c0..61c99210be 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -261,7 +261,7 @@ servantSitemap = BrigAPI.getClient = getClient, BrigAPI.getClientCapabilities = getClientCapabilities, BrigAPI.getClientPrekeys = getClientPrekeys, - BrigAPI.createConnectionUnqualified = createLocalConnection, + BrigAPI.createConnectionUnqualified = createConnectionUnqualified, BrigAPI.createConnection = createConnection, BrigAPI.listLocalConnections = listLocalConnections, BrigAPI.listConnections = listConnections, @@ -1085,22 +1085,23 @@ customerExtensionCheckBlockedDomains email = do when (domain `elem` blockedDomains) $ throwM $ customerExtensionBlockedDomain domain -createLocalConnection :: UserId -> ConnId -> Public.ConnectionRequest -> Handler (Public.ResponseForExistedCreated Public.UserConnection) -createLocalConnection self conn cr = do - API.createConnection self cr conn !>> connError +createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> Handler (Public.ResponseForExistedCreated Public.UserConnection) +createConnectionUnqualified self conn cr = do + lself <- qualifyLocal self + target <- qualifyLocal (Public.crUser cr) + API.createConnection lself conn (unTagged target) !>> connError --- | FUTUREWORK: also create remote connections: https://wearezeta.atlassian.net/browse/SQCORE-958 createConnection :: UserId -> ConnId -> Qualified UserId -> Handler (Public.ResponseForExistedCreated Public.UserConnection) -createConnection self conn (Qualified otherUser otherDomain) = do - localDomain <- viewFederationDomain - if localDomain == otherDomain - then createLocalConnection self conn (Public.ConnectionRequest otherUser (unsafeRange "_")) - else throwM federationNotImplemented +createConnection self conn target = do + lself <- qualifyLocal self + API.createConnection lself conn target !>> connError updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) updateLocalConnection self conn other update = do let newStatus = Public.cuStatus update - mc <- API.updateConnection self other newStatus (Just conn) !>> connError + lself <- qualifyLocal self + lother <- qualifyLocal other + mc <- API.updateConnection lself lother newStatus (Just conn) !>> connError return $ maybe Public.Unchanged Public.Updated mc -- | FUTUREWORK: also update remote connections: https://wearezeta.atlassian.net/browse/SQCORE-959 @@ -1119,15 +1120,15 @@ listLocalConnections uid start msize = do -- | FUTUREWORK: also list remote connections: https://wearezeta.atlassian.net/browse/SQCORE-963 listConnections :: UserId -> Public.ListConnectionsRequestPaginated -> Handler Public.ConnectionsPage listConnections uid req = do - localDomain <- viewFederationDomain + self <- qualifyLocal uid let size = Public.gmtprSize req - res :: C.PageWithState Data.LocalConnection <- Data.lookupLocalConnectionsPage uid convertedState (rcast size) - return (pageToConnectionsPage localDomain Public.PagingLocals res) + res :: C.PageWithState Public.UserConnection <- Data.lookupLocalConnectionsPage self convertedState (rcast size) + return (pageToConnectionsPage Public.PagingLocals res) where - pageToConnectionsPage :: Domain -> Public.LocalOrRemoteTable -> Data.PageWithState Data.LocalConnection -> Public.ConnectionsPage - pageToConnectionsPage localDomain table page@Data.PageWithState {..} = + pageToConnectionsPage :: Public.LocalOrRemoteTable -> Data.PageWithState Public.UserConnection -> Public.ConnectionsPage + pageToConnectionsPage table page@Data.PageWithState {..} = Public.MultiTablePage - { mtpResults = Data.localToUserConn localDomain <$> pwsResults, + { mtpResults = pwsResults, mtpHasMore = C.pwsHasMore page, -- FUTUREWORK confusingly, using 'ConversationPagingState' instead of 'ConnectionPagingState' doesn't fail any tests. -- Is this type actually useless? Or the tests not good enough? @@ -1140,7 +1141,10 @@ listConnections uid req = do convertedState = fmap mkState . Public.mtpsState =<< Public.gmtprState req getLocalConnection :: UserId -> UserId -> Handler (Maybe Public.UserConnection) -getLocalConnection self other = lift $ API.lookupLocalConnection self other +getLocalConnection self other = do + lself <- qualifyLocal self + lother <- qualifyLocal other + lift $ Data.lookupConnection lself (unTagged lother) getConnection :: UserId -> Qualified UserId -> Handler (Maybe Public.UserConnection) getConnection self (Qualified otherUser otherDomain) = do diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 10f3a4fc39..db2a8d95aa 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -41,6 +41,7 @@ import Brig.Types.Code (Timeout) import Brig.Types.Intra import Brig.User.Auth.Cookie (RetryAfter (..)) import Data.Id +import Data.Qualified import Imports import qualified Network.Wai.Utilities.Error as Wai import Wire.API.Federation.Client (FederationError) @@ -116,9 +117,9 @@ data ConnectionError | -- | An invalid connection status change. InvalidTransition UserId Relation | -- | The target user in an connection attempt is invalid, e.g. not activated. - InvalidUser UserId + InvalidUser (Qualified UserId) | -- | An attempt at updating a non-existent connection. - NotConnected UserId UserId + NotConnected UserId (Qualified UserId) | -- | An attempt at creating a connection from an account with -- no verified user identity. ConnectNoIdentity diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index d30481333f..65a2e3020f 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -64,6 +64,7 @@ module Brig.App forkAppIO, locationOf, viewFederationDomain, + qualifyLocal, ) where @@ -106,6 +107,7 @@ import Data.List1 (List1, list1) import Data.Metrics (Metrics) import qualified Data.Metrics.Middleware as Metrics import Data.Misc +import Data.Qualified (Local, Qualified (..), toLocal) import Data.Text (unpack) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) @@ -540,3 +542,6 @@ readTurnList = Text.readFile >=> return . fn . mapMaybe fromByteString . fmap Te viewFederationDomain :: MonadReader Env m => m (Domain) viewFederationDomain = view (settings . Opt.federationDomain) + +qualifyLocal :: MonadReader Env m => a -> m (Local a) +qualifyLocal a = fmap (toLocal . Qualified a) viewFederationDomain diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index e4b5ab2f47..bcf967be21 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -18,15 +18,10 @@ -- with this program. If not, see . module Brig.Data.Connection - ( -- * DB Types - LocalConnection (..), - RemoteConnection (..), - localToUserConn, - - -- * DB Operations - insertLocalConnection, - updateLocalConnection, - lookupLocalConnection, + ( -- * DB Operations + insertConnection, + updateConnection, + lookupConnection, lookupLocalConnectionsPage, lookupRelationWithHistory, lookupLocalConnections, @@ -47,12 +42,14 @@ module Brig.Data.Connection ) where -import Brig.App (AppIO) +import Brig.App (AppIO, qualifyLocal) import Brig.Data.Instances () import Brig.Data.Types as T import Brig.Types import Brig.Types.Intra import Cassandra +import Control.Monad.Morph +import Control.Monad.Trans.Maybe import Data.Conduit (runConduit, (.|)) import qualified Data.Conduit.List as C import Data.Domain (Domain) @@ -60,101 +57,114 @@ import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified import Data.Range +import Data.Tagged import Data.Time (getCurrentTime) -import Imports +import Imports hiding (local) import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Connection -data LocalConnection = LocalConnection - { lcFrom :: UserId, - lcTo :: UserId, - lcStatus :: Relation, - -- | Why is this a Maybe? Are there actually any users who have this as null in DB? - lcConv :: Maybe ConvId, - lcLastUpdated :: UTCTimeMillis - } - -localToUserConn :: Domain -> LocalConnection -> UserConnection -localToUserConn localDomain lc = - UserConnection - { ucFrom = lcFrom lc, - ucTo = Qualified (lcTo lc) localDomain, - ucStatus = lcStatus lc, - ucLastUpdate = lcLastUpdated lc, - ucConvId = flip Qualified localDomain <$> lcConv lc - } - -data RemoteConnection = RemoteConnection - { rcFrom :: UserId, - rcTo :: Qualified UserId, - rcRelationWithHistory :: Relation, - rcConv :: Qualified ConvId - } - -insertLocalConnection :: - -- | From - UserId -> - -- | To - UserId -> +insertConnection :: + Local UserId -> + Qualified UserId -> RelationWithHistory -> - ConvId -> - AppIO LocalConnection -insertLocalConnection from to status cid = do + Qualified ConvId -> + AppIO UserConnection +insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - retry x5 . write connectionInsert $ params Quorum (from, to, status, now, cid) - return $ toLocalUserConnection (from, to, status, now, Just cid) + let local (lUnqualified -> ltarget) = + write connectionInsert $ + params Quorum (lUnqualified self, ltarget, rel, now, cnv) + let remote (unTagged -> Qualified rtarget domain) = + write remoteConnectionInsert $ + params Quorum (lUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + retry x5 $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = lUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = now, + ucConvId = Just qcnv + } -updateLocalConnection :: LocalConnection -> RelationWithHistory -> AppIO LocalConnection -updateLocalConnection c@LocalConnection {..} status = do +updateConnection :: UserConnection -> RelationWithHistory -> AppIO UserConnection +updateConnection c status = do + self <- qualifyLocal (ucFrom c) now <- toUTCTimeMillis <$> liftIO getCurrentTime - retry x5 . write connectionUpdate $ params Quorum (status, now, lcFrom, lcTo) - return $ + let local (lUnqualified -> ltarget) = + write connectionUpdate $ + params Quorum (status, now, lUnqualified self, ltarget) + let remote (unTagged -> Qualified rtarget domain) = + write remoteConnectionUpdate $ + params Quorum (status, now, lUnqualified self, domain, rtarget) + retry x5 $ foldQualified self local remote (ucTo c) + pure $ c - { lcStatus = relationDropHistory status, - lcLastUpdated = now + { ucStatus = relationDropHistory status, + ucLastUpdate = now } -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). -lookupLocalConnection :: - -- | User 'A' - UserId -> - -- | User 'B' - UserId -> - AppIO (Maybe LocalConnection) -lookupLocalConnection from to = - toLocalUserConnection <$$> retry x1 (query1 connectionSelect (params Quorum (from, to))) +lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) +lookupConnection self target = runMaybeT $ do + let local (lUnqualified -> ltarget) = do + (_, _, rel, time, mcnv) <- + MaybeT . query1 connectionSelect $ + params Quorum (lUnqualified self, ltarget) + pure (rel, time, fmap (unTagged . qualifyAs self) mcnv) + let remote (unTagged -> Qualified rtarget domain) = do + (rel, time, cdomain, cnv) <- + MaybeT . query1 remoteConnectionSelectFrom $ + params Quorum (lUnqualified self, domain, rtarget) + pure (rel, time, Just (Qualified cnv cdomain)) + (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = lUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = time, + ucConvId = mqcnv + } -- | 'lookupConnection' with more 'Relation' info. lookupRelationWithHistory :: -- | User 'A' - UserId -> + Local UserId -> -- | User 'B' - UserId -> + Qualified UserId -> AppIO (Maybe RelationWithHistory) -lookupRelationWithHistory from to = - runIdentity - <$$> retry x1 (query1 relationSelect (params Quorum (from, to))) +lookupRelationWithHistory self target = do + let local (lUnqualified -> ltarget) = + query1 relationSelect (params Quorum (lUnqualified self, ltarget)) + let remote (unTagged -> Qualified rtarget domain) = + query1 remoteRelationSelect (params Quorum (lUnqualified self, domain, rtarget)) + runIdentity <$$> retry x1 (foldQualified self local remote target) -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -lookupLocalConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage LocalConnection) -lookupLocalConnections from start (fromRange -> size) = +lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage UserConnection) +lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of - Just u -> retry x1 $ paginate connectionsSelectFrom (paramsP Quorum (from, u) (size + 1)) - Nothing -> retry x1 $ paginate connectionsSelect (paramsP Quorum (Identity from) (size + 1)) + Just u -> + retry x1 $ + paginate connectionsSelectFrom (paramsP Quorum (lUnqualified lfrom, u) (size + 1)) + Nothing -> + retry x1 $ + paginate connectionsSelect (paramsP Quorum (Identity (lUnqualified lfrom)) (size + 1)) where - toResult = cassandraResultPage . fmap toLocalUserConnection . trim + toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim trim p = p {result = take (fromIntegral size) (result p)} -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -- Similar to lookupLocalConnections lookupLocalConnectionsPage :: (MonadClient m) => - UserId -> + Local UserId -> Maybe PagingState -> Range 1 1000 Int32 -> - m (PageWithState LocalConnection) -lookupLocalConnectionsPage usr pagingState (fromRange -> size) = - fmap toLocalUserConnection <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity usr) size pagingState) + m (PageWithState UserConnection) +lookupLocalConnectionsPage self pagingState (fromRange -> size) = + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (lUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] @@ -182,9 +192,9 @@ lookupContactListWithRelation u = -- | Count the number of connections a user has in a specific relation status. -- (If you want to distinguish 'RelationWithHistory', write a new function.) -- Note: The count is eventually consistent. -countConnections :: UserId -> [Relation] -> AppIO Int64 +countConnections :: Local UserId -> [Relation] -> AppIO Int64 countConnections u r = do - rels <- retry x1 . query selectStatus $ params One (Identity u) + rels <- retry x1 . query selectStatus $ params One (Identity (lUnqualified u)) return $ foldl' count 0 rels where selectStatus :: QueryString R (Identity UserId) (Identity RelationWithHistory) @@ -242,11 +252,14 @@ connectionClear = "DELETE FROM connection WHERE left = ?" remoteConnectionInsert :: PrepQuery W (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) () remoteConnectionInsert = "INSERT INTO connection_remote (left, right_domain, right_user, status, last_update, conv_domain, conv_id) VALUES (?, ?, ?, ?, ?, ?, ?)" -remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, Domain, ConvId) -remoteConnectionSelect = "SELECT right_domain, right_user, status, conv_domain, conv_id FROM connection_remote where left = ?" +remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelect = "SELECT right_domain, right_user, status, last_update, conv_domain, conv_id FROM connection_remote where left = ?" + +remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelectFrom = "SELECT status, last_update, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right = ?" -remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, Domain, ConvId) -remoteConnectionSelectFrom = "SELECT status, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right = ?" +remoteConnectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, Domain, UserId) () +remoteConnectionUpdate = "UPDATE connection_remote set status = ?, last_update = ? WHERE left = ? and right_domain = ? and right_user = ?" remoteConnectionDelete :: PrepQuery W (UserId, Domain, UserId) () remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right = ?" @@ -254,10 +267,17 @@ remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right remoteConnectionClear :: PrepQuery W (Identity UserId) () remoteConnectionClear = "DELETE FROM connection_remote where left = ?" +remoteRelationSelect :: PrepQuery R (UserId, Domain, UserId) (Identity RelationWithHistory) +remoteRelationSelect = "SELECT status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user = ?" + -- Conversions -toLocalUserConnection :: (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> LocalConnection -toLocalUserConnection (l, r, relationDropHistory -> rel, time, cid) = LocalConnection l r rel cid time +toLocalUserConnection :: + Local x -> + (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> + UserConnection +toLocalUserConnection loc (l, r, relationDropHistory -> rel, time, cid) = + UserConnection l (unTagged (qualifyAs loc r)) rel time (fmap (unTagged . qualifyAs loc) cid) toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 1b2d71880e..8ab904015c 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -92,6 +92,7 @@ import Data.List1 (List1, list1, singleton) import Data.Qualified import Data.Range import qualified Data.Set as Set +import Data.Tagged import Galley.Types (Connect (..), Conversation) import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) @@ -104,6 +105,7 @@ import Network.HTTP.Types.Method import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai import System.Logger.Class as Log hiding (name, (.=)) +import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Message (UserClients) import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) @@ -533,11 +535,15 @@ createSelfConv u = do . expect2xx -- | Calls 'Galley.API.createConnectConversationH'. -createConnectConv :: UserId -> UserId -> Maybe Text -> Maybe ConnId -> AppIO ConvId -createConnectConv from to cname conn = do - localDomain <- viewFederationDomain +createLocalConnectConv :: + Local UserId -> + Local UserId -> + Maybe Text -> + Maybe ConnId -> + AppIO ConvId +createLocalConnectConv from to cname conn = do debug $ - logConnection from (Qualified to localDomain) + logConnection (lUnqualified from) (unTagged to) . remote "galley" . msg (val "Creating connect conversation") r <- galleyRequest POST req @@ -547,15 +553,26 @@ createConnectConv from to cname conn = do where req = path "/i/conversations/connect" - . zUser from + . zUser (lUnqualified from) . maybe id (header "Z-Connection" . fromConnId) conn . contentJson - . lbytes (encode $ Connect to Nothing cname Nothing) + . lbytes (encode $ Connect (lUnqualified to) Nothing cname Nothing) . expect2xx +createConnectConv :: Local UserId -> Qualified UserId -> Maybe Text -> Maybe ConnId -> AppIO (Qualified ConvId) +createConnectConv from to cname conn = + foldQualified + from + ( \lto -> + unTagged . qualifyAs from + <$> createLocalConnectConv from lto cname conn + ) + (\_ -> throwM federationNotImplemented) + to + -- | Calls 'Galley.API.acceptConvH'. -acceptConnectConv :: UserId -> Maybe ConnId -> ConvId -> AppIO Conversation -acceptConnectConv from conn cnv = do +acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +acceptLocalConnectConv from conn cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) @@ -564,13 +581,20 @@ acceptConnectConv from conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "accept", "v2"] - . zUser from + . zUser (lUnqualified from) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx +acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +acceptConnectConv from conn = + foldQualified + from + (acceptLocalConnectConv from conn . lUnqualified) + (const (throwM federationNotImplemented)) + -- | Calls 'Galley.API.blockConvH'. -blockConv :: UserId -> Maybe ConnId -> ConvId -> AppIO () -blockConv usr conn cnv = do +blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO () +blockLocalConv lusr conn cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) @@ -579,13 +603,20 @@ blockConv usr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "block"] - . zUser usr + . zUser (lUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx +blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO () +blockConv lusr conn = + foldQualified + lusr + (blockLocalConv lusr conn . lUnqualified) + (const (throwM federationNotImplemented)) + -- | Calls 'Galley.API.unblockConvH'. -unblockConv :: UserId -> Maybe ConnId -> ConvId -> AppIO Conversation -unblockConv usr conn cnv = do +unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +unblockLocalConv lusr conn cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) @@ -594,10 +625,17 @@ unblockConv usr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "unblock"] - . zUser usr + . zUser (lUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx +unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +unblockConv luid conn = + foldQualified + luid + (unblockLocalConv luid conn . lUnqualified) + (const (throwM federationNotImplemented)) + -- | Calls 'Galley.API.getConversationH'. getConv :: UserId -> ConvId -> AppIO (Maybe Conversation) getConv usr cnv = do diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 5d1a1fb1a5..dca1f42b91 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1602,10 +1602,10 @@ postO2OConvOk = do alice <- randomUser bob <- randomUser connectUsers alice (singleton bob) - a <- postO2OConv alice bob (Just "chat")