From b2dec49bf6b116776266fb734d8b07ef6997fc5e Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 4 Oct 2021 13:13:41 +0200 Subject: [PATCH 01/88] Make federated connection functions work with qualified IDs (#1819) * Add stub for remote connection creation * Make connection DB functions work with Qualified * Simplify name of createConnection * Fix order of arguments in createConnection * Do not assert on 1-1 conversation names * Use Local newtype for some more local arguments Co-authored-by: jschaul --- changelog.d/5-internal/fed-connections-data | 1 + services/brig/brig.cabal | 4 +- services/brig/package.yaml | 2 + services/brig/src/Brig/API/Connection.hs | 305 +++++++++--------- services/brig/src/Brig/API/Public.hs | 40 +-- services/brig/src/Brig/API/Types.hs | 5 +- services/brig/src/Brig/App.hs | 5 + services/brig/src/Brig/Data/Connection.hs | 186 ++++++----- services/brig/src/Brig/IO/Intra.hs | 68 +++- services/galley/test/integration/API.hs | 8 +- .../test/integration/API/MessageTimer.hs | 2 +- 11 files changed, 357 insertions(+), 269 deletions(-) create mode 100644 changelog.d/5-internal/fed-connections-data diff --git a/changelog.d/5-internal/fed-connections-data b/changelog.d/5-internal/fed-connections-data new file mode 100644 index 00000000000..ece769f80e0 --- /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 7aff982fc2b..0fafc20c83f 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 7a78afb759c..ff6f5a8574d 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 78c7e047ab5..d8c7b4b97e5 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 7d607552c0b..61c99210bea 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 10f3a4fc391..db2a8d95aa3 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 d30481333f7..65a2e3020f1 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 e4b5ab2f470..bcf967be21e 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 1b2d71880e3..8ab904015cc 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 77584660721..fb34dc78b05 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1618,10 +1618,10 @@ postO2OConvOk = do alice <- randomUser bob <- randomUser connectUsers alice (singleton bob) - a <- postO2OConv alice bob (Just "chat") Date: Mon, 4 Oct 2021 15:20:51 +0200 Subject: [PATCH 02/88] Fix detail in stern online help (#1834) --- tools/stern/src/Stern/API.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 903c44fa422..27e8e727098 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -268,7 +268,7 @@ routes = do document "GET" "ejpd-info" $ do Doc.summary "internal wire.com process: https://wearezeta.atlassian.net/wiki/spaces/~463749889/pages/256738296/EJPD+official+requests+process" Doc.parameter Doc.Query "handles" Doc.string' $ - Doc.description "Handles of the user, separated by comments" + Doc.description "Handles of the user, separated by commas (NB: all chars need to be lower case!)" Doc.parameter Doc.Query "include_contacts" Doc.bool' $ do Doc.description "If 'true', this gives you more more exhaustive information about this user (including social network)" Doc.optional From 741fc514b7c0e5ec8e82aee8e56fcfd24b476be7 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 Oct 2021 12:45:20 -0700 Subject: [PATCH 03/88] Spar Polysemy: SAML2 effect (#1827) * Use Input effect instead of a MonadReader instance * Remove ReaderT * Fix package.yaml * Changelog * Review responses * SAML work Remove undefineds Interpreting is really hard Interpret everything wip Add toggleCookie to SAML2 Add Now effect get it compiling build Remove HasCreateUUID instance for Spar * Cleanup * CanonicalInterpreter and necessary changes * Rename to SPImpl * Fake CI * Another fake CI * Use catch in polysemy * Respond to review * Changelog * Apply suggestions from code review Co-authored-by: fisx * Hi CI * make format Co-authored-by: fisx --- changelog.d/5-internal/saml2-effect | 1 + services/spar/spar.cabal | 9 +- services/spar/src/Spar/API.hs | 76 ++++++--- services/spar/src/Spar/App.hs | 153 +++--------------- .../spar/src/Spar/CanonicalInterpreter.hs | 115 +++++++++++++ services/spar/src/Spar/Error.hs | 7 + services/spar/src/Spar/Scim.hs | 2 + services/spar/src/Spar/Scim/User.hs | 18 ++- services/spar/src/Spar/Sem/Now.hs | 9 ++ services/spar/src/Spar/Sem/Now/IO.hs | 10 ++ services/spar/src/Spar/Sem/SAML2.hs | 33 ++++ services/spar/src/Spar/Sem/SAML2/Library.hs | 139 ++++++++++++++++ .../spar/src/Spar/Sem/SamlProtocolSettings.hs | 13 ++ .../Spar/Sem/SamlProtocolSettings/Servant.hs | 18 +++ .../test-integration/Test/Spar/DataSpec.hs | 6 +- services/spar/test-integration/Util/Core.hs | 53 +----- 16 files changed, 455 insertions(+), 207 deletions(-) create mode 100644 changelog.d/5-internal/saml2-effect create mode 100644 services/spar/src/Spar/CanonicalInterpreter.hs create mode 100644 services/spar/src/Spar/Sem/Now.hs create mode 100644 services/spar/src/Spar/Sem/Now/IO.hs create mode 100644 services/spar/src/Spar/Sem/SAML2.hs create mode 100644 services/spar/src/Spar/Sem/SAML2/Library.hs create mode 100644 services/spar/src/Spar/Sem/SamlProtocolSettings.hs create mode 100644 services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs diff --git a/changelog.d/5-internal/saml2-effect b/changelog.d/5-internal/saml2-effect new file mode 100644 index 00000000000..6c97bc700a6 --- /dev/null +++ b/changelog.d/5-internal/saml2-effect @@ -0,0 +1 @@ +Add some new Spar effects, completely isolating us from saml2-web-sso interface diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 7086e210753..48e9772c412 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 573e0f5c3d7b76dbb9fbf48aff2a535df3059af23f8375307021c6c005d98a5b +-- hash: fe28e95f2571e0a2583e7d160ff87f80422801408c265139b1cd2392a425fd72 name: spar version: 0.1 @@ -22,6 +22,7 @@ library exposed-modules: Spar.API Spar.App + Spar.CanonicalInterpreter Spar.Data Spar.Data.Instances Spar.Error @@ -52,8 +53,14 @@ library Spar.Sem.IdP.Mem Spar.Sem.Logger Spar.Sem.Logger.TinyLog + Spar.Sem.Now + Spar.Sem.Now.IO Spar.Sem.Random Spar.Sem.Random.IO + Spar.Sem.SAML2 + Spar.Sem.SAML2.Library + Spar.Sem.SamlProtocolSettings + Spar.Sem.SamlProtocolSettings.Servant Spar.Sem.SAMLUserStore Spar.Sem.SAMLUserStore.Cassandra Spar.Sem.ScimExternalIdStore diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 4598a56cd76..ae21f03f0fa 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -59,6 +59,7 @@ import qualified SAML2.WebSSO as SAML import Servant import qualified Servant.Multipart as Multipart import Spar.App +import Spar.CanonicalInterpreter import qualified Spar.Data as Data (GetIdPResult (..), Replaced (..), Replacing (..)) import Spar.Error import qualified Spar.Intra.BrigApp as Brig @@ -78,10 +79,15 @@ import qualified Spar.Sem.GalleyAccess as GalleyAccess import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger +import Spar.Sem.Now (Now) import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random +import Spar.Sem.SAML2 (SAML2) +import qualified Spar.Sem.SAML2 as SAML2 import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore +import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings) +import qualified Spar.Sem.SamlProtocolSettings as SamlProtocolSettings import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore @@ -97,7 +103,7 @@ import Wire.API.User.Saml app :: Env -> Application app ctx = SAML.setHttpCachePolicy $ - serve (Proxy @API) (hoistServer (Proxy @API) (SAML.nt @SparError @(Spar _) ctx) (api $ sparCtxOpts ctx) :: Server API) + serve (Proxy @API) (hoistServer (Proxy @API) (runSparToHandler ctx) (api $ sparCtxOpts ctx) :: Server API) api :: Members @@ -115,9 +121,14 @@ api :: IdPEffect.IdP, SAMLUserStore, Random, + Error SparError, + SAML2, + Now, + SamlProtocolSettings, Logger String, Logger (Msg -> Msg), - Error SparError + -- TODO(sandy): Remove me when we get rid of runSparInSem + Final IO ] r => Opts -> @@ -144,14 +155,19 @@ apiSSO :: DefaultSsoCode, IdPEffect.IdP, Random, - SAMLUserStore + Error SparError, + SAML2, + SamlProtocolSettings, + SAMLUserStore, + -- TODO(sandy): Remove me when we get rid of runSparInSem + Final IO ] r => Opts -> ServerT APISSO (Spar r) apiSSO opts = - SAML.meta appName (sparSPIssuer Nothing) (sparResponseURI Nothing) - :<|> (\tid -> SAML.meta appName (sparSPIssuer (Just tid)) (sparResponseURI (Just tid))) + (liftSem $ SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing)) + :<|> (\tid -> liftSem $ SAML2.meta appName (SamlProtocolSettings.spIssuer (Just tid)) (SamlProtocolSettings.responseURI (Just tid))) :<|> authreqPrecheck :<|> authreq (maxttlAuthreqDiffTime opts) DoInitiateLogin :<|> authresp Nothing @@ -202,7 +218,7 @@ appName = "spar" authreqPrecheck :: Member IdPEffect.IdP r => Maybe URI.URI -> Maybe URI.URI -> SAML.IdPId -> Spar r NoContent authreqPrecheck msucc merr idpid = validateAuthreqParams msucc merr - *> SAML.getIdPConfig idpid + *> getIdPConfig idpid *> return NoContent authreq :: @@ -213,6 +229,8 @@ authreq :: BindCookieStore, AssIDStore, AReqIDStore, + SAML2, + SamlProtocolSettings, IdPEffect.IdP ] r => @@ -233,7 +251,7 @@ authreq authreqttl _ zusr msucc merr idpid = do mbtid = case fromMaybe defWireIdPAPIVersion (idp ^. SAML.idpExtraInfo . wiApiVersion) of WireIdPAPIV1 -> Nothing WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam - SAML.authreq authreqttl (sparSPIssuer mbtid) idpid + liftSem $ SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid wrapMonadClientSem $ AReqIDStore.storeVerdictFormat authreqttl reqid vformat cky <- initializeBindCookie zusr authreqttl liftSem $ Logger.log SAML.Debug $ "setting bind cookie: " <> show cky @@ -243,7 +261,14 @@ authreq authreqttl _ zusr msucc merr idpid = do -- domain, and store it in C*. If the user is not authenticated, return a deletion 'SetCookie' -- value that deletes any bind cookies on the client. initializeBindCookie :: - Members '[Random, Input Opts, Logger String, BindCookieStore] r => + Members + '[ Random, + SAML2, + Input Opts, + Logger String, + BindCookieStore + ] + r => Maybe UserId -> NominalDiffTime -> Spar r SetBindCookie @@ -253,7 +278,7 @@ initializeBindCookie zusr authreqttl = do if isJust zusr then liftSem $ Just . cs . ES.encode <$> Random.bytes 32 else pure Nothing - cky <- fmap SetBindCookie . SAML.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret + cky <- fmap SetBindCookie . liftSem . SAML2.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret forM_ zusr $ \userid -> wrapMonadClientSem $ BindCookieStore.insert cky userid authreqttl pure cky @@ -289,28 +314,33 @@ authresp :: AReqIDStore, ScimTokenStore, IdPEffect.IdP, - SAMLUserStore + SAML2, + SamlProtocolSettings, + Error SparError, + SAMLUserStore, + -- TODO(sandy): Remove me when we get rid of runSparInSem + Final IO ] r => Maybe TeamId -> Maybe ST -> SAML.AuthnResponseBody -> Spar r Void -authresp mbtid ckyraw arbody = logErrors $ SAML.authresp mbtid (sparSPIssuer mbtid) (sparResponseURI mbtid) go arbody +authresp mbtid ckyraw arbody = logErrors $ liftSem $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody where cky :: Maybe BindCookie cky = ckyraw >>= bindCookieFromHeader - go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Spar r Void + go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Sem r Void go resp verdict = do - result :: SAML.ResponseVerdict <- verdictHandler cky mbtid resp verdict - throwError $ SAML.CustomServant result + result :: SAML.ResponseVerdict <- runSparInSem $ verdictHandler cky mbtid resp verdict + throw @SparError $ SAML.CustomServant result logErrors :: Spar r Void -> Spar r Void - logErrors = flip catchError $ \case - e@(SAML.CustomServant _) -> throwError e + logErrors action = liftSem . catch @SparError (runSparInSem action) $ \case + e@(SAML.CustomServant _) -> throw e e -> do - throwError . SAML.CustomServant $ + throw @SparError . SAML.CustomServant $ errorPage e (Multipart.inputs (SAML.authnResponseBodyRaw arbody)) @@ -337,7 +367,7 @@ idpGet :: SAML.IdPId -> Spar r IdP idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do - idp <- SAML.getIdPConfig idpid + idp <- getIdPConfig idpid _ <- liftSem $ authorizeIdP zusr idp pure idp @@ -347,7 +377,7 @@ idpGetRaw :: SAML.IdPId -> Spar r RawIdPMetadata idpGetRaw zusr idpid = do - idp <- SAML.getIdPConfig idpid + idp <- getIdPConfig idpid _ <- liftSem $ authorizeIdP zusr idp wrapMonadClientSem (IdPEffect.getRawMetadata idpid) >>= \case Just txt -> pure $ RawIdPMetadata txt @@ -396,7 +426,7 @@ idpDelete :: Maybe Bool -> Spar r NoContent idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (const Nothing) $ do - idp <- SAML.getIdPConfig idpid + idp <- getIdPConfig idpid _ <- liftSem $ authorizeIdP zusr idp let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer team = idp ^. SAML.idpExtraInfo . wiTeam @@ -491,7 +521,7 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive assertNoScimOrNoIdP teamid idp <- validateNewIdP apiversion idpmeta teamid mReplaces wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw - SAML.storeIdPConfig idp + storeIdPConfig idp forM_ mReplaces $ \replaces -> wrapMonadClientSem $ do IdPEffect.setReplacedBy (Data.Replaced replaces) (Data.Replacing (idp ^. SAML.idpId)) pure idp @@ -539,7 +569,7 @@ validateNewIdP :: Maybe SAML.IdPId -> m IdP validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validateNewIdP" (Just . show . (^. SAML.idpId)) $ do - _idpId <- SAML.IdPId <$> SAML.createUUID + _idpId <- SAML.IdPId <$> liftSem Random.uuid oldIssuers :: [SAML.Issuer] <- case mReplaces of Nothing -> pure [] Just replaces -> do @@ -616,7 +646,7 @@ idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^ -- (if raw metadata is stored and then spar goes out, raw metadata won't match the -- structured idp config. since this will lead to a 5xx response, the client is epected to -- try again, which would clean up cassandra state.) - SAML.storeIdPConfig idp + storeIdPConfig idp pure idp -- | Check that: idp id is valid; calling user is admin in that idp's home team; team id in diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 733effb5e30..7b7bfc9d3b4 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -38,7 +38,10 @@ module Spar.App deleteTeam, wrapSpar, liftSem, - type RealInterpretation, + getIdPConfig, + storeIdPConfig, + getIdPConfigByIssuerOptionalSPId, + runSparInSem, ) where @@ -59,26 +62,17 @@ import Data.Id import Data.String.Conversions import Data.Text.Ascii (encodeBase64, toText) import qualified Data.Text.Lazy as LT -import Imports hiding (log) +import Imports hiding (MonadReader, asks, log) import qualified Network.HTTP.Types.Status as Http import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error import Polysemy.Final -import Polysemy.Input (Input, input, inputs, runInputConst) +import Polysemy.Input (Input, input) import SAML2.Util (renderURI) import SAML2.WebSSO - ( Assertion (..), - AuthnRequest (..), - HasConfig (..), - HasCreateUUID (..), - HasLogger (..), - HasNow (..), - IdPId (..), + ( IdPId (..), Issuer (..), - SPHandler (..), - SPStoreID (..), - SPStoreIdP (getIdPConfigByIssuerOptionalSPId), UnqualifiedNameID (..), explainDeniedReason, idpExtraInfo, @@ -95,41 +89,24 @@ import qualified Spar.Intra.BrigApp as Intra import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) import qualified Spar.Sem.AReqIDStore as AReqIDStore -import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError) -import Spar.Sem.AssIDStore (AssIDStore) -import qualified Spar.Sem.AssIDStore as AssIDStore -import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) import Spar.Sem.BindCookieStore (BindCookieStore) import qualified Spar.Sem.BindCookieStore as BindCookieStore -import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.BrigAccess.Http (brigAccessToHttp) -import Spar.Sem.DefaultSsoCode (DefaultSsoCode) -import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess -import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import Spar.Sem.IdP (GetIdPResult (..)) import qualified Spar.Sem.IdP as IdPEffect -import Spar.Sem.IdP.Cassandra (idPToCassandra) import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger -import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random -import Spar.Sem.Random.IO (randomToIO) import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore -import Spar.Sem.SAMLUserStore.Cassandra (interpretClientToIO, samlUserStoreToCassandra) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore -import Spar.Sem.ScimExternalIdStore.Cassandra (scimExternalIdStoreToCassandra) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore -import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) -import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) -import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) import qualified System.Logger as TinyLog import URI.ByteString as URI import Web.Cookie (SetCookie, renderSetCookie) @@ -160,9 +137,6 @@ instance MonadError SparError (Spar r) where instance MonadIO (Spar r) where liftIO m = Spar $ lift $ embedFinal m -instance Members '[Input Opts, Logger String] r => HasLogger (Spar r) where - logger lvl = liftSem . Logger.log lvl - data Env = Env { sparCtxOpts :: Opts, sparCtxLogger :: TinyLog.Logger, @@ -173,42 +147,26 @@ data Env = Env sparCtxRequestId :: RequestId } -instance Member (Input Opts) r => HasConfig (Spar r) where - getConfig = liftSem $ inputs saml - -instance HasNow (Spar r) - -instance Member Random r => HasCreateUUID (Spar r) where - createUUID = liftSem Random.uuid - -instance Member AReqIDStore r => SPStoreID AuthnRequest (Spar r) where - storeID i r = wrapMonadClientSem $ AReqIDStore.store i r - unStoreID r = wrapMonadClientSem $ AReqIDStore.unStore r - isAliveID r = wrapMonadClientSem $ AReqIDStore.isAlive r +runSparInSem :: Members '[Final IO, Error SparError] r => Spar r a -> Sem r a +runSparInSem (Spar action) = + runExceptT action >>= \case + Left err -> throw err + Right a -> pure a -instance Member AssIDStore r => SPStoreID Assertion (Spar r) where - storeID i r = wrapMonadClientSem $ AssIDStore.store i r - unStoreID r = wrapMonadClientSem $ AssIDStore.unStore r - isAliveID r = wrapMonadClientSem $ AssIDStore.isAlive r +getIdPConfig :: Member IdPEffect.IdP r => IdPId -> Spar r IdP +getIdPConfig = (>>= maybe (throwSpar (SparIdPNotFound mempty)) pure) . wrapMonadClientSem . IdPEffect.getConfig -instance Member IdPEffect.IdP r => SPStoreIdP SparError (Spar r) where - type IdPConfigExtra (Spar r) = WireIdP - type IdPConfigSPId (Spar r) = TeamId +storeIdPConfig :: Member IdPEffect.IdP r => IdP -> Spar r () +storeIdPConfig idp = wrapMonadClientSem $ IdPEffect.storeConfig idp - storeIdPConfig :: IdP -> Spar r () - storeIdPConfig idp = wrapMonadClientSem $ IdPEffect.storeConfig idp - - getIdPConfig :: IdPId -> Spar r IdP - getIdPConfig = (>>= maybe (throwSpar (SparIdPNotFound mempty)) pure) . wrapMonadClientSem . IdPEffect.getConfig - - getIdPConfigByIssuerOptionalSPId :: Issuer -> Maybe TeamId -> Spar r IdP - getIdPConfigByIssuerOptionalSPId issuer mbteam = do - wrapSpar (getIdPConfigByIssuerAllowOld issuer mbteam) >>= \case - Data.GetIdPFound idp -> pure idp - Data.GetIdPNotFound -> throwSpar $ SparIdPNotFound mempty - res@(Data.GetIdPDanglingId _) -> throwSpar $ SparIdPNotFound (cs $ show res) - res@(Data.GetIdPNonUnique _) -> throwSpar $ SparIdPNotFound (cs $ show res) - res@(Data.GetIdPWrongTeam _) -> throwSpar $ SparIdPNotFound (cs $ show res) +getIdPConfigByIssuerOptionalSPId :: Member IdPEffect.IdP r => Issuer -> Maybe TeamId -> Spar r IdP +getIdPConfigByIssuerOptionalSPId issuer mbteam = do + wrapSpar (getIdPConfigByIssuerAllowOld issuer mbteam) >>= \case + Data.GetIdPFound idp -> pure idp + Data.GetIdPNotFound -> throwSpar $ SparIdPNotFound mempty + res@(Data.GetIdPDanglingId _) -> throwSpar $ SparIdPNotFound (cs $ show res) + res@(Data.GetIdPNonUnique _) -> throwSpar $ SparIdPNotFound (cs $ show res) + res@(Data.GetIdPWrongTeam _) -> throwSpar $ SparIdPNotFound (cs $ show res) instance Member (Final IO) r => Catch.MonadThrow (Sem r) where throwM = embedFinal . Catch.throwM @IO @@ -421,69 +379,6 @@ bindUser buid userref = do Ephemeral -> err oldStatus PendingInvitation -> liftSem $ BrigAccess.setStatus buid Active -type RealInterpretation = - '[ BindCookieStore, - AssIDStore, - AReqIDStore, - ScimExternalIdStore, - ScimUserTimesStore, - ScimTokenStore, - DefaultSsoCode, - IdPEffect.IdP, - SAMLUserStore, - Embed (Cas.Client), - BrigAccess, - GalleyAccess, - Error TTLError, - Error SparError, - -- TODO(sandy): Make this a Logger Text instead - Logger String, - Logger (TinyLog.Msg -> TinyLog.Msg), - Input Opts, - Input TinyLog.Logger, - Random, - Embed IO, - Final IO - ] - -instance r ~ RealInterpretation => SPHandler SparError (Spar r) where - type NTCTX (Spar r) = Env - nt :: forall a. Env -> Spar r a -> Handler a - nt ctx (Spar action) = do - err <- actionHandler - throwErrorAsHandlerException err - where - actionHandler :: Handler (Either SparError a) - actionHandler = - fmap join - . liftIO - . runFinal - . embedToFinal @IO - . randomToIO - . runInputConst (sparCtxLogger ctx) - . runInputConst (sparCtxOpts ctx) - . loggerToTinyLog (sparCtxLogger ctx) - . stringLoggerToTinyLog - . runError @SparError - . ttlErrorToSparError - . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) - . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) - . interpretClientToIO (sparCtxCas ctx) - . samlUserStoreToCassandra @Cas.Client - . idPToCassandra @Cas.Client - . defaultSsoCodeToCassandra - . scimTokenStoreToCassandra - . scimUserTimesStoreToCassandra - . scimExternalIdStoreToCassandra - . aReqIDStoreToCassandra - . assIDStoreToCassandra - . bindCookieStoreToCassandra - $ runExceptT action - throwErrorAsHandlerException :: Either SparError a -> Handler a - throwErrorAsHandlerException (Left err) = - sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError - throwErrorAsHandlerException (Right a) = pure a - -- | The from of the response on the finalize-login request depends on the verdict (denied or -- granted), plus the choice that the client has made during the initiate-login request. Here we -- call either 'verdictHandlerWeb' or 'verdictHandlerMobile', resp., on the 'SAML.AccessVerdict'. diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs new file mode 100644 index 00000000000..3cc7481258f --- /dev/null +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -0,0 +1,115 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.CanonicalInterpreter where + +import qualified Cassandra as Cas +import Control.Monad.Except +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input (Input, runInputConst) +import Servant +import Spar.App +import Spar.Error +import Spar.Orphans () +import Spar.Sem.AReqIDStore (AReqIDStore) +import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError) +import Spar.Sem.AssIDStore (AssIDStore) +import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) +import Spar.Sem.BindCookieStore (BindCookieStore) +import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) +import Spar.Sem.BrigAccess (BrigAccess) +import Spar.Sem.BrigAccess.Http (brigAccessToHttp) +import Spar.Sem.DefaultSsoCode (DefaultSsoCode) +import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) +import Spar.Sem.GalleyAccess (GalleyAccess) +import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) +import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdP.Cassandra (idPToCassandra) +import Spar.Sem.Logger (Logger) +import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) +import Spar.Sem.Now (Now) +import Spar.Sem.Now.IO (nowToIO) +import Spar.Sem.Random (Random) +import Spar.Sem.Random.IO (randomToIO) +import Spar.Sem.SAML2 (SAML2) +import Spar.Sem.SAML2.Library (saml2ToSaml2WebSso) +import Spar.Sem.SAMLUserStore (SAMLUserStore) +import Spar.Sem.SAMLUserStore.Cassandra (interpretClientToIO, samlUserStoreToCassandra) +import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings) +import Spar.Sem.SamlProtocolSettings.Servant (sparRouteToServant) +import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) +import Spar.Sem.ScimExternalIdStore.Cassandra (scimExternalIdStoreToCassandra) +import Spar.Sem.ScimTokenStore (ScimTokenStore) +import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) +import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) +import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) +import qualified System.Logger as TinyLog +import Wire.API.User.Saml + +type CanonicalEffs = + '[ SAML2, + SamlProtocolSettings, + BindCookieStore, + AssIDStore, + AReqIDStore, + ScimExternalIdStore, + ScimUserTimesStore, + ScimTokenStore, + DefaultSsoCode, + IdPEffect.IdP, + SAMLUserStore, + Embed (Cas.Client), + BrigAccess, + GalleyAccess, + Error TTLError, + Error SparError, + -- TODO(sandy): Make this a Logger Text instead + Logger String, + Logger (TinyLog.Msg -> TinyLog.Msg), + Input Opts, + Input TinyLog.Logger, + Random, + Now, + Embed IO, + Final IO + ] + +runSparToIO :: Env -> Spar CanonicalEffs a -> IO (Either SparError a) +runSparToIO ctx (Spar action) = + fmap join + . runFinal + . embedToFinal @IO + . nowToIO + . randomToIO + . runInputConst (sparCtxLogger ctx) + . runInputConst (sparCtxOpts ctx) + . loggerToTinyLog (sparCtxLogger ctx) + . stringLoggerToTinyLog + . runError @SparError + . ttlErrorToSparError + . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) + . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) + . interpretClientToIO (sparCtxCas ctx) + . samlUserStoreToCassandra + . idPToCassandra + . defaultSsoCodeToCassandra + . scimTokenStoreToCassandra + . scimUserTimesStoreToCassandra + . scimExternalIdStoreToCassandra + . aReqIDStoreToCassandra + . assIDStoreToCassandra + . bindCookieStoreToCassandra + . sparRouteToServant (saml $ sparCtxOpts ctx) + . saml2ToSaml2WebSso + $ runExceptT action + +runSparToHandler :: Env -> Spar CanonicalEffs a -> Handler a +runSparToHandler ctx spar = do + err <- liftIO $ runSparToIO ctx spar + throwErrorAsHandlerException err + where + throwErrorAsHandlerException :: Either SparError a -> Handler a + throwErrorAsHandlerException (Left err) = + sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError + throwErrorAsHandlerException (Right a) = pure a diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index fb96e017b7e..1bb2be8d966 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -100,6 +100,12 @@ data SparCustomError | SparIdPIssuerInUse | SparProvisioningMoreThanOneIdP LT | SparProvisioningTokenLimitReached + | -- | FUTUREWORK(fisx): This constructor is used in exactly one place (see + -- "Spar.Sem.SAML2.Library"), for an error that immediately gets caught. + -- Instead, we could just use an IO exception, and catch it with + -- 'catchErrors' (see "Spar.Run"). Maybe we want to remove this case + -- altogether? Not sure. + SparInternalError LT | -- | All errors returned from SCIM handlers are wrapped into 'SparScimError' SparScimError Scim.ScimError deriving (Eq, Show) @@ -184,6 +190,7 @@ renderSparError (SAML.CustomError (SparProvisioningMoreThanOneIdP msg)) = Right renderSparError (SAML.CustomError SparProvisioningTokenLimitReached) = Right $ Wai.mkError status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached" -- SCIM errors renderSparError (SAML.CustomError (SparScimError err)) = Left $ Scim.scimToServerError err +renderSparError (SAML.CustomError (SparInternalError err)) = Right $ Wai.mkError status500 "server-error" ("Internal error: " <> err) -- Other renderSparError (SAML.CustomServant err) = Left err diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index ac883f39d39..8f6d0db1765 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -88,6 +88,7 @@ import Spar.Sem.BrigAccess (BrigAccess) import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.Logger (Logger) +import Spar.Sem.Now (Now) import Spar.Sem.Random (Random) import Spar.Sem.SAMLUserStore (SAMLUserStore) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -121,6 +122,7 @@ apiScim :: Input Opts, Logger (Msg -> Msg), Logger String, + Now, Error SparError, GalleyAccess, BrigAccess, diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index d74b3a65dc5..64cbd0d6e9d 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -76,6 +76,8 @@ import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger +import Spar.Sem.Now (Now) +import qualified Spar.Sem.Now as Now import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -115,6 +117,7 @@ instance Logger String, Random, Input Opts, + Now, GalleyAccess, BrigAccess, ScimExternalIdStore, @@ -394,6 +397,7 @@ createValidScimUser :: (m ~ Scim.ScimHandler (Spar r)) => Members '[ Random, + Now, Input Opts, Logger (Msg -> Msg), Logger String, @@ -491,6 +495,7 @@ updateValidScimUser :: Input Opts, Logger (Msg -> Msg), Logger String, + Now, GalleyAccess, BrigAccess, ScimExternalIdStore, @@ -609,13 +614,13 @@ toScimStoredUser' createdAt lastChangedAt baseuri uid usr = } updScimStoredUser :: - forall m. - (SAML.HasNow m) => + forall r. + Member Now r => Scim.User ST.SparTag -> Scim.StoredUser ST.SparTag -> - m (Scim.StoredUser ST.SparTag) + Spar r (Scim.StoredUser ST.SparTag) updScimStoredUser usr storedusr = do - SAML.Time (toUTCTimeMillis -> now) <- SAML.getNow + SAML.Time (toUTCTimeMillis -> now) <- liftSem Now.get pure $ updScimStoredUser' now usr storedusr updScimStoredUser' :: @@ -769,6 +774,7 @@ synthesizeStoredUser :: forall r. Members '[ Input Opts, + Now, Logger (Msg -> Msg), BrigAccess, ScimUserTimesStore @@ -807,7 +813,7 @@ synthesizeStoredUser usr veid = liftSem $ BrigAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri) <- lift readState - SAML.Time (toUTCTimeMillis -> now) <- lift SAML.getNow + SAML.Time (toUTCTimeMillis -> now) <- lift $ liftSem Now.get let (createdAt, lastUpdatedAt) = fromMaybe (now, now) accessTimes handle <- lift $ liftSem $ Brig.giveDefaultHandle (accountUser usr) @@ -865,6 +871,7 @@ synthesizeScimUser info = scimFindUserByHandle :: Members '[ Input Opts, + Now, Logger (Msg -> Msg), BrigAccess, ScimUserTimesStore @@ -892,6 +899,7 @@ scimFindUserByEmail :: forall r. Members '[ Input Opts, + Now, Logger (Msg -> Msg), BrigAccess, ScimExternalIdStore, diff --git a/services/spar/src/Spar/Sem/Now.hs b/services/spar/src/Spar/Sem/Now.hs new file mode 100644 index 00000000000..4c43be4a466 --- /dev/null +++ b/services/spar/src/Spar/Sem/Now.hs @@ -0,0 +1,9 @@ +module Spar.Sem.Now where + +import Polysemy +import qualified SAML2.WebSSO as SAML + +data Now m a where + Get :: Now m SAML.Time + +makeSem ''Now diff --git a/services/spar/src/Spar/Sem/Now/IO.hs b/services/spar/src/Spar/Sem/Now/IO.hs new file mode 100644 index 00000000000..74f75f738b8 --- /dev/null +++ b/services/spar/src/Spar/Sem/Now/IO.hs @@ -0,0 +1,10 @@ +module Spar.Sem.Now.IO where + +import Imports +import Polysemy +import SAML2.WebSSO (getNowIO) +import Spar.Sem.Now + +nowToIO :: Member (Embed IO) r => Sem (Now ': r) a -> Sem r a +nowToIO = interpret $ \case + Get -> embed @IO getNowIO diff --git a/services/spar/src/Spar/Sem/SAML2.hs b/services/spar/src/Spar/Sem/SAML2.hs new file mode 100644 index 00000000000..ae5007e9709 --- /dev/null +++ b/services/spar/src/Spar/Sem/SAML2.hs @@ -0,0 +1,33 @@ +module Spar.Sem.SAML2 where + +import Data.Id (TeamId) +import Data.String.Conversions (SBS, ST) +import Data.Time (NominalDiffTime) +import GHC.TypeLits (KnownSymbol) +import Imports hiding (log) +import Polysemy +import SAML2.WebSSO +import URI.ByteString (URI) + +data SAML2 m a where + AuthReq :: + NominalDiffTime -> + m Issuer -> + IdPId -> + SAML2 m (FormRedirect AuthnRequest) + AuthResp :: + Maybe TeamId -> + m Issuer -> + m URI -> + (AuthnResponse -> AccessVerdict -> m resp) -> + AuthnResponseBody -> + SAML2 m resp + Meta :: ST -> m Issuer -> m URI -> SAML2 m SPMetadata + ToggleCookie :: + KnownSymbol name => + SBS -> + Maybe (ST, NominalDiffTime) -> + SAML2 m (SimpleSetCookie name) + +-- TODO(sandy): Inline this definition --- no TH +makeSem ''SAML2 diff --git a/services/spar/src/Spar/Sem/SAML2/Library.hs b/services/spar/src/Spar/Sem/SAML2/Library.hs new file mode 100644 index 00000000000..3de69921410 --- /dev/null +++ b/services/spar/src/Spar/Sem/SAML2/Library.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.SAML2.Library (saml2ToSaml2WebSso) where + +import qualified Control.Monad.Catch as Catch +import Control.Monad.Except +import Data.Id (TeamId) +import Data.String.Conversions (cs) +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Internal.Tactics +import SAML2.WebSSO hiding (Error) +import qualified SAML2.WebSSO as SAML hiding (Error) +import qualified Spar.App as App +import Spar.Error (SparCustomError (..), SparError) +import Spar.Sem.AReqIDStore (AReqIDStore) +import qualified Spar.Sem.AReqIDStore as AReqIDStore +import Spar.Sem.AssIDStore (AssIDStore) +import qualified Spar.Sem.AssIDStore as AssIDStore +import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.Logger (Logger) +import qualified Spar.Sem.Logger as Logger +import Spar.Sem.SAML2 +import Wire.API.User.IdentityProvider (WireIdP) +import Wire.API.User.Saml + +wrapMonadClientSPImpl :: Members '[Error SparError, Final IO] r => Sem r a -> SPImpl r a +wrapMonadClientSPImpl action = + SPImpl $ + action + `Catch.catch` (throw . SAML.CustomError . SparCassandraError . cs . show @SomeException) + +newtype SPImpl r a = SPImpl {unSPImpl :: Sem r a} + deriving (Functor, Applicative, Monad) + +instance Member (Input Opts) r => HasConfig (SPImpl r) where + getConfig = SPImpl $ inputs saml + +instance Members '[Input Opts, Logger String] r => HasLogger (SPImpl r) where + logger lvl = SPImpl . Logger.log lvl + +instance Member (Embed IO) r => MonadIO (SPImpl r) where + liftIO = SPImpl . embed @IO + +instance Member (Embed IO) r => HasCreateUUID (SPImpl r) + +instance Member (Embed IO) r => HasNow (SPImpl r) + +instance Members '[Error SparError, Final IO, AReqIDStore] r => SPStoreID AuthnRequest (SPImpl r) where + storeID = (wrapMonadClientSPImpl .) . AReqIDStore.store + unStoreID = wrapMonadClientSPImpl . AReqIDStore.unStore + isAliveID = wrapMonadClientSPImpl . AReqIDStore.isAlive + +instance Members '[Error SparError, Final IO, AssIDStore] r => SPStoreID Assertion (SPImpl r) where + storeID = (wrapMonadClientSPImpl .) . AssIDStore.store + unStoreID = wrapMonadClientSPImpl . AssIDStore.unStore + isAliveID = wrapMonadClientSPImpl . AssIDStore.isAlive + +instance Members '[Error SparError, IdPEffect.IdP, Final IO] r => SPStoreIdP SparError (SPImpl r) where + type IdPConfigExtra (SPImpl r) = WireIdP + type IdPConfigSPId (SPImpl r) = TeamId + + storeIdPConfig = SPImpl . App.runSparInSem . App.storeIdPConfig + getIdPConfig = SPImpl . App.runSparInSem . App.getIdPConfig + getIdPConfigByIssuerOptionalSPId a = SPImpl . App.runSparInSem . App.getIdPConfigByIssuerOptionalSPId a + +instance Member (Error SparError) r => MonadError SparError (SPImpl r) where + throwError = SPImpl . throw + catchError m handler = SPImpl $ catch (unSPImpl m) $ unSPImpl . handler + +-- | To learn more about polysemy tactics, read this: +-- * https://reasonablypolymorphic.com/blog/freer-higher-order-effects/ +-- * https://reasonablypolymorphic.com/blog/tactics/ +saml2ToSaml2WebSso :: + forall r a. + Members + '[ AReqIDStore, + AssIDStore, + Error SparError, + IdPEffect.IdP, + Input Opts, + Logger String, + Embed IO, + Final IO + ] + r => + Sem (SAML2 ': r) a -> + Sem r a +saml2ToSaml2WebSso = + interpretH $ \case + AuthReq n ma i -> do + get_a <- runT ma + ins <- getInspectorT + x <- raise $ unSPImpl $ SAML.authreq @_ @SparError n (inspectOrBomb ins get_a) i + s <- getInitialStateT + pure $ x <$ s + AuthResp mitlt ma mb mc ab -> do + get_a <- runT ma + get_b <- runT mb + get_c <- bindT $ uncurry mc + ins <- getInspectorT + s <- getInitialStateT + x <- raise $ unSPImpl $ SAML.authresp mitlt (inspectOrBomb ins get_a) (inspectOrBomb ins get_b) (\x y -> inspectOrBomb ins $ get_c $ (x, y) <$ s) ab + pure $ x <$ s + Meta t ma mb -> do + get_a <- runT ma + get_b <- runT mb + ins <- getInspectorT + x <- raise $ unSPImpl $ SAML.meta t (inspectOrBomb ins get_a) (inspectOrBomb ins get_b) + s <- getInitialStateT + pure $ x <$ s + ToggleCookie sbs mp -> do + liftT $ unSPImpl $ SAML.toggleCookie sbs mp + +inspectOrBomb :: + Members + '[ AReqIDStore, + AssIDStore, + Error SparError, + IdPEffect.IdP, + Logger String, + Input Opts, + Embed IO, + Final IO + ] + r => + Inspector f -> + Sem (SAML2 : r) (f b) -> + SPImpl r b +inspectOrBomb ins get_a = do + fa <- SPImpl $ saml2ToSaml2WebSso get_a + maybe + (SPImpl . throw @SparError $ SAML.CustomError $ SparInternalError "saml2ToSaml2WebSso called with an uninspectable weaving functor") + pure + $ inspect ins fa diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings.hs new file mode 100644 index 00000000000..ea545706614 --- /dev/null +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings.hs @@ -0,0 +1,13 @@ +module Spar.Sem.SamlProtocolSettings where + +import Data.Id (TeamId) +import Imports +import Polysemy +import qualified SAML2.WebSSO.Types as SAML +import qualified URI.ByteString as URI + +data SamlProtocolSettings m a where + SpIssuer :: Maybe TeamId -> SamlProtocolSettings m SAML.Issuer + ResponseURI :: Maybe TeamId -> SamlProtocolSettings m URI.URI + +makeSem ''SamlProtocolSettings diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs new file mode 100644 index 00000000000..138ba41640f --- /dev/null +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Spar.Sem.SamlProtocolSettings.Servant where + +import Imports +import Polysemy +import qualified SAML2.WebSSO as SAML +import Spar.Sem.SamlProtocolSettings +import Wire.API.Routes.Public.Spar + +-- TODO(sandy): Why is this instance not provided by SAML? Very rude! +instance SAML.HasConfig ((->) SAML.Config) where + getConfig = id + +sparRouteToServant :: SAML.Config -> Sem (SamlProtocolSettings ': r) a -> Sem r a +sparRouteToServant cfg = interpret $ \x -> case x of + SpIssuer mitlt -> pure $ sparSPIssuer mitlt cfg + ResponseURI mitlt -> pure $ sparResponseURI mitlt cfg diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index b37ba065a80..a294653fe3c 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -230,9 +230,9 @@ spec = do testSPStoreID :: forall (a :: Type). (Typeable a) => - (SAML.ID a -> SAML.Time -> Sem RealInterpretation ()) -> - (SAML.ID a -> Sem RealInterpretation ()) -> - (SAML.ID a -> Sem RealInterpretation Bool) -> + (SAML.ID a -> SAML.Time -> Sem CanonicalEffs ()) -> + (SAML.ID a -> Sem CanonicalEffs ()) -> + (SAML.ID a -> Sem CanonicalEffs Bool) -> SpecWith TestEnv testSPStoreID store unstore isalive = do describe ("SPStoreID @" <> show (typeRep @a)) $ do diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index a4f799881c8..c66bbdd5bef 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -117,7 +117,7 @@ module Util.Core ssoToUidSpar, runSimpleSP, runSpar, - type RealInterpretation, + type CanonicalEffs, getSsoidViaSelf, getSsoidViaSelf', getUserIdViaRef, @@ -168,35 +168,20 @@ import Network.HTTP.Client.MultipartFormData import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp.Internal as Warp import qualified Options.Applicative as OPA -import Polysemy -import Polysemy.Error (runError) -import Polysemy.Input import SAML2.WebSSO as SAML import qualified SAML2.WebSSO.API.Example as SAML import SAML2.WebSSO.Test.Lenses (userRefL) import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util (SampleIdP (..), makeSampleIdPMetadata) -import Spar.App (liftSem, type RealInterpretation) +import Spar.App (liftSem) import qualified Spar.App as Spar -import Spar.Error (SparError) +import Spar.CanonicalInterpreter import qualified Spar.Intra.BrigApp as Intra import qualified Spar.Options import Spar.Run -import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError) -import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) -import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) -import Spar.Sem.BrigAccess.Http (brigAccessToHttp) -import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) -import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) -import Spar.Sem.IdP.Cassandra -import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog, toLevel) -import Spar.Sem.Random.IO (randomToIO) +import Spar.Sem.Logger.TinyLog (toLevel) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore -import Spar.Sem.SAMLUserStore.Cassandra import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore -import Spar.Sem.ScimExternalIdStore.Cassandra (scimExternalIdStoreToCassandra) -import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) -import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) import qualified System.Logger.Extended as Log import System.Random (randomRIO) import Test.Hspec hiding (it, pending, pendingWith, xit) @@ -1236,36 +1221,12 @@ runSimpleSP action = do runSpar :: (MonadReader TestEnv m, MonadIO m) => - Spar.Spar RealInterpretation a -> + Spar.Spar CanonicalEffs a -> m a -runSpar (Spar.Spar action) = do +runSpar action = do ctx <- (^. teSparEnv) <$> ask liftIO $ do - result <- - fmap join - . liftIO - . runFinal - . embedToFinal @IO - . randomToIO - . runInputConst (Spar.sparCtxLogger ctx) - . runInputConst (Spar.sparCtxOpts ctx) - . loggerToTinyLog (Spar.sparCtxLogger ctx) - . stringLoggerToTinyLog - . runError @SparError - . ttlErrorToSparError - . galleyAccessToHttp (Spar.sparCtxHttpManager ctx) (Spar.sparCtxHttpGalley ctx) - . brigAccessToHttp (Spar.sparCtxHttpManager ctx) (Spar.sparCtxHttpBrig ctx) - . interpretClientToIO (Spar.sparCtxCas ctx) - . samlUserStoreToCassandra @Cas.Client - . idPToCassandra @Cas.Client - . defaultSsoCodeToCassandra - . scimTokenStoreToCassandra - . scimUserTimesStoreToCassandra - . scimExternalIdStoreToCassandra - . aReqIDStoreToCassandra - . assIDStoreToCassandra - . bindCookieStoreToCassandra - $ runExceptT action + result <- runSparToIO ctx action either (throwIO . ErrorCall . show) pure result getSsoidViaSelf :: HasCallStack => UserId -> TestSpar UserSSOId From 47ecffe33d9d85eeaa0d5c1166c1bd98d4622411 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 5 Oct 2021 05:08:17 -0700 Subject: [PATCH 04/88] Spar Polysemy: Fully polysemize Spar (#1833) * Remove wrapMonadClientSem Put it into the Cassandra interpreter instead * Remove MonadIO instance * Remove MonadError instance * Remove ExceptT * Remove Final IO from Spar * Fix one use of undefined * Reporter effect; NO MORE IO * Remove the Spar newtype * Remove Spar type * Stylistic cleanup * Changelog * Weird rebase problem * Review comments --- changelog.d/5-internal/spar-no-io-2 | 1 + services/spar/spar.cabal | 4 +- services/spar/src/Spar/API.hs | 282 ++++++++------- services/spar/src/Spar/App.hs | 320 +++++++++--------- .../spar/src/Spar/CanonicalInterpreter.hs | 18 +- services/spar/src/Spar/Error.hs | 7 - services/spar/src/Spar/Scim.hs | 77 ++--- services/spar/src/Spar/Scim/Auth.hs | 59 ++-- services/spar/src/Spar/Scim/User.hs | 161 +++++---- services/spar/src/Spar/Sem/Reporter.hs | 12 + services/spar/src/Spar/Sem/Reporter/Wai.hs | 14 + services/spar/src/Spar/Sem/SAML2/Library.hs | 23 +- .../src/Spar/Sem/SAMLUserStore/Cassandra.hs | 18 +- .../test-integration/Test/Spar/APISpec.hs | 7 +- .../test-integration/Test/Spar/AppSpec.hs | 3 +- .../test-integration/Test/Spar/DataSpec.hs | 112 +++--- .../Test/Spar/Intra/BrigSpec.hs | 5 +- .../Test/Spar/Scim/UserSpec.hs | 61 ++-- services/spar/test-integration/Util/Core.hs | 12 +- services/spar/test-integration/Util/Scim.hs | 20 +- 20 files changed, 648 insertions(+), 568 deletions(-) create mode 100644 changelog.d/5-internal/spar-no-io-2 create mode 100644 services/spar/src/Spar/Sem/Reporter.hs create mode 100644 services/spar/src/Spar/Sem/Reporter/Wai.hs diff --git a/changelog.d/5-internal/spar-no-io-2 b/changelog.d/5-internal/spar-no-io-2 new file mode 100644 index 00000000000..b682ca5002b --- /dev/null +++ b/changelog.d/5-internal/spar-no-io-2 @@ -0,0 +1 @@ +Replace the `Spar` newtype, instead using `Sem` directly. diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 48e9772c412..e23c70faad2 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: fe28e95f2571e0a2583e7d160ff87f80422801408c265139b1cd2392a425fd72 +-- hash: e1e1abfd9d2fd00bd96a693a9466a13e0b7aef15677f0506941f662094a340a1 name: spar version: 0.1 @@ -57,6 +57,8 @@ library Spar.Sem.Now.IO Spar.Sem.Random Spar.Sem.Random.IO + Spar.Sem.Reporter + Spar.Sem.Reporter.Wai Spar.Sem.SAML2 Spar.Sem.SAML2.Library Spar.Sem.SamlProtocolSettings diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index ae21f03f0fa..dddd5b8c653 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- This file is part of the Wire Server implementation. -- @@ -82,6 +83,7 @@ import qualified Spar.Sem.Logger as Logger import Spar.Sem.Now (Now) import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random +import Spar.Sem.Reporter (Reporter) import Spar.Sem.SAML2 (SAML2) import qualified Spar.Sem.SAML2 as SAML2 import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -93,7 +95,6 @@ import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import System.Logger (Msg) -import qualified System.Logger as TinyLog import qualified URI.ByteString as URI import Wire.API.Cookie import Wire.API.Routes.Public.Spar @@ -109,7 +110,6 @@ api :: Members '[ GalleyAccess, BrigAccess, - Input TinyLog.Logger, Input Opts, BindCookieStore, AssIDStore, @@ -126,13 +126,14 @@ api :: Now, SamlProtocolSettings, Logger String, - Logger (Msg -> Msg), - -- TODO(sandy): Remove me when we get rid of runSparInSem - Final IO + Reporter, + -- TODO(sandy): Only necessary for 'fromExceptionSem' in 'apiScim' + Final IO, + Logger (Msg -> Msg) ] r => Opts -> - ServerT API (Spar r) + ServerT API (Sem r) api opts = apiSSO opts :<|> authreqPrecheck @@ -145,7 +146,6 @@ apiSSO :: Members '[ GalleyAccess, Logger String, - Input TinyLog.Logger, Input Opts, BrigAccess, BindCookieStore, @@ -158,16 +158,15 @@ apiSSO :: Error SparError, SAML2, SamlProtocolSettings, - SAMLUserStore, - -- TODO(sandy): Remove me when we get rid of runSparInSem - Final IO + Reporter, + SAMLUserStore ] r => Opts -> - ServerT APISSO (Spar r) + ServerT APISSO (Sem r) apiSSO opts = - (liftSem $ SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing)) - :<|> (\tid -> liftSem $ SAML2.meta appName (SamlProtocolSettings.spIssuer (Just tid)) (SamlProtocolSettings.responseURI (Just tid))) + (SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing)) + :<|> (\tid -> SAML2.meta appName (SamlProtocolSettings.spIssuer (Just tid)) (SamlProtocolSettings.responseURI (Just tid))) :<|> authreqPrecheck :<|> authreq (maxttlAuthreqDiffTime opts) DoInitiateLogin :<|> authresp Nothing @@ -186,7 +185,7 @@ apiIDP :: Error SparError ] r => - ServerT APIIDP (Spar r) + ServerT APIIDP (Sem r) apiIDP = idpGet :<|> idpGetRaw @@ -200,10 +199,11 @@ apiINTERNAL :: '[ ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => - ServerT APIINTERNAL (Spar r) + ServerT APIINTERNAL (Sem r) apiINTERNAL = internalStatus :<|> internalDeleteTeam @@ -215,7 +215,16 @@ appName = "spar" ---------------------------------------------------------------------------- -- SSO API -authreqPrecheck :: Member IdPEffect.IdP r => Maybe URI.URI -> Maybe URI.URI -> SAML.IdPId -> Spar r NoContent +authreqPrecheck :: + Members + '[ IdPEffect.IdP, + Error SparError + ] + r => + Maybe URI.URI -> + Maybe URI.URI -> + SAML.IdPId -> + Sem r NoContent authreqPrecheck msucc merr idpid = validateAuthreqParams msucc merr *> getIdPConfig idpid @@ -231,6 +240,7 @@ authreq :: AReqIDStore, SAML2, SamlProtocolSettings, + Error SparError, IdPEffect.IdP ] r => @@ -240,21 +250,21 @@ authreq :: Maybe URI.URI -> Maybe URI.URI -> SAML.IdPId -> - Spar r (WithSetBindCookie (SAML.FormRedirect SAML.AuthnRequest)) -authreq _ DoInitiateLogin (Just _) _ _ _ = throwSpar SparInitLoginWithAuth -authreq _ DoInitiateBind Nothing _ _ _ = throwSpar SparInitBindWithoutAuth + Sem r (WithSetBindCookie (SAML.FormRedirect SAML.AuthnRequest)) +authreq _ DoInitiateLogin (Just _) _ _ _ = throwSparSem SparInitLoginWithAuth +authreq _ DoInitiateBind Nothing _ _ _ = throwSparSem SparInitBindWithoutAuth authreq authreqttl _ zusr msucc merr idpid = do vformat <- validateAuthreqParams msucc merr form@(SAML.FormRedirect _ ((^. SAML.rqID) -> reqid)) <- do - idp :: IdP <- wrapMonadClientSem (IdPEffect.getConfig idpid) >>= maybe (throwSpar (SparIdPNotFound (cs $ show idpid))) pure + idp :: IdP <- IdPEffect.getConfig idpid >>= maybe (throwSparSem (SparIdPNotFound (cs $ show idpid))) pure let mbtid :: Maybe TeamId mbtid = case fromMaybe defWireIdPAPIVersion (idp ^. SAML.idpExtraInfo . wiApiVersion) of WireIdPAPIV1 -> Nothing WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam - liftSem $ SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid - wrapMonadClientSem $ AReqIDStore.storeVerdictFormat authreqttl reqid vformat + SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid + AReqIDStore.storeVerdictFormat authreqttl reqid vformat cky <- initializeBindCookie zusr authreqttl - liftSem $ Logger.log SAML.Debug $ "setting bind cookie: " <> show cky + Logger.log SAML.Debug $ "setting bind cookie: " <> show cky pure $ addHeader cky form -- | If the user is already authenticated, create bind cookie with a given life expectancy and our @@ -271,34 +281,34 @@ initializeBindCookie :: r => Maybe UserId -> NominalDiffTime -> - Spar r SetBindCookie + Sem r SetBindCookie initializeBindCookie zusr authreqttl = do - DerivedOpts {derivedOptsBindCookiePath} <- liftSem $ inputs derivedOpts + DerivedOpts {derivedOptsBindCookiePath} <- inputs derivedOpts msecret <- if isJust zusr - then liftSem $ Just . cs . ES.encode <$> Random.bytes 32 + then Just . cs . ES.encode <$> Random.bytes 32 else pure Nothing - cky <- fmap SetBindCookie . liftSem . SAML2.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret - forM_ zusr $ \userid -> wrapMonadClientSem $ BindCookieStore.insert cky userid authreqttl + cky <- fmap SetBindCookie . SAML2.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret + forM_ zusr $ \userid -> BindCookieStore.insert cky userid authreqttl pure cky redirectURLMaxLength :: Int redirectURLMaxLength = 140 -validateAuthreqParams :: Maybe URI.URI -> Maybe URI.URI -> Spar r VerdictFormat +validateAuthreqParams :: Member (Error SparError) r => Maybe URI.URI -> Maybe URI.URI -> Sem r VerdictFormat validateAuthreqParams msucc merr = case (msucc, merr) of (Nothing, Nothing) -> pure VerdictFormatWeb (Just ok, Just err) -> do validateRedirectURL `mapM_` [ok, err] pure $ VerdictFormatMobile ok err - _ -> throwSpar $ SparBadInitiateLoginQueryParams "need-both-redirect-urls" + _ -> throwSparSem $ SparBadInitiateLoginQueryParams "need-both-redirect-urls" -validateRedirectURL :: URI.URI -> Spar r () +validateRedirectURL :: Member (Error SparError) r => URI.URI -> Sem r () validateRedirectURL uri = do unless ((SBS.take 4 . URI.schemeBS . URI.uriScheme $ uri) == "wire") $ do - throwSpar $ SparBadInitiateLoginQueryParams "invalid-schema" + throwSparSem $ SparBadInitiateLoginQueryParams "invalid-schema" unless ((SBS.length $ URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do - throwSpar $ SparBadInitiateLoginQueryParams "url-too-long" + throwSparSem $ SparBadInitiateLoginQueryParams "url-too-long" authresp :: forall r. @@ -306,7 +316,6 @@ authresp :: '[ Random, Logger String, Input Opts, - Input TinyLog.Logger, GalleyAccess, BrigAccess, BindCookieStore, @@ -317,27 +326,26 @@ authresp :: SAML2, SamlProtocolSettings, Error SparError, - SAMLUserStore, - -- TODO(sandy): Remove me when we get rid of runSparInSem - Final IO + Reporter, + SAMLUserStore ] r => Maybe TeamId -> Maybe ST -> SAML.AuthnResponseBody -> - Spar r Void -authresp mbtid ckyraw arbody = logErrors $ liftSem $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody + Sem r Void +authresp mbtid ckyraw arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody where cky :: Maybe BindCookie cky = ckyraw >>= bindCookieFromHeader go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Sem r Void go resp verdict = do - result :: SAML.ResponseVerdict <- runSparInSem $ verdictHandler cky mbtid resp verdict + result :: SAML.ResponseVerdict <- verdictHandler cky mbtid resp verdict throw @SparError $ SAML.CustomServant result - logErrors :: Spar r Void -> Spar r Void - logErrors action = liftSem . catch @SparError (runSparInSem action) $ \case + logErrors :: Sem r Void -> Sem r Void + logErrors action = catch @SparError action $ \case e@(SAML.CustomServant _) -> throw e e -> do throw @SparError . SAML.CustomServant $ @@ -346,9 +354,9 @@ authresp mbtid ckyraw arbody = logErrors $ liftSem $ SAML2.authResp mbtid (SamlP (Multipart.inputs (SAML.authnResponseBodyRaw arbody)) ckyraw -ssoSettings :: Member DefaultSsoCode r => Spar r SsoSettings +ssoSettings :: Member DefaultSsoCode r => Sem r SsoSettings ssoSettings = do - SsoSettings <$> wrapMonadClientSem DefaultSsoCode.get + SsoSettings <$> DefaultSsoCode.get ---------------------------------------------------------------------------- -- IdP API @@ -365,23 +373,23 @@ idpGet :: r => Maybe UserId -> SAML.IdPId -> - Spar r IdP + Sem r IdP idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do idp <- getIdPConfig idpid - _ <- liftSem $ authorizeIdP zusr idp + _ <- authorizeIdP zusr idp pure idp idpGetRaw :: Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => Maybe UserId -> SAML.IdPId -> - Spar r RawIdPMetadata + Sem r RawIdPMetadata idpGetRaw zusr idpid = do idp <- getIdPConfig idpid - _ <- liftSem $ authorizeIdP zusr idp - wrapMonadClientSem (IdPEffect.getRawMetadata idpid) >>= \case + _ <- authorizeIdP zusr idp + IdPEffect.getRawMetadata idpid >>= \case Just txt -> pure $ RawIdPMetadata txt - Nothing -> throwSpar $ SparIdPNotFound (cs $ show idpid) + Nothing -> throwSparSem $ SparIdPNotFound (cs $ show idpid) idpGetAll :: Members @@ -394,10 +402,10 @@ idpGetAll :: ] r => Maybe UserId -> - Spar r IdPList + Sem r IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do - teamid <- liftSem $ Brig.getZUsrCheckPerm zusr ReadIdp - _idplProviders <- wrapMonadClientSem $ IdPEffect.getConfigsByTeam teamid + teamid <- Brig.getZUsrCheckPerm zusr ReadIdp + _idplProviders <- IdPEffect.getConfigsByTeam teamid pure IdPList {..} -- | Delete empty IdPs, or if @"purge=true"@ in the HTTP query, delete all users @@ -424,41 +432,40 @@ idpDelete :: Maybe UserId -> SAML.IdPId -> Maybe Bool -> - Spar r NoContent + Sem r NoContent idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (const Nothing) $ do idp <- getIdPConfig idpid - _ <- liftSem $ authorizeIdP zusr idp + _ <- authorizeIdP zusr idp let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer team = idp ^. SAML.idpExtraInfo . wiTeam -- if idp is not empty: fail or purge - idpIsEmpty <- wrapMonadClientSem $ isNothing <$> SAMLUserStore.getAnyByIssuer issuer - let doPurge :: Spar r () + idpIsEmpty <- isNothing <$> SAMLUserStore.getAnyByIssuer issuer + let doPurge :: Sem r () doPurge = do - some <- wrapMonadClientSem (SAMLUserStore.getSomeByIssuer issuer) + some <- SAMLUserStore.getSomeByIssuer issuer forM_ some $ \(uref, uid) -> do - liftSem $ BrigAccess.delete uid - wrapMonadClientSem (SAMLUserStore.delete uid uref) + BrigAccess.delete uid + SAMLUserStore.delete uid uref unless (null some) doPurge when (not idpIsEmpty) $ do if purge then doPurge - else throwSpar SparIdPHasBoundUsers + else throwSparSem SparIdPHasBoundUsers updateOldIssuers idp updateReplacingIdP idp - wrapSpar $ do - -- Delete tokens associated with given IdP (we rely on the fact that - -- each IdP has exactly one team so we can look up all tokens - -- associated with the team and then filter them) - tokens <- liftSem $ ScimTokenStore.getByTeam team - for_ tokens $ \ScimTokenInfo {..} -> - when (stiIdP == Just idpid) $ liftSem $ ScimTokenStore.delete team stiId - -- Delete IdP config - liftSem $ do - IdPEffect.deleteConfig idpid issuer team - IdPEffect.deleteRawMetadata idpid + -- Delete tokens associated with given IdP (we rely on the fact that + -- each IdP has exactly one team so we can look up all tokens + -- associated with the team and then filter them) + tokens <- ScimTokenStore.getByTeam team + for_ tokens $ \ScimTokenInfo {..} -> + when (stiIdP == Just idpid) $ ScimTokenStore.delete team stiId + -- Delete IdP config + do + IdPEffect.deleteConfig idpid issuer team + IdPEffect.deleteRawMetadata idpid return NoContent where - updateOldIssuers :: IdP -> Spar r () + updateOldIssuers :: IdP -> Sem r () updateOldIssuers _ = pure () -- we *could* update @idp ^. SAML.idpExtraInfo . wiReplacedBy@ to not keep the idp about -- to be deleted in its old issuers list, but it's tricky to avoid race conditions, and @@ -467,15 +474,14 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons -- won't find any users to migrate. still, doesn't hurt mucht to look either. so we -- leave old issuers dangling for now. - updateReplacingIdP :: IdP -> Spar r () + updateReplacingIdP :: IdP -> Sem r () updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) $ \oldIssuer -> do - wrapSpar $ do - getIdPIdByIssuer oldIssuer (idp ^. SAML.idpExtraInfo . wiTeam) >>= \case - Data.GetIdPFound iid -> liftSem $ IdPEffect.clearReplacedBy $ Data.Replaced iid - Data.GetIdPNotFound -> pure () - Data.GetIdPDanglingId _ -> pure () - Data.GetIdPNonUnique _ -> pure () - Data.GetIdPWrongTeam _ -> pure () + getIdPIdByIssuer oldIssuer (idp ^. SAML.idpExtraInfo . wiTeam) >>= \case + Data.GetIdPFound iid -> IdPEffect.clearReplacedBy $ Data.Replaced iid + Data.GetIdPNotFound -> pure () + Data.GetIdPDanglingId _ -> pure () + Data.GetIdPNonUnique _ -> pure () + Data.GetIdPWrongTeam _ -> pure () -- | This handler only does the json parsing, and leaves all authorization checks and -- application logic to 'idpCreateXML'. @@ -494,7 +500,7 @@ idpCreate :: IdPMetadataInfo -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> - Spar r IdP + Sem r IdP idpCreate zusr (IdPMetadataValue raw xml) midpid apiversion = idpCreateXML zusr raw xml midpid apiversion -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. @@ -514,15 +520,15 @@ idpCreateXML :: SAML.IdPMetadata -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> - Spar r IdP + Sem r IdP idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do - teamid <- liftSem $ Brig.getZUsrCheckPerm zusr CreateUpdateDeleteIdp - liftSem $ GalleyAccess.assertSSOEnabled teamid + teamid <- Brig.getZUsrCheckPerm zusr CreateUpdateDeleteIdp + GalleyAccess.assertSSOEnabled teamid assertNoScimOrNoIdP teamid idp <- validateNewIdP apiversion idpmeta teamid mReplaces - wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw + IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw storeIdPConfig idp - forM_ mReplaces $ \replaces -> wrapMonadClientSem $ do + forM_ mReplaces $ \replaces -> do IdPEffect.setReplacedBy (Data.Replaced replaces) (Data.Replacing (idp ^. SAML.idpId)) pure idp @@ -530,12 +536,20 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive -- data contains no information about the idp issuer, only the user name, so no valid saml -- credentials can be created. To fix this, we need to implement a way to associate scim -- tokens with IdPs. https://wearezeta.atlassian.net/browse/SQSERVICES-165 -assertNoScimOrNoIdP :: Members '[ScimTokenStore, IdPEffect.IdP] r => TeamId -> Spar r () +assertNoScimOrNoIdP :: + Members + '[ ScimTokenStore, + Error SparError, + IdPEffect.IdP + ] + r => + TeamId -> + Sem r () assertNoScimOrNoIdP teamid = do - numTokens <- length <$> wrapMonadClientSem (ScimTokenStore.getByTeam teamid) - numIdps <- length <$> wrapMonadClientSem (IdPEffect.getConfigsByTeam teamid) + numTokens <- length <$> ScimTokenStore.getByTeam teamid + numIdps <- length <$> IdPEffect.getConfigsByTeam teamid when (numTokens > 0 && numIdps > 0) $ do - throwSpar $ + throwSparSem $ SparProvisioningMoreThanOneIdP "Teams with SCIM tokens can only have at most one IdP" @@ -561,37 +575,43 @@ assertNoScimOrNoIdP teamid = do -- update, delete of idps.) validateNewIdP :: forall m r. - (HasCallStack, m ~ Spar r) => - Members '[Random, Logger String, IdPEffect.IdP] r => + (HasCallStack, m ~ Sem r) => + Members + '[ Random, + Logger String, + IdPEffect.IdP, + Error SparError + ] + r => WireIdPAPIVersion -> SAML.IdPMetadata -> TeamId -> Maybe SAML.IdPId -> m IdP validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validateNewIdP" (Just . show . (^. SAML.idpId)) $ do - _idpId <- SAML.IdPId <$> liftSem Random.uuid + _idpId <- SAML.IdPId <$> Random.uuid oldIssuers :: [SAML.Issuer] <- case mReplaces of Nothing -> pure [] Just replaces -> do - idp <- wrapMonadClientSem (IdPEffect.getConfig replaces) >>= maybe (throwSpar (SparIdPNotFound (cs $ show mReplaces))) pure + idp <- IdPEffect.getConfig replaces >>= maybe (throwSparSem (SparIdPNotFound (cs $ show mReplaces))) pure pure $ (idp ^. SAML.idpMetadata . SAML.edIssuer) : (idp ^. SAML.idpExtraInfo . wiOldIssuers) let requri = _idpMetadata ^. SAML.edRequestURI _idpExtraInfo = WireIdP teamId (Just apiversion) oldIssuers Nothing enforceHttps requri - idp <- wrapSpar $ getIdPConfigByIssuer (_idpMetadata ^. SAML.edIssuer) teamId - liftSem $ Logger.log SAML.Debug $ show (apiversion, _idpMetadata, teamId, mReplaces) - liftSem $ Logger.log SAML.Debug $ show (_idpId, oldIssuers, idp) + idp <- getIdPConfigByIssuer (_idpMetadata ^. SAML.edIssuer) teamId + Logger.log SAML.Debug $ show (apiversion, _idpMetadata, teamId, mReplaces) + Logger.log SAML.Debug $ show (_idpId, oldIssuers, idp) let handleIdPClash :: Either id idp -> m () -- (HINT: using type vars above instead of the actual types constitutes a proof that -- we're not using any properties of the arguments in this function.) handleIdPClash = case apiversion of WireIdPAPIV1 -> const $ do - throwSpar $ SparNewIdPAlreadyInUse "you can't create an IdP with api_version v1 if the issuer is already in use on the wire instance." + throwSparSem $ SparNewIdPAlreadyInUse "you can't create an IdP with api_version v1 if the issuer is already in use on the wire instance." WireIdPAPIV2 -> \case (Right _) -> do -- idp' was found by lookup with teamid, so it's in the same team. - throwSpar $ SparNewIdPAlreadyInUse "if the exisitng IdP is registered for a team, the new one can't have it." + throwSparSem $ SparNewIdPAlreadyInUse "if the exisitng IdP is registered for a team, the new one can't have it." (Left _) -> do -- this idp *id* is from a different team, and we're in the 'WireIdPAPIV2' case, so this is fine. pure () @@ -599,7 +619,7 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validate case idp of Data.GetIdPFound idp' {- same team -} -> handleIdPClash (Right idp') Data.GetIdPNotFound -> pure () - res@(Data.GetIdPDanglingId _) -> throwSpar . SparIdPNotFound . ("validateNewIdP: " <>) . cs . show $ res -- database inconsistency + res@(Data.GetIdPDanglingId _) -> throwSparSem . SparIdPNotFound . ("validateNewIdP: " <>) . cs . show $ res -- database inconsistency Data.GetIdPNonUnique ids' {- same team didn't yield anything, but there are at least two other teams with this issuer already -} -> handleIdPClash (Left ids') Data.GetIdPWrongTeam id' {- different team -} -> handleIdPClash (Left id') @@ -621,7 +641,7 @@ idpUpdate :: Maybe UserId -> IdPMetadataInfo -> SAML.IdPId -> - Spar r IdP + Sem r IdP idpUpdate zusr (IdPMetadataValue raw xml) idpid = idpUpdateXML zusr raw xml idpid idpUpdateXML :: @@ -638,11 +658,11 @@ idpUpdateXML :: Text -> SAML.IdPMetadata -> SAML.IdPId -> - Spar r IdP + Sem r IdP idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^. SAML.idpId)) $ do (teamid, idp) <- validateIdPUpdate zusr idpmeta idpid - liftSem $ GalleyAccess.assertSSOEnabled teamid - wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw + GalleyAccess.assertSSOEnabled teamid + IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw -- (if raw metadata is stored and then spar goes out, raw metadata won't match the -- structured idp config. since this will lead to a 5xx response, the client is epected to -- try again, which would clean up cassandra state.) @@ -655,7 +675,7 @@ idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^ -- info if issuer has changed. validateIdPUpdate :: forall m r. - (HasCallStack, m ~ Spar r) => + (HasCallStack, m ~ Sem r) => Members '[ Random, Logger String, @@ -671,28 +691,28 @@ validateIdPUpdate :: m (TeamId, IdP) validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just . show . (_2 %~ (^. SAML.idpId))) $ do previousIdP <- - wrapMonadClientSem (IdPEffect.getConfig _idpId) >>= \case - Nothing -> throwError errUnknownIdPId + IdPEffect.getConfig _idpId >>= \case + Nothing -> throw errUnknownIdPId Just idp -> pure idp - teamId <- liftSem $ authorizeIdP zusr previousIdP + teamId <- authorizeIdP zusr previousIdP unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ do - throwError errUnknownIdP + throw errUnknownIdP _idpExtraInfo <- do let previousIssuer = previousIdP ^. SAML.idpMetadata . SAML.edIssuer newIssuer = _idpMetadata ^. SAML.edIssuer if previousIssuer == newIssuer then pure $ previousIdP ^. SAML.idpExtraInfo else do - foundConfig <- wrapSpar $ getIdPConfigByIssuerAllowOld newIssuer (Just teamId) + foundConfig <- getIdPConfigByIssuerAllowOld newIssuer (Just teamId) notInUseByOthers <- case foundConfig of Data.GetIdPFound c -> pure $ c ^. SAML.idpId == _idpId Data.GetIdPNotFound -> pure True - res@(Data.GetIdPDanglingId _) -> throwSpar . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible - res@(Data.GetIdPNonUnique _) -> throwSpar . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible (because team id was used in lookup) + res@(Data.GetIdPDanglingId _) -> throwSparSem . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible + res@(Data.GetIdPNonUnique _) -> throwSparSem . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible (because team id was used in lookup) Data.GetIdPWrongTeam _ -> pure False if notInUseByOthers then pure $ (previousIdP ^. SAML.idpExtraInfo) & wiOldIssuers %~ nub . (previousIssuer :) - else throwSpar SparIdPIssuerInUse + else throwSparSem SparIdPIssuerInUse let requri = _idpMetadata ^. SAML.edRequestURI enforceHttps requri pure (teamId, SAML.IdPConfig {..}) @@ -703,12 +723,12 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just uri = _idpMetadata ^. SAML.edIssuer . SAML.fromIssuer errUnknownIdPId = SAML.UnknownIdP . cs . SAML.idPIdToST $ _idpId -withDebugLog :: Member (Logger String) r => String -> (a -> Maybe String) -> Spar r a -> Spar r a +withDebugLog :: Member (Logger String) r => String -> (a -> Maybe String) -> Sem r a -> Sem r a withDebugLog msg showval action = do - liftSem $ Logger.log SAML.Debug $ "entering " ++ msg + Logger.log SAML.Debug $ "entering " ++ msg val <- action let mshowedval = showval val - liftSem $ Logger.log SAML.Debug $ "leaving " ++ msg ++ mconcat [": " ++ fromJust mshowedval | isJust mshowedval] + Logger.log SAML.Debug $ "leaving " ++ msg ++ mconcat [": " ++ fromJust mshowedval | isJust mshowedval] pure val authorizeIdP :: @@ -722,35 +742,43 @@ authorizeIdP (Just zusr) idp = do GalleyAccess.assertHasPermission teamid CreateUpdateDeleteIdp zusr pure teamid -enforceHttps :: URI.URI -> Spar r () +enforceHttps :: Member (Error SparError) r => URI.URI -> Sem r () enforceHttps uri = do unless ((uri ^. URI.uriSchemeL . URI.schemeBSL) == "https") $ do - throwSpar . SparNewIdPWantHttps . cs . SAML.renderURI $ uri + throwSparSem . SparNewIdPWantHttps . cs . SAML.renderURI $ uri ---------------------------------------------------------------------------- -- Internal API -internalStatus :: Spar r NoContent +internalStatus :: Sem r NoContent internalStatus = pure NoContent -- | Cleanup handler that is called by Galley whenever a team is about to -- get deleted. -internalDeleteTeam :: Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => TeamId -> Spar r NoContent +internalDeleteTeam :: Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => TeamId -> Sem r NoContent internalDeleteTeam team = do - wrapSpar $ deleteTeam team + deleteTeam team pure NoContent -internalPutSsoSettings :: Members '[DefaultSsoCode, IdPEffect.IdP] r => SsoSettings -> Spar r NoContent +internalPutSsoSettings :: + Members + '[ DefaultSsoCode, + Error SparError, + IdPEffect.IdP + ] + r => + SsoSettings -> + Sem r NoContent internalPutSsoSettings SsoSettings {defaultSsoCode = Nothing} = do - wrapMonadClientSem $ DefaultSsoCode.delete + DefaultSsoCode.delete pure NoContent internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = do - wrapMonadClientSem (IdPEffect.getConfig code) >>= \case + IdPEffect.getConfig code >>= \case Nothing -> -- this will return a 404, which is not quite right, -- but it's an internal endpoint and the message clearly says -- "Could not find IdP". - throwSpar $ SparIdPNotFound mempty + throwSparSem $ SparIdPNotFound mempty Just _ -> do - wrapMonadClientSem $ DefaultSsoCode.store code + DefaultSsoCode.store code pure NoContent diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 7b7bfc9d3b4..87daf33352f 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- This file is part of the Wire Server implementation. @@ -22,9 +21,8 @@ -- | The 'Spar' monad and a set of actions (e.g. 'createUser') that can be performed in it. module Spar.App - ( Spar (..), - Env (..), - wrapMonadClientSem, + ( Env (..), + throwSparSem, verdictHandler, GetUserResult (..), getUserIdByUref, @@ -36,12 +34,11 @@ module Spar.App getIdPConfigByIssuer, getIdPConfigByIssuerAllowOld, deleteTeam, - wrapSpar, - liftSem, getIdPConfig, storeIdPConfig, getIdPConfigByIssuerOptionalSPId, - runSparInSem, + sparToServerErrorWithLogging, + renderSparErrorWithLogging, ) where @@ -51,9 +48,7 @@ import Brig.Types.Intra (AccountStatus (..), accountStatus, accountUser) import qualified Cassandra as Cas import Control.Exception (assert) import Control.Lens hiding ((.=)) -import qualified Control.Monad.Catch as Catch import Control.Monad.Except -import Control.Monad.Trans.Except (except) import Data.Aeson as Aeson (encode, object, (.=)) import Data.Aeson.Text as Aeson (encodeToLazyText) import qualified Data.ByteString.Builder as Builder @@ -67,8 +62,6 @@ import qualified Network.HTTP.Types.Status as Http import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error -import Polysemy.Final -import Polysemy.Input (Input, input) import SAML2.Util (renderURI) import SAML2.WebSSO ( IdPId (..), @@ -84,7 +77,7 @@ import qualified SAML2.WebSSO.Types.Email as SAMLEmail import Servant import qualified Servant.Multipart as Multipart import qualified Spar.Data as Data (GetIdPResult (..)) -import Spar.Error +import Spar.Error hiding (sparToServerErrorWithLogging) import qualified Spar.Intra.BrigApp as Intra import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) @@ -101,6 +94,8 @@ import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random +import Spar.Sem.Reporter (Reporter) +import qualified Spar.Sem.Reporter as Reporter import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -116,26 +111,8 @@ import Wire.API.User.IdentityProvider import Wire.API.User.Saml import Wire.API.User.Scim (ValidExternalId (..)) -newtype Spar r a = Spar {fromSpar :: Member (Final IO) r => ExceptT SparError (Sem r) a} - deriving (Functor) - -liftSem :: Sem r a -> Spar r a -liftSem r = Spar $ lift r - -instance Applicative (Spar r) where - pure a = Spar $ pure a - liftA2 f a b = Spar $ liftA2 f (fromSpar a) (fromSpar b) - -instance Monad (Spar r) where - return = pure - f >>= a = Spar $ fromSpar f >>= fromSpar . a - -instance MonadError SparError (Spar r) where - throwError err = Spar $ throwError err - catchError m handler = Spar $ catchError (fromSpar m) $ fromSpar . handler - -instance MonadIO (Spar r) where - liftIO m = Spar $ lift $ embedFinal m +throwSparSem :: Member (Error SparError) r => SparCustomError -> Sem r a +throwSparSem = throw . SAML.CustomError data Env = Env { sparCtxOpts :: Opts, @@ -147,52 +124,30 @@ data Env = Env sparCtxRequestId :: RequestId } -runSparInSem :: Members '[Final IO, Error SparError] r => Spar r a -> Sem r a -runSparInSem (Spar action) = - runExceptT action >>= \case - Left err -> throw err - Right a -> pure a - -getIdPConfig :: Member IdPEffect.IdP r => IdPId -> Spar r IdP -getIdPConfig = (>>= maybe (throwSpar (SparIdPNotFound mempty)) pure) . wrapMonadClientSem . IdPEffect.getConfig +getIdPConfig :: + Members + '[ IdPEffect.IdP, + Error SparError + ] + r => + IdPId -> + Sem r IdP +getIdPConfig = (>>= maybe (throwSparSem (SparIdPNotFound mempty)) pure) . IdPEffect.getConfig -storeIdPConfig :: Member IdPEffect.IdP r => IdP -> Spar r () -storeIdPConfig idp = wrapMonadClientSem $ IdPEffect.storeConfig idp +storeIdPConfig :: Member IdPEffect.IdP r => IdP -> Sem r () +storeIdPConfig idp = IdPEffect.storeConfig idp -getIdPConfigByIssuerOptionalSPId :: Member IdPEffect.IdP r => Issuer -> Maybe TeamId -> Spar r IdP +getIdPConfigByIssuerOptionalSPId :: Members '[IdPEffect.IdP, Error SparError] r => Issuer -> Maybe TeamId -> Sem r IdP getIdPConfigByIssuerOptionalSPId issuer mbteam = do - wrapSpar (getIdPConfigByIssuerAllowOld issuer mbteam) >>= \case + getIdPConfigByIssuerAllowOld issuer mbteam >>= \case Data.GetIdPFound idp -> pure idp - Data.GetIdPNotFound -> throwSpar $ SparIdPNotFound mempty - res@(Data.GetIdPDanglingId _) -> throwSpar $ SparIdPNotFound (cs $ show res) - res@(Data.GetIdPNonUnique _) -> throwSpar $ SparIdPNotFound (cs $ show res) - res@(Data.GetIdPWrongTeam _) -> throwSpar $ SparIdPNotFound (cs $ show res) - -instance Member (Final IO) r => Catch.MonadThrow (Sem r) where - throwM = embedFinal . Catch.throwM @IO - -instance Member (Final IO) r => Catch.MonadCatch (Sem r) where - catch m handler = withStrategicToFinal @IO $ do - m' <- runS m - st <- getInitialStateS - handler' <- bindS handler - pure $ m' `Catch.catch` \e -> handler' $ e <$ st - --- | Call a 'Sem' command in the 'Spar' monad. Catch all (IO) exceptions and --- re-throw them as 500 in Handler. -wrapMonadClientSem :: Sem r a -> Spar r a -wrapMonadClientSem action = - Spar $ - lift action - `Catch.catch` (throwSpar . SparCassandraError . cs . show @SomeException) - -wrapSpar :: Spar r a -> Spar r a -wrapSpar action = Spar $ do - fromSpar $ - wrapMonadClientSem (runExceptT $ fromSpar action) >>= Spar . except - -insertUser :: Member SAMLUserStore r => SAML.UserRef -> UserId -> Spar r () -insertUser uref uid = wrapMonadClientSem $ SAMLUserStore.insert uref uid + Data.GetIdPNotFound -> throwSparSem $ SparIdPNotFound mempty + res@(Data.GetIdPDanglingId _) -> throwSparSem $ SparIdPNotFound (cs $ show res) + res@(Data.GetIdPNonUnique _) -> throwSparSem $ SparIdPNotFound (cs $ show res) + res@(Data.GetIdPWrongTeam _) -> throwSparSem $ SparIdPNotFound (cs $ show res) + +insertUser :: Member SAMLUserStore r => SAML.UserRef -> UserId -> Sem r () +insertUser uref uid = SAMLUserStore.insert uref uid -- | Look up user locally in table @spar.user@ or @spar.scim_user@ (depending on the -- argument), then in brig, then return the 'UserId'. If either lookup fails, or user is not @@ -211,17 +166,17 @@ insertUser uref uid = wrapMonadClientSem $ SAMLUserStore.insert uref uid -- the team with valid SAML credentials. -- -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR. (in https://github.com/wireapp/wire-server/pull/1410, undo https://github.com/wireapp/wire-server/pull/1418) -getUserIdByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult UserId) +getUserIdByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Sem r (GetUserResult UserId) getUserIdByUref mbteam uref = userId <$$> getUserByUref mbteam uref -getUserByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult User) +getUserByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Sem r (GetUserResult User) getUserByUref mbteam uref = do - muid <- wrapMonadClientSem $ SAMLUserStore.get uref + muid <- SAMLUserStore.get uref case muid of Nothing -> pure GetUserNotFound Just uid -> do let withpending = Intra.WithPendingInvitations -- see haddocks above - liftSem (Intra.getBrigUser withpending uid) >>= \case + Intra.getBrigUser withpending uid >>= \case Nothing -> pure GetUserNotFound Just user | isNothing (userTeam user) -> pure GetUserNoTeam @@ -242,14 +197,14 @@ instance Functor GetUserResult where fmap _ GetUserWrongTeam = GetUserWrongTeam -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR -getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Spar r (Maybe UserId) +getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Sem r (Maybe UserId) getUserIdByScimExternalId tid email = do - muid <- wrapMonadClientSem $ (ScimExternalIdStore.lookup tid email) + muid <- (ScimExternalIdStore.lookup tid email) case muid of Nothing -> pure Nothing Just uid -> do let withpending = Intra.WithPendingInvitations -- see haddocks above - itis <- liftSem $ isJust <$> Intra.getBrigUserTeam withpending uid + itis <- isJust <$> Intra.getBrigUserTeam withpending uid pure $ if itis then Just uid else Nothing -- | Create a fresh 'UserId', store it on C* locally together with 'SAML.UserRef', then @@ -268,10 +223,20 @@ getUserIdByScimExternalId tid email = do -- FUTUREWORK: once we support , brig will refuse to delete -- users that have an sso id, unless the request comes from spar. then we can make users -- undeletable in the team admin page, and ask admins to go talk to their IdP system. -createSamlUserWithId :: Members '[BrigAccess, SAMLUserStore] r => TeamId -> UserId -> SAML.UserRef -> Spar r () +createSamlUserWithId :: + Members + '[ Error SparError, + BrigAccess, + SAMLUserStore + ] + r => + TeamId -> + UserId -> + SAML.UserRef -> + Sem r () createSamlUserWithId teamid buid suid = do - uname <- either (throwSpar . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) - buid' <- liftSem $ BrigAccess.createSAML suid buid teamid uname ManagedByWire + uname <- either (throwSparSem . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) + buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire assert (buid == buid') $ pure () insertUser suid buid @@ -284,14 +249,15 @@ autoprovisionSamlUser :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => Maybe TeamId -> SAML.UserRef -> - Spar r UserId + Sem r UserId autoprovisionSamlUser mbteam suid = do - buid <- liftSem $ Id <$> Random.uuid + buid <- Id <$> Random.uuid autoprovisionSamlUserWithId mbteam buid suid pure buid @@ -303,13 +269,14 @@ autoprovisionSamlUserWithId :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => Maybe TeamId -> UserId -> SAML.UserRef -> - Spar r () + Sem r () autoprovisionSamlUserWithId mbteam buid suid = do idp <- getIdPConfigByIssuerOptionalSPId (suid ^. uidTenant) mbteam guardReplacedIdP idp @@ -318,33 +285,33 @@ autoprovisionSamlUserWithId mbteam buid suid = do validateEmailIfExists buid suid where -- Replaced IdPs are not allowed to create new wire accounts. - guardReplacedIdP :: IdP -> Spar r () + guardReplacedIdP :: IdP -> Sem r () guardReplacedIdP idp = do unless (isNothing $ idp ^. idpExtraInfo . wiReplacedBy) $ do - throwSpar $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId) + throwSparSem $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId) -- IdPs in teams with scim tokens are not allowed to auto-provision. - guardScimTokens :: IdP -> Spar r () + guardScimTokens :: IdP -> Sem r () guardScimTokens idp = do let teamid = idp ^. idpExtraInfo . wiTeam - scimtoks <- wrapMonadClientSem $ ScimTokenStore.getByTeam teamid + scimtoks <- ScimTokenStore.getByTeam teamid unless (null scimtoks) $ do - throwSpar SparSamlCredentialsNotFound + throwSparSem SparSamlCredentialsNotFound -- | If user's 'NameID' is an email address and the team has email validation for SSO enabled, -- make brig initiate the email validate procedure. -validateEmailIfExists :: forall r. Members '[GalleyAccess, BrigAccess] r => UserId -> SAML.UserRef -> Spar r () +validateEmailIfExists :: forall r. Members '[GalleyAccess, BrigAccess] r => UserId -> SAML.UserRef -> Sem r () validateEmailIfExists uid = \case (SAML.UserRef _ (view SAML.nameID -> UNameIDEmail email)) -> doValidate (CI.original email) _ -> pure () where - doValidate :: SAMLEmail.Email -> Spar r () + doValidate :: SAMLEmail.Email -> Sem r () doValidate email = do enabled <- do - tid <- liftSem $ Intra.getBrigUserTeam Intra.NoPendingInvitations uid - maybe (pure False) (liftSem . GalleyAccess.isEmailValidationEnabledTeam) tid + tid <- Intra.getBrigUserTeam Intra.NoPendingInvitations uid + maybe (pure False) (GalleyAccess.isEmailValidationEnabledTeam) tid when enabled $ do - liftSem $ BrigAccess.updateEmail uid (Intra.emailFromSAML email) + BrigAccess.updateEmail uid (Intra.emailFromSAML email) -- | Check if 'UserId' is in the team that hosts the idp that owns the 'UserRef'. If so, -- register a the user under its SAML credentials and write the 'UserRef' into the @@ -352,32 +319,43 @@ validateEmailIfExists uid = \case -- -- Before returning, change account status or fail if account is nto active or pending an -- invitation. -bindUser :: Members '[BrigAccess, IdPEffect.IdP, SAMLUserStore] r => UserId -> SAML.UserRef -> Spar r UserId +bindUser :: + forall r. + Members + '[ BrigAccess, + IdPEffect.IdP, + Error SparError, + SAMLUserStore + ] + r => + UserId -> + SAML.UserRef -> + Sem r UserId bindUser buid userref = do oldStatus <- do - let err :: Spar r a - err = throwSpar . SparBindFromWrongOrNoTeam . cs . show $ buid + let err :: Sem r a + err = throwSparSem . SparBindFromWrongOrNoTeam . cs . show $ buid teamid :: TeamId <- - wrapSpar (getIdPConfigByIssuerAllowOld (userref ^. uidTenant) Nothing) >>= \case + getIdPConfigByIssuerAllowOld (userref ^. uidTenant) Nothing >>= \case Data.GetIdPFound idp -> pure $ idp ^. idpExtraInfo . wiTeam Data.GetIdPNotFound -> err Data.GetIdPDanglingId _ -> err -- database inconsistency - Data.GetIdPNonUnique is -> throwSpar $ SparUserRefInNoOrMultipleTeams (cs $ show (buid, is)) + Data.GetIdPNonUnique is -> throwSparSem $ SparUserRefInNoOrMultipleTeams (cs $ show (buid, is)) Data.GetIdPWrongTeam _ -> err -- impossible - acc <- liftSem (BrigAccess.getAccount Intra.WithPendingInvitations buid) >>= maybe err pure + acc <- BrigAccess.getAccount Intra.WithPendingInvitations buid >>= maybe err pure teamid' :: TeamId <- userTeam (accountUser acc) & maybe err pure unless (teamid' == teamid) err pure (accountStatus acc) insertUser userref buid buid <$ do - liftSem $ BrigAccess.setVeid buid (UrefOnly userref) - let err = throwSpar . SparBindFromBadAccountStatus . cs . show + BrigAccess.setVeid buid (UrefOnly userref) + let err = throwSparSem . SparBindFromBadAccountStatus . cs . show case oldStatus of Active -> pure () Suspended -> err oldStatus Deleted -> err oldStatus Ephemeral -> err oldStatus - PendingInvitation -> liftSem $ BrigAccess.setStatus buid Active + PendingInvitation -> BrigAccess.setStatus buid Active -- | The from of the response on the finalize-login request depends on the verdict (denied or -- granted), plus the choice that the client has made during the initiate-login request. Here we @@ -392,7 +370,6 @@ verdictHandler :: HasCallStack => Members '[ Random, - Input TinyLog.Logger, Logger String, GalleyAccess, BrigAccess, @@ -400,6 +377,8 @@ verdictHandler :: AReqIDStore, ScimTokenStore, IdPEffect.IdP, + Error SparError, + Reporter, SAMLUserStore ] r => @@ -407,14 +386,14 @@ verdictHandler :: Maybe TeamId -> SAML.AuthnResponse -> SAML.AccessVerdict -> - Spar r SAML.ResponseVerdict + Sem r SAML.ResponseVerdict verdictHandler cky mbteam aresp verdict = do -- [3/4.1.4.2] -- [...] If the containing message is in response to an , then -- the InResponseTo attribute MUST match the request's ID. - liftSem $ Logger.log SAML.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict) - reqid <- either (throwSpar . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp - format :: Maybe VerdictFormat <- wrapMonadClientSem $ AReqIDStore.getVerdictFormat reqid + Logger.log SAML.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict) + reqid <- either (throwSparSem . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp + format :: Maybe VerdictFormat <- AReqIDStore.getVerdictFormat reqid resp <- case format of Just (VerdictFormatWeb) -> verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb @@ -422,8 +401,8 @@ verdictHandler cky mbteam aresp verdict = do verdictHandlerResult cky mbteam verdict >>= verdictHandlerMobile granted denied Nothing -> -- (this shouldn't happen too often, see 'storeVerdictFormat') - throwSpar SparNoSuchRequest - liftSem $ Logger.log SAML.Debug $ "leaving verdictHandler: " <> show resp + throwSparSem SparNoSuchRequest + Logger.log SAML.Debug $ "leaving verdictHandler: " <> show resp pure resp data VerdictHandlerResult @@ -436,34 +415,41 @@ verdictHandlerResult :: HasCallStack => Members '[ Random, - Input TinyLog.Logger, Logger String, GalleyAccess, BrigAccess, BindCookieStore, ScimTokenStore, IdPEffect.IdP, + Error SparError, + Reporter, SAMLUserStore ] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> - Spar r VerdictHandlerResult + Sem r VerdictHandlerResult verdictHandlerResult bindCky mbteam verdict = do - liftSem $ Logger.log SAML.Debug $ "entering verdictHandlerResult: " <> show (fromBindCookie <$> bindCky) + Logger.log SAML.Debug $ "entering verdictHandlerResult: " <> show (fromBindCookie <$> bindCky) result <- catchVerdictErrors $ verdictHandlerResultCore bindCky mbteam verdict - liftSem $ Logger.log SAML.Debug $ "leaving verdictHandlerResult" <> show result + Logger.log SAML.Debug $ "leaving verdictHandlerResult" <> show result pure result -catchVerdictErrors :: forall r. Member (Input TinyLog.Logger) r => Spar r VerdictHandlerResult -> Spar r VerdictHandlerResult -catchVerdictErrors = (`catchError` hndlr) +catchVerdictErrors :: + forall r. + Members + '[ Reporter, + Error SparError + ] + r => + Sem r VerdictHandlerResult -> + Sem r VerdictHandlerResult +catchVerdictErrors = (`catch` hndlr) where - hndlr :: SparError -> Spar r VerdictHandlerResult + hndlr :: SparError -> Sem r VerdictHandlerResult hndlr err = do - logr <- liftSem input - -- TODO(sandy): When we remove this line, we can get rid of the @Input TinyLog.Logger@ effect - waiErr <- renderSparErrorWithLogging logr err + waiErr <- renderSparErrorWithLogging err pure $ case waiErr of Right (werr :: Wai.Error) -> VerifyHandlerError (cs $ Wai.label werr) (cs $ Wai.message werr) Left (serr :: ServerError) -> VerifyHandlerError "unknown-error" (cs (errReasonPhrase serr) <> " " <> cs (errBody serr)) @@ -471,10 +457,21 @@ catchVerdictErrors = (`catchError` hndlr) -- | If a user attempts to login presenting a new IdP issuer, but there is no entry in -- @"spar.user"@ for her: lookup @"old_issuers"@ from @"spar.idp"@ for the new IdP, and -- traverse the old IdPs in search for the old entry. Return that old entry. -findUserIdWithOldIssuer :: forall r. Members '[BrigAccess, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult (SAML.UserRef, UserId)) +findUserIdWithOldIssuer :: + forall r. + Members + '[ BrigAccess, + IdPEffect.IdP, + SAMLUserStore, + Error SparError + ] + r => + Maybe TeamId -> + SAML.UserRef -> + Sem r (GetUserResult (SAML.UserRef, UserId)) findUserIdWithOldIssuer mbteam (SAML.UserRef issuer subject) = do idp <- getIdPConfigByIssuerOptionalSPId issuer mbteam - let tryFind :: GetUserResult (SAML.UserRef, UserId) -> Issuer -> Spar r (GetUserResult (SAML.UserRef, UserId)) + let tryFind :: GetUserResult (SAML.UserRef, UserId) -> Issuer -> Sem r (GetUserResult (SAML.UserRef, UserId)) tryFind found@(GetUserFound _) _ = pure found tryFind _ oldIssuer = (uref,) <$$> getUserIdByUref mbteam uref where @@ -483,11 +480,11 @@ findUserIdWithOldIssuer mbteam (SAML.UserRef issuer subject) = do -- | After a user has been found using 'findUserWithOldIssuer', update it everywhere so that -- the old IdP is not needed any more next time. -moveUserToNewIssuer :: Members '[BrigAccess, SAMLUserStore] r => SAML.UserRef -> SAML.UserRef -> UserId -> Spar r () +moveUserToNewIssuer :: Members '[BrigAccess, SAMLUserStore] r => SAML.UserRef -> SAML.UserRef -> UserId -> Sem r () moveUserToNewIssuer oldUserRef newUserRef uid = do - wrapMonadClientSem $ SAMLUserStore.insert newUserRef uid - liftSem $ BrigAccess.setVeid uid (UrefOnly newUserRef) - wrapMonadClientSem $ SAMLUserStore.delete uid oldUserRef + SAMLUserStore.insert newUserRef uid + BrigAccess.setVeid uid (UrefOnly newUserRef) + SAMLUserStore.delete uid oldUserRef verdictHandlerResultCore :: HasCallStack => @@ -499,19 +496,20 @@ verdictHandlerResultCore :: BindCookieStore, ScimTokenStore, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> - Spar r VerdictHandlerResult + Sem r VerdictHandlerResult verdictHandlerResultCore bindCky mbteam = \case SAML.AccessDenied reasons -> do pure $ VerifyHandlerDenied reasons SAML.AccessGranted userref -> do uid :: UserId <- do - viaBindCookie <- maybe (pure Nothing) (wrapMonadClientSem . BindCookieStore.lookup) bindCky + viaBindCookie <- maybe (pure Nothing) (BindCookieStore.lookup) bindCky viaSparCassandra <- getUserIdByUref mbteam userref -- race conditions: if the user has been created on spar, but not on brig, 'getUser' -- returns 'Nothing'. this is ok assuming 'createUser', 'bindUser' (called below) are @@ -524,10 +522,10 @@ verdictHandlerResultCore bindCky mbteam = \case SparUserRefInNoOrMultipleTeams . cs $ show (userref, viaBindCookie, viaSparCassandra, viaSparCassandraOldIssuer) case (viaBindCookie, viaSparCassandra, viaSparCassandraOldIssuer) of - (_, GetUserNoTeam, _) -> throwSpar err - (_, GetUserWrongTeam, _) -> throwSpar err - (_, _, GetUserNoTeam) -> throwSpar err - (_, _, GetUserWrongTeam) -> throwSpar err + (_, GetUserNoTeam, _) -> throwSparSem err + (_, GetUserWrongTeam, _) -> throwSparSem err + (_, _, GetUserNoTeam) -> throwSparSem err + (_, _, GetUserWrongTeam) -> throwSparSem err -- This is the first SSO authentication, so we auto-create a user. We know the user -- has not been created via SCIM because then we would've ended up in the -- "reauthentication" branch. @@ -542,16 +540,16 @@ verdictHandlerResultCore bindCky mbteam = \case -- Redundant binding (no change to Brig or Spar) | uid == uid' -> pure uid -- Attempt to use ssoid for a second Wire user - | otherwise -> throwSpar SparBindUserRefTaken + | otherwise -> throwSparSem SparBindUserRefTaken -- same two cases as above, but between last login and bind there was an issuer update. (Just uid, GetUserNotFound, GetUserFound (oldUserRef, uid')) | uid == uid' -> moveUserToNewIssuer oldUserRef userref uid >> pure uid - | otherwise -> throwSpar SparBindUserRefTaken + | otherwise -> throwSparSem SparBindUserRefTaken (Just _, GetUserFound _, GetUserFound _) -> -- to see why, consider the condition on the call to 'findUserWithOldIssuer' above. error "impossible." - liftSem $ Logger.log SAML.Debug ("granting sso login for " <> show uid) - cky <- liftSem $ BrigAccess.ssoLogin uid + Logger.log SAML.Debug ("granting sso login for " <> show uid) + cky <- BrigAccess.ssoLogin uid pure $ VerifyHandlerGranted cky uid -- | If the client is web, it will be served with an HTML page that it can process to decide whether @@ -561,7 +559,7 @@ verdictHandlerResultCore bindCky mbteam = \case -- - A title element with contents @wire:sso:@. This is chosen to be easily parseable and -- not be the title of any page sent by the IdP while it negotiates with the user. -- - The page broadcasts a message to '*', to be picked up by the app. -verdictHandlerWeb :: HasCallStack => VerdictHandlerResult -> Spar r SAML.ResponseVerdict +verdictHandlerWeb :: HasCallStack => VerdictHandlerResult -> Sem r SAML.ResponseVerdict verdictHandlerWeb = pure . \case VerifyHandlerGranted cky _uid -> successPage cky @@ -632,22 +630,22 @@ easyHtml doc = -- | If the client is mobile, it has picked error and success redirect urls (see -- 'mkVerdictGrantedFormatMobile', 'mkVerdictDeniedFormatMobile'); variables in these URLs are here -- substituted and the client is redirected accordingly. -verdictHandlerMobile :: HasCallStack => URI.URI -> URI.URI -> VerdictHandlerResult -> Spar r SAML.ResponseVerdict +verdictHandlerMobile :: (HasCallStack, Member (Error SparError) r) => URI.URI -> URI.URI -> VerdictHandlerResult -> Sem r SAML.ResponseVerdict verdictHandlerMobile granted denied = \case VerifyHandlerGranted cky uid -> mkVerdictGrantedFormatMobile granted cky uid & either - (throwSpar . SparCouldNotSubstituteSuccessURI . cs) + (throwSparSem . SparCouldNotSubstituteSuccessURI . cs) (pure . successPage cky) VerifyHandlerDenied reasons -> mkVerdictDeniedFormatMobile denied "forbidden" & either - (throwSpar . SparCouldNotSubstituteFailureURI . cs) + (throwSparSem . SparCouldNotSubstituteFailureURI . cs) (pure . forbiddenPage "forbidden" (explainDeniedReason <$> reasons)) VerifyHandlerError lbl msg -> mkVerdictDeniedFormatMobile denied lbl & either - (throwSpar . SparCouldNotSubstituteFailureURI . cs) + (throwSparSem . SparCouldNotSubstituteFailureURI . cs) (pure . forbiddenPage lbl [msg]) where forbiddenPage :: ST -> [ST] -> URI.URI -> SAML.ResponseVerdict @@ -702,13 +700,13 @@ getIdPIdByIssuerAllowOld :: Member IdPEffect.IdP r => SAML.Issuer -> Maybe TeamId -> - Spar r (GetIdPResult SAML.IdPId) + Sem r (GetIdPResult SAML.IdPId) getIdPIdByIssuerAllowOld issuer mbteam = do - mbv2 <- liftSem $ maybe (pure Nothing) (IdPEffect.getIdByIssuerWithTeam issuer) mbteam - mbv1v2 <- liftSem $ maybe (IdPEffect.getIdByIssuerWithoutTeam issuer) (pure . GetIdPFound) mbv2 + mbv2 <- maybe (pure Nothing) (IdPEffect.getIdByIssuerWithTeam issuer) mbteam + mbv1v2 <- maybe (IdPEffect.getIdByIssuerWithoutTeam issuer) (pure . GetIdPFound) mbv2 case (mbv1v2, mbteam) of (GetIdPFound idpid, Just team) -> do - liftSem (IdPEffect.getConfig idpid) >>= \case + IdPEffect.getConfig idpid >>= \case Nothing -> do pure $ GetIdPDanglingId idpid Just idp -> @@ -723,7 +721,7 @@ getIdPConfigByIssuer :: (HasCallStack, Member IdPEffect.IdP r) => SAML.Issuer -> TeamId -> - Spar r (GetIdPResult IdP) + Sem r (GetIdPResult IdP) getIdPConfigByIssuer issuer = getIdPIdByIssuer issuer >=> mapGetIdPResult @@ -732,7 +730,7 @@ getIdPConfigByIssuerAllowOld :: (HasCallStack, Member IdPEffect.IdP r) => SAML.Issuer -> Maybe TeamId -> - Spar r (GetIdPResult IdP) + Sem r (GetIdPResult IdP) getIdPConfigByIssuerAllowOld issuer = do getIdPIdByIssuerAllowOld issuer >=> mapGetIdPResult @@ -742,13 +740,13 @@ getIdPIdByIssuer :: (HasCallStack, Member IdPEffect.IdP r) => SAML.Issuer -> TeamId -> - Spar r (GetIdPResult SAML.IdPId) + Sem r (GetIdPResult SAML.IdPId) getIdPIdByIssuer issuer = getIdPIdByIssuerAllowOld issuer . Just -- | (There are probably category theoretical models for what we're doing here, but it's more -- straight-forward to just handle the one instance we need.) -mapGetIdPResult :: (HasCallStack, Member IdPEffect.IdP r) => GetIdPResult SAML.IdPId -> Spar r (GetIdPResult IdP) -mapGetIdPResult (GetIdPFound i) = liftSem (IdPEffect.getConfig i) <&> maybe (GetIdPDanglingId i) GetIdPFound +mapGetIdPResult :: (HasCallStack, Member IdPEffect.IdP r) => GetIdPResult SAML.IdPId -> Sem r (GetIdPResult IdP) +mapGetIdPResult (GetIdPFound i) = IdPEffect.getConfig i <&> maybe (GetIdPDanglingId i) GetIdPFound mapGetIdPResult GetIdPNotFound = pure GetIdPNotFound mapGetIdPResult (GetIdPDanglingId i) = pure (GetIdPDanglingId i) mapGetIdPResult (GetIdPNonUnique is) = pure (GetIdPNonUnique is) @@ -758,8 +756,8 @@ mapGetIdPResult (GetIdPWrongTeam i) = pure (GetIdPWrongTeam i) deleteTeam :: (HasCallStack, Members '[ScimTokenStore, SAMLUserStore, IdPEffect.IdP] r) => TeamId -> - Spar r () -deleteTeam team = liftSem $ do + Sem r () +deleteTeam team = do ScimTokenStore.deleteByTeam team -- Since IdPs are not shared between teams, we can look at the set of IdPs -- used by the team, and remove everything related to those IdPs, too. @@ -769,3 +767,15 @@ deleteTeam team = liftSem $ do issuer = idp ^. SAML.idpMetadata . SAML.edIssuer SAMLUserStore.deleteByIssuer issuer IdPEffect.deleteConfig idpid issuer team + +sparToServerErrorWithLogging :: Member Reporter r => SparError -> Sem r ServerError +sparToServerErrorWithLogging err = do + let errServant = sparToServerError err + Reporter.report Nothing (servantToWaiError errServant) + pure errServant + +renderSparErrorWithLogging :: Member Reporter r => SparError -> Sem r (Either ServerError Wai.Error) +renderSparErrorWithLogging err = do + let errPossiblyWai = renderSparError err + Reporter.report Nothing (either servantToWaiError id $ errPossiblyWai) + pure errPossiblyWai diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 3cc7481258f..12e96163767 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -9,7 +9,7 @@ import Polysemy import Polysemy.Error import Polysemy.Input (Input, runInputConst) import Servant -import Spar.App +import Spar.App hiding (sparToServerErrorWithLogging) import Spar.Error import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) @@ -32,6 +32,8 @@ import Spar.Sem.Now (Now) import Spar.Sem.Now.IO (nowToIO) import Spar.Sem.Random (Random) import Spar.Sem.Random.IO (randomToIO) +import Spar.Sem.Reporter (Reporter) +import Spar.Sem.Reporter.Wai (reporterToTinyLogWai) import Spar.Sem.SAML2 (SAML2) import Spar.Sem.SAML2.Library (saml2ToSaml2WebSso) import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -64,6 +66,7 @@ type CanonicalEffs = GalleyAccess, Error TTLError, Error SparError, + Reporter, -- TODO(sandy): Make this a Logger Text instead Logger String, Logger (TinyLog.Msg -> TinyLog.Msg), @@ -75,10 +78,9 @@ type CanonicalEffs = Final IO ] -runSparToIO :: Env -> Spar CanonicalEffs a -> IO (Either SparError a) -runSparToIO ctx (Spar action) = - fmap join - . runFinal +runSparToIO :: Env -> Sem CanonicalEffs a -> IO (Either SparError a) +runSparToIO ctx action = + runFinal . embedToFinal @IO . nowToIO . randomToIO @@ -86,6 +88,7 @@ runSparToIO ctx (Spar action) = . runInputConst (sparCtxOpts ctx) . loggerToTinyLog (sparCtxLogger ctx) . stringLoggerToTinyLog + . reporterToTinyLogWai . runError @SparError . ttlErrorToSparError . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) @@ -101,10 +104,9 @@ runSparToIO ctx (Spar action) = . assIDStoreToCassandra . bindCookieStoreToCassandra . sparRouteToServant (saml $ sparCtxOpts ctx) - . saml2ToSaml2WebSso - $ runExceptT action + $ saml2ToSaml2WebSso action -runSparToHandler :: Env -> Spar CanonicalEffs a -> Handler a +runSparToHandler :: Env -> Sem CanonicalEffs a -> Handler a runSparToHandler ctx spar = do err <- liftIO $ runSparToIO ctx spar throwErrorAsHandlerException err diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index 1bb2be8d966..6d1e83b03de 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -29,7 +29,6 @@ module Spar.Error SparCustomError (..), throwSpar, sparToServerErrorWithLogging, - renderSparErrorWithLogging, rethrow, parseResponse, -- FUTUREWORK: we really shouldn't export this, but that requires that we can use our @@ -132,12 +131,6 @@ waiToServant waierr@(Wai.Error status label _ _) = errHeaders = [] } -renderSparErrorWithLogging :: MonadIO m => Log.Logger -> SparError -> m (Either ServerError Wai.Error) -renderSparErrorWithLogging logger err = do - let errPossiblyWai = renderSparError err - liftIO $ Wai.logError logger (Nothing :: Maybe Wai.Request) (either servantToWaiError id $ errPossiblyWai) - pure errPossiblyWai - renderSparError :: SparError -> Either ServerError Wai.Error renderSparError (SAML.CustomError SparNoSuchRequest) = Right $ Wai.mkError status500 "server-error" "AuthRequest seems to have disappeared (could not find verdict format)." renderSparError (SAML.CustomError (SparNoRequestRefInResponse msg)) = Right $ Wai.mkError status400 "server-error-unsupported-saml" ("The IdP needs to provide an InResponseTo attribute in the assertion: " <> msg) diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index 8f6d0db1765..95ae0d4db5e 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -64,23 +64,19 @@ module Spar.Scim ) where -import Control.Monad.Catch (try) -import Control.Monad.Except import Data.String.Conversions (cs) import Imports import Polysemy -import Polysemy.Error (Error) -import Polysemy.Input (Input, input) +import Polysemy.Error (Error, fromExceptionSem, runError, throw, try) +import Polysemy.Input (Input) import qualified SAML2.WebSSO as SAML import Servant import Servant.API.Generic import Servant.Server.Generic (AsServerT) -import Spar.App (Spar (..)) +import Spar.App (sparToServerErrorWithLogging, throwSparSem) import Spar.Error ( SparCustomError (SparScimError), SparError, - sparToServerErrorWithLogging, - throwSpar, ) import Spar.Scim.Auth import Spar.Scim.User @@ -90,12 +86,12 @@ import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.Logger (Logger) import Spar.Sem.Now (Now) import Spar.Sem.Random (Random) +import Spar.Sem.Reporter (Reporter) import Spar.Sem.SAMLUserStore (SAMLUserStore) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import Spar.Sem.ScimTokenStore (ScimTokenStore) import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import System.Logger (Msg) -import qualified System.Logger as TinyLog import qualified Web.Scim.Capabilities.MetaSchema as Scim.Meta import qualified Web.Scim.Class.Auth as Scim.Auth import qualified Web.Scim.Class.User as Scim.User @@ -117,8 +113,7 @@ configuration = Scim.Meta.empty apiScim :: forall r. Members - '[ Input TinyLog.Logger, - Random, + '[ Random, Input Opts, Logger (Msg -> Msg), Logger String, @@ -129,11 +124,14 @@ apiScim :: ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, + Reporter, IdPEffect.IdP, + -- TODO(sandy): Only necessary for 'fromExceptionSem'. But can these errors even happen? + Final IO, SAMLUserStore ] r => - ServerT APIScim (Spar r) + ServerT APIScim (Sem r) apiScim = hoistScim (toServant (server configuration)) :<|> apiScimToken @@ -141,7 +139,7 @@ apiScim = hoistScim = hoistServer (Proxy @(ScimSiteAPI SparTag)) - (wrapScimErrors . Scim.fromScimHandler (throwSpar . SparScimError)) + (wrapScimErrors . Scim.fromScimHandler (throwSparSem . SparScimError)) -- Wrap /all/ errors into the format required by SCIM, even server exceptions that have -- nothing to do with SCIM. -- @@ -149,34 +147,33 @@ apiScim = -- Let's hope that SCIM clients can handle non-SCIM-formatted errors -- properly. See -- for why it's hard to catch impure exceptions. - wrapScimErrors :: Spar r a -> Spar r a - wrapScimErrors act = Spar $ - ExceptT $ do - result :: Either SomeException (Either SparError a) <- try $ runExceptT $ fromSpar $ act - case result of - Left someException -> do - -- We caught an exception that's not a Spar exception at all. It is wrapped into - -- Scim.serverError. - pure . Left . SAML.CustomError . SparScimError $ - Scim.serverError (cs (displayException someException)) - Right err@(Left (SAML.CustomError (SparScimError _))) -> - -- We caught a 'SparScimError' exception. It is left as-is. - pure err - Right (Left sparError) -> do - -- We caught some other Spar exception. It is rendered and wrapped into a scim error - -- with the same status and message, and no scim error type. - logger <- input @TinyLog.Logger - err :: ServerError <- embedFinal @IO $ sparToServerErrorWithLogging logger sparError - pure . Left . SAML.CustomError . SparScimError $ - Scim.ScimError - { schemas = [Scim.Schema.Error20], - status = Scim.Status $ errHTTPCode err, - scimType = Nothing, - detail = Just . cs $ errBody err - } - Right (Right x) -> do - -- No exceptions! Good. - pure $ Right x + wrapScimErrors :: Sem r a -> Sem r a + wrapScimErrors act = do + result :: Either SomeException (Either SparError a) <- + runError $ fromExceptionSem @SomeException $ raise $ try @SparError act + case result of + Left someException -> do + -- We caught an exception that's not a Spar exception at all. It is wrapped into + -- Scim.serverError. + throw . SAML.CustomError . SparScimError $ + Scim.serverError (cs (displayException someException)) + Right (Left err@(SAML.CustomError (SparScimError _))) -> + -- We caught a 'SparScimError' exception. It is left as-is. + throw err + Right (Left sparError) -> do + -- We caught some other Spar exception. It is rendered and wrapped into a scim error + -- with the same status and message, and no scim error type. + err :: ServerError <- sparToServerErrorWithLogging sparError + throw . SAML.CustomError . SparScimError $ + Scim.ScimError + { schemas = [Scim.Schema.Error20], + status = Scim.Status $ errHTTPCode err, + scimType = Nothing, + detail = Just . cs $ errBody err + } + Right (Right x) -> do + -- No exceptions! Good. + pure x -- | This is similar to 'Scim.siteServer, but does not include the 'Scim.groupServer', -- as we don't support it (we don't implement 'Web.Scim.Class.Group.GroupDB'). diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 6b8241f8c49..f3ae450783d 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -39,7 +39,6 @@ import Control.Lens hiding (Strict, (.=)) import qualified Data.ByteString.Base64 as ES import Data.Id (ScimTokenId, UserId) import Data.String.Conversions (cs) -import Data.Time (getCurrentTime) import Imports -- FUTUREWORK: these imports are not very handy. split up Spar.Scim into -- Spar.Scim.{Core,User,Group} to avoid at least some of the hscim name clashes? @@ -49,13 +48,15 @@ import Polysemy.Error import Polysemy.Input import qualified SAML2.WebSSO as SAML import Servant (NoContent (NoContent), ServerT, (:<|>) ((:<|>))) -import Spar.App (Spar, liftSem, wrapMonadClientSem) +import Spar.App (throwSparSem) import qualified Spar.Error as E import qualified Spar.Intra.BrigApp as Intra.Brig import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.Now (Now) +import qualified Spar.Sem.Now as Now import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random import Spar.Sem.ScimTokenStore (ScimTokenStore) @@ -68,14 +69,14 @@ import Wire.API.User.Saml (Opts, maxScimTokens) import Wire.API.User.Scim -- | An instance that tells @hscim@ how authentication should be done for SCIM routes. -instance Member ScimTokenStore r => Scim.Class.Auth.AuthDB SparTag (Spar r) where +instance Member ScimTokenStore r => Scim.Class.Auth.AuthDB SparTag (Sem r) where -- Validate and resolve a given token - authCheck :: Maybe ScimToken -> Scim.ScimHandler (Spar r) ScimTokenInfo + authCheck :: Maybe ScimToken -> Scim.ScimHandler (Sem r) ScimTokenInfo authCheck Nothing = Scim.throwScim (Scim.unauthorized "Token not provided") authCheck (Just token) = maybe (Scim.throwScim (Scim.unauthorized "Invalid token")) pure - =<< lift (wrapMonadClientSem (ScimTokenStore.lookup token)) + =<< lift (ScimTokenStore.lookup token) ---------------------------------------------------------------------------- -- Token API @@ -91,11 +92,12 @@ apiScimToken :: GalleyAccess, BrigAccess, ScimTokenStore, + Now, IdPEffect.IdP, Error E.SparError ] r => - ServerT APIScimToken (Spar r) + ServerT APIScimToken (Sem r) apiScimToken = createScimToken :<|> deleteScimToken @@ -113,6 +115,7 @@ createScimToken :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + Now, Error E.SparError ] r => @@ -120,31 +123,35 @@ createScimToken :: Maybe UserId -> -- | Request body CreateScimToken -> - Spar r CreateScimTokenResponse + Sem r CreateScimTokenResponse createScimToken zusr CreateScimToken {..} = do let descr = createScimTokenDescr - teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr - liftSem $ BrigAccess.ensureReAuthorised zusr createScimTokenPassword - tokenNumber <- fmap length $ wrapMonadClientSem $ ScimTokenStore.getByTeam teamid - maxTokens <- liftSem $ inputs maxScimTokens + teamid <- Intra.Brig.authorizeScimTokenManagement zusr + BrigAccess.ensureReAuthorised zusr createScimTokenPassword + tokenNumber <- fmap length $ ScimTokenStore.getByTeam teamid + maxTokens <- inputs maxScimTokens unless (tokenNumber < maxTokens) $ - E.throwSpar E.SparProvisioningTokenLimitReached - idps <- wrapMonadClientSem $ IdPEffect.getConfigsByTeam teamid + throwSparSem E.SparProvisioningTokenLimitReached + idps <- IdPEffect.getConfigsByTeam teamid - let caseOneOrNoIdP :: Maybe SAML.IdPId -> Spar r CreateScimTokenResponse + let caseOneOrNoIdP :: Maybe SAML.IdPId -> Sem r CreateScimTokenResponse caseOneOrNoIdP midpid = do - token <- liftSem $ ScimToken . cs . ES.encode <$> Random.bytes 32 - tokenid <- liftSem $ Random.scimTokenId - now <- liftIO getCurrentTime + token <- ScimToken . cs . ES.encode <$> Random.bytes 32 + tokenid <- Random.scimTokenId + -- FUTUREWORK(fisx): the fact that we're using @Now.get@ + -- here means that the 'Now' effect should not contain + -- types from saml2-web-sso. We can just use 'UTCTime' + -- there, right? + now <- Now.get let info = ScimTokenInfo { stiId = tokenid, stiTeam = teamid, - stiCreatedAt = now, + stiCreatedAt = SAML.fromTime now, stiIdP = midpid, stiDescr = descr } - wrapMonadClientSem $ ScimTokenStore.insert token info + ScimTokenStore.insert token info pure $ CreateScimTokenResponse token info case idps of @@ -154,7 +161,7 @@ createScimToken zusr CreateScimToken {..} = do -- be changed. currently, it relies on the fact that there is never more than one IdP. -- https://wearezeta.atlassian.net/browse/SQSERVICES-165 _ -> - E.throwSpar $ + throwSparSem $ E.SparProvisioningMoreThanOneIdP "SCIM tokens can only be created for a team with at most one IdP" @@ -166,10 +173,10 @@ deleteScimToken :: -- | Who is trying to delete a token Maybe UserId -> ScimTokenId -> - Spar r NoContent + Sem r NoContent deleteScimToken zusr tokenid = do - teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr - wrapMonadClientSem $ ScimTokenStore.delete teamid tokenid + teamid <- Intra.Brig.authorizeScimTokenManagement zusr + ScimTokenStore.delete teamid tokenid pure NoContent -- | > docs/reference/provisioning/scim-token.md {#RefScimTokenList} @@ -180,7 +187,7 @@ listScimTokens :: Members '[GalleyAccess, BrigAccess, ScimTokenStore, Error E.SparError] r => -- | Who is trying to list tokens Maybe UserId -> - Spar r ScimTokenList + Sem r ScimTokenList listScimTokens zusr = do - teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr - ScimTokenList <$> wrapMonadClientSem (ScimTokenStore.getByTeam teamid) + teamid <- Intra.Brig.authorizeScimTokenManagement zusr + ScimTokenList <$> ScimTokenStore.getByTeam teamid diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 64cbd0d6e9d..549a23c89dc 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -66,7 +66,7 @@ import Network.URI (URI, parseURI) import Polysemy import Polysemy.Input import qualified SAML2.WebSSO as SAML -import Spar.App (GetUserResult (..), Spar, getUserIdByScimExternalId, getUserIdByUref, liftSem, validateEmailIfExists, wrapMonadClientSem) +import Spar.App (GetUserResult (..), getUserIdByScimExternalId, getUserIdByUref, validateEmailIfExists) import qualified Spar.Intra.BrigApp as Brig import Spar.Scim.Auth () import Spar.Scim.Types (normalizeLikeStored) @@ -126,12 +126,12 @@ instance SAMLUserStore ] r => - Scim.UserDB ST.SparTag (Spar r) + Scim.UserDB ST.SparTag (Sem r) where getUsers :: ScimTokenInfo -> Maybe Scim.Filter -> - Scim.ScimHandler (Spar r) (Scim.ListResponse (Scim.StoredUser ST.SparTag)) + Scim.ScimHandler (Sem r) (Scim.ListResponse (Scim.StoredUser ST.SparTag)) getUsers _ Nothing = do throwError $ Scim.badRequest Scim.TooMany (Just "Please specify a filter when getting users.") getUsers tokeninfo@ScimTokenInfo {stiTeam, stiIdP} (Just filter') = @@ -141,7 +141,7 @@ instance . logFilter filter' ) $ do - mIdpConfig <- maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP case filter' of Scim.FilterAttrCompare (Scim.AttrPath schema attrName _subAttr) Scim.OpEq (Scim.ValString val) | Scim.isUserSchema schema -> do @@ -156,7 +156,7 @@ instance getUser :: ScimTokenInfo -> UserId -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) getUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = logScim ( logFunction "Spar.Scim.User.getUser" @@ -164,9 +164,9 @@ instance . logTokenInfo tokeninfo ) $ do - mIdpConfig <- maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP let notfound = Scim.notFound "User" (idToText uid) - brigUser <- lift (liftSem $ BrigAccess.getAccount Brig.WithPendingInvitations uid) >>= maybe (throwError notfound) pure + brigUser <- lift (BrigAccess.getAccount Brig.WithPendingInvitations uid) >>= maybe (throwError notfound) pure unless (userTeam (accountUser brigUser) == Just stiTeam) (throwError notfound) case Brig.veidFromBrigUser (accountUser brigUser) ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Right veid -> synthesizeStoredUser brigUser veid @@ -175,18 +175,18 @@ instance postUser :: ScimTokenInfo -> Scim.User ST.SparTag -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) postUser tokinfo user = createValidScimUser tokinfo =<< validateScimUser tokinfo user putUser :: ScimTokenInfo -> UserId -> Scim.User ST.SparTag -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) putUser tokinfo uid newScimUser = updateValidScimUser tokinfo uid =<< validateScimUser tokinfo newScimUser - deleteUser :: ScimTokenInfo -> UserId -> Scim.ScimHandler (Spar r) () + deleteUser :: ScimTokenInfo -> UserId -> Scim.ScimHandler (Sem r) () deleteUser tokeninfo uid = logScim ( logFunction "Spar.Scim.User.deleteUser" @@ -202,7 +202,7 @@ instance -- 'ValidScimUser''. validateScimUser :: forall m r. - (m ~ Scim.ScimHandler (Spar r)) => + (m ~ Scim.ScimHandler (Sem r)) => Members '[Input Opts, IdPEffect.IdP] r => -- | Used to decide what IdP to assign the user to ScimTokenInfo -> @@ -210,12 +210,12 @@ validateScimUser :: m ST.ValidScimUser validateScimUser tokinfo user = do mIdpConfig <- tokenInfoToIdP tokinfo - richInfoLimit <- lift $ liftSem $ inputs richInfoLimit + richInfoLimit <- lift $ inputs richInfoLimit validateScimUser' mIdpConfig richInfoLimit user -tokenInfoToIdP :: Member IdPEffect.IdP r => ScimTokenInfo -> Scim.ScimHandler (Spar r) (Maybe IdP) +tokenInfoToIdP :: Member IdPEffect.IdP r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) tokenInfoToIdP ScimTokenInfo {stiIdP} = do - maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP -- | Validate a handle (@userName@). validateHandle :: MonadError Scim.ScimError m => Text -> m Handle @@ -341,7 +341,7 @@ mkValidExternalId (Just idp) (Just extid) = do Scim.InvalidValue (Just $ "Can't construct a subject ID from externalId: " <> Text.pack err) -logScim :: forall r a. (Member (Logger (Msg -> Msg)) r) => (Msg -> Msg) -> Scim.ScimHandler (Spar r) a -> Scim.ScimHandler (Spar r) a +logScim :: forall r a. (Member (Logger (Msg -> Msg)) r) => (Msg -> Msg) -> Scim.ScimHandler (Sem r) a -> Scim.ScimHandler (Sem r) a logScim context action = flip mapExceptT action $ \action' -> do eith <- action' @@ -351,10 +351,10 @@ logScim context action = case Scim.detail e of Just d -> d Nothing -> cs (Aeson.encode e) - liftSem $ Logger.warn $ context . Log.msg errorMsg + Logger.warn $ context . Log.msg errorMsg pure (Left e) Right x -> do - liftSem $ Logger.info $ context . Log.msg @Text "call without exception" + Logger.info $ context . Log.msg @Text "call without exception" pure (Right x) logEmail :: Email -> (Msg -> Msg) @@ -394,7 +394,7 @@ veidEmail (ST.EmailOnly email) = Just email -- This is the pain and the price you pay for the horribleness called MTL createValidScimUser :: forall m r. - (m ~ Scim.ScimHandler (Spar r)) => + (m ~ Scim.ScimHandler (Sem r)) => Members '[ Random, Now, @@ -431,25 +431,24 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid buid <- ST.runValidExternalId ( \uref -> - liftSem $ do + do uid <- Id <$> Random.uuid BrigAccess.createSAML uref uid stiTeam name ManagedByScim ) ( \email -> do - liftSem $ BrigAccess.createNoSAML email stiTeam name + BrigAccess.createNoSAML email stiTeam name ) veid - liftSem $ Logger.debug ("createValidScimUser: brig says " <> show buid) + Logger.debug ("createValidScimUser: brig says " <> show buid) -- {If we crash now, we have an active user that cannot login. And can not -- be bound this will be a zombie user that needs to be manually cleaned -- up. We should consider making setUserHandle part of createUser and -- making it transactional. If the user redoes the POST A new standalone -- user will be created.} - liftSem $ do - BrigAccess.setHandle buid handl - BrigAccess.setRichInfo buid richInfo + BrigAccess.setHandle buid handl + BrigAccess.setRichInfo buid richInfo pure buid -- {If we crash now, a POST retry will fail with 409 user already exists. @@ -462,13 +461,13 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- to reload the Account from brig. storedUser <- do acc <- - lift (liftSem $ BrigAccess.getAccount Brig.WithPendingInvitations buid) + lift (BrigAccess.getAccount Brig.WithPendingInvitations buid) >>= maybe (throwError $ Scim.serverError "Server error: user vanished") pure synthesizeStoredUser acc veid - lift $ liftSem $ Logger.debug ("createValidScimUser: spar says " <> show storedUser) + lift $ Logger.debug ("createValidScimUser: spar says " <> show storedUser) -- {(arianvp): these two actions we probably want to make transactional.} - lift . wrapMonadClientSem $ do + lift $ do -- Store scim timestamps, saml credentials, scim externalId locally in spar. ScimUserTimesStore.write storedUser ST.runValidExternalId @@ -481,10 +480,10 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- {suspension via scim: if we don't reach the following line, the user will be active.} lift $ do - old <- liftSem $ BrigAccess.getStatus buid + old <- BrigAccess.getStatus buid let new = ST.scimActiveFlagToAccountStatus old (Scim.unScimBool <$> active) active = Scim.active . Scim.value . Scim.thing $ storedUser - when (new /= old) $ liftSem $ BrigAccess.setStatus buid new + when (new /= old) $ BrigAccess.setStatus buid new pure storedUser -- TODO(arianvp): how do we get this safe w.r.t. race conditions / crashes? @@ -504,7 +503,7 @@ updateValidScimUser :: SAMLUserStore ] r => - (m ~ Scim.ScimHandler (Spar r)) => + (m ~ Scim.ScimHandler (Sem r)) => ScimTokenInfo -> UserId -> ST.ValidScimUser -> @@ -540,22 +539,21 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid newValidScimUser = _ -> pure () when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ do - liftSem $ BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) + BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) when (oldValidScimUser ^. ST.vsuHandle /= newValidScimUser ^. ST.vsuHandle) $ do - liftSem $ BrigAccess.setHandle uid (newValidScimUser ^. ST.vsuHandle) + BrigAccess.setHandle uid (newValidScimUser ^. ST.vsuHandle) when (oldValidScimUser ^. ST.vsuRichInfo /= newValidScimUser ^. ST.vsuRichInfo) $ do - liftSem $ BrigAccess.setRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) + BrigAccess.setRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) - liftSem $ - BrigAccess.getStatusMaybe uid >>= \case - Nothing -> pure () - Just old -> do - let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser ^. ST.vsuActive) - when (new /= old) $ BrigAccess.setStatus uid new + BrigAccess.getStatusMaybe uid >>= \case + Nothing -> pure () + Just old -> do + let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser ^. ST.vsuActive) + when (new /= old) $ BrigAccess.setStatus uid new - wrapMonadClientSem $ ScimUserTimesStore.write newScimStoredUser + ScimUserTimesStore.write newScimStoredUser pure newScimStoredUser updateVsuUref :: @@ -570,18 +568,17 @@ updateVsuUref :: UserId -> ST.ValidExternalId -> ST.ValidExternalId -> - Spar r () + Sem r () updateVsuUref team uid old new = do let geturef = ST.runValidExternalId Just (const Nothing) case (geturef old, geturef new) of (mo, mn@(Just newuref)) | mo /= mn -> validateEmailIfExists uid newuref _ -> pure () - wrapMonadClientSem $ do - old & ST.runValidExternalId (SAMLUserStore.delete uid) (ScimExternalIdStore.delete team) - new & ST.runValidExternalId (`SAMLUserStore.insert` uid) (\email -> ScimExternalIdStore.insert team email uid) + old & ST.runValidExternalId (SAMLUserStore.delete uid) (ScimExternalIdStore.delete team) + new & ST.runValidExternalId (`SAMLUserStore.insert` uid) (\email -> ScimExternalIdStore.insert team email uid) - liftSem $ BrigAccess.setVeid uid new + BrigAccess.setVeid uid new toScimStoredUser' :: HasCallStack => @@ -618,9 +615,9 @@ updScimStoredUser :: Member Now r => Scim.User ST.SparTag -> Scim.StoredUser ST.SparTag -> - Spar r (Scim.StoredUser ST.SparTag) + Sem r (Scim.StoredUser ST.SparTag) updScimStoredUser usr storedusr = do - SAML.Time (toUTCTimeMillis -> now) <- liftSem Now.get + SAML.Time (toUTCTimeMillis -> now) <- Now.get pure $ updScimStoredUser' now usr storedusr updScimStoredUser' :: @@ -649,7 +646,7 @@ deleteScimUser :: r => ScimTokenInfo -> UserId -> - Scim.ScimHandler (Spar r) () + Scim.ScimHandler (Sem r) () deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = logScim ( logFunction "Spar.Scim.User.deleteScimUser" @@ -657,7 +654,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = . logUser uid ) $ do - mbBrigUser <- lift (liftSem $ Brig.getBrigUser Brig.WithPendingInvitations uid) + mbBrigUser <- lift (Brig.getBrigUser Brig.WithPendingInvitations uid) case mbBrigUser of Nothing -> do -- double-deletion gets you a 404. @@ -671,19 +668,19 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = throwError $ Scim.notFound "user" (idToText uid) - mIdpConfig <- maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP case Brig.veidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Left _ -> pure () Right veid -> - lift . wrapMonadClientSem $ + lift $ ST.runValidExternalId (SAMLUserStore.delete uid) (ScimExternalIdStore.delete stiTeam) veid - lift . wrapMonadClientSem $ ScimUserTimesStore.delete uid - lift . liftSem $ BrigAccess.delete uid + lift $ ScimUserTimesStore.delete uid + lift $ BrigAccess.delete uid return () ---------------------------------------------------------------------------- @@ -713,7 +710,7 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdUnused :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () +assertExternalIdUnused :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Sem r) () assertExternalIdUnused tid veid = do assertExternalIdInAllowedValues [Nothing] @@ -727,7 +724,7 @@ assertExternalIdUnused tid veid = do -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdNotUsedElsewhere :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Spar r) () +assertExternalIdNotUsedElsewhere :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Sem r) () assertExternalIdNotUsedElsewhere tid veid wireUserId = do assertExternalIdInAllowedValues [Nothing, Just wireUserId] @@ -735,7 +732,7 @@ assertExternalIdNotUsedElsewhere tid veid wireUserId = do tid veid -assertExternalIdInAllowedValues :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => [Maybe UserId] -> Text -> TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () +assertExternalIdInAllowedValues :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => [Maybe UserId] -> Text -> TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Sem r) () assertExternalIdInAllowedValues allowedValues errmsg tid veid = do isGood <- lift $ @@ -752,18 +749,18 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do unless isGood $ throwError Scim.conflict {Scim.detail = Just errmsg} -assertHandleUnused :: Member BrigAccess r => Handle -> Scim.ScimHandler (Spar r) () +assertHandleUnused :: Member BrigAccess r => Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused = assertHandleUnused' "userName is already taken" -assertHandleUnused' :: Member BrigAccess r => Text -> Handle -> Scim.ScimHandler (Spar r) () +assertHandleUnused' :: Member BrigAccess r => Text -> Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused' msg hndl = - lift (liftSem $ BrigAccess.checkHandleAvailable hndl) >>= \case + lift (BrigAccess.checkHandleAvailable hndl) >>= \case True -> pure () False -> throwError Scim.conflict {Scim.detail = Just msg} -assertHandleNotUsedElsewhere :: Member BrigAccess r => UserId -> Handle -> Scim.ScimHandler (Spar r) () +assertHandleNotUsedElsewhere :: Member BrigAccess r => UserId -> Handle -> Scim.ScimHandler (Sem r) () assertHandleNotUsedElsewhere uid hndl = do - musr <- lift $ liftSem $ Brig.getBrigUser Brig.WithPendingInvitations uid + musr <- lift $ Brig.getBrigUser Brig.WithPendingInvitations uid unless ((userHandle =<< musr) == Just hndl) $ assertHandleUnused' "userName already in use by another wire user" hndl @@ -782,7 +779,7 @@ synthesizeStoredUser :: r => UserAccount -> ST.ValidExternalId -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) synthesizeStoredUser usr veid = logScim ( logFunction "Spar.Scim.User.synthesizeStoredUser" @@ -795,28 +792,28 @@ synthesizeStoredUser usr veid = let uid = userId (accountUser usr) accStatus = accountStatus usr - let readState :: Spar r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI) + let readState :: Sem r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI) readState = do - richInfo <- liftSem $ BrigAccess.getRichInfo uid - accessTimes <- wrapMonadClientSem (ScimUserTimesStore.read uid) - baseuri <- liftSem $ inputs $ derivedOptsScimBaseURI . derivedOpts + richInfo <- BrigAccess.getRichInfo uid + accessTimes <- ScimUserTimesStore.read uid + baseuri <- inputs $ derivedOptsScimBaseURI . derivedOpts pure (richInfo, accessTimes, baseuri) - let writeState :: Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> RI.RichInfo -> Scim.StoredUser ST.SparTag -> Spar r () + let writeState :: Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> RI.RichInfo -> Scim.StoredUser ST.SparTag -> Sem r () writeState oldAccessTimes oldManagedBy oldRichInfo storedUser = do when (isNothing oldAccessTimes) $ do - wrapMonadClientSem $ ScimUserTimesStore.write storedUser + ScimUserTimesStore.write storedUser when (oldManagedBy /= ManagedByScim) $ do - liftSem $ BrigAccess.setManagedBy uid ManagedByScim + BrigAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser when (oldRichInfo /= newRichInfo) $ do - liftSem $ BrigAccess.setRichInfo uid newRichInfo + BrigAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri) <- lift readState - SAML.Time (toUTCTimeMillis -> now) <- lift $ liftSem Now.get + SAML.Time (toUTCTimeMillis -> now) <- lift Now.get let (createdAt, lastUpdatedAt) = fromMaybe (now, now) accessTimes - handle <- lift $ liftSem $ Brig.giveDefaultHandle (accountUser usr) + handle <- lift $ Brig.giveDefaultHandle (accountUser usr) storedUser <- synthesizeStoredUser' @@ -880,10 +877,10 @@ scimFindUserByHandle :: Maybe IdP -> TeamId -> Text -> - MaybeT (Scim.ScimHandler (Spar r)) (Scim.StoredUser ST.SparTag) + MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByHandle mIdpConfig stiTeam hndl = do handle <- MaybeT . pure . parseHandle . Text.toLower $ hndl - brigUser <- MaybeT . lift . liftSem . BrigAccess.getByHandle $ handle + brigUser <- MaybeT . lift . BrigAccess.getByHandle $ handle guard $ userTeam (accountUser brigUser) == Just stiTeam case Brig.veidFromBrigUser (accountUser brigUser) ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Right veid -> lift $ synthesizeStoredUser brigUser veid @@ -910,7 +907,7 @@ scimFindUserByEmail :: Maybe IdP -> TeamId -> Text -> - MaybeT (Scim.ScimHandler (Spar r)) (Scim.StoredUser ST.SparTag) + MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByEmail mIdpConfig stiTeam email = do -- Azure has been observed to search for externalIds that are not emails, even if the -- mapping is set up like it should be. This is a problem: if there is no SAML IdP, 'mkValidExternalId' @@ -920,24 +917,24 @@ scimFindUserByEmail mIdpConfig stiTeam email = do -- a UUID, or any other text that is valid according to SCIM. veid <- MaybeT (either (const Nothing) Just <$> runExceptT (mkValidExternalId mIdpConfig (pure email))) uid <- MaybeT . lift $ ST.runValidExternalId withUref withEmailOnly veid - brigUser <- MaybeT . lift . liftSem . BrigAccess.getAccount Brig.WithPendingInvitations $ uid + brigUser <- MaybeT . lift . BrigAccess.getAccount Brig.WithPendingInvitations $ uid guard $ userTeam (accountUser brigUser) == Just stiTeam lift $ synthesizeStoredUser brigUser veid where - withUref :: SAML.UserRef -> Spar r (Maybe UserId) + withUref :: SAML.UserRef -> Sem r (Maybe UserId) withUref uref = do - wrapMonadClientSem (SAMLUserStore.get uref) >>= \case + SAMLUserStore.get uref >>= \case Nothing -> maybe (pure Nothing) withEmailOnly $ Brig.urefToEmail uref Just uid -> pure (Just uid) - withEmailOnly :: BT.Email -> Spar r (Maybe UserId) + withEmailOnly :: BT.Email -> Sem r (Maybe UserId) withEmailOnly eml = maybe inbrig (pure . Just) =<< inspar where -- FUTUREWORK: we could also always lookup brig, that's simpler and possibly faster, -- and it never should be visible in spar, but not in brig. - inspar, inbrig :: Spar r (Maybe UserId) - inspar = wrapMonadClientSem $ ScimExternalIdStore.lookup stiTeam eml - inbrig = liftSem $ userId . accountUser <$$> BrigAccess.getByEmail eml + inspar, inbrig :: Sem r (Maybe UserId) + inspar = ScimExternalIdStore.lookup stiTeam eml + inbrig = userId . accountUser <$$> BrigAccess.getByEmail eml logFilter :: Filter -> (Msg -> Msg) logFilter (FilterAttrCompare attr op val) = diff --git a/services/spar/src/Spar/Sem/Reporter.hs b/services/spar/src/Spar/Sem/Reporter.hs new file mode 100644 index 00000000000..b0381521110 --- /dev/null +++ b/services/spar/src/Spar/Sem/Reporter.hs @@ -0,0 +1,12 @@ +module Spar.Sem.Reporter where + +import Imports +import qualified Network.Wai as Wai +import Network.Wai.Utilities.Error (Error) +import Polysemy + +data Reporter m a where + Report :: Maybe Wai.Request -> Error -> Reporter m () + +-- TODO(sandy): Inline this definition --- no TH +makeSem ''Reporter diff --git a/services/spar/src/Spar/Sem/Reporter/Wai.hs b/services/spar/src/Spar/Sem/Reporter/Wai.hs new file mode 100644 index 00000000000..548be65b329 --- /dev/null +++ b/services/spar/src/Spar/Sem/Reporter/Wai.hs @@ -0,0 +1,14 @@ +module Spar.Sem.Reporter.Wai where + +import Imports +import qualified Network.Wai.Utilities.Server as Wai +import Polysemy +import Polysemy.Input +import Spar.Sem.Reporter +import qualified System.Logger as TinyLog + +reporterToTinyLogWai :: Members '[Embed IO, Input TinyLog.Logger] r => Sem (Reporter ': r) a -> Sem r a +reporterToTinyLogWai = interpret $ \case + Report req err -> do + logger <- input + embed @IO $ Wai.logError logger req err diff --git a/services/spar/src/Spar/Sem/SAML2/Library.hs b/services/spar/src/Spar/Sem/SAML2/Library.hs index 3de69921410..9c8be48238e 100644 --- a/services/spar/src/Spar/Sem/SAML2/Library.hs +++ b/services/spar/src/Spar/Sem/SAML2/Library.hs @@ -11,6 +11,7 @@ import Data.String.Conversions (cs) import Imports import Polysemy import Polysemy.Error +import Polysemy.Final import Polysemy.Input import Polysemy.Internal.Tactics import SAML2.WebSSO hiding (Error) @@ -30,9 +31,19 @@ import Wire.API.User.Saml wrapMonadClientSPImpl :: Members '[Error SparError, Final IO] r => Sem r a -> SPImpl r a wrapMonadClientSPImpl action = - SPImpl $ - action - `Catch.catch` (throw . SAML.CustomError . SparCassandraError . cs . show @SomeException) + SPImpl action + `Catch.catch` (SPImpl . throw . SAML.CustomError . SparCassandraError . cs . show @SomeException) + +instance Member (Final IO) r => Catch.MonadThrow (SPImpl r) where + throwM = SPImpl . embedFinal . Catch.throwM @IO + +instance Member (Final IO) r => Catch.MonadCatch (SPImpl r) where + catch (SPImpl m) handler = SPImpl $ + withStrategicToFinal @IO $ do + m' <- runS m + st <- getInitialStateS + handler' <- bindS $ unSPImpl . handler + pure $ m' `Catch.catch` \e -> handler' $ e <$ st newtype SPImpl r a = SPImpl {unSPImpl :: Sem r a} deriving (Functor, Applicative, Monad) @@ -64,9 +75,9 @@ instance Members '[Error SparError, IdPEffect.IdP, Final IO] r => SPStoreIdP Spa type IdPConfigExtra (SPImpl r) = WireIdP type IdPConfigSPId (SPImpl r) = TeamId - storeIdPConfig = SPImpl . App.runSparInSem . App.storeIdPConfig - getIdPConfig = SPImpl . App.runSparInSem . App.getIdPConfig - getIdPConfigByIssuerOptionalSPId a = SPImpl . App.runSparInSem . App.getIdPConfigByIssuerOptionalSPId a + storeIdPConfig = SPImpl . App.storeIdPConfig + getIdPConfig = SPImpl . App.getIdPConfig + getIdPConfigByIssuerOptionalSPId a = SPImpl . App.getIdPConfigByIssuerOptionalSPId a instance Member (Error SparError) r => MonadError SparError (SPImpl r) where throwError = SPImpl . throw diff --git a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs index 409c5a4b2f3..c2711056aed 100644 --- a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs @@ -3,9 +3,15 @@ module Spar.Sem.SAMLUserStore.Cassandra where import Cassandra +import qualified Control.Monad.Catch as Catch +import Data.String.Conversions (cs) import Imports import Polysemy +import Polysemy.Error +import Polysemy.Final +import qualified SAML2.WebSSO.Error as SAML import qualified Spar.Data as Data +import Spar.Error import Spar.Sem.SAMLUserStore samlUserStoreToCassandra :: @@ -23,6 +29,14 @@ samlUserStoreToCassandra = DeleteByIssuer is -> Data.deleteSAMLUsersByIssuer is Delete uid ur -> Data.deleteSAMLUser uid ur -interpretClientToIO :: Member (Final IO) r => ClientState -> Sem (Embed Client ': r) a -> Sem r a +interpretClientToIO :: + Members '[Error SparError, Final IO] r => + ClientState -> + Sem (Embed Client ': r) a -> + Sem r a interpretClientToIO ctx = interpret $ \case - Embed action -> embedFinal $ runClient ctx action + Embed action -> withStrategicToFinal @IO $ do + action' <- liftS $ runClient ctx action + st <- getInitialStateS + handler' <- bindS $ throw @SparError . SAML.CustomError . SparCassandraError . cs . show @SomeException + pure $ action' `Catch.catch` \e -> handler' $ e <$ st diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 57afed49fd2..7685df85177 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -70,7 +70,6 @@ import qualified SAML2.WebSSO as SAML import SAML2.WebSSO.Test.Lenses import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.IdP as IdPEffect @@ -870,7 +869,7 @@ specCRUDIdentityProvider = do pure $ idpmeta1 & edIssuer .~ (idpmeta3 ^. edIssuer) do - midp <- runSpar $ liftSem $ IdPEffect.getConfig idpid1 + midp <- runSpar $ IdPEffect.getConfig idpid1 liftIO $ do (midp ^? _Just . idpMetadata . edIssuer) `shouldBe` Just (idpmeta1 ^. edIssuer) (midp ^? _Just . idpExtraInfo . wiOldIssuers) `shouldBe` Just [] @@ -883,7 +882,7 @@ specCRUDIdentityProvider = do resp <- call $ callIdpUpdate' (env ^. teSpar) (Just owner1) idpid1 (IdPMetadataValue (cs $ SAML.encode new) undefined) liftIO $ statusCode resp `shouldBe` 200 - midp <- runSpar $ liftSem $ IdPEffect.getConfig idpid1 + midp <- runSpar $ IdPEffect.getConfig idpid1 liftIO $ do (midp ^? _Just . idpMetadata . edIssuer) `shouldBe` Just (new ^. edIssuer) sort <$> (midp ^? _Just . idpExtraInfo . wiOldIssuers) `shouldBe` Just (sort $ olds <&> (^. edIssuer)) @@ -1298,7 +1297,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do brig <- view teBrig resp <- call . delete $ brig . paths ["i", "users", toByteString' uid] liftIO $ responseStatus resp `shouldBe` status202 - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Deleted) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Deleted) specScimAndSAML :: SpecWith TestEnv specScimAndSAML = do diff --git a/services/spar/test-integration/Test/Spar/AppSpec.hs b/services/spar/test-integration/Test/Spar/AppSpec.hs index 0ee8760f00d..5f38b3830a3 100644 --- a/services/spar/test-integration/Test/Spar/AppSpec.hs +++ b/services/spar/test-integration/Test/Spar/AppSpec.hs @@ -33,7 +33,6 @@ import Imports import SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML import qualified Servant -import Spar.App (liftSem) import qualified Spar.App as Spar import Spar.Orphans () import qualified Spar.Sem.SAMLUserStore as SAMLUserStore @@ -181,5 +180,5 @@ requestAccessVerdict idp isGranted mkAuthnReq = do $ outcome qry :: [(SBS, SBS)] qry = queryPairs $ uriQuery loc - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + muid <- runSpar $ SAMLUserStore.get uref pure (muid, outcome, loc, qry) diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index a294653fe3c..2c66752773d 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -72,7 +72,7 @@ spec = do (_, _, (^. SAML.idpId) -> idpid) <- registerTestIdP (_, req) <- call $ callAuthnReq (env ^. teSpar) idpid let probe :: (MonadIO m, MonadReader TestEnv m) => m Bool - probe = runSpar $ liftSem $ AReqIDStore.isAlive (req ^. SAML.rqID) + probe = runSpar $ AReqIDStore.isAlive (req ^. SAML.rqID) maxttl :: Int -- musec maxttl = (fromIntegral . fromTTL $ env ^. teOpts . to maxttlAuthreq) * 1000 * 1000 liftIO $ maxttl `shouldSatisfy` (< 60 * 1000 * 1000) -- otherwise the test will be really slow. @@ -93,8 +93,8 @@ spec = do context "insert and get are \"inverses\"" $ do let check vf = it (show vf) $ do vid <- nextSAMLID - () <- runSpar $ liftSem $ AReqIDStore.storeVerdictFormat 1 vid vf - mvf <- runSpar $ liftSem $ AReqIDStore.getVerdictFormat vid + () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid vf + mvf <- runSpar $ AReqIDStore.getVerdictFormat vid liftIO $ mvf `shouldBe` Just vf check `mapM_` [ VerdictFormatWeb, @@ -103,47 +103,47 @@ spec = do context "has timed out" $ do it "AReqIDStore.getVerdictFormat returns Nothing" $ do vid <- nextSAMLID - () <- runSpar $ liftSem $ AReqIDStore.storeVerdictFormat 1 vid VerdictFormatWeb + () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid VerdictFormatWeb liftIO $ threadDelay 2000000 - mvf <- runSpar $ liftSem $ AReqIDStore.getVerdictFormat vid + mvf <- runSpar $ AReqIDStore.getVerdictFormat vid liftIO $ mvf `shouldBe` Nothing context "does not exist" $ do it "AReqIDStore.getVerdictFormat returns Nothing" $ do vid <- nextSAMLID - mvf <- runSpar $ liftSem $ AReqIDStore.getVerdictFormat vid + mvf <- runSpar $ AReqIDStore.getVerdictFormat vid liftIO $ mvf `shouldBe` Nothing describe "User" $ do context "user is new" $ do it "getUser returns Nothing" $ do uref <- nextUserRef - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Nothing it "inserts new user and responds with 201 / returns new user" $ do uref <- nextUserRef uid <- nextWireId - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + () <- runSpar $ SAMLUserStore.insert uref uid + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Just uid context "user already exists (idempotency)" $ do it "inserts new user and responds with 201 / returns new user" $ do uref <- nextUserRef uid <- nextWireId uid' <- nextWireId - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid' - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + () <- runSpar $ SAMLUserStore.insert uref uid + () <- runSpar $ SAMLUserStore.insert uref uid' + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Just uid' describe "DELETE" $ do it "works" $ do uref <- nextUserRef uid <- nextWireId do - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid - muid <- runSpar $ liftSem (SAMLUserStore.get uref) + () <- runSpar $ SAMLUserStore.insert uref uid + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Just uid do - () <- runSpar $ liftSem $ SAMLUserStore.delete uid uref - muid <- runSpar (liftSem $ SAMLUserStore.get uref) `aFewTimes` isNothing + () <- runSpar $ SAMLUserStore.delete uid uref + muid <- runSpar (SAMLUserStore.get uref) `aFewTimes` isNothing liftIO $ muid `shouldBe` Nothing describe "BindCookie" $ do let mkcky :: TestSpar SetBindCookie @@ -151,58 +151,58 @@ spec = do it "insert and get are \"inverses\"" $ do uid <- nextWireId cky <- mkcky - () <- runSpar $ liftSem $ BindCookieStore.insert cky uid 1 - muid <- runSpar $ liftSem $ BindCookieStore.lookup (setBindCookieValue cky) + () <- runSpar $ BindCookieStore.insert cky uid 1 + muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) liftIO $ muid `shouldBe` Just uid context "has timed out" $ do it "BindCookieStore.lookup returns Nothing" $ do uid <- nextWireId cky <- mkcky - () <- runSpar $ liftSem $ BindCookieStore.insert cky uid 1 + () <- runSpar $ BindCookieStore.insert cky uid 1 liftIO $ threadDelay 2000000 - muid <- runSpar $ liftSem $ BindCookieStore.lookup (setBindCookieValue cky) + muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) liftIO $ muid `shouldBe` Nothing context "does not exist" $ do it "BindCookieStore.lookup returns Nothing" $ do cky <- mkcky - muid <- runSpar $ liftSem $ BindCookieStore.lookup (setBindCookieValue cky) + muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) liftIO $ muid `shouldBe` Nothing describe "Team" $ do testDeleteTeam describe "IdPConfig" $ do it "storeIdPConfig, getIdPConfig are \"inverses\"" $ do idp <- makeTestIdP - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp - midp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. idpId) + () <- runSpar $ IdPEffect.storeConfig idp + midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Just idp it "getIdPConfigByIssuer works" $ do idp <- makeTestIdP - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp + () <- runSpar $ IdPEffect.storeConfig idp midp <- runSpar $ App.getIdPConfigByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) liftIO $ midp `shouldBe` GetIdPFound idp it "getIdPIdByIssuer works" $ do idp <- makeTestIdP - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp + () <- runSpar $ IdPEffect.storeConfig idp midp <- runSpar $ App.getIdPIdByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) liftIO $ midp `shouldBe` GetIdPFound (idp ^. idpId) it "getIdPConfigsByTeam works" $ do skipIdPAPIVersions [WireIdPAPIV1] teamid <- nextWireId idp <- makeTestIdP <&> idpExtraInfo .~ (WireIdP teamid Nothing [] Nothing) - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp - idps <- runSpar $ liftSem $ IdPEffect.getConfigsByTeam teamid + () <- runSpar $ IdPEffect.storeConfig idp + idps <- runSpar $ IdPEffect.getConfigsByTeam teamid liftIO $ idps `shouldBe` [idp] it "deleteIdPConfig works" $ do teamid <- nextWireId idpApiVersion <- asks (^. teWireIdPAPIVersion) idp <- makeTestIdP <&> idpExtraInfo .~ (WireIdP teamid (Just idpApiVersion) [] Nothing) - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp + () <- runSpar $ IdPEffect.storeConfig idp do - midp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. idpId) + midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Just idp - () <- runSpar $ liftSem $ IdPEffect.deleteConfig (idp ^. idpId) (idp ^. idpMetadata . edIssuer) teamid + () <- runSpar $ IdPEffect.deleteConfig (idp ^. idpId) (idp ^. idpMetadata . edIssuer) teamid do - midp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. idpId) + midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Nothing do midp <- runSpar $ App.getIdPConfigByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) @@ -211,18 +211,18 @@ spec = do midp <- runSpar $ App.getIdPIdByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) liftIO $ midp `shouldBe` GetIdPNotFound do - idps <- runSpar $ liftSem $ IdPEffect.getConfigsByTeam teamid + idps <- runSpar $ IdPEffect.getConfigsByTeam teamid liftIO $ idps `shouldBe` [] describe "{set,clear}ReplacedBy" $ do it "handle non-existent idps gradefully" $ do pendingWith "this requires a cql{,-io} upgrade. https://gitlab.com/twittner/cql-io/-/issues/7" idp1 <- makeTestIdP idp2 <- makeTestIdP - runSpar $ liftSem $ IdPEffect.setReplacedBy (Data.Replaced (idp1 ^. idpId)) (Data.Replacing (idp2 ^. idpId)) - idp1' <- runSpar $ liftSem (IdPEffect.getConfig (idp1 ^. idpId)) + runSpar $ IdPEffect.setReplacedBy (Data.Replaced (idp1 ^. idpId)) (Data.Replacing (idp2 ^. idpId)) + idp1' <- runSpar $ IdPEffect.getConfig (idp1 ^. idpId) liftIO $ idp1' `shouldBe` Nothing - runSpar $ liftSem $ IdPEffect.clearReplacedBy (Data.Replaced (idp1 ^. idpId)) - idp2' <- runSpar $ liftSem (IdPEffect.getConfig (idp1 ^. idpId)) + runSpar $ IdPEffect.clearReplacedBy (Data.Replaced (idp1 ^. idpId)) + idp2' <- runSpar $ IdPEffect.getConfig (idp1 ^. idpId) liftIO $ idp2' `shouldBe` Nothing -- TODO(sandy): This function should be more polymorphic over it's polysemy @@ -240,24 +240,24 @@ testSPStoreID store unstore isalive = do it "isAliveID is True" $ do xid :: SAML.ID a <- nextSAMLID eol :: Time <- addTime 5 <$> runSimpleSP getNow - () <- runSpar $ liftSem $ store xid eol - isit <- runSpar $ liftSem $ isalive xid + () <- runSpar $ store xid eol + isit <- runSpar $ isalive xid liftIO $ isit `shouldBe` True context "after TTL" $ do it "isAliveID returns False" $ do xid :: SAML.ID a <- nextSAMLID eol :: Time <- addTime 2 <$> runSimpleSP getNow - () <- runSpar $ liftSem $ store xid eol + () <- runSpar $ store xid eol liftIO $ threadDelay 3000000 - isit <- runSpar $ liftSem $ isalive xid + isit <- runSpar $ isalive xid liftIO $ isit `shouldBe` False context "after call to unstore" $ do it "isAliveID returns False" $ do xid :: SAML.ID a <- nextSAMLID eol :: Time <- addTime 5 <$> runSimpleSP getNow - () <- runSpar $ liftSem $ store xid eol - () <- runSpar $ liftSem $ unstore xid - isit <- runSpar $ liftSem $ isalive xid + () <- runSpar $ store xid eol + () <- runSpar $ unstore xid + isit <- runSpar $ isalive xid liftIO $ isit `shouldBe` False -- | Test that when a team is deleted, all relevant data is pruned from the @@ -280,38 +280,36 @@ testDeleteTeam = it "cleans up all the right tables after deletion" $ do -- -- The token from 'team_provisioning_by_token': do - tokenInfo <- runSpar $ liftSem $ ScimTokenStore.lookup tok + tokenInfo <- runSpar $ ScimTokenStore.lookup tok liftIO $ tokenInfo `shouldBe` Nothing -- The team from 'team_provisioning_by_team': do - tokens <- runSpar $ liftSem $ ScimTokenStore.getByTeam tid + tokens <- runSpar $ ScimTokenStore.getByTeam tid liftIO $ tokens `shouldBe` [] -- The users from 'user': do mbUser1 <- case veidFromUserSSOId ssoid1 of Right veid -> runSpar $ - liftSem $ - runValidExternalId - SAMLUserStore.get - undefined -- could be @Data.lookupScimExternalId@, but we don't hit that path. - veid + runValidExternalId + SAMLUserStore.get + undefined -- could be @Data.lookupScimExternalId@, but we don't hit that path. + veid Left _email -> undefined -- runSparCass . Data.lookupScimExternalId . fromEmail $ _email liftIO $ mbUser1 `shouldBe` Nothing do mbUser2 <- case veidFromUserSSOId ssoid2 of Right veid -> runSpar $ - liftSem $ - runValidExternalId - SAMLUserStore.get - undefined - veid + runValidExternalId + SAMLUserStore.get + undefined + veid Left _email -> undefined liftIO $ mbUser2 `shouldBe` Nothing -- The config from 'idp': do - mbIdp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. SAML.idpId) + mbIdp <- runSpar $ IdPEffect.getConfig (idp ^. SAML.idpId) liftIO $ mbIdp `shouldBe` Nothing -- The config from 'issuer_idp': do @@ -320,5 +318,5 @@ testDeleteTeam = it "cleans up all the right tables after deletion" $ do liftIO $ mbIdp `shouldBe` GetIdPNotFound -- The config from 'team_idp': do - idps <- runSpar $ liftSem $ IdPEffect.getConfigsByTeam tid + idps <- runSpar $ IdPEffect.getConfigsByTeam tid liftIO $ idps `shouldBe` [] diff --git a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs index 84114d80278..e2e3ef3ce11 100644 --- a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs @@ -25,7 +25,6 @@ import Control.Lens ((^.)) import Data.Id (Id (Id)) import qualified Data.UUID as UUID import Imports hiding (head) -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import Util import qualified Web.Scim.Schema.User as Scim.User @@ -40,7 +39,7 @@ spec = do describe "getBrigUser" $ do it "return Nothing if n/a" $ do - musr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") + musr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") liftIO $ musr `shouldSatisfy` isNothing it "return Just if /a" $ do @@ -53,5 +52,5 @@ spec = do scimUserId <$> createUser tok scimUser uid <- setup - musr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid + musr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid liftIO $ musr `shouldSatisfy` isJust diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 831c2951b48..24a339cc802 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -59,7 +59,6 @@ import Imports import qualified Network.Wai.Utilities.Error as Wai import qualified SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import Spar.Scim import Spar.Scim.Types (normalizeLikeStored) @@ -118,9 +117,9 @@ specSuspend = do -- NOTE: once SCIM is enabled, SSO Auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) handle'@(Handle handle) <- nextHandle - runSpar $ liftSem $ BrigAccess.setHandle member handle' + runSpar $ BrigAccess.setHandle member handle' unless isActive $ do - runSpar $ liftSem $ BrigAccess.setStatus member Suspended + runSpar $ BrigAccess.setStatus member Suspended [user] <- listUsers tok (Just (filterBy "userName" handle)) lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ user) `shouldBe` Just isActive it "pre-existing suspended users are inactive" $ do @@ -139,19 +138,19 @@ specSuspend = do -- Once we get rid of the `scim` table and make scim serve brig records directly, this is -- not an issue anymore. lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUserBlah) `shouldBe` Just True - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user False lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just False - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Suspended) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) it "PUT will change state from active to inactive and back" $ do void . activeInactiveAndBack $ \tok uid user active -> @@ -190,10 +189,10 @@ specSuspend = do (tok, _) <- registerIdPAndScimToken scimStoredUserBlah <- createUser tok user let uid = Scim.id . Scim.thing $ scimStoredUserBlah - runSpar $ liftSem $ BrigAccess.setStatus uid Suspended - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Suspended) + runSpar $ BrigAccess.setStatus uid Suspended + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) void $ patchUser tok uid $ PatchOp.PatchOp [deleteAttrib "active"] - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) ---------------------------------------------------------------------------- -- User creation @@ -304,10 +303,10 @@ testCreateUserNoIdP = do -- get account from brig, status should be PendingInvitation do - aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (pure ()) (error "pending user in brig is visible, even though it should not be") brigUserAccount <- - aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure let brigUser = accountUser brigUserAccount brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser @@ -347,7 +346,7 @@ testCreateUserNoIdP = do -- user should now be active do brigUser <- - aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure liftIO $ accountStatus brigUser `shouldBe` Active liftIO $ userManagedBy (accountUser brigUser) `shouldBe` ManagedByScim @@ -431,7 +430,7 @@ testCreateUserWithSamlIdP = do . expect2xx ) brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser - accStatus <- aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus (userId brigUser)) (== Active) + accStatus <- aFewTimes (runSpar $ BrigAccess.getStatus (userId brigUser)) (== Active) liftIO $ accStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -823,9 +822,9 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do -- auto-provision user via saml memberWithSSO <- do uid <- loginSsoUserFirstTime idp privCreds - Just usr <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid + Just usr <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid handle <- nextHandle - runSpar $ liftSem $ BrigAccess.setHandle uid handle + runSpar $ BrigAccess.setHandle uid handle pure usr let memberIdWithSSO = userId memberWithSSO externalId = either error id $ veidToText =<< Intra.veidFromBrigUser memberWithSSO Nothing @@ -836,7 +835,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do liftIO $ userManagedBy memberWithSSO `shouldBe` ManagedByWire users <- listUsers tok (Just (filterBy "externalId" externalId)) liftIO $ (scimUserId <$> users) `shouldContain` [memberIdWithSSO] - Just brigUser' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO + Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim where veidToText :: MonadError String m => ValidExternalId -> m Text @@ -857,7 +856,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO = do users' <- listUsers tok (Just (filterBy "externalId" emailInvited)) liftIO $ (scimUserId <$> users') `shouldContain` [memberIdInvited] - Just brigUserInvited' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId :: TestSpar () @@ -869,7 +868,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId = do let memberIdInvited = userId memberInvited _ <- getUser tok memberIdInvited - Just brigUserInvited' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations (memberIdInvited) + Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations (memberIdInvited) liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindProvisionedUserNoIdP :: TestSpar () @@ -888,8 +887,8 @@ testFindNonProvisionedUserNoIdP findBy = do uid <- userId <$> call (inviteAndRegisterUser (env ^. teBrig) owner teamid) handle <- nextHandle - runSpar $ liftSem $ BrigAccess.setHandle uid handle - Just brigUser <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid + runSpar $ BrigAccess.setHandle uid handle + Just brigUser <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid let Just email = userEmail brigUser do @@ -904,7 +903,7 @@ testFindNonProvisionedUserNoIdP findBy = do do liftIO $ users `shouldBe` [uid] - Just brigUser' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid + Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim liftIO $ brigUser' `shouldBe` brigUser {userManagedBy = ManagedByScim} @@ -989,7 +988,7 @@ testGetUser = do shouldBeManagedBy :: HasCallStack => UserId -> ManagedBy -> TestSpar () shouldBeManagedBy uid flag = do - managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) + managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid) liftIO $ managedBy `shouldBe` flag -- | This is (roughly) the behavior on develop as well as on the branch where this test was @@ -1042,12 +1041,12 @@ testGetUserWithNoHandle = do uid <- loginSsoUserFirstTime idp privcreds tok <- registerScimToken tid (Just (idp ^. SAML.idpId)) - mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) + mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid) liftIO $ mhandle `shouldSatisfy` isNothing storedUser <- getUser tok uid liftIO $ (Scim.User.displayName . Scim.value . Scim.thing) storedUser `shouldSatisfy` isJust - mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid)) isJust + mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid)) isJust liftIO $ mhandle' `shouldSatisfy` isJust liftIO $ (fromHandle <$> mhandle') `shouldBe` (Just . Scim.User.userName . Scim.value . Scim.thing $ storedUser) @@ -1321,7 +1320,7 @@ testUpdateExternalId withidp = do lookupByValidExternalId :: ValidExternalId -> TestSpar (Maybe UserId) lookupByValidExternalId = runValidExternalId - (runSpar . liftSem . SAMLUserStore.get) + (runSpar . SAMLUserStore.get) ( \email -> do let action = SU.scimFindUserByEmail midp tid $ fromEmail email result <- runSpar . runExceptT . runMaybeT $ action @@ -1345,7 +1344,7 @@ testBrigSideIsUpdated = do validScimUser <- either (error . show) pure $ validateScimUser' (Just idp) 999999 user' - brigUser <- maybe (error "no brig user") pure =<< runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations userid) + brigUser <- maybe (error "no brig user") pure =<< runSpar (Intra.getBrigUser Intra.WithPendingInvitations userid) brigUser `userShouldMatch` validScimUser ---------------------------------------------------------------------------- @@ -1527,7 +1526,7 @@ specDeleteUser = do storedUser <- createUser tok user let uid :: UserId = scimUserId storedUser uref :: SAML.UserRef <- do - usr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid + usr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid let err = error . ("brig user without UserRef: " <>) . show case (`Intra.veidFromBrigUser` Nothing) <$> usr of bad@(Just (Right veid)) -> runValidExternalId pure (const $ err bad) veid @@ -1536,11 +1535,11 @@ specDeleteUser = do deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode brigUser :: Maybe User <- - aFewTimes (runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) isNothing + aFewTimes (runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid) isNothing samlUser :: Maybe UserId <- aFewTimes (getUserIdViaRef' uref) isNothing scimUser <- - aFewTimes (runSpar $ liftSem $ ScimUserTimesStore.read uid) isNothing + aFewTimes (runSpar $ ScimUserTimesStore.read uid) isNothing liftIO $ (brigUser, samlUser, scimUser) `shouldBe` (Nothing, Nothing, Nothing) @@ -1744,7 +1743,7 @@ testDeletedUsersFreeExternalIdNoIdp = do void $ aFewTimes - (runSpar $ liftSem $ ScimExternalIdStore.lookup tid email) + (runSpar $ ScimExternalIdStore.lookup tid email) (== Nothing) specSCIMManaged :: SpecWith TestEnv diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index c66bbdd5bef..bc20e478566 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -168,12 +168,12 @@ import Network.HTTP.Client.MultipartFormData import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp.Internal as Warp import qualified Options.Applicative as OPA +import Polysemy (Sem) import SAML2.WebSSO as SAML import qualified SAML2.WebSSO.API.Example as SAML import SAML2.WebSSO.Test.Lenses (userRefL) import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util (SampleIdP (..), makeSampleIdPMetadata) -import Spar.App (liftSem) import qualified Spar.App as Spar import Spar.CanonicalInterpreter import qualified Spar.Intra.BrigApp as Intra @@ -1207,8 +1207,8 @@ ssoToUidSpar tid ssoid = do veid <- either (error . ("could not parse brig sso_id: " <>)) pure $ Intra.veidFromUserSSOId ssoid runSpar $ runValidExternalId - (liftSem . SAMLUserStore.get) - (liftSem . ScimExternalIdStore.lookup tid) + (SAMLUserStore.get) + (ScimExternalIdStore.lookup tid) veid runSimpleSP :: (MonadReader TestEnv m, MonadIO m) => SAML.SimpleSP a -> m a @@ -1221,7 +1221,7 @@ runSimpleSP action = do runSpar :: (MonadReader TestEnv m, MonadIO m) => - Spar.Spar CanonicalEffs a -> + Sem CanonicalEffs a -> m a runSpar action = do ctx <- (^. teSparEnv) <$> ask @@ -1234,7 +1234,7 @@ getSsoidViaSelf uid = maybe (error "not found") pure =<< getSsoidViaSelf' uid getSsoidViaSelf' :: HasCallStack => UserId -> TestSpar (Maybe UserSSOId) getSsoidViaSelf' uid = do - musr <- aFewTimes (runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust + musr <- aFewTimes (runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust pure $ case userIdentity =<< musr of Just (SSOIdentity ssoid _ _) -> Just ssoid Just (FullIdentity _ _) -> Nothing @@ -1247,7 +1247,7 @@ getUserIdViaRef uref = maybe (error "not found") pure =<< getUserIdViaRef' uref getUserIdViaRef' :: HasCallStack => UserRef -> TestSpar (Maybe UserId) getUserIdViaRef' uref = do - aFewTimes (runSpar $ liftSem $ SAMLUserStore.get uref) isJust + aFewTimes (runSpar $ SAMLUserStore.get uref) isJust checkErr :: HasCallStack => Int -> Maybe TestErrorLabel -> Assertions () checkErr status mlabel = do diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 854ba7dd4fa..71a698d0e1b 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -34,7 +34,6 @@ import Data.UUID.V4 as UUID import Imports import qualified SAML2.WebSSO as SAML import SAML2.WebSSO.Types (IdPId, idpId) -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import Spar.Scim.User (synthesizeScimUser, validateScimUser') import qualified Spar.Sem.ScimTokenStore as ScimTokenStore @@ -82,16 +81,15 @@ registerScimToken teamid midpid = do scimTokenId <- randomId now <- liftIO getCurrentTime runSpar $ - liftSem $ - ScimTokenStore.insert - tok - ScimTokenInfo - { stiTeam = teamid, - stiId = scimTokenId, - stiCreatedAt = now, - stiIdP = midpid, - stiDescr = "test token" - } + ScimTokenStore.insert + tok + ScimTokenInfo + { stiTeam = teamid, + stiId = scimTokenId, + stiCreatedAt = now, + stiIdP = midpid, + stiDescr = "test token" + } pure tok -- | Generate a SCIM user with a random name and handle. At the very least, everything considered From 4d2ac4f11efbfb1b269164ccc4eebb1cc0a5c2fb Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 6 Oct 2021 08:08:22 +0200 Subject: [PATCH 05/88] Use hs-certificate master (#1822) * Use master branch of hs-certificate The error handling fix https://github.com/vincenthz/hs-certificate/pull/125 has been merged, so we can just use the upstream master now, and later switch to the hackage package once it is released. --- changelog.d/5-internal/hs-certificate-master | 1 + stack.yaml | 4 ++-- stack.yaml.lock | 10 +++++----- 3 files changed, 8 insertions(+), 7 deletions(-) create mode 100644 changelog.d/5-internal/hs-certificate-master diff --git a/changelog.d/5-internal/hs-certificate-master b/changelog.d/5-internal/hs-certificate-master new file mode 100644 index 00000000000..c9c67da740f --- /dev/null +++ b/changelog.d/5-internal/hs-certificate-master @@ -0,0 +1 @@ +Depend on hs-certificate master instead of our fork diff --git a/stack.yaml b/stack.yaml index 191946cb296..b816f92c3c4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -250,8 +250,8 @@ extra-deps: commit: b0e5c08af48911caecffa4fa6a3e74872018b258 # master (Sep 03, 2021) # Error handling fix: https://github.com/vincenthz/hs-certificate/pull/125 -- git: https://github.com/wireapp/hs-certificate - commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 # master (Aug 31, 2021) +- git: https://github.com/vincenthz/hs-certificate + commit: a899bda3d7666d25143be7be8f3105fc076703d9 # master (Sep 29, 2021) subdirs: - x509-store diff --git a/stack.yaml.lock b/stack.yaml.lock index 439ca987af9..a8910cfe1db 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -811,15 +811,15 @@ packages: subdir: x509-store name: x509-store version: 1.6.7 - git: https://github.com/wireapp/hs-certificate + git: https://github.com/vincenthz/hs-certificate pantry-tree: size: 398 - sha256: 96deca9a5358118057cd145f198b5be06d88019eae46b263bee86c76b2fc574d - commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 + sha256: bf71c28417dcf76a8aef361fbc74abe78962c80e7e996a2515996fd44b2f6ba6 + commit: a899bda3d7666d25143be7be8f3105fc076703d9 original: subdir: x509-store - git: https://github.com/wireapp/hs-certificate - commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 + git: https://github.com/vincenthz/hs-certificate + commit: a899bda3d7666d25143be7be8f3105fc076703d9 - completed: hackage: ormolu-0.1.4.1@sha256:ed404eac6e4eb64da1ca5fb749e0f99907431a9633e6ba34e44d260e7d7728ba,6499 pantry-tree: From f1040077f8ff39b77f64d591d6a8a219d7b414df Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 6 Oct 2021 13:25:54 +0200 Subject: [PATCH 06/88] Servantify legacy addMember endpoint (#1838) --- changelog.d/5-internal/servantify-add-member | 1 + libs/wire-api/src/Wire/API/Conversation.hs | 28 +++++++++++-------- .../src/Wire/API/Routes/Public/Galley.hs | 18 +++++++++++- services/galley/src/Galley/API/Public.hs | 26 ++--------------- services/galley/src/Galley/API/Update.hs | 15 +++++----- 5 files changed, 43 insertions(+), 45 deletions(-) create mode 100644 changelog.d/5-internal/servantify-add-member diff --git a/changelog.d/5-internal/servantify-add-member b/changelog.d/5-internal/servantify-add-member new file mode 100644 index 00000000000..234c506a47d --- /dev/null +++ b/changelog.d/5-internal/servantify-add-member @@ -0,0 +1 @@ +Convert legacy POST conversations/:cnv/members endpoint to Servant diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 17d2fb21a39..ad7bdd5311e 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -726,6 +726,18 @@ data Invite = Invite -- Deprecated, use InviteQualified (and maybe rename?) } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Invite) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema Invite) + +instance ToSchema Invite where + schema = + object "Invite" $ + Invite + <$> (toNonEmpty . invUsers) + .= fmap List1 (field "users" (nonEmptyArray schema)) + <*> (Just . invRoleName) + .= fmap + (fromMaybe roleNameWireAdmin) + (optField "conversation_role" Nothing schema) data InviteQualified = InviteQualified { invQUsers :: NonEmpty (Qualified UserId), @@ -741,7 +753,10 @@ instance ToSchema InviteQualified where object "InviteQualified" $ InviteQualified <$> invQUsers .= field "qualified_users" (nonEmptyArray schema) - <*> invQRoleName .= (field "conversation_role" schema <|> pure roleNameWireAdmin) + <*> (Just . invQRoleName) + .= fmap + (fromMaybe roleNameWireAdmin) + (optField "conversation_role" Nothing schema) newInvite :: List1 UserId -> Invite newInvite us = Invite us roleNameWireAdmin @@ -752,17 +767,6 @@ modelInvite = Doc.defineModel "Invite" $ do Doc.property "users" (Doc.unique $ Doc.array Doc.bytes') $ Doc.description "List of user IDs to add to a conversation" -instance ToJSON Invite where - toJSON i = - A.object - [ "users" A..= invUsers i, - "conversation_role" A..= invRoleName i - ] - -instance FromJSON Invite where - parseJSON = A.withObject "invite object" $ \o -> - Invite <$> o A..: "users" <*> o A..:? "conversation_role" A..!= roleNameWireAdmin - -------------------------------------------------------------------------------- -- update diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 7fd3202e1d3..7ba622cd808 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -233,7 +233,23 @@ data Api routes = Api :> "one2one" :> ReqBody '[Servant.JSON] NewConvUnmanaged :> ConversationVerb, - addMembersToConversationV2 :: + -- This endpoint can lead to the following events being sent: + -- - MemberJoin event to members + addMembersToConversationUnqualified :: + routes + :- Summary "Add members to an existing conversation (deprecated)" + :> CanThrow ConvNotFound + :> CanThrow NotConnected + :> CanThrow ConvAccessDenied + :> CanThrow (InvalidOp "Invalid operation") + :> ZUser + :> ZConn + :> "conversations" + :> Capture "cnv" ConvId + :> "members" + :> ReqBody '[JSON] Invite + :> MultiVerb 'POST '[JSON] ConvUpdateResponses (UpdateResult Event), + addMembersToConversation :: routes :- Summary "Add qualified members to an existing conversation." :> ZUser diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 9b863fb3673..1c7f9eb1963 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -54,7 +54,6 @@ import Network.Wai.Utilities.ZAuth hiding (ZAuthUser) import Servant hiding (Handler, JSON, addHeader, contentType, respond) import Servant.Server.Generic (genericServerT) import Servant.Swagger.Internal.Orphans () -import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public import qualified Wire.API.Conversation.Typing as Public import qualified Wire.API.CustomBackend as Public @@ -89,7 +88,8 @@ servantSitemap = GalleyAPI.createGroupConversation = Create.createGroupConversation, GalleyAPI.createSelfConversation = Create.createSelfConversation, GalleyAPI.createOne2OneConversation = Create.createOne2OneConversation, - GalleyAPI.addMembersToConversationV2 = Update.addMembers, + GalleyAPI.addMembersToConversationUnqualified = Update.addMembersUnqualified, + GalleyAPI.addMembersToConversation = Update.addMembers, GalleyAPI.removeMemberUnqualified = Update.removeMemberUnqualified, GalleyAPI.removeMember = Update.removeMemberQualified, GalleyAPI.updateOtherMemberUnqualified = Update.updateOtherMemberUnqualified, @@ -644,28 +644,6 @@ sitemap = do errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) errorResponse Error.invalidAccessOp - -- This endpoint can lead to the following events being sent: - -- - MemberJoin event to members - post "/conversations/:cnv/members" (continue Update.addMembersH) $ - zauthUserId - .&. zauthConnId - .&. capture "cnv" - .&. jsonRequest @Public.Invite - document "POST" "addMembers" $ do - summary "Add users to an existing conversation" - parameter Path "cnv" bytes' $ - description "Conversation ID" - body (ref Public.modelInvite) $ - description "JSON body" - returns (ref Public.modelEvent) - response 200 "Members added" end - response 204 "No change" end - response 412 "The user(s) cannot be added to the conversation (eg., due to legalhold policy conflict)." end - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - errorResponse (Error.invalidOp "Conversation type does not allow adding members") - errorResponse (Error.errorDescriptionTypeToWai @Error.NotConnected) - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvAccessDenied) - -- This endpoint can lead to the following events being sent: -- - Typing event to members post "/conversations/:cnv/typing" (continue Update.isTypingH) $ diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 152d0735af5..59bf3e4f293 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -38,7 +38,7 @@ module Galley.API.Update updateConversationAccess, -- * Managing Members - addMembersH, + addMembersUnqualified, addMembers, updateUnqualifiedSelfMember, updateSelfMember, @@ -567,13 +567,6 @@ joinConversation zusr zcon cnv access = do (convTargets conv <> extraTargets) action -addMembersH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.Invite -> Galley Response -addMembersH (zusr ::: zcon ::: cid ::: req) = do - (Invite u r) <- fromJsonBody req - domain <- viewFederationDomain - let qInvite = Public.InviteQualified (flip Qualified domain <$> toNonEmpty u) r - handleUpdateResult <$> addMembers zusr zcon cid qInvite - -- | Add users to a conversation without performing any checks. Return extra -- notification targets and the action performed. addMembersToLocalConversation :: @@ -656,6 +649,12 @@ performAddMemberAction qusr conv invited role = do checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () checkLHPolicyConflictsRemote _remotes = pure () +addMembersUnqualified :: + UserId -> ConnId -> ConvId -> Public.Invite -> Galley (UpdateResult Event) +addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do + qusers <- traverse (fmap unTagged . qualifyLocal) (toNonEmpty users) + addMembers zusr zcon cnv (Public.InviteQualified qusers role) + addMembers :: UserId -> ConnId -> ConvId -> Public.InviteQualified -> Galley (UpdateResult Event) addMembers zusr zcon cnv (Public.InviteQualified users role) = do lusr <- qualifyLocal zusr From 0ba6b8fa86b59d39c98eb2bb0e5e8e50832c6f28 Mon Sep 17 00:00:00 2001 From: jschaul Date: Wed, 6 Oct 2021 14:26:14 +0200 Subject: [PATCH 07/88] Use helmfile's parallelism to speed up integration test setup time (#1805) Motivation: decrease integration setup time, especially for the default two-backend setup. Make use of tooling used elsewhere, and use less of hacky bash scripts. See also https://wearezeta.atlassian.net/wiki/spaces/PS/pages/513573957/CI+runs+of+wire-server+state+and+possible+improvements for a discussion of other CI improvement opportunities. This should save off about ~5 minutes of setup time for each CI run simply because all helm charts for both backends are now installed in parallel, rather than sequentially. (that is, `make kube-integration-setup` now should be faster than before this PR) - Create a few FUTUREWORKS in Jira and link to them from the code comments - Create two helmfiles, one for federation, one for single-backend - Add helmfile to nix-shell tooling (Helmfile itself comes with a different version of helm; but since so far things inside nix-shell are only in use for local development, this should not matter too much. In the future this can be streamlined with wire-server-deploy to use the same versions everywhere) --- Makefile | 2 +- changelog.d/5-internal/helmfile | 1 + charts/fake-aws-s3/values.yaml | 2 + docs/developer/dependencies.md | 2 +- hack/bin/helm_overrides.sh | 15 +++ hack/bin/integration-setup-federation.sh | 59 ++++++++-- hack/bin/integration-setup.sh | 76 ++----------- hack/bin/integration-teardown-federation.sh | 22 ++-- hack/bin/integration-teardown.sh | 14 ++- hack/bin/selfsigned-kubernetes.sh | 11 +- hack/helm_vars/.gitignore | 2 + hack/helmfile-single.yaml | 65 +++++++++++ hack/helmfile.yaml | 113 ++++++++++++++++++++ shell.nix | 36 +++++++ 14 files changed, 318 insertions(+), 102 deletions(-) create mode 100644 changelog.d/5-internal/helmfile create mode 100644 hack/bin/helm_overrides.sh create mode 100644 hack/helmfile-single.yaml create mode 100644 hack/helmfile.yaml diff --git a/Makefile b/Makefile index 3dc11425689..96f406dc6c8 100644 --- a/Makefile +++ b/Makefile @@ -311,7 +311,7 @@ release-chart-%: .PHONY: guard-tag guard-tag: @if [ "${DOCKER_TAG}" = "${USER}" ]; then \ - echo "Environment variable DOCKER_TAG not set to non-default value. Re-run with DOCKER_TAG=. Try using 'make latest-brig-tag' for latest develop docker image tag";\ + echo "Environment variable DOCKER_TAG not set to non-default value. Re-run with DOCKER_TAG=. Try using 'make latest-tag' for latest develop docker image tag";\ exit 1; \ fi diff --git a/changelog.d/5-internal/helmfile b/changelog.d/5-internal/helmfile new file mode 100644 index 00000000000..c3689c20a19 --- /dev/null +++ b/changelog.d/5-internal/helmfile @@ -0,0 +1 @@ +Internal CI tooling improvement: decrease integration setup time by using helmfile. diff --git a/charts/fake-aws-s3/values.yaml b/charts/fake-aws-s3/values.yaml index 4f995011dda..2e0d4582351 100644 --- a/charts/fake-aws-s3/values.yaml +++ b/charts/fake-aws-s3/values.yaml @@ -7,6 +7,8 @@ minio: enabled: false environment: MINIO_BROWSER: "off" + defaultBucket: + name: dummy-bucket buckets: - name: dummy-bucket purge: true diff --git a/docs/developer/dependencies.md b/docs/developer/dependencies.md index be011c84dfb..25a15e42055 100644 --- a/docs/developer/dependencies.md +++ b/docs/developer/dependencies.md @@ -225,4 +225,4 @@ See `make buildah-docker` for an entry point here. ## Helm chart development, integration tests in kubernetes -You need `kubectl`, `helm`, and a valid kubernetes context. Refer to https://docs.wire.com for details. +You need `kubectl`, `helm`, `helmfile`, and a valid kubernetes context. Refer to https://docs.wire.com for details. diff --git a/hack/bin/helm_overrides.sh b/hack/bin/helm_overrides.sh new file mode 100644 index 00000000000..63498978315 --- /dev/null +++ b/hack/bin/helm_overrides.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +# Helm (v3) writes into XDG folders only these days. They don't honor HELM_ vars +# anymore. +# Derive a helm-specific folder inside the wire-server/.local to avoid polluting +# ~. + +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +TOP_LEVEL="$DIR/../.." +LOCAL_HELM_FOLDER="$TOP_LEVEL/.local/helm" + +[[ -e $LOCAL_HELM_FOLDER ]] || mkdir -p "$LOCAL_HELM_FOLDER" +export XDG_CACHE_HOME=${LOCAL_HELM_FOLDER}/cache +export XDG_CONFIG_HOME=${LOCAL_HELM_FOLDER}/config +export XDG_DATA_HOME=${LOCAL_HELM_FOLDER}/data diff --git a/hack/bin/integration-setup-federation.sh b/hack/bin/integration-setup-federation.sh index d7035867777..f78febbf5e0 100755 --- a/hack/bin/integration-setup-federation.sh +++ b/hack/bin/integration-setup-federation.sh @@ -1,19 +1,56 @@ #!/usr/bin/env bash -USAGE="Usage: $0" +set -euo pipefail -set -e - -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." - export NAMESPACE=${NAMESPACE:-test-integration} +CHARTS_DIR="${TOP_LEVEL}/.local/charts" + +. "$DIR/helm_overrides.sh" +${DIR}/integration-cleanup.sh + +# FUTUREWORK explore: have helmfile do the interpolation (and skip the "make charts" step) https://wearezeta.atlassian.net/browse/SQPIT-722 +# +# FUTUREWORK: get rid of wrapper charts, use helmfile for pinning. Then we may not need the recursive update hack anymore: https://wearezeta.atlassian.net/browse/SQPIT-721 +# +# Sadly, even with helmfile, we still need to use use this recursive update +# script beforehand on all relevant charts to download the nested dependencies +# (e.g. cassandra from underneath databases-ephemeral) +echo "updating recursive dependencies ..." +charts=(fake-aws databases-ephemeral wire-server nginx-ingress-controller nginx-ingress-services) +for chart in "${charts[@]}"; do + "$DIR/update.sh" "$CHARTS_DIR/$chart" +done + +# FUTUREWORK: use helm functions instead, see https://wearezeta.atlassian.net/browse/SQPIT-723 +echo "Generating self-signed certificates..." + +export NAMESPACE_1="$NAMESPACE" +export FEDERATION_DOMAIN_BASE="$NAMESPACE_1.svc.cluster.local" +export FEDERATION_DOMAIN_1="federation-test-helper.$FEDERATION_DOMAIN_BASE" +"$DIR/selfsigned-kubernetes.sh" namespace1 + +export NAMESPACE_2="$NAMESPACE-fed2" +export FEDERATION_DOMAIN_BASE="$NAMESPACE_2.svc.cluster.local" +export FEDERATION_DOMAIN_2="federation-test-helper.$FEDERATION_DOMAIN_BASE" +"$DIR/selfsigned-kubernetes.sh" namespace2 + +echo "Installing charts..." + +helmfile --file ${TOP_LEVEL}/hack/helmfile.yaml sync -$DIR/integration-setup.sh +# wait for fakeSNS to create resources. TODO, cleaner: make initiate-fake-aws-sns a post hook. See cassandra-migrations chart for an example. +resourcesReady() { + SNS_POD=$(kubectl -n "${NAMESPACE_1}" get pods | grep fake-aws-sns | grep Running | awk '{print $1}') + kubectl -n "${NAMESPACE_1}" logs "$SNS_POD" -c initiate-fake-aws-sns | grep created -# The suffix '-fed2' must be kept in sync with configuration inside -# charts/brig/templates/tests/configmap.yaml and -# hack/bin/integration-teardown-federation.sh -export NAMESPACE=${NAMESPACE}-fed2 + SNS_POD=$(kubectl -n "${NAMESPACE_2}" get pods | grep fake-aws-sns | grep Running | awk '{print $1}') + kubectl -n "${NAMESPACE_2}" logs "$SNS_POD" -c initiate-fake-aws-sns | grep created +} +until resourcesReady; do + echo 'waiting for SNS resources' + sleep 1 +done -$DIR/integration-setup.sh +echo "done" diff --git a/hack/bin/integration-setup.sh b/hack/bin/integration-setup.sh index 1f917dfc24f..267c712a99b 100755 --- a/hack/bin/integration-setup.sh +++ b/hack/bin/integration-setup.sh @@ -1,84 +1,30 @@ #!/usr/bin/env bash -USAGE="Usage: $0" - -set -e +set -euo pipefail DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." +export NAMESPACE=${NAMESPACE:-test-integration} CHARTS_DIR="${TOP_LEVEL}/.local/charts" -NAMESPACE=${NAMESPACE:-test-integration} -ENABLE_KIND_VALUES=${ENABLE_KIND_VALUES:-0} - -kubectl create namespace "${NAMESPACE}" >/dev/null 2>&1 || true +. "$DIR/helm_overrides.sh" -${DIR}/integration-cleanup.sh - -charts=(fake-aws databases-ephemeral wire-server nginx-ingress-controller nginx-ingress-services) +"${DIR}/integration-cleanup.sh" echo "updating recursive dependencies ..." +charts=(fake-aws databases-ephemeral wire-server nginx-ingress-controller nginx-ingress-services) for chart in "${charts[@]}"; do "$DIR/update.sh" "$CHARTS_DIR/$chart" done -echo "Installing charts..." - -function printLogs() { - echo "---- a command failed, attempting to print useful debug information..." - echo "-------------------------------" - echo "-------------------------------" - echo "-------------------------------" - echo "" - kubectl -n ${NAMESPACE} get pods - kubectl -n ${NAMESPACE} get pods | grep -v Running | grep -v Pending | grep -v Completed | grep -v STATUS | grep -v ContainerCreating | awk '{print $1}' | xargs -n 1 -I{} bash -c "printf '\n\n----LOGS FROM {}:\n'; kubectl -n ${NAMESPACE} logs --tail=30 {}" || true - kubectl -n ${NAMESPACE} get pods | grep Pending | awk '{print $1}' | xargs -n 1 -I{} bash -c "printf '\n\n----DESCRIBE 'pending' {}:\n'; kubectl -n ${NAMESPACE} describe pod {}" || true -} - -trap printLogs ERR - +echo "Generating self-signed certificates..." export FEDERATION_DOMAIN_BASE="$NAMESPACE.svc.cluster.local" -FEDERATION_DOMAIN="federation-test-helper.$FEDERATION_DOMAIN_BASE" -"$DIR/selfsigned-kubernetes.sh" - -for chart in "${charts[@]}"; do - kubectl -n ${NAMESPACE} get pods - valuesfile="${DIR}/../helm_vars/${chart}/values.yaml" - kindValuesfile="${DIR}/../helm_vars/${chart}/kind-values.yaml" - certificatesValuesfile="${DIR}/../helm_vars/${chart}/certificates.yaml" - - declare -a options=() - - if [ -f "$valuesfile" ]; then - options+=(-f "$valuesfile") - fi +export FEDERATION_DOMAIN="federation-test-helper.$FEDERATION_DOMAIN_BASE" +"$DIR/selfsigned-kubernetes.sh" namespace1 - if [ -f "$certificatesValuesfile" ]; then - options+=(-f "$certificatesValuesfile") - fi - - if [[ "$chart" == "nginx-ingress-services" ]]; then - # Federation domain is also the SRV record created by the - # federation-test-helper service. Maybe we can find a way to make these - # differ, so we don't make any silly assumptions in the code. - options+=("--set" "config.dns.federator=$FEDERATION_DOMAIN") - fi - - if [[ "$ENABLE_KIND_VALUES" == "1" ]] && [[ -f "$kindValuesfile" ]]; then - options+=(-f "$kindValuesfile") - fi +echo "Installing charts..." - # default is 5m but may not be enough on a fresh install including cassandra migrations - TIMEOUT=10m - set -x - helm upgrade --install --namespace "${NAMESPACE}" "${NAMESPACE}-${chart}" "${CHARTS_DIR}/${chart}" \ - ${options[*]} \ - --set brig.config.optSettings.setFederationDomain="$FEDERATION_DOMAIN" \ - --set galley.config.settings.federationDomain="$FEDERATION_DOMAIN" \ - --wait \ - --timeout "$TIMEOUT" - set +x -done +helmfile --file "${TOP_LEVEL}/hack/helmfile-single.yaml" sync # wait for fakeSNS to create resources. TODO, cleaner: make initiate-fake-aws-sns a post hook. See cassandra-migrations chart for an example. resourcesReady() { @@ -90,6 +36,6 @@ until resourcesReady; do sleep 1 done -kubectl -n ${NAMESPACE} get pods +kubectl -n "${NAMESPACE}" get pods echo "done" diff --git a/hack/bin/integration-teardown-federation.sh b/hack/bin/integration-teardown-federation.sh index 7c652171ef6..76633f3c6a6 100755 --- a/hack/bin/integration-teardown-federation.sh +++ b/hack/bin/integration-teardown-federation.sh @@ -1,16 +1,16 @@ #!/usr/bin/env bash -set -e +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +TOP_LEVEL="$DIR/../.." -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +set -ex -export NAMESPACE=${NAMESPACE:-test-integration} +NAMESPACE=${NAMESPACE:-test-integration} +export NAMESPACE_1="$NAMESPACE" +export NAMESPACE_2="$NAMESPACE-fed2" +# these don't matter for destruction but have to be set. +export FEDERATION_DOMAIN_1="." +export FEDERATION_DOMAIN_2="." -$DIR/integration-teardown.sh - -# The suffix '-fed2' must be kept in sync with configuration inside -# charts/brig/templates/tests/configmap.yaml and -# hack/bin/integration-setup-federation.sh -export NAMESPACE=${NAMESPACE}-fed2 - -$DIR/integration-teardown.sh +. "$DIR/helm_overrides.sh" +helmfile --file "${TOP_LEVEL}/hack/helmfile.yaml" destroy diff --git a/hack/bin/integration-teardown.sh b/hack/bin/integration-teardown.sh index f09dff597b7..cd82194c2b8 100755 --- a/hack/bin/integration-teardown.sh +++ b/hack/bin/integration-teardown.sh @@ -1,15 +1,13 @@ #!/usr/bin/env bash -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )/.." +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +TOP_LEVEL="$DIR/../.." NAMESPACE=${NAMESPACE:-test-integration} +# doesn't matter for destruction but needs to be set +export FEDERATION_DOMAIN="." set -ex -echo "NAMESPACE = $NAMESPACE" - -helm ls --all --namespace ${NAMESPACE} | grep -v NAME | awk '{print $1}' | xargs -n 1 helm -n "$NAMESPACE" delete - -sleep 10 - -kubectl delete namespace ${NAMESPACE} +. "$DIR/helm_overrides.sh" +helmfile --file "${TOP_LEVEL}/hack/helmfile-single.yaml" destroy diff --git a/hack/bin/selfsigned-kubernetes.sh b/hack/bin/selfsigned-kubernetes.sh index 73b97762312..d0023cce0f3 100755 --- a/hack/bin/selfsigned-kubernetes.sh +++ b/hack/bin/selfsigned-kubernetes.sh @@ -5,7 +5,8 @@ # These certificates are only meant for integration tests. # (The CA certificates are assumed to be re-used across the domains A and B for end2end integration tests.) -set -ex +set -e +SUFFIX=${1:?"need suffix argument"} TEMP=${TEMP:-/tmp} CSR="$TEMP/csr.json" OUTPUTNAME_CA="integration-ca" @@ -13,8 +14,8 @@ OUTPUTNAME_LEAF_CERT="integration-leaf" OUTPUTNAME_CLIENT_CERT="integration-client" DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." -OUTPUT_CONFIG_FEDERATOR="$TOP_LEVEL/hack/helm_vars/wire-server/certificates.yaml" -OUTPUT_CONFIG_INGRESS="$TOP_LEVEL/hack/helm_vars/nginx-ingress-services/certificates.yaml" +OUTPUT_CONFIG_FEDERATOR="$TOP_LEVEL/hack/helm_vars/wire-server/certificates-$SUFFIX.yaml" +OUTPUT_CONFIG_INGRESS="$TOP_LEVEL/hack/helm_vars/nginx-ingress-services/certificates-$SUFFIX.yaml" command -v cfssl >/dev/null 2>&1 || { echo >&2 "cfssl is not installed, aborting. See https://github.com/cloudflare/cfssl" @@ -70,7 +71,7 @@ cfssl gencert -ca "$OUTPUTNAME_CA.pem" -ca-key "$OUTPUTNAME_CA-key.pem" -hostnam sed -e 's/^/ /' $OUTPUTNAME_LEAF_CERT-key.pem echo " tlsClientCA: |" sed -e 's/^/ /' $OUTPUTNAME_CA.pem -} | tee "$OUTPUT_CONFIG_INGRESS" +} >"$OUTPUT_CONFIG_INGRESS" # the following yaml override file is needed as an override to # the wire-server (federator) helm chart @@ -85,7 +86,7 @@ cfssl gencert -ca "$OUTPUTNAME_CA.pem" -ca-key "$OUTPUTNAME_CA-key.pem" -hostnam sed -e 's/^/ /' $OUTPUTNAME_CLIENT_CERT.pem echo " clientPrivateKeyContents: |" sed -e 's/^/ /' $OUTPUTNAME_CLIENT_CERT-key.pem -} | tee "$OUTPUT_CONFIG_FEDERATOR" +} >"$OUTPUT_CONFIG_FEDERATOR" # cleanup unneeded files rm "$OUTPUTNAME_LEAF_CERT.csr" diff --git a/hack/helm_vars/.gitignore b/hack/helm_vars/.gitignore index 9849d951a02..38a7ff397ae 100644 --- a/hack/helm_vars/.gitignore +++ b/hack/helm_vars/.gitignore @@ -1 +1,3 @@ certificates.yaml +certificates-namespace1.yaml +certificates-namespace2.yaml diff --git a/hack/helmfile-single.yaml b/hack/helmfile-single.yaml new file mode 100644 index 00000000000..3adbdf425a1 --- /dev/null +++ b/hack/helmfile-single.yaml @@ -0,0 +1,65 @@ +# This helmfile is similar to the 'helmfile.yaml', but only spawns up components for a single backend. +# In some situations (when not testing anything federation specific), use of a single backend is sufficient. +# +# The 'make kube-integration-setup-sans-federation' target uses this helmfile. + +helmDefaults: + wait: true + timeout: 600 + devel: true + +environments: + default: + values: + - namespace: {{ requiredEnv "NAMESPACE" }} + - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN" }} + +repositories: + - name: stable + url: 'https://charts.helm.sh/stable' + +releases: + - name: '{{ .Values.namespace }}-fake-aws' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/fake-aws' + values: + - './helm_vars/fake-aws/values.yaml' + + - name: '{{ .Values.namespace }}-databases-ephemeral' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/databases-ephemeral' + + - name: '{{ .Values.namespace }}-nginx-ingress-controller' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-controller' + values: + - './helm_vars/nginx-ingress-controller/values.yaml' + + - name: '{{ .Values.namespace }}-nginx-ingress-services' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-services' + values: + - './helm_vars/nginx-ingress-services/values.yaml' + - './helm_vars/nginx-ingress-services/certificates-namespace1.yaml' + set: + # Federation domain is also the SRV record created by the + # federation-test-helper service. Maybe we can find a way to make these + # differ, so we don't make any silly assumptions in the code. + - name: config.dns.federator + value: {{ .Values.federationDomain }} + + # Note that wire-server depends on databases-ephemeral being up; and in some + # cases on nginx-ingress also being up. If installing helm charts in a + # parallel way, it's expected to see some wire-server pods (namely the + # cassandra-migration one) fail and get restarted a few times) + - name: '{{ .Values.namespace }}-wire-server' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/wire-server' + values: + - './helm_vars/wire-server/values.yaml' + - './helm_vars/wire-server/certificates-namespace1.yaml' + set: + - name: brig.config.optSettings.setFederationDomain + value: {{ .Values.federationDomain }} + - name: galley.config.settings.federationDomain + value: {{ .Values.federationDomain }} diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml new file mode 100644 index 00000000000..724a6161465 --- /dev/null +++ b/hack/helmfile.yaml @@ -0,0 +1,113 @@ +# This helfile is used for the setup of two ephemeral backends on kubernetes +# during integration testing (including federation integration tests spanning +# over 2 backends) +# This helmfile is used via the './hack/bin/integration-setup-federation.sh' via +# 'make kube-integration-setup', which set environment variables required here +# and generate some keys. + +helmDefaults: + wait: true + timeout: 600 + devel: true + +environments: + default: + values: + - namespace: {{ requiredEnv "NAMESPACE_1" }} + - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN_1" }} + - namespaceFed2: {{ requiredEnv "NAMESPACE_2" }} + - federationDomainFed2: {{ requiredEnv "FEDERATION_DOMAIN_2" }} + +repositories: + - name: stable + url: 'https://charts.helm.sh/stable' + +releases: + - name: '{{ .Values.namespace }}-fake-aws' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/fake-aws' + values: + - './helm_vars/fake-aws/values.yaml' + + - name: '{{ .Values.namespace }}-fake-aws-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/fake-aws' + values: + - './helm_vars/fake-aws/values.yaml' + + - name: '{{ .Values.namespace }}-databases-ephemeral' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/databases-ephemeral' + + - name: '{{ .Values.namespace }}-databases-ephemeral-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/databases-ephemeral' + + - name: '{{ .Values.namespace }}-nginx-ingress-controller' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-controller' + values: + - './helm_vars/nginx-ingress-controller/values.yaml' + + - name: '{{ .Values.namespace }}-nginx-ingress-controller-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/nginx-ingress-controller' + values: + - './helm_vars/nginx-ingress-controller/values.yaml' + + - name: '{{ .Values.namespace }}-nginx-ingress-services' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-services' + values: + - './helm_vars/nginx-ingress-services/values.yaml' + - './helm_vars/nginx-ingress-services/certificates-namespace1.yaml' + set: + # Federation domain is also the SRV record created by the + # federation-test-helper service. Maybe we can find a way to make these + # differ, so we don't make any silly assumptions in the code. + - name: config.dns.federator + value: {{ .Values.federationDomain }} + + - name: '{{ .Values.namespace }}-nginx-ingress-services-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/nginx-ingress-services' + values: + - './helm_vars/nginx-ingress-services/values.yaml' + - './helm_vars/nginx-ingress-services/certificates-namespace2.yaml' + set: + # Federation domain is also the SRV record created by the + # federation-test-helper service. Maybe we can find a way to make these + # differ, so we don't make any silly assumptions in the code. + - name: config.dns.federator + value: {{ .Values.federationDomainFed2 }} + + #--------------------------------------------- + # + # Note that wire-server depends on databases-ephemeral being up; and in some + # cases on nginx-ingress also being up. If installing helm charts in a + # parallel way, it's expected to see some wire-server pods (namely the + # cassandra-migration one) fail and get restarted a few times) + + - name: '{{ .Values.namespace }}-wire-server' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/wire-server' + values: + - './helm_vars/wire-server/values.yaml' + - './helm_vars/wire-server/certificates-namespace1.yaml' + set: + - name: brig.config.optSettings.setFederationDomain + value: {{ .Values.federationDomain }} + - name: galley.config.settings.federationDomain + value: {{ .Values.federationDomain }} + + - name: '{{ .Values.namespace }}-wire-server-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/wire-server' + values: + - './helm_vars/wire-server/values.yaml' + - './helm_vars/wire-server/certificates-namespace2.yaml' + set: + - name: brig.config.optSettings.setFederationDomain + value: {{ .Values.federationDomainFed2 }} + - name: galley.config.settings.federationDomain + value: {{ .Values.federationDomainFed2 }} diff --git a/shell.nix b/shell.nix index 1057866883b..88bfff74941 100644 --- a/shell.nix +++ b/shell.nix @@ -20,6 +20,30 @@ let cp ${binPath} $out/bin ''; }; + + staticBinary = { pname, version, linuxAmd64Url, linuxAmd64Sha256, darwinAmd64Url, darwinAmd64Sha256, binPath ? pname }: + pkgs.stdenv.mkDerivation { + inherit pname version; + + src = + if pkgs.stdenv.isDarwin + then pkgs.fetchurl { + url = darwinAmd64Url; + sha256 = darwinAmd64Sha256; + } + else pkgs.fetchurl { + url = linuxAmd64Url; + sha256 = linuxAmd64Sha256; + }; + phases = ["installPhase" "patchPhase"]; + + installPhase = '' + mkdir -p $out/bin + cp $src $out/bin/${binPath} + chmod +x $out/bin/${binPath} + ''; + }; + pinned = { stack = staticBinaryInTarball { pname = "stack"; @@ -43,6 +67,17 @@ let linuxAmd64Sha256 = "cdd7ad304e2615c583dde0ffb0cb38fc1336cd7ce8ff3b5f237434dcadb28c98"; }; + helmfile = staticBinary { + pname = "helmfile"; + version = "0.141.0"; + + darwinAmd64Url = "https://github.com/roboll/helmfile/releases/download/v0.141.0/helmfile_darwin_amd64"; + darwinAmd64Sha256 = "0szfd3vy6fzd5657079hz5vii86f9xkg3bdzp3g4knkcw5x1kpxy"; + + linuxAmd64Url = "https://github.com/roboll/helmfile/releases/download/v0.141.0/helmfile_linux_amd64"; + linuxAmd64Sha256 = "0f5d9w3qjvwip4qn79hsigwp8nbjpj58p289hww503j43wjyxx8r"; + }; + kubectl = staticBinaryInTarball { pname = "kubectl"; version = "1.19.8"; @@ -76,6 +111,7 @@ in pkgs.mkShell { pinned.stack pinned.helm + pinned.helmfile pinned.kubectl ]; } From a486304ce7c0be1ffbb73aff1e72db6610aa8790 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 7 Oct 2021 08:35:34 +0200 Subject: [PATCH 08/88] [Federation] Include Remote Connections in Listing All Connections (#1826) * Expand a test to also include remote connections while listing --- .../6-federation/list-remote-connections | 1 + services/brig/src/Brig/API/Public.hs | 35 +++++++++++++---- services/brig/src/Brig/Data/Connection.hs | 21 ++++++++++ services/brig/test/integration/API/User.hs | 7 ++-- .../test/integration/API/User/Connection.hs | 38 +++++++++++++++---- services/brig/test/integration/Main.hs | 2 +- services/galley/src/Galley/API/Query.hs | 2 +- 7 files changed, 86 insertions(+), 20 deletions(-) create mode 100644 changelog.d/6-federation/list-remote-connections diff --git a/changelog.d/6-federation/list-remote-connections b/changelog.d/6-federation/list-remote-connections new file mode 100644 index 00000000000..90ebdc89f04 --- /dev/null +++ b/changelog.d/6-federation/list-remote-connections @@ -0,0 +1 @@ +Include remote connections in the response to `POST /list-connections` diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 61c99210bea..4b2ec723dc9 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -70,7 +70,7 @@ import Data.Handle (Handle, parseHandle) import Data.Id as Id import qualified Data.Map.Strict as Map import Data.Misc (IpAddr (..)) -import Data.Qualified (Qualified (..), partitionRemoteOrLocalIds) +import Data.Qualified (Local, Qualified (..), partitionRemoteOrLocalIds) import Data.Range import Data.String.Interpolate as QQ import qualified Data.Swagger as S @@ -1117,13 +1117,20 @@ listLocalConnections uid start msize = do let defaultSize = toRange (Proxy @100) lift $ API.lookupConnections uid start (fromMaybe defaultSize msize) --- | FUTUREWORK: also list remote connections: https://wearezeta.atlassian.net/browse/SQCORE-963 +-- | Lists connection IDs for the logged in user in a paginated way. +-- +-- Pagination requires an order, in this case the order is defined as: +-- +-- - First all the local connections are listed ordered by their id +-- +-- - After local connections, remote connections are listed ordered +-- - lexicographically by their domain and then by their id. listConnections :: UserId -> Public.ListConnectionsRequestPaginated -> Handler Public.ConnectionsPage -listConnections uid req = do +listConnections uid Public.GetMultiTablePageRequest {..} = do self <- qualifyLocal uid - let size = Public.gmtprSize req - res :: C.PageWithState Public.UserConnection <- Data.lookupLocalConnectionsPage self convertedState (rcast size) - return (pageToConnectionsPage Public.PagingLocals res) + case gmtprState of + Just (Public.ConnectionPagingState Public.PagingRemotes stateBS) -> remotesOnly self (mkState <$> stateBS) (fromRange gmtprSize) + _ -> localsAndRemotes self (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize where pageToConnectionsPage :: Public.LocalOrRemoteTable -> Data.PageWithState Public.UserConnection -> Public.ConnectionsPage pageToConnectionsPage table page@Data.PageWithState {..} = @@ -1134,11 +1141,23 @@ listConnections uid req = do -- Is this type actually useless? Or the tests not good enough? mtpPagingState = Public.ConnectionPagingState table (LBS.toStrict . C.unPagingState <$> pwsState) } + mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - convertedState :: Maybe C.PagingState - convertedState = fmap mkState . Public.mtpsState =<< Public.gmtprState req + localsAndRemotes :: Local UserId -> Maybe C.PagingState -> Range 1 500 Int32 -> Handler Public.ConnectionsPage + localsAndRemotes self pagingState size = do + localPage <- pageToConnectionsPage Public.PagingLocals <$> Data.lookupLocalConnectionsPage self pagingState (rcast size) + let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) + if Public.mtpHasMore localPage || remainingSize <= 0 + then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. + else do + remotePage <- remotesOnly self Nothing remainingSize + pure remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} + + remotesOnly :: Local UserId -> Maybe C.PagingState -> Int32 -> Handler Public.ConnectionsPage + remotesOnly self pagingState size = + pageToConnectionsPage Public.PagingRemotes <$> Data.lookupRemoteConnectionsPage self pagingState size getLocalConnection :: UserId -> UserId -> Handler (Maybe Public.UserConnection) getLocalConnection self other = do diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index bcf967be21e..583f186e861 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -23,6 +23,7 @@ module Brig.Data.Connection updateConnection, lookupConnection, lookupLocalConnectionsPage, + lookupRemoteConnectionsPage, lookupRelationWithHistory, lookupLocalConnections, lookupConnectionStatus, @@ -166,6 +167,19 @@ lookupLocalConnectionsPage :: lookupLocalConnectionsPage self pagingState (fromRange -> size) = fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (lUnqualified self)) size pagingState) +-- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. +lookupRemoteConnectionsPage :: + (MonadClient m) => + Local UserId -> + Maybe PagingState -> + Int32 -> + m (PageWithState UserConnection) +lookupRemoteConnectionsPage self pagingState size = + fmap (toRemoteUserConnection self) + <$> paginateWithState + remoteConnectionSelect + (paramsPagingState Quorum (Identity (lUnqualified self)) size pagingState) + -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] lookupConnectionStatus from to = @@ -279,5 +293,12 @@ toLocalUserConnection :: toLocalUserConnection loc (l, r, relationDropHistory -> rel, time, cid) = UserConnection l (unTagged (qualifyAs loc r)) rel time (fmap (unTagged . qualifyAs loc) cid) +toRemoteUserConnection :: + Local UserId -> + (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> + UserConnection +toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, cid) = + UserConnection (lUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) + toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index 3b66f966b69..9be577d73ab 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -34,14 +34,15 @@ import Bilge hiding (accept, timeout) import qualified Brig.AWS as AWS import qualified Brig.Options as Opt import qualified Brig.ZAuth as ZAuth +import qualified Cassandra as DB import Data.List.NonEmpty (NonEmpty ((:|))) import Imports import Test.Tasty hiding (Timeout) import Util import Util.Options.Common -tests :: Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> IO TestTree -tests conf p b c ch g n aws = do +tests :: Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> DB.ClientState -> IO TestTree +tests conf p b c ch g n aws db = do let cl = ConnectionLimit $ Opt.setUserMaxConnections (Opt.optSettings conf) let at = Opt.setActivationTimeout (Opt.optSettings conf) z <- mkZAuthEnv (Just conf) @@ -51,7 +52,7 @@ tests conf p b c ch g n aws = do [ API.User.Client.tests cl at conf p b c g, API.User.Account.tests cl at conf p b c ch g aws, API.User.Auth.tests conf p z b g n, - API.User.Connection.tests cl at conf p b c g, + API.User.Connection.tests cl at conf p b c g db, API.User.Handles.tests cl at conf p b c g, API.User.PasswordReset.tests cl at conf p b c g, API.User.Property.tests cl at conf p b c g, diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index fbd9509b118..eff003c6799 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -25,13 +25,18 @@ where import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert +import Brig.Data.Connection (remoteConnectionInsert) import qualified Brig.Options as Opt import Brig.Types import Brig.Types.Intra +import qualified Cassandra as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion +import Data.Domain (Domain (..)) import Data.Id hiding (client) +import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified +import Data.Time.Clock (getCurrentTime) import qualified Data.UUID.V4 as UUID import Galley.Types import Imports @@ -42,8 +47,8 @@ import Util import Wire.API.Connection import Wire.API.Routes.MultiTablePaging -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree -tests cl _at _conf p b _c g = +tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> DB.ClientState -> TestTree +tests cl _at _conf p b _c g db = testGroup "connection" [ test p "post /connections" $ testCreateManualConnections b, @@ -73,7 +78,7 @@ tests cl _at _conf p b _c g = test p "put /connections/:id noop" $ testUpdateConnectionNoop b, test p "put /connections/:domain/:id noop" $ testUpdateConnectionNoopQualified b, test p "get /connections - 200 (paging)" $ testLocalConnectionsPaging b, - test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging b, + test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging b db, test p "post /connections - 400 (max conns)" $ testConnectionLimit b cl, test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl ] @@ -593,14 +598,20 @@ testLocalConnectionsPaging b = do liftIO $ assertEqual "has more" (Just (count' < total)) more return . (count',) $ (conns >>= fmap (qUnqualified . ucTo) . listToMaybe . reverse) -testAllConnectionsPaging :: Brig -> Http () -testAllConnectionsPaging b = do +testAllConnectionsPaging :: Brig -> DB.ClientState -> Http () +testAllConnectionsPaging b db = do quid <- userQualifiedId <$> randomUser b let uid = qUnqualified quid - replicateM_ total $ do + replicateM_ totalLocal $ do qOther <- userQualifiedId <$> randomUser b postConnectionQualified b uid qOther !!! const 201 === statusCode + -- FUTUREWORK: For now, because we do not support creating remote connections + -- yet (as of Oct 1, 2021), we write some made-up remote connections directly + -- to the database such that querying works. + now <- toUTCTimeMillis <$> liftIO getCurrentTime + replicateM_ totalRemote $ createRemoteConnection uid now + -- get all connections at once resAll :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing Nothing liftIO $ assertEqual "all: size" total (length . mtpResults $ resAll) @@ -616,7 +627,20 @@ testAllConnectionsPaging b = do liftIO $ assertEqual "next: has_more" False (mtpHasMore resNext) where size = 2 - total = 5 + totalLocal = 5 + totalRemote = 3 + total = totalLocal + totalRemote + remoteDomain = Domain "faraway.example.com" + createRemoteConnection :: UserId -> UTCTimeMillis -> Http () + createRemoteConnection self now = do + qOther <- (`Qualified` remoteDomain) <$> randomId + qConv <- (`Qualified` remoteDomain) <$> randomId + liftIO . DB.runClient db $ + DB.retry DB.x5 $ + DB.write remoteConnectionInsert $ + DB.params + DB.Quorum + (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv) testConnectionLimit :: Brig -> ConnectionLimit -> Http () testConnectionLimit brig (ConnectionLimit l) = do diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index ab31aa1d332..566c4dd0b9f 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -122,7 +122,7 @@ runTests iConf brigOpts otherArgs = do let fedBrigClient = mkFedBrigClient mg (brig iConf) emailAWSOpts <- parseEmailAWSOpts awsEnv <- AWS.mkEnv lg awsOpts emailAWSOpts mg - userApi <- User.tests brigOpts mg b c ch g n awsEnv + userApi <- User.tests brigOpts mg b c ch g n awsEnv db providerApi <- Provider.tests localDomain (provider iConf) mg db b c g searchApis <- Search.tests brigOpts mg g b teamApis <- Team.tests brigOpts mg n b c g awsEnv diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index cd7a495ff5a..a1ac79fd98a 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -239,7 +239,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) <$> Data.localConversationIdsPageFrom zusr pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 - then pure localPage {Public.mtpHasMore = True} -- We haven't check the remotes yet, so has_more must always be True here. + then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. else do remotePage <- remotesOnly Nothing remainingSize pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} From fa25b0939e848b88d1e173d68f3ec20614a4885e Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 7 Oct 2021 11:49:33 +0200 Subject: [PATCH 09/88] Remove deprecated endpoint for listing convs (#1840) * Remove deprecated endpoint for listing convs Also removed the V2 from the name of the endpoint (in the code, not in the endpoint path). * Remove /list-conversations from nginx conf * Remove use of /list-conversations from End2end --- .../remove-list-conversations-endpoint | 1 + charts/nginz/values.yaml | 3 - .../conf/nginz/nginx-docker.conf | 5 - deploy/services-demo/conf/nginz/nginx.conf | 5 - libs/wire-api/src/Wire/API/Conversation.hs | 27 +--- .../src/Wire/API/Routes/Public/Galley.hs | 19 +-- ...on => testObject_ListConversations_1.json} | 0 .../test/unit/Test/Wire/API/Golden/Manual.hs | 6 +- ...onversationsV2.hs => ListConversations.hs} | 10 +- libs/wire-api/wire-api.cabal | 4 +- .../test/integration/Federation/End2end.hs | 17 ++- services/brig/test/integration/Util.hs | 41 +++--- services/galley/src/Galley/API/Public.hs | 1 - services/galley/src/Galley/API/Query.hs | 51 +------- services/galley/test/integration/API.hs | 120 +----------------- services/galley/test/integration/API/Util.hs | 29 ----- 16 files changed, 59 insertions(+), 280 deletions(-) create mode 100644 changelog.d/1-api-changes/remove-list-conversations-endpoint rename libs/wire-api/test/golden/{testObject_ListConversationsV2_1.json => testObject_ListConversations_1.json} (100%) rename libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/{ListConversationsV2.hs => ListConversations.hs} (84%) diff --git a/changelog.d/1-api-changes/remove-list-conversations-endpoint b/changelog.d/1-api-changes/remove-list-conversations-endpoint new file mode 100644 index 00000000000..60539f03a99 --- /dev/null +++ b/changelog.d/1-api-changes/remove-list-conversations-endpoint @@ -0,0 +1 @@ +Remove `POST /list-conversations` endpoint. diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 3773dd2aed2..2d006ddb7b9 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -304,9 +304,6 @@ nginx_conf: envs: - all doc: true - - path: ~* ^/list-conversations$ - envs: - - all - path: ~* ^/teams$ envs: - all diff --git a/deploy/services-demo/conf/nginz/nginx-docker.conf b/deploy/services-demo/conf/nginz/nginx-docker.conf index c674cdd4ac4..9fdd32baf84 100644 --- a/deploy/services-demo/conf/nginz/nginx-docker.conf +++ b/deploy/services-demo/conf/nginz/nginx-docker.conf @@ -253,11 +253,6 @@ http { proxy_pass http://galley; } - location /list-conversations { - include common_response_with_zauth.conf; - proxy_pass http://galley; - } - location ~* ^/conversations/([^/]*)/otr/messages { include common_response_with_zauth.conf; proxy_pass http://galley; diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 5d577caed68..543dc2d8c3c 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -313,11 +313,6 @@ http { proxy_pass http://galley; } - location /list-conversations { - include common_response_with_zauth.conf; - proxy_pass http://galley; - } - location ~* ^/conversations/([^/]*)/otr/messages { include common_response_with_zauth.conf; proxy_pass http://galley; diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index ad7bdd5311e..e65b0e0a884 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -37,7 +37,6 @@ module Wire.API.Conversation ConversationCoverView (..), ConversationList (..), ListConversations (..), - ListConversationsV2 (..), GetPaginatedConversationIds, pattern GetPaginatedConversationIds, ConvIdsPage, @@ -359,37 +358,19 @@ type GetPaginatedConversationIds = GetMultiTablePageRequest ConversationPagingNa pattern GetPaginatedConversationIds :: Maybe (MultiTablePagingState name tables) -> Range 1 max Int32 -> GetMultiTablePageRequest name tables max def pattern GetPaginatedConversationIds state size = GetMultiTablePageRequest size state -data ListConversations = ListConversations - { lQualifiedIds :: Maybe (NonEmpty (Qualified ConvId)), - lStartId :: Maybe (Qualified ConvId), - lSize :: Maybe (Range 1 500 Int32) - } - deriving stock (Eq, Show, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema ListConversations - -instance ToSchema ListConversations where - schema = - objectWithDocModifier - "ListConversations" - (description ?~ "A request to list some or all of a user's conversations, including remote ones") - $ ListConversations - <$> lQualifiedIds .= optField "qualified_ids" Nothing (nonEmptyArray schema) - <*> lStartId .= optField "start_id" Nothing schema - <*> lSize .= optField "size" Nothing schema - -- | Used on the POST /conversations/list/v2 endpoint -newtype ListConversationsV2 = ListConversationsV2 +newtype ListConversations = ListConversations { lcQualifiedIds :: Range 1 1000 [Qualified ConvId] } deriving stock (Eq, Show, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema ListConversationsV2 + deriving (FromJSON, ToJSON, S.ToSchema) via Schema ListConversations -instance ToSchema ListConversationsV2 where +instance ToSchema ListConversations where schema = objectWithDocModifier "ListConversations" (description ?~ "A request to list some of a user's conversations, including remote ones. Maximum 1000 qualified conversation IDs") - $ ListConversationsV2 + $ ListConversations <$> (fromRange . lcQualifiedIds) .= field "qualified_ids" (rangedSchema sing sing (array schema)) data ConversationsResponse = ConversationsResponse diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 7ba622cd808..41cd9d2ae17 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -141,7 +141,10 @@ data Api routes = Api getConversations :: routes :- Summary "Get all *local* conversations." - :> Description "Will not return remote conversations (will eventually be deprecated in favour of list-conversations)" + :> Description + "Will not return remote conversations.\n\n\ + \Use `POST /conversations/list-ids` followed by \ + \`POST /conversations/list/v2` instead." :> ZUser :> "conversations" :> QueryParam' @@ -167,25 +170,13 @@ data Api routes = Api (Range 1 500 Int32) :> Get '[Servant.JSON] (ConversationList Conversation), listConversations :: - routes - :- Summary "[deprecated] Get all conversations (also returns remote conversations)" - :> Description - "Like GET /conversations, but allows specifying a list of remote conversations in its request body. \ - \Will return all or the requested qualified conversations, including remote ones. \ - \Size parameter is not yet honoured for remote conversations.\n\ - \**NOTE** This endpoint will soon be removed." - :> ZUser - :> "list-conversations" - :> ReqBody '[Servant.JSON] ListConversations - :> Post '[Servant.JSON] (ConversationList Conversation), - listConversationsV2 :: routes :- Summary "Get conversation metadata for a list of conversation ids" :> ZUser :> "conversations" :> "list" :> "v2" - :> ReqBody '[Servant.JSON] ListConversationsV2 + :> ReqBody '[Servant.JSON] ListConversations :> Post '[Servant.JSON] ConversationsResponse, -- This endpoint can lead to the following events being sent: -- - ConvCreate event to members diff --git a/libs/wire-api/test/golden/testObject_ListConversationsV2_1.json b/libs/wire-api/test/golden/testObject_ListConversations_1.json similarity index 100% rename from libs/wire-api/test/golden/testObject_ListConversationsV2_1.json rename to libs/wire-api/test/golden/testObject_ListConversations_1.json diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs index e6d9e3cd859..e4edd42411b 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs @@ -27,7 +27,7 @@ import Test.Wire.API.Golden.Manual.ConversationPagingState import Test.Wire.API.Golden.Manual.ConversationsResponse import Test.Wire.API.Golden.Manual.FeatureConfigEvent import Test.Wire.API.Golden.Manual.GetPaginatedConversationIds -import Test.Wire.API.Golden.Manual.ListConversationsV2 +import Test.Wire.API.Golden.Manual.ListConversations import Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap import Test.Wire.API.Golden.Manual.UserClientPrekeyMap import Test.Wire.API.Golden.Manual.UserIdList @@ -96,9 +96,9 @@ tests = [ (testObject_UserIdList_1, "testObject_UserIdList_1.json"), (testObject_UserIdList_2, "testObject_UserIdList_2.json") ], - testGroup "ListConversationsV2" $ + testGroup "ListConversations" $ testObjects - [(testObject_ListConversationsV2_1, "testObject_ListConversationsV2_1.json")], + [(testObject_ListConversations_1, "testObject_ListConversations_1.json")], testGroup "ConversationsResponse" $ testObjects [(testObject_ConversationsResponse_1, "testObject_ConversationsResponse_1.json")] ] diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversationsV2.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversations.hs similarity index 84% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversationsV2.hs rename to libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversations.hs index 6cac2a29ca9..c10a79ddfd5 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversationsV2.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversations.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Golden.Manual.ListConversationsV2 where +module Test.Wire.API.Golden.Manual.ListConversations where import Data.Domain (Domain (Domain)) import Data.Id (Id (Id)) @@ -23,11 +23,11 @@ import Data.Qualified (Qualified (Qualified)) import Data.Range (unsafeRange) import qualified Data.UUID as UUID import Imports -import Wire.API.Conversation (ListConversationsV2 (..)) +import Wire.API.Conversation (ListConversations (..)) -testObject_ListConversationsV2_1 :: ListConversationsV2 -testObject_ListConversationsV2_1 = - ListConversationsV2 +testObject_ListConversations_1 :: ListConversations +testObject_ListConversations_1 = + ListConversations ( unsafeRange [ Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002"))) (Domain "domain.example.com"), Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-111111111112"))) (Domain "domain2.example.com") diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index b85340b9ba8..d76a81d602c 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4ba12caf3f3efd379bd7183a7661ac527d4da4072b7d92dd240af982bdab27de +-- hash: c6591983c73573c4734c452218e0831333768e896f0ab08718ba9f2c6b110567 name: wire-api version: 0.1.0 @@ -412,7 +412,7 @@ test-suite wire-api-tests Test.Wire.API.Golden.Manual.ConvIdsPage Test.Wire.API.Golden.Manual.FeatureConfigEvent Test.Wire.API.Golden.Manual.GetPaginatedConversationIds - Test.Wire.API.Golden.Manual.ListConversationsV2 + Test.Wire.API.Golden.Manual.ListConversations Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap Test.Wire.API.Golden.Manual.UserClientPrekeyMap Test.Wire.API.Golden.Manual.UserIdList diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 39961ea2478..fc9f39ccf15 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -37,6 +37,7 @@ import Data.List1 as List1 import qualified Data.Map as Map import qualified Data.ProtoLens as Protolens import Data.Qualified +import Data.Range (checked) import qualified Data.Set as Set import Federation.Util (generateClientPrekeys, getConvQualified) import Gundeck.Types.Notification (ntfTransient) @@ -52,6 +53,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Event.Conversation import Wire.API.Message +import Wire.API.Routes.MultiTablePaging import Wire.API.User (ListUsersQuery (ListUsersByIds)) import Wire.API.User.Client @@ -414,10 +416,17 @@ testListConversations brig1 brig2 galley1 galley2 = do -- From Alice's point of view -- both conversations should show her as the self member and bob as Othermember. let expected = cnv1 - rs <- listAllConvs galley1 (userId alice) responseJsonUnsafe rs - let c1 = cs >>= find ((== cnvQualifiedId cnv1) . cnvQualifiedId) - let c2 = cs >>= find ((== cnvQualifiedId cnv2) . cnvQualifiedId) + rs <- listConvIdsFirstPage galley1 (userId alice) assertFailure "too many conversations" + Just r -> pure r + (cs :: [Conversation]) <- + (fmap crFound . responseJsonError) + =<< listConvs galley1 (userId alice) cids do assertEqual "self member mismatch" diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index e5840321566..cc9963d6c7e 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -41,7 +41,6 @@ import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Retry import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _Integral, _JSON, _String) -import Data.Aeson.Types (emptyObject) import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack) @@ -53,6 +52,7 @@ import Data.Id import Data.List1 (List1) import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) +import Data.Proxy import Data.Qualified import Data.Range import qualified Data.Text as Text @@ -72,10 +72,10 @@ import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import qualified UnliftIO.Async as Async import Util.AWS -import Wire.API.Conversation (ListConversations, NewConv (..), NewConvUnmanaged (..)) -import Wire.API.Conversation.Member (Member (..)) +import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.Federation.API.Brig as FedBrig +import Wire.API.Routes.MultiTablePaging type Brig = Request -> Request @@ -584,28 +584,29 @@ createConversation galley zusr usersToAdd = do . zConn "conn" . json conv --- (should be) equivalent to --- listConvs u (ListConversations [] Nothing Nothing) -listAllConvs :: (MonadIO m, MonadHttp m) => Galley -> UserId -> m ResponseLBS -listAllConvs g u = do +listConvIdsFirstPage :: (MonadIO m, MonadHttp m) => Galley -> UserId -> m ResponseLBS +listConvIdsFirstPage galley zusr = do + let req = GetMultiTablePageRequest (toRange (Proxy @1000)) Nothing :: GetPaginatedConversationIds post $ - g - . path "/list-conversations" - . zUser u + galley + . path "/conversations/list-ids" + . zUser zusr . zConn "conn" - . json emptyObject + . json req -listConvs :: (MonadIO m, MonadHttp m) => Galley -> UserId -> ListConversations -> m ResponseLBS -listConvs g u req = do - -- when using servant-client (pending #1605), this would become: - -- galleyClient <- view tsGalleyClient - -- res :: Public.ConversationList Public.Conversation <- listConversations galleyClient req +listConvs :: + (MonadIO m, MonadHttp m) => + Galley -> + UserId -> + Range 1 1000 [Qualified ConvId] -> + m ResponseLBS +listConvs galley zusr convs = do post $ - g - . path "/list-conversations" - . zUser u + galley + . path "/conversations/list/v2" + . zUser zusr . zConn "conn" - . json req + . json (ListConversations convs) isMember :: Galley -> UserId -> ConvId -> (MonadIO m, MonadHttp m) => m Bool isMember g usr cnv = do diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 1c7f9eb1963..a5422585473 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -84,7 +84,6 @@ servantSitemap = GalleyAPI.getConversations = Query.getConversations, GalleyAPI.getConversationByReusableCode = Query.getConversationByReusableCode, GalleyAPI.listConversations = Query.listConversations, - GalleyAPI.listConversationsV2 = Query.listConversationsV2, GalleyAPI.createGroupConversation = Create.createGroupConversation, GalleyAPI.createSelfConversation = Create.createSelfConversation, GalleyAPI.createOne2OneConversation = Create.createOne2OneConversation, diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index a1ac79fd98a..ab447495338 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -25,7 +25,6 @@ module Galley.API.Query conversationIdsPageFrom, getConversations, listConversations, - listConversationsV2, iterateConversations, getLocalSelf, internalGetMemberH, @@ -288,54 +287,8 @@ getConversationsInternal user mids mstart msize = do | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True --- | Deprecated. FUTUREWORK(federation): Delete this endpoint -listConversations :: UserId -> Public.ListConversations -> Galley (Public.ConversationList Public.Conversation) -listConversations user (Public.ListConversations mIds qstart msize) = do - localDomain <- viewFederationDomain - when (isJust mIds && isJust qstart) $ - throwM (invalidPayload "'start' and 'qualified_ids' are mutually exclusive") - (localMore, localConvIds, remoteConvIds) <- case mIds of - Just xs -> do - let (remoteConvIds, localIds) = partitionRemoteOrLocalIds' localDomain (toList xs) - (localMore, localConvIds) <- getIdsAndMore localIds - pure (localMore, localConvIds, remoteConvIds) - Nothing -> do - (localMore, localConvIds) <- getAll (localstart localDomain) - remoteConvIds <- Data.conversationsRemote user - pure (localMore, localConvIds, remoteConvIds) - - localInternalConversations <- - Data.localConversations localConvIds - >>= filterM removeDeleted - >>= filterM (pure . isMember user . Data.convLocalMembers) - localConversations <- mapM (Mapping.conversationView user) localInternalConversations - - remoteConversations <- getRemoteConversations user remoteConvIds - let allConvs = localConversations <> remoteConversations - pure $ Public.ConversationList allConvs localMore - where - localstart localDomain = case qstart of - Just start | qDomain start == localDomain -> Just (qUnqualified start) - _ -> Nothing - - size = fromMaybe (toRange (Proxy @32)) msize - - getIdsAndMore :: [ConvId] -> Galley (Bool, [ConvId]) - getIdsAndMore ids = (False,) <$> Data.localConversationIdsOf user ids - - getAll :: Maybe ConvId -> Galley (Bool, [ConvId]) - getAll mstart = do - r <- Data.conversationIdsFrom user mstart (rcast size) - let hasMore = Data.resultSetType r == Data.ResultSetTruncated - pure (hasMore, Data.resultSetResult r) - - removeDeleted :: Data.Conversation -> Galley Bool - removeDeleted c - | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False - | otherwise = pure True - -listConversationsV2 :: UserId -> Public.ListConversationsV2 -> Galley Public.ConversationsResponse -listConversationsV2 user (Public.ListConversationsV2 ids) = do +listConversations :: UserId -> Public.ListConversations -> Galley Public.ConversationsResponse +listConversations user (Public.ListConversations ids) = do localDomain <- viewFederationDomain let (remoteIds, localIds) = partitionRemoteOrLocalIds' localDomain (fromRange ids) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index fb34dc78b05..2bcbf2ba80f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -120,9 +120,7 @@ tests s = test s "metrics" metrics, test s "create conversation" postConvOk, test s "get empty conversations" getConvsOk, - test s "list-conversations empty" listConvsOk, test s "get conversations by ids" getConvsOk2, - test s "list-conversations by ids" listConvsOk2, test s "fail to get >500 conversations" getConvsFailMaxSize, test s "get conversation ids" getConvIdsOk, test s "get conversation ids v2" listConvIdsOk, @@ -131,7 +129,6 @@ tests s = test s "paginate through /conversations/list-ids - page ending at locals and remote domain" paginateConvListIdsPageEndingAtLocalsAndDomain, test s "fail to get >1000 conversation ids" getConvIdsFailMaxSize, test s "page through conversations" getConvsPagingOk, - test s "page through list-conversations (local conversations only)" listConvsPagingOk, test s "fail to create conversation when not connected" postConvFailNotConnected, test s "fail to create conversation with qualified users when not connected" postConvQualifiedFailNotConnected, test s "M:N conversation creation with N - 1 invitees should be allowed" postConvLimitOk, @@ -167,7 +164,6 @@ tests s = test s "get conversations/:domain/:cnv - remote" testGetQualifiedRemoteConv, test s "get conversations/:domain/:cnv - remote, not found" testGetQualifiedRemoteConvNotFound, test s "get conversations/:domain/:cnv - remote, not found on remote" testGetQualifiedRemoteConvNotFoundOnRemote, - test s "post list-conversations" testListRemoteConvs, test s "post conversations/list/v2" testBulkGetQualifiedConvs, test s "add non-existing remote members" testAddRemoteMemberFailure, test s "add deleted remote members" testAddDeletedRemoteUser, @@ -1160,14 +1156,6 @@ getConvsOk = do const 200 === statusCode const [toUUID usr] === map (toUUID . qUnqualified . cnvQualifiedId) . decodeConvList --- same test as getConvsOk, but using the listConversations endpoint -listConvsOk :: TestM () -listConvsOk = do - usr <- randomUser - listAllConvs usr !!! do - const 200 === statusCode - const [toUUID usr] === map (toUUID . qUnqualified . cnvQualifiedId) . decodeConvList - getConvsOk2 :: TestM () getConvsOk2 = do [alice, bob] <- randomUsers 2 @@ -1203,44 +1191,6 @@ getConvsOk2 = do (Just []) ((\c -> cmOthers (cnvMembers c) \\ cmOthers (cnvMembers expected)) <$> actual) --- same test as getConvsOk2, but using the listConversations endpoint -listConvsOk2 :: TestM () -listConvsOk2 = do - [alice, bob] <- randomUsers 2 - connectUsers alice (singleton bob) - -- create & get one2one conv - cnv1 <- responseJsonUnsafeWithMsg "conversation" <$> postO2OConv alice bob (Just "gossip1") - let req1 = ListConversations (Just (cnvQualifiedId cnv1 :| [])) Nothing Nothing - listConvs alice req1 !!! do - const 200 === statusCode - const (Just [cnvQualifiedId cnv1]) === fmap (map cnvQualifiedId . convList) . responseJsonUnsafe - -- create & get group conv - carl <- randomUser - connectUsers alice (singleton carl) - cnv2 <- responseJsonUnsafeWithMsg "conversation" <$> postConv alice [bob, carl] (Just "gossip2") [] Nothing Nothing - let req2 = ListConversations (Just (cnvQualifiedId cnv2 :| [])) Nothing Nothing - listConvs alice req2 !!! do - const 200 === statusCode - const (Just [cnvQualifiedId cnv2]) === fmap (map cnvQualifiedId . convList) . responseJsonUnsafe - -- get both - rs <- listAllConvs alice responseJsonUnsafe rs - let c1 = convs >>= find ((== cnvQualifiedId cnv1) . cnvQualifiedId) - let c2 = convs >>= find ((== cnvQualifiedId cnv2) . cnvQualifiedId) - liftIO . forM_ [(cnv1, c1), (cnv2, c2)] $ \(expected, actual) -> do - assertEqual - "name mismatch" - (Just $ cnvName expected) - (cnvName <$> actual) - assertEqual - "self member mismatch" - (Just . cmSelf $ cnvMembers expected) - (cmSelf . cnvMembers <$> actual) - assertEqual - "other members mismatch" - (Just []) - ((\c -> cmOthers (cnvMembers c) \\ cmOthers (cnvMembers expected)) <$> actual) - getConvsFailMaxSize :: TestM () getConvsFailMaxSize = do usr <- randomUser @@ -1453,35 +1403,6 @@ getConvsPagingOk = do liftIO $ assertBool "getConvIds /= getConvs" (ids1 == ids3) return $ ids1 >>= listToMaybe . reverse --- same test as getConvsPagingOk, but using the listConversations endpoint --- (only tests pagination behaviour for local conversations) --- FUTUREWORK: pagination for remote conversations -listConvsPagingOk :: TestM () -listConvsPagingOk = do - [ally, bill, carl] <- randomUsers 3 - connectUsers ally (list1 bill [carl]) - replicateM_ 11 $ postConv ally [bill, carl] (Just "gossip") [] Nothing Nothing - walk ally [3, 3, 3, 3, 2] -- 11 (group) + 2 (1:1) + 1 (self) - walk bill [3, 3, 3, 3, 1] -- 11 (group) + 1 (1:1) + 1 (self) - walk carl [3, 3, 3, 3, 1] -- 11 (group) + 1 (1:1) + 1 (self) - where - walk :: Foldable t => UserId -> t Int -> TestM () - walk u = foldM_ (next u 3) Nothing - next :: UserId -> Int32 -> Maybe ConvId -> Int -> TestM (Maybe ConvId) - next u step start n = do - -- FUTUREWORK: support an endpoint to get qualified conversation IDs - -- (without all the conversation metadata) - r1 <- getConvIds u (Right <$> start) (Just step) responseJsonUnsafe r1 - liftIO $ assertEqual "unexpected length (getConvIds)" (Just n) (length <$> ids1) - localDomain <- viewFederationDomain - let requestBody = ListConversations Nothing (flip Qualified localDomain <$> start) (Just (unsafeRange step)) - r2 <- listConvs u requestBody responseJsonUnsafe r2 - liftIO $ assertEqual "unexpected length (getConvs)" (Just n) (length <$> ids3) - liftIO $ assertBool "getConvIds /= getConvs" (ids1 == ids3) - return $ ids1 >>= listToMaybe . reverse - postConvFailNotConnected :: TestM () postConvFailNotConnected = do alice <- randomUser @@ -1971,42 +1892,7 @@ testGetQualifiedRemoteConvNotFoundOnRemote = do const 404 === statusCode const (Just "no-conversation") === view (at "label") . responseJsonUnsafe @Object -testListRemoteConvs :: TestM () -testListRemoteConvs = do - -- alice on local domain - -- bob and the conversation on the remote domain - aliceQ <- randomQualifiedUser - let alice = qUnqualified aliceQ - bobId <- randomId - convId <- randomId - let remoteDomain = Domain "far-away.example.com" - bobQ = Qualified bobId remoteDomain - remoteConvId = Qualified convId remoteDomain - - let aliceAsOtherMember = OtherMember aliceQ Nothing roleNameWireAdmin - mockConversation = mkConv remoteConvId alice roleNameWireAdmin [aliceAsOtherMember] - remoteConversationResponse = GetConversationsResponse [mockConversation] - opts <- view tsGConf - - registerRemoteConv remoteConvId bobQ Nothing (Set.fromList [aliceAsOtherMember]) - - -- FUTUREWORK: Do this test with more than one remote domains - -- test POST /list-conversations - (respAll, _) <- - withTempMockFederator - opts - remoteDomain - (const remoteConversationResponse) - (listAllConvs alice) - convs <- responseJsonUnsafe <$> (pure respAll pure . F.OutwardResponseError $ F.OutwardError F.DiscoveryFailed "discovery failed" _ -> assertFailure $ "Unrecognized domain: " <> show fedReq ) - (listConvsV2 alice req) + (listConvs alice req) convs <- responseJsonUnsafe <$> (pure respAll UserId -> m ResponseLBS -listAllConvs u = do - g <- viewGalley - post $ - g - . path "/list-conversations" - . zUser u - . zConn "conn" - . zType "access" - . json emptyObject - listConvs :: (MonadIO m, MonadHttp m, HasGalley m) => UserId -> ListConversations -> m ResponseLBS listConvs u req = do - -- when using servant-client (pending #1605), this would become: - -- galleyClient <- view tsGalleyClient - -- res :: Public.ConversationList Public.Conversation <- listConversations galleyClient req - g <- viewGalley - post $ - g - . path "/list-conversations" - . zUser u - . zConn "conn" - . zType "access" - . json req - -listConvsV2 :: (MonadIO m, MonadHttp m, HasGalley m) => UserId -> ListConversationsV2 -> m ResponseLBS -listConvsV2 u req = do g <- viewGalley post $ g From e742a41731c9d078ef4004a33cce7681ff53a322 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 7 Oct 2021 14:13:16 +0200 Subject: [PATCH 10/88] Federation: Allow connecting to remote users (#1824) One2One conversations are not created yet. This will be worked upon separately. Legal-hold restrictions are also not dealt with as for now, it will not be allowed to turn on legal-hold and federation at the same point. Co-authored-by: Stefan Matting Co-authored-by: jschaul Co-authored-by: Akshay Mankar --- changelog.d/6-federation/fed-connections | 1 + .../src/Wire/API/Federation/API/Brig.hs | 53 +++- .../Wire/API/Federation/Golden/GoldenSpec.hs | 12 + .../Federation/Golden/NewConnectionRequest.hs | 39 +++ .../Golden/NewConnectionResponse.hs | 33 +++ .../testObject_NewConnectionRequest1.json | 5 + .../testObject_NewConnectionRequest2.json | 5 + .../testObject_NewConnectionResponse1.json | 4 + .../testObject_NewConnectionResponse2.json | 4 + .../testObject_NewConnectionResponse3.json | 4 + .../testObject_NewConnectionResponse4.json | 3 + .../wire-api-federation.cabal | 4 +- libs/wire-api/package.yaml | 1 + libs/wire-api/src/Wire/API/Connection.hs | 12 + .../src/Wire/API/Routes/Public/Util.hs | 9 +- libs/wire-api/wire-api.cabal | 3 +- services/brig/brig.cabal | 5 +- services/brig/package.yaml | 1 + services/brig/src/Brig/API/Connection.hs | 109 ++++--- .../brig/src/Brig/API/Connection/Remote.hs | 266 ++++++++++++++++++ services/brig/src/Brig/API/Connection/Util.hs | 44 +++ services/brig/src/Brig/API/Error.hs | 1 + services/brig/src/Brig/API/Federation.hs | 24 +- services/brig/src/Brig/API/Public.hs | 28 +- services/brig/src/Brig/API/Types.hs | 4 +- services/brig/src/Brig/Data/Connection.hs | 36 ++- services/brig/src/Brig/Federation/Client.hs | 11 + services/brig/src/Brig/IO/Intra.hs | 28 +- .../brig/test/integration/API/Federation.hs | 27 +- .../brig/test/integration/API/Team/Util.hs | 8 +- services/brig/test/integration/API/User.hs | 6 +- .../test/integration/API/User/Connection.hs | 201 ++++++++++++- .../brig/test/integration/API/User/Util.hs | 74 ++++- services/brig/test/integration/Main.hs | 2 +- services/brig/test/integration/Util.hs | 18 +- services/galley/test/integration/API.hs | 3 +- 36 files changed, 958 insertions(+), 130 deletions(-) create mode 100644 changelog.d/6-federation/fed-connections create mode 100644 libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionRequest.hs create mode 100644 libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionResponse.hs create mode 100644 libs/wire-api-federation/test/golden/testObject_NewConnectionRequest1.json create mode 100644 libs/wire-api-federation/test/golden/testObject_NewConnectionRequest2.json create mode 100644 libs/wire-api-federation/test/golden/testObject_NewConnectionResponse1.json create mode 100644 libs/wire-api-federation/test/golden/testObject_NewConnectionResponse2.json create mode 100644 libs/wire-api-federation/test/golden/testObject_NewConnectionResponse3.json create mode 100644 libs/wire-api-federation/test/golden/testObject_NewConnectionResponse4.json create mode 100644 services/brig/src/Brig/API/Connection/Remote.hs create mode 100644 services/brig/src/Brig/API/Connection/Util.hs diff --git a/changelog.d/6-federation/fed-connections b/changelog.d/6-federation/fed-connections new file mode 100644 index 00000000000..f5aa2e774d7 --- /dev/null +++ b/changelog.d/6-federation/fed-connections @@ -0,0 +1 @@ +Allow connecting to remote users. One to one conversations are not created yet. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index 1e714c58c03..9599b40e4c0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -20,7 +20,7 @@ module Wire.API.Federation.API.Brig where import Control.Monad.Except (MonadError (..)) import Data.Aeson (FromJSON, ToJSON) import Data.Handle (Handle) -import Data.Id (ClientId, UserId) +import Data.Id import Imports import Servant.API import Servant.API.Generic @@ -28,6 +28,7 @@ import Servant.Client.Generic (AsClientT, genericClient) import Test.QuickCheck (Arbitrary) import Wire.API.Arbitrary (GenericUniform (..)) import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) +import Wire.API.Federation.Domain (OriginDomainHeader) import qualified Wire.API.Federation.GRPC.Types as Proto import Wire.API.Message (UserClients) import Wire.API.User (UserProfile) @@ -92,7 +93,14 @@ data Api routes = Api :- "federation" :> "get-user-clients" :> ReqBody '[JSON] GetUserClients - :> Post '[JSON] (UserMap (Set PubClient)) + :> Post '[JSON] (UserMap (Set PubClient)), + sendConnectionAction :: + routes + :- "federation" + :> "send-connection-action" + :> OriginDomainHeader + :> ReqBody '[JSON] NewConnectionRequest + :> Post '[JSON] NewConnectionResponse } deriving (Generic) @@ -102,5 +110,46 @@ newtype GetUserClients = GetUserClients deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) via (CustomEncoded GetUserClients) +-- NOTE: ConversationId for remote connections +-- +-- The plan is to model the connect/one2one conversationId as deterministically derived from +-- the combination of both userIds and both domains. It may be in the domain +-- of the sending OR the receiving backend (with a 50/50 probability). +-- However at the level of the federation API, we are only concerned about +-- the question of which backend has the authority over the conversationId. +-- +-- (Backend A should not prescribe backend B to use a certain UUID for its +-- conversation; as that could lead to a potential malicious override of an +-- existing conversation) +-- +-- The deterministic conversation Id should be seen as a 'best effort' +-- attempt only. (we cannot guarantee a backend won't change the code in the +-- future) + +data NewConnectionRequest = NewConnectionRequest + { -- | The 'from' userId is understood to always have the domain of the backend making the connection request + ncrFrom :: UserId, + -- | The 'to' userId is understood to always have the domain of the receiving backend. + ncrTo :: UserId, + ncrAction :: RemoteConnectionAction + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform NewConnectionRequest) + deriving (FromJSON, ToJSON) via (CustomEncoded NewConnectionRequest) + +data RemoteConnectionAction + = RemoteConnect + | RemoteRescind + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform RemoteConnectionAction) + deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConnectionAction) + +data NewConnectionResponse + = NewConnectionResponseUserNotActivated + | NewConnectionResponseOk (Maybe RemoteConnectionAction) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform NewConnectionResponse) + deriving (FromJSON, ToJSON) via (CustomEncoded NewConnectionResponse) + clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Brig m)) clientRoutes = genericClient diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index eb9fded3083..8142d17ae17 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -23,6 +23,8 @@ import qualified Test.Wire.API.Federation.Golden.ConversationUpdate as Conversat import qualified Test.Wire.API.Federation.Golden.LeaveConversationRequest as LeaveConversationRequest import qualified Test.Wire.API.Federation.Golden.LeaveConversationResponse as LeaveConversationResponse import qualified Test.Wire.API.Federation.Golden.MessageSendResponse as MessageSendResponse +import qualified Test.Wire.API.Federation.Golden.NewConnectionRequest as NewConnectionRequest +import qualified Test.Wire.API.Federation.Golden.NewConnectionResponse as NewConnectionResponse import Test.Wire.API.Federation.Golden.Runner (testObjects) spec :: Spec @@ -50,3 +52,13 @@ spec = (LeaveConversationResponse.testObject_LeaveConversationResponse7, "testObject_LeaveConversationResponse7.json"), (LeaveConversationResponse.testObject_LeaveConversationResponse8, "testObject_LeaveConversationResponse8.json") ] + testObjects + [ (NewConnectionRequest.testObject_NewConnectionRequest1, "testObject_NewConnectionRequest1.json"), + (NewConnectionRequest.testObject_NewConnectionRequest2, "testObject_NewConnectionRequest2.json") + ] + testObjects + [ (NewConnectionResponse.testObject_NewConnectionResponse1, "testObject_NewConnectionResponse1.json"), + (NewConnectionResponse.testObject_NewConnectionResponse2, "testObject_NewConnectionResponse2.json"), + (NewConnectionResponse.testObject_NewConnectionResponse3, "testObject_NewConnectionResponse3.json"), + (NewConnectionResponse.testObject_NewConnectionResponse4, "testObject_NewConnectionResponse4.json") + ] diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionRequest.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionRequest.hs new file mode 100644 index 00000000000..07a4d0306f2 --- /dev/null +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionRequest.hs @@ -0,0 +1,39 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Federation.Golden.NewConnectionRequest where + +import Data.Id +import qualified Data.UUID as UUID +import Imports +import Wire.API.Federation.API.Brig + +testObject_NewConnectionRequest1 :: NewConnectionRequest +testObject_NewConnectionRequest1 = + NewConnectionRequest + { ncrFrom = Id (fromJust (UUID.fromString "69f66843-6cf1-48fb-8c05-1cf58c23566a")), + ncrTo = Id (fromJust (UUID.fromString "1669240c-c510-43e0-bf1a-33378fa4ba55")), + ncrAction = RemoteConnect + } + +testObject_NewConnectionRequest2 :: NewConnectionRequest +testObject_NewConnectionRequest2 = + NewConnectionRequest + { ncrFrom = Id (fromJust (UUID.fromString "69f66843-6cf1-48fb-8c05-1cf58c23566a")), + ncrTo = Id (fromJust (UUID.fromString "1669240c-c510-43e0-bf1a-33378fa4ba55")), + ncrAction = RemoteRescind + } diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionResponse.hs new file mode 100644 index 00000000000..23c8833459a --- /dev/null +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionResponse.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Federation.Golden.NewConnectionResponse where + +import Imports +import Wire.API.Federation.API.Brig + +testObject_NewConnectionResponse1 :: NewConnectionResponse +testObject_NewConnectionResponse1 = NewConnectionResponseOk Nothing + +testObject_NewConnectionResponse2 :: NewConnectionResponse +testObject_NewConnectionResponse2 = NewConnectionResponseOk (Just RemoteConnect) + +testObject_NewConnectionResponse3 :: NewConnectionResponse +testObject_NewConnectionResponse3 = NewConnectionResponseOk (Just RemoteRescind) + +testObject_NewConnectionResponse4 :: NewConnectionResponse +testObject_NewConnectionResponse4 = NewConnectionResponseUserNotActivated diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest1.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest1.json new file mode 100644 index 00000000000..cebe1dfa478 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest1.json @@ -0,0 +1,5 @@ +{ + "to": "1669240c-c510-43e0-bf1a-33378fa4ba55", + "from": "69f66843-6cf1-48fb-8c05-1cf58c23566a", + "action": "RemoteConnect" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest2.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest2.json new file mode 100644 index 00000000000..46109706108 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest2.json @@ -0,0 +1,5 @@ +{ + "to": "1669240c-c510-43e0-bf1a-33378fa4ba55", + "from": "69f66843-6cf1-48fb-8c05-1cf58c23566a", + "action": "RemoteRescind" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse1.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse1.json new file mode 100644 index 00000000000..61c94bf0db3 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse1.json @@ -0,0 +1,4 @@ +{ + "tag": "NewConnectionResponseOk", + "contents": null +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse2.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse2.json new file mode 100644 index 00000000000..84fa71d7368 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse2.json @@ -0,0 +1,4 @@ +{ + "tag": "NewConnectionResponseOk", + "contents": "RemoteConnect" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse3.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse3.json new file mode 100644 index 00000000000..aeee3a6db92 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse3.json @@ -0,0 +1,4 @@ +{ + "tag": "NewConnectionResponseOk", + "contents": "RemoteRescind" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse4.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse4.json new file mode 100644 index 00000000000..06b63107715 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse4.json @@ -0,0 +1,3 @@ +{ + "tag": "NewConnectionResponseUserNotActivated" +} \ No newline at end of file diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index 5fada7cdf10..e8729651c85 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 8106f61fbca587df7a82a89effeec838bb9d9326c84bd7af8f615502cedc152f +-- hash: 03f7245b036ccc38819ed5f5654dae8d96b7ec5917b2f898be3305193bc3faf5 name: wire-api-federation version: 0.1.0 @@ -82,6 +82,8 @@ test-suite spec Test.Wire.API.Federation.Golden.LeaveConversationRequest Test.Wire.API.Federation.Golden.LeaveConversationResponse Test.Wire.API.Federation.Golden.MessageSendResponse + Test.Wire.API.Federation.Golden.NewConnectionRequest + Test.Wire.API.Federation.Golden.NewConnectionResponse Test.Wire.API.Federation.Golden.Runner Test.Wire.API.Federation.GRPC.TypesSpec Paths_wire_api_federation diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index b08c802a5a3..18108e1cd3e 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -28,6 +28,7 @@ library: - cassandra-util - cassava >= 0.5 - cereal + - comonad - cookie - cryptonite - currency-codes >=2.0 diff --git a/libs/wire-api/src/Wire/API/Connection.hs b/libs/wire-api/src/Wire/API/Connection.hs index 73e60c50288..7a6e51d9067 100644 --- a/libs/wire-api/src/Wire/API/Connection.hs +++ b/libs/wire-api/src/Wire/API/Connection.hs @@ -31,6 +31,7 @@ module Wire.API.Connection Relation (..), RelationWithHistory (..), relationDropHistory, + relationWithHistory, -- * Requests ConnectionRequest (..), @@ -192,6 +193,17 @@ data RelationWithHistory deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform RelationWithHistory) +-- | Convert a 'Relation' to 'RelationWithHistory'. This is to be used only if +-- the MissingLegalholdConsent case does not need to be supported. +relationWithHistory :: Relation -> RelationWithHistory +relationWithHistory Accepted = AcceptedWithHistory +relationWithHistory Blocked = BlockedWithHistory +relationWithHistory Pending = PendingWithHistory +relationWithHistory Ignored = IgnoredWithHistory +relationWithHistory Sent = SentWithHistory +relationWithHistory Cancelled = CancelledWithHistory +relationWithHistory MissingLegalholdConsent = MissingLegalholdConsentFromCancelled + relationDropHistory :: RelationWithHistory -> Relation relationDropHistory = \case AcceptedWithHistory -> Accepted diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Util.hs b/libs/wire-api/src/Wire/API/Routes/Public/Util.hs index a2479de2afd..3779cdad365 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Util.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Util.hs @@ -20,8 +20,8 @@ module Wire.API.Routes.Public.Util where +import Control.Comonad import Data.SOP (I (..), NS (..)) -import Imports import Servant import Servant.Swagger.Internal.Orphans () import Wire.API.Routes.MultiVerb @@ -45,6 +45,13 @@ data ResponseForExistedCreated a | Created !a deriving (Functor) +instance Comonad ResponseForExistedCreated where + extract (Existed x) = x + extract (Created x) = x + + duplicate r@(Existed _) = Existed r + duplicate r@(Created _) = Created r + type ResponsesForExistedCreated eDesc cDesc a = '[ Respond 200 eDesc a, Respond 201 cDesc a diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index d76a81d602c..e365d0a9b45 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c6591983c73573c4734c452218e0831333768e896f0ab08718ba9f2c6b110567 +-- hash: 3acb28729470b6c8562eb847a9eb27f8ba8f9999ecce268b3a5a404e5f4794b6 name: wire-api version: 0.1.0 @@ -113,6 +113,7 @@ library , cassandra-util , cassava >=0.5 , cereal + , comonad , containers >=0.5 , cookie , cryptonite diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 0fafc20c83f..5ff67e3f5c0 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: 74882d161b7ecee96907491a40139775942d4f15987cbe1aa30d13b30fc79e0e +-- hash: 33acd5be229059e16903857f1923a9afcf55f285461298721a15d8d8c5b88a12 name: brig version: 1.35.0 @@ -22,6 +22,8 @@ library Brig.API Brig.API.Client Brig.API.Connection + Brig.API.Connection.Remote + Brig.API.Connection.Util Brig.API.Error Brig.API.Federation Brig.API.Handler @@ -137,6 +139,7 @@ library , bytestring >=0.10 , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 + , comonad , conduit >=1.2.8 , containers >=0.5 , cookie >=0.4 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index ff6f5a8574d..3adddffd60d 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -31,6 +31,7 @@ library: - bytestring >=0.10 - bytestring-conversion >=0.2 - cassandra-util >=0.16.2 + - comonad - conduit >=1.2.8 - containers >=0.5 - cookie >=0.4 diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index d8c7b4b97e5..fbf217927c5 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - -- TODO: Move to Brig.User.Connection (& split out Brig.User.Invitation?) -- | > docs/reference/user/connection.md {#RefConnection} @@ -33,6 +32,8 @@ module Brig.API.Connection ) where +import Brig.API.Connection.Remote +import Brig.API.Connection.Util import Brig.API.Error (errorDescriptionTypeToWai) import Brig.API.Types import Brig.API.User (getLegalHoldStatus) @@ -41,11 +42,9 @@ import qualified Brig.Data.Connection as Data import Brig.Data.Types (resultHasMore, resultList) import qualified Brig.Data.User as Data import qualified Brig.IO.Intra as Intra -import Brig.Options (setUserMaxConnections) import Brig.Types import Brig.Types.User.Event import Control.Error -import Control.Lens (view) import Control.Monad.Catch (throwM) import Data.Id as Id import qualified Data.LegalHold as LH @@ -59,21 +58,38 @@ import qualified System.Logger.Class as Log import System.Logger.Message import Wire.API.Connection (RelationWithHistory (..)) import Wire.API.ErrorDescription -import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -type ConnectionM = ExceptT ConnectionError AppIO +ensureIsActivated :: Local UserId -> MaybeT AppIO () +ensureIsActivated lusr = do + active <- lift $ Data.isActivated (lUnqualified lusr) + guard active + +ensureNotSameTeam :: Local UserId -> Local UserId -> ConnectionM () +ensureNotSameTeam self target = do + selfTeam <- lift $ Intra.getTeamId (lUnqualified self) + targetTeam <- lift $ Intra.getTeamId (lUnqualified target) + when (isJust selfTeam && selfTeam == targetTeam) $ + throwE ConnectSameBindingTeamUsers createConnection :: Local UserId -> ConnId -> Qualified UserId -> ConnectionM (ResponseForExistedCreated UserConnection) -createConnection lusr con = +createConnection self con target = do + -- basic checks: no need to distinguish between local and remote at this point + when (unTagged self == target) $ + throwE (InvalidUser target) + noteT ConnectNoIdentity $ + ensureIsActivated self + + -- branch according to whether we are connecting to a local or remote user foldQualified - lusr - (createConnectionToLocalUser lusr con) - (createConnectionToRemoteUser lusr con) + self + (createConnectionToLocalUser self con) + (createConnectionToRemoteUser self con) + target createConnectionToLocalUser :: Local UserId -> @@ -81,20 +97,10 @@ createConnectionToLocalUser :: 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 (lUnqualified target) - unless otherActive $ - throwE (InvalidUser (unTagged target)) + noteT (InvalidUser (unTagged target)) $ + ensureIsActivated 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 + ensureNotSameTeam self target s2o <- lift $ Data.lookupConnection self (unTagged target) o2s <- lift $ Data.lookupConnection target (unTagged self) @@ -109,7 +115,7 @@ createConnectionToLocalUser self conn target = do Log.info $ logConnection (lUnqualified self) (unTagged target) . msg (val "Creating connection") - qcnv <- Intra.createConnectConv self (unTagged target) Nothing (Just conn) + qcnv <- Intra.createConnectConv (unTagged self) (unTagged target) Nothing (Just conn) s2o' <- Data.insertConnection self (unTagged target) SentWithHistory qcnv o2s' <- Data.insertConnection target (unTagged self) PendingWithHistory qcnv e2o <- @@ -121,12 +127,12 @@ createConnectionToLocalUser self conn target = do 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 + (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) + (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) (Accepted, Accepted) -> return $ Existed s2o (Accepted, Blocked) -> return $ Existed s2o (Sent, Blocked) -> return $ Existed s2o - (Blocked, _) -> throwE $ InvalidTransition (lUnqualified self) Sent + (Blocked, _) -> throwE $ InvalidTransition (lUnqualified self) (_, Blocked) -> change s2o SentWithHistory (_, Sent) -> accept s2o o2s (_, Accepted) -> accept s2o o2s @@ -169,19 +175,6 @@ createConnectionToLocalUser self conn target = do 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 (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 @@ -208,12 +201,26 @@ checkLegalholdPolicyConflict uid1 uid2 = do oneway status1 status2 oneway status2 status1 +updateConnection :: + Local UserId -> + Qualified UserId -> + Relation -> + Maybe ConnId -> + ConnectionM (Maybe UserConnection) +updateConnection self other newStatus conn = + let doUpdate = + foldQualified + self + (updateConnectionToLocalUser self) + (updateConnectionToRemoteUser self) + in doUpdate other newStatus conn + -- | Change the status of a connection from one user to another. -- -- Note: 'updateConnection' doesn't explicitly check that users don't belong to the same team, -- because a connection between two team members can not exist in the first place. -- {#RefConnectionTeam} -updateConnection :: +updateConnectionToLocalUser :: -- | From Local UserId -> -- | To @@ -222,15 +229,15 @@ updateConnection :: Relation -> -- | Acting device connection ID Maybe ConnId -> - ExceptT ConnectionError AppIO (Maybe UserConnection) -updateConnection self other newStatus conn = do + ConnectionM (Maybe UserConnection) +updateConnectionToLocalUser self other newStatus conn = do s2o <- localConnection self other o2s <- localConnection other self s2o' <- case (ucStatus s2o, ucStatus o2s, newStatus) of -- missing legalhold consent: call 'updateConectionInternal' instead. - (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (lUnqualified self) newStatus - (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) newStatus - (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) newStatus + (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (lUnqualified self) + (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) + (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) -- Pending -> {Blocked, Ignored, Accepted} (Pending, _, Blocked) -> block s2o (Pending, _, Ignored) -> change s2o Ignored @@ -266,7 +273,7 @@ updateConnection self other newStatus conn = do -- no change (old, _, new) | old == new -> return Nothing -- invalid - _ -> throwE $ InvalidTransition (lUnqualified self) newStatus + _ -> throwE $ InvalidTransition (lUnqualified self) let s2oUserConn = s2o' lift . for_ s2oUserConn $ \c -> let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing @@ -464,13 +471,3 @@ lookupConnections from start size = do lusr <- qualifyLocal from rs <- Data.lookupLocalConnections lusr start size return $! UserConnectionList (Data.resultList rs) (Data.resultHasMore rs) - --- Helpers - -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 (lUnqualified u) diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs new file mode 100644 index 00000000000..12213cfbd1a --- /dev/null +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -0,0 +1,266 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.API.Connection.Remote + ( performLocalAction, + performRemoteAction, + createConnectionToRemoteUser, + updateConnectionToRemoteUser, + ) +where + +import Brig.API.Connection.Util (ConnectionM, checkLimit) +import Brig.API.Types (ConnectionError (..)) +import Brig.App +import qualified Brig.Data.Connection as Data +import Brig.Federation.Client (sendConnectionAction) +import qualified Brig.IO.Intra as Intra +import Brig.Types +import Brig.Types.User.Event +import Control.Comonad +import Control.Error.Util ((??)) +import Control.Monad.Trans.Except (runExceptT, throwE) +import Data.Id as Id +import Data.Qualified +import Data.Tagged +import Data.UUID.V4 +import Imports +import Network.Wai.Utilities.Error +import Wire.API.Connection (relationWithHistory) +import Wire.API.Federation.API.Brig + ( NewConnectionResponse (..), + RemoteConnectionAction (..), + ) +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) + +data LocalConnectionAction + = LocalConnect + | LocalBlock + | LocalIgnore + | LocalRescind + deriving (Eq) + +data ConnectionAction + = LCA LocalConnectionAction + | RCA RemoteConnectionAction + +-- | Connection state transition logic. +-- +-- In the following, A is a local user, and B is a remote user. +-- +-- LocalConnect: A communicates that they now want to connect. This +-- transitions Pending → Accepted, and every other state (but including Sent) to Sent. +-- LocalBlock: A communicates that they do not want to connect. This +-- transitions every state except Blocked to Blocked. +-- LocalIgnore: A ignores the connection. Pending → Ignored. +-- LocalRescind: A withdraws their intention to connect. Sent → Cancelled, Accepted → Pending. +-- RemoteConnect: B communicates that they now want to connect. Sent → Accepted, Cancelled → Pending, Accepted → Accepted. +-- RemoteRescind: B withdraws their intention to connect. Pending → Cancelled, Accepted → Sent. +-- +-- Returns 'Nothing' if no transition is possible from the current state for +-- the given action. This results in an 'InvalidTransition' error if the +-- connection does not exist. +transition :: ConnectionAction -> Relation -> Maybe Relation +-- MissingLegalholdConsent is treated exactly like blocked +transition action MissingLegalholdConsent = transition action Blocked +transition (LCA LocalConnect) Pending = Just Accepted +transition (LCA LocalConnect) Accepted = Just Accepted +transition (LCA LocalConnect) _ = Just Sent +transition (LCA LocalBlock) Blocked = Nothing +transition (LCA LocalBlock) _ = Just Blocked +transition (LCA LocalIgnore) Pending = Just Ignored +transition (LCA LocalIgnore) _ = Nothing +transition (LCA LocalRescind) Sent = Just Cancelled +-- The following transition is to make sure we always end up in state P +-- when we start in S and receive the two actions RC and LR in an arbitrary +-- order. +transition (LCA LocalRescind) Accepted = Just Pending +transition (LCA LocalRescind) _ = Nothing +transition (RCA RemoteConnect) Sent = Just Accepted +transition (RCA RemoteConnect) Accepted = Just Accepted +transition (RCA RemoteConnect) Blocked = Nothing +transition (RCA RemoteConnect) _ = Just Pending +transition (RCA RemoteRescind) Pending = Just Cancelled +-- The following transition is to make sure we always end up in state S +-- when we start in P and receive the two actions LC and RR in an arbitrary +-- order. +transition (RCA RemoteRescind) Accepted = Just Sent +transition (RCA RemoteRescind) _ = Nothing + +-- When user A has made a request -> Only user A's membership in conv is affected -> User A wants to be in one2one conv with B, or User A doesn't want to be in one2one conv with B +updateOne2OneConv :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Maybe (Qualified ConvId) -> + Relation -> + AppIO (Qualified ConvId) +updateOne2OneConv _ _ _ _ _ = do + -- FUTUREWORK: use galley internal API to update 1-1 conversation and retrieve ID + uid <- liftIO nextRandom + unTagged <$> qualifyLocal (Id uid) + +-- | Perform a state transition on a connection, handle conversation updates and +-- push events. +-- +-- NOTE: This function does not check whether the max connection limit has been +-- reached, the consumers must ensure of this. +-- +-- Returns the connection, and whether it was updated or not. +transitionTo :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Maybe UserConnection -> + Maybe Relation -> + ConnectionM (ResponseForExistedCreated UserConnection, Bool) +transitionTo self _ _ Nothing Nothing = + -- This can only happen if someone tries to ignore as a first action on a + -- connection. This shouldn't be possible. + throwE (InvalidTransition (lUnqualified self)) +transitionTo self mzcon other Nothing (Just rel) = lift $ do + -- update 1-1 connection + qcnv <- updateOne2OneConv self mzcon other Nothing rel + + -- create connection + connection <- + Data.insertConnection + self + (unTagged other) + (relationWithHistory rel) + qcnv + + -- send event + pushEvent self mzcon connection + pure (Created connection, True) +transitionTo _self _zcon _other (Just connection) Nothing = pure (Existed connection, False) +transitionTo self mzcon other (Just connection) (Just rel) = lift $ do + -- update 1-1 conversation + void $ updateOne2OneConv self Nothing other (ucConvId connection) rel + + -- update connection + connection' <- Data.updateConnection connection (relationWithHistory rel) + + -- send event + pushEvent self mzcon connection' + pure (Existed connection', True) + +-- | Send an event to the local user when the state of a connection changes. +pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> AppIO () +pushEvent self mzcon connection = do + let event = ConnectionUpdated connection Nothing Nothing + Intra.onConnectionEvent (lUnqualified self) mzcon event + +performLocalAction :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Maybe UserConnection -> + LocalConnectionAction -> + ConnectionM (ResponseForExistedCreated UserConnection, Bool) +performLocalAction self mzcon other mconnection action = do + let rel0 = maybe Cancelled ucStatus mconnection + checkLimitForLocalAction self rel0 action + mrel2 <- for (transition (LCA action) rel0) $ \rel1 -> do + mreaction <- fmap join . for (remoteAction action) $ \ra -> do + response <- sendConnectionAction self other ra !>> ConnectFederationError + case (response :: NewConnectionResponse) of + NewConnectionResponseOk reaction -> pure reaction + NewConnectionResponseUserNotActivated -> throwE (InvalidUser (unTagged other)) + pure $ + fromMaybe rel1 $ do + reactionAction <- (mreaction :: Maybe RemoteConnectionAction) + transition (RCA reactionAction) rel1 + transitionTo self mzcon other mconnection mrel2 + where + remoteAction :: LocalConnectionAction -> Maybe RemoteConnectionAction + remoteAction LocalConnect = Just RemoteConnect + remoteAction LocalRescind = Just RemoteRescind + remoteAction _ = Nothing + +-- | The 'RemoteConnectionAction' "reaction" that may be returned is processed +-- by the remote caller. This extra action allows to automatically resolve some +-- inconsistent states, for example: +-- +-- Without any reaction +-- @ +-- A B +-- A connects: Sent Pending +-- B ignores: Sent Ignore +-- B connects: Accepted Sent +-- @ +-- +-- Using the reaction returned by A +-- +-- @ +-- A B +-- A connects: Sent Pending +-- B ignores: Sent Ignore +-- B connects & A reacts: Accepted Accepted +-- @ +performRemoteAction :: + Local UserId -> + Remote UserId -> + Maybe UserConnection -> + RemoteConnectionAction -> + AppIO (Maybe RemoteConnectionAction) +performRemoteAction self other mconnection action = do + let rel0 = maybe Cancelled ucStatus mconnection + let rel1 = transition (RCA action) rel0 + result <- runExceptT . void $ transitionTo self Nothing other mconnection rel1 + pure $ either (const (Just RemoteRescind)) (const (reaction rel1)) result + where + reaction :: Maybe Relation -> Maybe RemoteConnectionAction + reaction (Just Accepted) = Just RemoteConnect + reaction (Just Sent) = Just RemoteConnect + reaction _ = Nothing + +createConnectionToRemoteUser :: + Local UserId -> + ConnId -> + Remote UserId -> + ConnectionM (ResponseForExistedCreated UserConnection) +createConnectionToRemoteUser self zcon other = do + mconnection <- lift $ Data.lookupConnection self (unTagged other) + fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect + +updateConnectionToRemoteUser :: + Local UserId -> + Remote UserId -> + Relation -> + Maybe ConnId -> + ConnectionM (Maybe UserConnection) +updateConnectionToRemoteUser self other rel1 zcon = do + mconnection <- lift $ Data.lookupConnection self (unTagged other) + action <- + actionForTransition rel1 + ?? InvalidTransition (lUnqualified self) + (conn, wasUpdated) <- performLocalAction self zcon other mconnection action + pure $ guard wasUpdated $> extract conn + where + actionForTransition Cancelled = Just LocalRescind + actionForTransition Sent = Just LocalConnect + actionForTransition Accepted = Just LocalConnect + actionForTransition Blocked = Just LocalBlock + actionForTransition Ignored = Just LocalIgnore + actionForTransition Pending = Nothing + actionForTransition MissingLegalholdConsent = Nothing + +checkLimitForLocalAction :: Local UserId -> Relation -> LocalConnectionAction -> ConnectionM () +checkLimitForLocalAction u oldRel action = + when (oldRel `notElem` [Accepted, Sent] && (action == LocalConnect)) $ + checkLimit u diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs new file mode 100644 index 00000000000..bc054986ca9 --- /dev/null +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -0,0 +1,44 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.API.Connection.Util + ( ConnectionM, + checkLimit, + ) +where + +import Brig.API.Types +import Brig.App +import qualified Brig.Data.Connection as Data +import Brig.Options (Settings (setUserMaxConnections)) +import Control.Error (noteT) +import Control.Lens (view) +import Control.Monad.Trans.Except +import Data.Id (UserId) +import Data.Qualified (Local, lUnqualified) +import Imports +import Wire.API.Connection (Relation (..)) + +type ConnectionM = ExceptT ConnectionError AppIO + +-- Helpers + +checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () +checkLimit u = noteT (TooManyConnections (lUnqualified u)) $ do + n <- lift $ Data.countConnections u [Accepted, Sent] + l <- setUserMaxConnections <$> view settings + guard (n < l) diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index edce3880082..a2c87b1b063 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -116,6 +116,7 @@ connError (ConnectInvalidEmail _ _) = StdError invalidEmail connError ConnectInvalidPhone {} = StdError invalidPhone connError ConnectSameBindingTeamUsers = StdError sameBindingTeamUsers connError ConnectMissingLegalholdConsent = StdError (errorDescriptionTypeToWai @MissingLegalholdConsent) +connError (ConnectFederationError e) = fedError e actError :: ActivationError -> Error actError (UserKeyExists _) = StdError userKeyExists diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 9ef12ad8a1e..a397357e3ba 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -18,13 +20,20 @@ module Brig.API.Federation (federationSitemap) where import qualified Brig.API.Client as API +import Brig.API.Connection.Remote (performRemoteAction) import Brig.API.Error (clientError) import Brig.API.Handler (Handler) import qualified Brig.API.User as API +import Brig.App (qualifyLocal) +import qualified Brig.Data.Connection as Data +import qualified Brig.Data.User as Data import Brig.Types (PrekeyBundle) import Brig.User.API.Handle +import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, UserId) +import Data.Qualified +import Data.Tagged (Tagged (unTagged)) import Imports import Network.Wai.Utilities.Error ((!>>)) import Servant (ServerT) @@ -51,9 +60,22 @@ federationSitemap = Federated.claimPrekeyBundle = claimPrekeyBundle, Federated.claimMultiPrekeyBundle = claimMultiPrekeyBundle, Federated.searchUsers = searchUsers, - Federated.getUserClients = getUserClients + Federated.getUserClients = getUserClients, + Federated.sendConnectionAction = sendConnectionAction } +sendConnectionAction :: Domain -> NewConnectionRequest -> Handler NewConnectionResponse +sendConnectionAction originDomain NewConnectionRequest {..} = do + active <- lift $ Data.isActivated ncrTo + if active + then do + self <- qualifyLocal ncrTo + let other = toRemote $ Qualified ncrFrom originDomain + mconnection <- lift $ Data.lookupConnection self (unTagged other) + maction <- lift $ performRemoteAction self other mconnection ncrAction + pure $ NewConnectionResponseOk maction + else pure NewConnectionResponseUserNotActivated + getUserByHandle :: Handle -> Handler (Maybe UserProfile) getUserByHandle handle = lift $ do maybeOwnerId <- API.lookupHandle handle diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 4b2ec723dc9..057006c2b8c 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -98,7 +98,6 @@ import qualified System.Logger.Class as Log import Util.Logging (logFunction, logHandle, logTeam, logUser) import qualified Wire.API.Connection as Public import Wire.API.ErrorDescription -import Wire.API.Federation.Error (federationNotImplemented) import qualified Wire.API.Properties as Public import qualified Wire.API.Routes.MultiTablePaging as Public import Wire.API.Routes.Public.Brig (Api (updateConnectionUnqualified)) @@ -1098,19 +1097,15 @@ createConnection self conn target = do updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) updateLocalConnection self conn other update = do - let newStatus = Public.cuStatus update - lself <- qualifyLocal self lother <- qualifyLocal other - mc <- API.updateConnection lself lother newStatus (Just conn) !>> connError - return $ maybe Public.Unchanged Public.Updated mc + updateConnection self conn (unTagged lother) update --- | FUTUREWORK: also update remote connections: https://wearezeta.atlassian.net/browse/SQCORE-959 updateConnection :: UserId -> ConnId -> Qualified UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) -updateConnection self conn (Qualified otherUid otherDomain) update = do - localDomain <- viewFederationDomain - if localDomain == otherDomain - then updateLocalConnection self conn otherUid update - else throwM federationNotImplemented +updateConnection self conn other update = do + let newStatus = Public.cuStatus update + lself <- qualifyLocal self + mc <- API.updateConnection lself other newStatus (Just conn) !>> connError + return $ maybe Public.Unchanged Public.Updated mc listLocalConnections :: UserId -> Maybe UserId -> Maybe (Range 1 500 Int32) -> Handler Public.UserConnectionList listLocalConnections uid start msize = do @@ -1161,16 +1156,13 @@ listConnections uid Public.GetMultiTablePageRequest {..} = do getLocalConnection :: UserId -> UserId -> Handler (Maybe Public.UserConnection) getLocalConnection self other = do - lself <- qualifyLocal self lother <- qualifyLocal other - lift $ Data.lookupConnection lself (unTagged lother) + getConnection self (unTagged lother) getConnection :: UserId -> Qualified UserId -> Handler (Maybe Public.UserConnection) -getConnection self (Qualified otherUser otherDomain) = do - localDomain <- viewFederationDomain - if localDomain == otherDomain - then getLocalConnection self otherUser - else throwM federationNotImplemented +getConnection self other = do + lself <- qualifyLocal self + lift $ Data.lookupConnection lself other deleteUser :: UserId -> diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index db2a8d95aa3..a0d4244199e 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -115,7 +115,7 @@ data ConnectionError -- when attempting to create or accept a connection. TooManyConnections UserId | -- | An invalid connection status change. - InvalidTransition UserId Relation + InvalidTransition UserId | -- | The target user in an connection attempt is invalid, e.g. not activated. InvalidUser (Qualified UserId) | -- | An attempt at updating a non-existent connection. @@ -133,6 +133,8 @@ data ConnectionError ConnectSameBindingTeamUsers | -- | Something doesn't work because somebody has a LH device and somebody else has not granted consent. ConnectMissingLegalholdConsent + | -- | Remote connection creation or update failed because of a federation error + ConnectFederationError FederationError data PasswordResetError = PasswordResetInProgress (Maybe Timeout) diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 583f186e861..dbd7db7d912 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -21,7 +21,9 @@ module Brig.Data.Connection ( -- * DB Operations insertConnection, updateConnection, + updateConnectionStatus, lookupConnection, + lookupRelation, lookupLocalConnectionsPage, lookupRemoteConnectionsPage, lookupRelationWithHistory, @@ -91,6 +93,15 @@ insertConnection self target rel qcnv@(Qualified cnv cdomain) = do updateConnection :: UserConnection -> RelationWithHistory -> AppIO UserConnection updateConnection c status = do self <- qualifyLocal (ucFrom c) + now <- updateConnectionStatus self (ucTo c) status + pure $ + c + { ucStatus = relationDropHistory status, + ucLastUpdate = now + } + +updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> AppIO UTCTimeMillis +updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (lUnqualified -> ltarget) = write connectionUpdate $ @@ -98,12 +109,8 @@ updateConnection c status = do 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 - { ucStatus = relationDropHistory status, - ucLastUpdate = now - } + retry x5 $ foldQualified self local remote target + pure now -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) @@ -142,6 +149,12 @@ lookupRelationWithHistory self target = do query1 remoteRelationSelect (params Quorum (lUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) +lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation +lookupRelation self target = + lookupRelationWithHistory self target <&> \case + Nothing -> Cancelled + Just relh -> (relationDropHistory relh) + -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage UserConnection) lookupLocalConnections lfrom start (fromRange -> size) = @@ -209,11 +222,16 @@ lookupContactListWithRelation u = countConnections :: Local UserId -> [Relation] -> AppIO Int64 countConnections u r = do rels <- retry x1 . query selectStatus $ params One (Identity (lUnqualified u)) - return $ foldl' count 0 rels + relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (lUnqualified u)) + + return $ foldl' count 0 rels + foldl' count 0 relsRemote where selectStatus :: QueryString R (Identity UserId) (Identity RelationWithHistory) selectStatus = "SELECT status FROM connection WHERE left = ?" + selectStatusRemote :: QueryString R (Identity UserId) (Identity RelationWithHistory) + selectStatusRemote = "SELECT status FROM connection_remote WHERE left = ?" + count n (Identity s) | (relationDropHistory s) `elem` r = n + 1 count n _ = n @@ -270,13 +288,13 @@ remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, Relatio 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 = "SELECT status, last_update, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" 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 = ?" +remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" remoteConnectionClear :: PrepQuery W (Identity UserId) () remoteConnectionClear = "DELETE FROM connection_remote where left = ?" diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index e0b732d3158..78bd55a5732 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -31,6 +31,7 @@ import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) import Data.Qualified +import Data.Tagged import qualified Data.Text as T import Imports import qualified System.Logger.Class as Log @@ -84,3 +85,13 @@ getUserClients :: Domain -> GetUserClients -> FederationAppIO (UserMap (Set PubC getUserClients domain guc = do Log.info $ Log.msg @Text "Brig-federation: get users' clients from remote backend" executeFederated domain $ FederatedBrig.getUserClients clientRoutes guc + +sendConnectionAction :: + Local UserId -> + Remote UserId -> + RemoteConnectionAction -> + FederationAppIO NewConnectionResponse +sendConnectionAction self (unTagged -> other) action = do + let req = NewConnectionRequest (lUnqualified self) (qUnqualified other) action + Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" + executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (lDomain self) req diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 8ab904015cc..28472c47796 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -288,7 +288,7 @@ rawPush (toList -> events) usrs orig route conn = do g ( method POST . path "/i/push/v2" - . zUser orig + . zUser orig -- FUTUREWORK: Remove, because gundeck handler ignores this. . json (map (mkPush rcps . snd) events) . expect2xx ) @@ -559,16 +559,22 @@ createLocalConnectConv from to cname conn = do . 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 +createConnectConv :: + Qualified UserId -> + Qualified UserId -> + Maybe Text -> + Maybe ConnId -> + AppIO (Qualified ConvId) +createConnectConv from to cname conn = do + lfrom <- ensureLocal from + lto <- ensureLocal to + unTagged . qualifyAs lfrom + <$> createLocalConnectConv lfrom lto cname conn + where + ensureLocal :: Qualified a -> AppIO (Local a) + ensureLocal x = do + loc <- qualifyLocal () + foldQualified loc pure (\_ -> throwM federationNotImplemented) x -- | Calls 'Galley.API.acceptConvH'. acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index 15e6a508405..8825e3240df 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -24,9 +24,9 @@ import Brig.Types import Control.Arrow (Arrow (first), (&&&)) import Data.Aeson (encode) import Data.Handle (Handle (..)) -import Data.Id (Id (..), UserId) +import Data.Id import qualified Data.Map as Map -import Data.Qualified (qUnqualified) +import Data.Qualified import qualified Data.Set as Set import qualified Data.UUID.V4 as UUIDv4 import Federation.Util (generateClientPrekeys) @@ -42,21 +42,22 @@ import Wire.API.Message (UserClients (..)) import Wire.API.User.Client (mkUserClientPrekeyMap) import Wire.API.UserMap (UserMap (UserMap)) +-- Note: POST /federation/send-connection-action is implicitly tested in API.User.Connection tests :: Manager -> Brig -> FedBrigClient -> IO TestTree tests m brig fedBrigClient = return $ testGroup "federation" - [ test m "GET /federation/search-users : Found" (testSearchSuccess brig fedBrigClient), - test m "GET /federation/search-users : NotFound" (testSearchNotFound fedBrigClient), - test m "GET /federation/search-users : Empty Input - NotFound" (testSearchNotFoundEmpty fedBrigClient), - test m "GET /federation/get-user-by-handle : Found" (testGetUserByHandleSuccess brig fedBrigClient), - test m "GET /federation/get-user-by-handle : NotFound" (testGetUserByHandleNotFound fedBrigClient), - test m "GET /federation/get-users-by-ids : 200 all found" (testGetUsersByIdsSuccess brig fedBrigClient), - test m "GET /federation/get-users-by-ids : 200 partially found" (testGetUsersByIdsPartial brig fedBrigClient), - test m "GET /federation/get-users-by-ids : 200 none found" (testGetUsersByIdsNoneFound fedBrigClient), - test m "GET /federation/claim-prekey : 200" (testClaimPrekeySuccess brig fedBrigClient), - test m "GET /federation/claim-prekey-bundle : 200" (testClaimPrekeyBundleSuccess brig fedBrigClient), + [ test m "POST /federation/search-users : Found" (testSearchSuccess brig fedBrigClient), + test m "POST /federation/search-users : NotFound" (testSearchNotFound fedBrigClient), + test m "POST /federation/search-users : Empty Input - NotFound" (testSearchNotFoundEmpty fedBrigClient), + test m "POST /federation/get-user-by-handle : Found" (testGetUserByHandleSuccess brig fedBrigClient), + test m "POST /federation/get-user-by-handle : NotFound" (testGetUserByHandleNotFound fedBrigClient), + test m "POST /federation/get-users-by-ids : 200 all found" (testGetUsersByIdsSuccess brig fedBrigClient), + test m "POST /federation/get-users-by-ids : 200 partially found" (testGetUsersByIdsPartial brig fedBrigClient), + test m "POST /federation/get-users-by-ids : 200 none found" (testGetUsersByIdsNoneFound fedBrigClient), + test m "POST /federation/claim-prekey : 200" (testClaimPrekeySuccess brig fedBrigClient), + test m "POST /federation/claim-prekey-bundle : 200" (testClaimPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/claim-multi-prekey-bundle : 200" (testClaimMultiPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/get-user-clients : 200" (testGetUserClients brig fedBrigClient), test m "POST /federation/get-user-clients : Not Found" (testGetUserClientsNotFound fedBrigClient) @@ -203,7 +204,7 @@ testGetUserClients brig fedBrigClient = do testGetUserClientsNotFound :: FedBrigClient -> Http () testGetUserClientsNotFound fedBrigClient = do - absentUserId :: UserId <- Id <$> lift UUIDv4.nextRandom + absentUserId <- randomId UserMap userClients <- FedBrig.getUserClients fedBrigClient (GetUserClients [absentUserId]) liftIO $ assertEqual diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index f2bea23d82a..2e7329bf5c2 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -85,7 +85,9 @@ createPopulatedBindingTeamWithNames brig names = do invitees <- forM names $ \name -> do inviteeEmail <- randomEmail let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation brig tid (userId inviter) invite + inv <- + responseJsonError =<< postInvitation brig tid (userId inviter) invite + Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> DB.ClientState -> IO TestTree -tests conf p b c ch g n aws db = do +tests :: Opt.Opts -> FedBrigClient -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> DB.ClientState -> IO TestTree +tests conf fbc p b c ch g n aws db = do let cl = ConnectionLimit $ Opt.setUserMaxConnections (Opt.optSettings conf) let at = Opt.setActivationTimeout (Opt.optSettings conf) z <- mkZAuthEnv (Just conf) @@ -52,7 +52,7 @@ tests conf p b c ch g n aws db = do [ API.User.Client.tests cl at conf p b c g, API.User.Account.tests cl at conf p b c ch g aws, API.User.Auth.tests conf p z b g n, - API.User.Connection.tests cl at conf p b c g db, + API.User.Connection.tests cl at conf p b c g fbc db, API.User.Handles.tests cl at conf p b c g, API.User.PasswordReset.tests cl at conf p b c g, API.User.Property.tests cl at conf p b c g, diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index eff003c6799..480b0dc5586 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -32,7 +32,7 @@ import Brig.Types.Intra import qualified Cassandra as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion -import Data.Domain (Domain (..)) +import Data.Domain import Data.Id hiding (client) import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified @@ -45,10 +45,11 @@ import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util import Wire.API.Connection +import qualified Wire.API.Federation.API.Brig as F import Wire.API.Routes.MultiTablePaging -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> DB.ClientState -> TestTree -tests cl _at _conf p b _c g db = +tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> FedBrigClient -> DB.ClientState -> TestTree +tests cl _at opts p b _c g fedBrigClient db = testGroup "connection" [ test p "post /connections" $ testCreateManualConnections b, @@ -80,7 +81,20 @@ tests cl _at _conf p b _c g db = test p "get /connections - 200 (paging)" $ testLocalConnectionsPaging b, test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging b db, test p "post /connections - 400 (max conns)" $ testConnectionLimit b cl, - test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl + test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl, + test p "Remote connections: connect with no federation" (testConnectFederationNotAvailable b), + test p "Remote connections: connect OK" (testConnectOK b fedBrigClient), + test p "Remote connections: connect with Anon" (testConnectWithAnon b fedBrigClient), + test p "Remote connections: connection from Anon" (testConnectFromAnon b), + test p "Remote connections: mutual Connect - local action then remote action" (testConnectMutualLocalActionThenRemoteAction opts b fedBrigClient), + test p "Remote connections: mutual Connect - remote action then local action" (testConnectMutualRemoteActionThenLocalAction opts b fedBrigClient), + test p "Remote connections: connect twice" (testConnectFromPending b fedBrigClient), + test p "Remote connections: ignore then accept" (testConnectFromIgnored opts b fedBrigClient), + test p "Remote connections: ignore, remote cancels, then accept" (testSentFromIgnored opts b fedBrigClient), + test p "Remote connections: block then accept" (testConnectFromBlocked opts b fedBrigClient), + test p "Remote connections: block, remote cancels, then accept" (testSentFromBlocked opts b fedBrigClient), + test p "Remote connections: send then cancel" (testCancel opts b), + test p "Remote connections: limits" (testConnectionLimits opts b fedBrigClient) ] testCreateConnectionInvalidUser :: Brig -> Http () @@ -689,3 +703,182 @@ testConnectionLimitQualified brig (ConnectionLimit l) = do assertLimited = do const 403 === statusCode const (Just "connection-limit") === fmap Error.label . responseJsonMaybe + +testConnectFederationNotAvailable :: Brig -> Http () +testConnectFederationNotAvailable brig = do + (uid1, quid2) <- localAndRemoteUser brig + postConnectionQualified brig uid1 quid2 + !!! const 422 === statusCode + +testConnectOK :: Brig -> FedBrigClient -> Http () +testConnectOK brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + +testConnectWithAnon :: Brig -> FedBrigClient -> Http () +testConnectWithAnon brig fedBrigClient = do + fromUser <- randomId + toUser <- userId <$> createAnonUser "anon1234" brig + res <- F.sendConnectionAction fedBrigClient (Domain "far-away.example.com") (F.NewConnectionRequest fromUser toUser F.RemoteConnect) + liftIO $ + assertEqual "The response should specify that the user is not activated" F.NewConnectionResponseUserNotActivated res + +testConnectFromAnon :: Brig -> Http () +testConnectFromAnon brig = do + anonUser <- userId <$> createAnonUser "anon1234" brig + remoteUser <- fakeRemoteUser + postConnectionQualified brig anonUser remoteUser !!! const 403 === statusCode + +testConnectMutualLocalActionThenRemoteAction :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectMutualLocalActionThenRemoteAction opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- First create a connection request from local to remote user, as this test + -- aims to test the behaviour of recieving a mutual request from remote + sendConnectionAction brig opts uid1 quid2 Nothing Sent + + -- The response should have 'RemoteConnect' as action, because we cannot be + -- sure if the remote was previously in Ignored state or not + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect (Just F.RemoteConnect) Accepted + +testConnectMutualRemoteActionThenLocalAction :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectMutualRemoteActionThenLocalAction opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- First create a connection request from remote to local user, as this test + -- aims to test the behaviour of sending a mutual request to remote + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + + -- The mock response has 'RemoteConnect' as action, because the remote backend + -- cannot be sure if the local backend was previously in Ignored state or not + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + +testConnectFromPending :: Brig -> FedBrigClient -> Http () +testConnectFromPending brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Cancelled + +testConnectFromIgnored :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectFromIgnored opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- set up an initial 'Ignored' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Ignored !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Ignored + + -- if the remote side sends a new connection request, we go back to 'Pending' + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + + -- if we accept, and the remote side still wants to connect, we transition to 'Accepted' + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + +testSentFromIgnored :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testSentFromIgnored opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- set up an initial 'Ignored' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Ignored !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Ignored + + -- if the remote side rescinds, we stay in 'Ignored' + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Ignored + + -- if we accept, and the remote does not want to connect anymore, we transition to 'Sent' + sendConnectionAction brig opts uid1 quid2 Nothing Sent + +testConnectFromBlocked :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectFromBlocked opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- set up an initial 'Blocked' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Blocked + + -- if the remote side sends a new connection request, we ignore it + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Blocked + + -- if we accept (or send a connection request), and the remote side still + -- wants to connect, we transition to 'Accepted' + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + +testSentFromBlocked :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testSentFromBlocked opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- set up an initial 'Blocked' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Blocked + + -- if the remote side rescinds, we stay in 'Blocked' + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Blocked + + -- if we accept, and the remote does not want to connect anymore, we transition to 'Sent' + sendConnectionAction brig opts uid1 quid2 Nothing Sent + +testCancel :: Opt.Opts -> Brig -> Http () +testCancel opts brig = do + (uid1, quid2) <- localAndRemoteUser brig + + sendConnectionAction brig opts uid1 quid2 Nothing Sent + sendConnectionUpdateAction brig opts uid1 quid2 Nothing Cancelled + +testConnectionLimits :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectionLimits opts brig fedBrigClient = do + let connectionLimit = Opt.setUserMaxConnections (Opt.optSettings opts) + (uid1, quid2) <- localAndRemoteUser brig + [quid3, quid4, quid5] <- replicateM 3 fakeRemoteUser + + -- set up N-1 connections from uid1 to remote users + (quid6Sent : _) <- replicateM (fromIntegral connectionLimit - 1) (newConn uid1) + + -- accepting another one should be allowed + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + + -- get an incoming connection requests beyond the limit, This connection + -- cannot be accepted. This is also the behaviour without federation, if the + -- user wants to accept this one, they have to either sacrifice another + -- connection or ask the backend operator to increase the limit. + receiveConnectionAction brig fedBrigClient uid1 quid3 F.RemoteConnect Nothing Pending + + -- accepting the second one hits the limit (and relation stays Pending): + sendConnectionActionExpectLimit uid1 quid3 (Just F.RemoteConnect) + assertConnectionQualified brig uid1 quid3 Pending + + -- When a remote accepts, it is allowed, this does not break the limit as a + -- Sent becomes an Accepted. + assertConnectionQualified brig uid1 quid6Sent Sent + receiveConnectionAction brig fedBrigClient uid1 quid6Sent F.RemoteConnect (Just F.RemoteConnect) Accepted + + -- attempting to send an own new connection request also hits the limit + sendConnectionActionExpectLimit uid1 quid4 (Just F.RemoteConnect) + getConnectionQualified brig uid1 quid4 !!! const 404 === statusCode + + -- (re-)sending an already accepted connection does not affect the limit + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + + -- blocked connections do not count towards the limit + putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Blocked + + -- after blocking quid2, we can now accept another connection request + receiveConnectionAction brig fedBrigClient uid1 quid5 F.RemoteConnect Nothing Pending + sendConnectionAction brig opts uid1 quid5 (Just F.RemoteConnect) Accepted + where + newConn :: UserId -> Http (Qualified UserId) + newConn from = do + to <- fakeRemoteUser + sendConnectionAction brig opts from to Nothing Sent + pure to + + sendConnectionActionExpectLimit :: HasCallStack => UserId -> Qualified UserId -> Maybe F.RemoteConnectionAction -> Http () + sendConnectionActionExpectLimit uid1 quid2 _reaction = do + postConnectionQualified brig uid1 quid2 !!! do + const 403 === statusCode + const (Just "connection-limit") === fmap Error.label . responseJsonMaybe diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 155a5c7e832..88febee65a3 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -22,6 +22,7 @@ module API.User.Util where import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Data.PasswordReset +import Brig.Options (Opts) import Brig.Types import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) @@ -37,17 +38,22 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LB -import Data.Domain (Domain) +import Data.Domain (Domain, domainText) import Data.Handle (Handle (Handle)) import Data.Id hiding (client) import Data.Misc (PlainTextPassword (..)) import Data.Qualified import Data.Range (unsafeRange) +import Data.String.Conversions (cs) import qualified Data.Text.Ascii as Ascii import qualified Data.Vector as Vec +import Federation.Util (withTempMockFederator) import Imports import Test.Tasty.HUnit import Util +import qualified Wire.API.Federation.API.Brig as F +import Wire.API.Federation.GRPC.Types hiding (body, path) +import qualified Wire.API.Federation.GRPC.Types as F import Wire.API.Routes.MultiTablePaging (LocalOrRemoteTable, MultiTablePagingState) newtype ConnectionLimit = ConnectionLimit Int64 @@ -310,12 +316,12 @@ countCookies brig u label = do return $ Vec.length <$> (preview (key "cookies" . _Array) =<< responseJsonMaybe @Value r) assertConnections :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> UserId -> [ConnectionStatus] -> m () -assertConnections brig u cs = +assertConnections brig u connections = listConnections brig u !!! do const 200 === statusCode const (Just True) === fmap (check . map status . clConnections) . responseJsonMaybe where - check xs = all (`elem` xs) cs + check xs = all (`elem` xs) connections status c = ConnectionStatus (ucFrom c) (qUnqualified $ ucTo c) (ucStatus c) assertConnectionQualified :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> UserId -> Qualified UserId -> Relation -> m () @@ -324,6 +330,68 @@ assertConnectionQualified brig u1 qu2 rel = const 200 === statusCode const (Right rel) === fmap ucStatus . responseJsonEither +receiveConnectionAction :: + HasCallStack => + Brig -> + FedBrigClient -> + UserId -> + Qualified UserId -> + F.RemoteConnectionAction -> + Maybe F.RemoteConnectionAction -> + Relation -> + Http () +receiveConnectionAction brig fedBrigClient uid1 quid2 action expectedReaction expectedRel = do + res <- + F.sendConnectionAction fedBrigClient (qDomain quid2) $ + F.NewConnectionRequest (qUnqualified quid2) uid1 action + liftIO $ do + res @?= F.NewConnectionResponseOk expectedReaction + assertConnectionQualified brig uid1 quid2 expectedRel + +sendConnectionAction :: + HasCallStack => + Brig -> + Opts -> + UserId -> + Qualified UserId -> + Maybe F.RemoteConnectionAction -> + Relation -> + Http () +sendConnectionAction brig opts uid1 quid2 reaction expectedRel = do + let mockConnectionResponse = F.NewConnectionResponseOk reaction + mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) + (res, reqs) <- + liftIO . withTempMockFederator opts (qDomain quid2) mockResponse $ + postConnectionQualified brig uid1 quid2 + + liftIO $ do + req <- assertOne reqs + F.domain req @?= domainText (qDomain quid2) + fmap F.component (F.request req) @?= Just F.Brig + fmap F.path (F.request req) @?= Just "/federation/send-connection-action" + eitherDecode . cs . F.body <$> F.request req + @?= Just (Right (F.NewConnectionRequest uid1 (qUnqualified quid2) F.RemoteConnect)) + + liftIO $ assertBool "postConnectionQualified failed" $ statusCode res `elem` [200, 201] + assertConnectionQualified brig uid1 quid2 expectedRel + +sendConnectionUpdateAction :: + HasCallStack => + Brig -> + Opts -> + UserId -> + Qualified UserId -> + Maybe F.RemoteConnectionAction -> + Relation -> + Http () +sendConnectionUpdateAction brig opts uid1 quid2 reaction expectedRel = do + let mockConnectionResponse = F.NewConnectionResponseOk reaction + mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) + void $ + liftIO . withTempMockFederator opts (qDomain quid2) mockResponse $ + putConnectionQualified brig uid1 quid2 expectedRel !!! const 200 === statusCode + assertConnectionQualified brig uid1 quid2 expectedRel + assertEmailVisibility :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> User -> User -> Bool -> m () assertEmailVisibility brig a b visible = get (brig . paths ["users", pack . show $ userId b] . zUser (userId a)) !!! do diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 566c4dd0b9f..75906db35c5 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -122,7 +122,7 @@ runTests iConf brigOpts otherArgs = do let fedBrigClient = mkFedBrigClient mg (brig iConf) emailAWSOpts <- parseEmailAWSOpts awsEnv <- AWS.mkEnv lg awsOpts emailAWSOpts mg - userApi <- User.tests brigOpts mg b c ch g n awsEnv db + userApi <- User.tests brigOpts fedBrigClient mg b c ch g n awsEnv db providerApi <- Provider.tests localDomain (provider iConf) mg db b c g searchApis <- Search.tests brigOpts mg g b teamApis <- Team.tests brigOpts mg n b c g awsEnv diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index cc9963d6c7e..06cdfa598d8 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -46,7 +46,7 @@ import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion -import Data.Domain (Domain, domainText, mkDomain) +import Data.Domain (Domain (..), domainText, mkDomain) import Data.Handle (Handle (..)) import Data.Id import Data.List1 (List1) @@ -131,6 +131,18 @@ twoRandomUsers brig = do uid2 = qUnqualified quid2 pure (quid1, uid1, quid2, uid2) +localAndRemoteUser :: + (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => + Brig -> + m (UserId, Qualified UserId) +localAndRemoteUser brig = do + uid1 <- userId <$> randomUser brig + quid2 <- fakeRemoteUser + pure (uid1, quid2) + +fakeRemoteUser :: (HasCallStack, MonadIO m) => m (Qualified UserId) +fakeRemoteUser = Qualified <$> randomId <*> pure (Domain "far-away.example.com") + randomUser :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> @@ -886,3 +898,7 @@ aFewTimes (exponentialBackoff 1000 <> limitRetries retries) (\_ -> pure . not . good) (\_ -> action) + +assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a +assertOne [a] = pure a +assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 2bcbf2ba80f..065f4f9768f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -229,7 +229,8 @@ emptyFederatedBrig = FederatedBrig.claimPrekeyBundle = \_ -> e "claimPrekeyBundle", FederatedBrig.claimMultiPrekeyBundle = \_ -> e "claimMultiPrekeyBundle", FederatedBrig.searchUsers = \_ -> e "searchUsers", - FederatedBrig.getUserClients = \_ -> e "getUserClients" + FederatedBrig.getUserClients = \_ -> e "getUserClients", + FederatedBrig.sendConnectionAction = \_ _ -> e "sendConnectionAction" } emptyFederatedGalley :: FederatedGalley.Api (AsServerT Handler) From c4c6763c8c262edbd25fec3c9cd08c62dea80881 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 7 Oct 2021 17:18:48 +0200 Subject: [PATCH 11/88] Fix more swagger validation errors (#1841) * Fix more swagger validation errors These could be prevented by turning some lists to sets in the swagger2 package, but for now we simply go through all the schemas in the `Swagger` structure, and apply `nub` on them. --- changelog.d/5-internal/fix-swagger-errors | 1 + services/brig/src/Brig/API/Public.hs | 18 ++++++++++++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) create mode 100644 changelog.d/5-internal/fix-swagger-errors diff --git a/changelog.d/5-internal/fix-swagger-errors b/changelog.d/5-internal/fix-swagger-errors new file mode 100644 index 00000000000..85628ccf63b --- /dev/null +++ b/changelog.d/5-internal/fix-swagger-errors @@ -0,0 +1 @@ +Fix more Swagger validation errors. diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 057006c2b8c..baccc478fc8 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -56,7 +56,7 @@ import Brig.User.Phone import qualified Cassandra as C import qualified Cassandra as Data import Control.Error hiding (bool) -import Control.Lens (view, (%~), (.~), (?~), (^.)) +import Control.Lens (view, (%~), (.~), (?~), (^.), _Just) import Control.Monad.Catch (throwM) import Data.Aeson hiding (json) import Data.ByteString.Conversion @@ -133,10 +133,24 @@ swaggerDocsAPI = & S.info . S.title .~ "Wire-Server API" & S.info . S.description ?~ desc & S.security %~ nub + -- sanitise definitions & S.definitions . traverse %~ sanitise + -- sanitise general responses + & S.responses . traverse . S.schema . _Just . S._Inline %~ sanitise + -- sanitise all responses of all paths + & S.allOperations . S.responses . S.responses + . traverse + . S._Inline + . S.schema + . _Just + . S._Inline + %~ sanitise where sanitise :: S.Schema -> S.Schema - sanitise = (S.properties . traverse . S._Inline %~ sanitise) . (S.required %~ nubOrd) + sanitise = + (S.properties . traverse . S._Inline %~ sanitise) + . (S.required %~ nubOrd) + . (S.enum_ . _Just %~ nub) desc = Text.pack [QQ.i| From 78d7ca6e407738a4479d2312d55fc7a1155e814d Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 7 Oct 2021 17:51:19 +0200 Subject: [PATCH 12/88] Various cleanups of Qualified and related types (#1839) * Refactor tagged Qualified types This makes the `Local` and `Remote` type constructor safer, because now it is not possible to change the domain inside a tagged value using the `Functor` instance. * Rename `partitionQualified` to `indexQualified` * Refactor partitionRemoteOrLocalIds Also rename it to partitionQualified and swap the order of results. * Refactor and rename `partitionRemote` The `partitionRemote` function has been renamed to `indexRemote` for consistency with `indexQualified`, and it now returns a list of `Remote [a]`, which preserves the information about the domains being remote. * Remove some uses of toRemoteUnsafe * Remove convId from ConversationMetadata Also change type of toRemoteUnsafe and toLocalUnsafe to just take a `Domain` and an `a` instead of `Qualified a`. * Remove one more use of toRemoteUnsafe * Remove lUnqualified and lDomain We can simply use the general versions that work for both qualified tags. * Remove renderQualified and corresponding test It was completely unused. * Use data kinds for Id tags * Better schema instance for `Qualified` values * Add CHANGELOG entry --- .../5-internal/refactor-tagged-qualified | 1 + changelog.d/6-federation/unqualify-conv-id | 1 + libs/galley-types/src/Galley/Types.hs | 1 - .../src/Galley/Types/Conversations/Members.hs | 3 +- libs/types-common/src/Data/Id.hs | 79 +++++++--- libs/types-common/src/Data/Misc.hs | 2 +- libs/types-common/src/Data/Qualified.hs | 146 ++++++++++-------- libs/types-common/test/Test/Qualified.hs | 15 +- .../src/Wire/API/Federation/API/Galley.hs | 5 +- libs/wire-api/src/Wire/API/Conversation.hs | 24 ++- .../ConversationList_20Conversation_user.hs | 6 +- .../API/Golden/Generated/Conversation_user.hs | 12 +- .../Wire/API/Golden/Generated/Event_user.hs | 6 +- .../Golden/Manual/ConversationsResponse.hs | 12 +- .../API/Golden/Manual/UserClientPrekeyMap.hs | 2 +- services/brig/src/Brig/API/Client.hs | 10 +- services/brig/src/Brig/API/Connection.hs | 83 +++++----- .../brig/src/Brig/API/Connection/Remote.hs | 17 +- services/brig/src/Brig/API/Connection/Util.hs | 4 +- services/brig/src/Brig/API/Federation.hs | 5 +- services/brig/src/Brig/API/Public.hs | 12 +- services/brig/src/Brig/API/User.hs | 4 +- services/brig/src/Brig/App.hs | 6 +- services/brig/src/Brig/Data/Connection.hs | 55 ++++--- services/brig/src/Brig/Federation/Client.hs | 7 +- services/brig/src/Brig/IO/Intra.hs | 21 ++- .../test/integration/Federation/End2end.hs | 2 +- services/galley/src/Galley/API/Create.hs | 7 +- services/galley/src/Galley/API/Federation.hs | 12 +- services/galley/src/Galley/API/Internal.hs | 9 +- services/galley/src/Galley/API/LegalHold.hs | 6 +- services/galley/src/Galley/API/Mapping.hs | 12 +- services/galley/src/Galley/API/Message.hs | 13 +- services/galley/src/Galley/API/Query.hs | 51 +++--- services/galley/src/Galley/API/Update.hs | 96 ++++++------ services/galley/src/Galley/API/Util.hs | 56 +++---- services/galley/src/Galley/Data.hs | 65 ++++---- services/galley/src/Galley/Types/UserList.hs | 5 +- services/galley/test/integration/API.hs | 17 +- .../galley/test/integration/API/Federation.hs | 2 +- services/galley/test/integration/API/Util.hs | 8 +- .../galley/test/unit/Test/Galley/Mapping.hs | 15 +- 42 files changed, 467 insertions(+), 448 deletions(-) create mode 100644 changelog.d/5-internal/refactor-tagged-qualified create mode 100644 changelog.d/6-federation/unqualify-conv-id diff --git a/changelog.d/5-internal/refactor-tagged-qualified b/changelog.d/5-internal/refactor-tagged-qualified new file mode 100644 index 00000000000..e884a8bb704 --- /dev/null +++ b/changelog.d/5-internal/refactor-tagged-qualified @@ -0,0 +1 @@ +Improve the `Qualified` abstraction and make local/remote tagging safer diff --git a/changelog.d/6-federation/unqualify-conv-id b/changelog.d/6-federation/unqualify-conv-id new file mode 100644 index 00000000000..65579183b13 --- /dev/null +++ b/changelog.d/6-federation/unqualify-conv-id @@ -0,0 +1 @@ +Make conversation ID of `RemoteConversation` unqualified and move it out of the metadata record. diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index 6b0a86f099e..e9f69bbb43a 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -24,7 +24,6 @@ module Galley.Types -- * re-exports ConversationMetadata (..), Conversation (..), - cnvQualifiedId, cnvType, cnvCreator, cnvAccess, diff --git a/libs/galley-types/src/Galley/Types/Conversations/Members.hs b/libs/galley-types/src/Galley/Types/Conversations/Members.hs index 7e6a88c6db8..42a3fb9ddad 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Members.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Members.hs @@ -30,7 +30,6 @@ where import Data.Domain import Data.Id as Id import Data.Qualified -import Data.Tagged import Imports import Wire.API.Conversation import Wire.API.Conversation.Role (RoleName) @@ -46,7 +45,7 @@ data RemoteMember = RemoteMember remoteMemberToOther :: RemoteMember -> OtherMember remoteMemberToOther x = OtherMember - { omQualifiedId = unTagged (rmId x), + { omQualifiedId = qUntagged (rmId x), omService = Nothing, omConvRoleName = rmConvRoleName x } diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index c06c897b7b4..60f418eba18 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -22,7 +21,36 @@ -- for UUID instances -module Data.Id where +module Data.Id + ( -- * Tagged IDs + Id (..), + IdTag, + KnownIdTag (..), + idTagName, + randomId, + AssetId, + InvitationId, + ConvId, + UserId, + ProviderId, + ServiceId, + TeamId, + ScimTokenId, + parseIdFromText, + idToText, + IdObject (..), + + -- * Client IDs + ClientId (..), + newClientId, + + -- * Other IDs + ConnId (..), + RequestId (..), + BotId (..), + NoId, + ) +where import Cassandra hiding (S) import Control.Lens ((?~)) @@ -56,39 +84,54 @@ import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Test.QuickCheck import Test.QuickCheck.Instances () -data A +data IdTag = A | C | I | U | P | S | T | STo -data C +idTagName :: IdTag -> Text +idTagName A = "Asset" +idTagName C = "Conv" +idTagName I = "Invitation" +idTagName U = "User" +idTagName P = "Provider" +idTagName S = "Service" +idTagName T = "Team" +idTagName STo = "ScimToken" -data I +class KnownIdTag (t :: IdTag) where + idTagValue :: IdTag -data U +instance KnownIdTag 'A where idTagValue = A -data P +instance KnownIdTag 'C where idTagValue = C -data S +instance KnownIdTag 'I where idTagValue = I -data T +instance KnownIdTag 'U where idTagValue = U -data STo +instance KnownIdTag 'P where idTagValue = P -type AssetId = Id A +instance KnownIdTag 'S where idTagValue = S -type InvitationId = Id I +instance KnownIdTag 'T where idTagValue = T + +instance KnownIdTag 'STo where idTagValue = STo + +type AssetId = Id 'A + +type InvitationId = Id 'I -- | A local conversation ID -type ConvId = Id C +type ConvId = Id 'C -- | A local user ID -type UserId = Id U +type UserId = Id 'U -type ProviderId = Id P +type ProviderId = Id 'P -type ServiceId = Id S +type ServiceId = Id 'S -type TeamId = Id T +type TeamId = Id 'T -type ScimTokenId = Id STo +type ScimTokenId = Id 'STo -- Id ------------------------------------------------------------------------- diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index cb0214a7102..2f731095dda 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -350,5 +350,5 @@ instance Arbitrary PlainTextPassword where -- -- Example: -- >>> let (FutureWork @'LegalholdPlusFederationNotImplemented -> _remoteUsers, localUsers) --- >>> = partitionRemoteOrLocalIds domain qualifiedUids +-- >>> = partitionQualified domain qualifiedUids newtype FutureWork label payload = FutureWork payload diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 6a01d6d10ac..84b6eb1572a 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE StrictData #-} @@ -21,35 +22,33 @@ module Data.Qualified ( -- * Qualified Qualified (..), + QualifiedWithTag, + tUnqualified, + tUnqualifiedL, + tDomain, + qUntagged, + qTagUnsafe, Remote, - toRemote, + toRemoteUnsafe, Local, - toLocal, - lUnqualified, - lDomain, + toLocalUnsafe, qualifyAs, foldQualified, - renderQualifiedId, - partitionRemoteOrLocalIds, - partitionRemoteOrLocalIds', partitionQualified, + indexQualified, + indexRemote, deprecatedSchema, - partitionRemote, ) where -import Control.Lens ((?~)) +import Control.Lens (Lens, lens, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) -import Data.Bifunctor (first) -import Data.Domain (Domain, domainText) +import Data.Domain (Domain) import Data.Handle (Handle (..)) -import Data.Id (Id (toUUID)) +import Data.Id import qualified Data.Map as Map import Data.Schema -import Data.String.Conversions (cs) import qualified Data.Swagger as S -import Data.Tagged -import qualified Data.UUID as UUID import Imports hiding (local) import Test.QuickCheck (Arbitrary (arbitrary)) @@ -62,72 +61,85 @@ data Qualified a = Qualified } deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) --- | A type to differentiate between generally Qualified values, and values --- where it is known if they are coming from a Remote backend or not. --- Use 'toRemote' or 'partitionRemoteOrLocalIds\'' to get Remote values and use --- 'unTagged' to convert from a Remote value back to a plain Qualified one. -type Remote a = Tagged "remote" (Qualified a) +data QTag = QLocal | QRemote + deriving (Eq, Show) --- | Convert a Qualified something to a Remote something. -toRemote :: Qualified a -> Remote a -toRemote = Tagged +-- | A type to differentiate between generally 'Qualified' values, and "tagged" values, +-- for which it is known whether they are coming from a remote or local backend. +-- Use 'foldQualified', 'partitionQualified' or 'qualifyLocal' to get tagged values and use +-- 'qUntagged' to convert from a tagged value back to a plain 'Qualified' one. +newtype QualifiedWithTag (t :: QTag) a = QualifiedWithTag {qUntagged :: Qualified a} + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + deriving newtype (Arbitrary) --- | A type representing a Qualified value where the domain is guaranteed to be --- the local one. -type Local a = Tagged "local" (Qualified a) +qTagUnsafe :: forall t a. Qualified a -> QualifiedWithTag t a +qTagUnsafe = QualifiedWithTag -toLocal :: Qualified a -> Local a -toLocal = Tagged +tUnqualified :: QualifiedWithTag t a -> a +tUnqualified = qUnqualified . qUntagged -lUnqualified :: Local a -> a -lUnqualified = qUnqualified . unTagged +tDomain :: QualifiedWithTag t a -> Domain +tDomain = qDomain . qUntagged -lDomain :: Local a -> Domain -lDomain = qDomain . unTagged +tUnqualifiedL :: Lens (QualifiedWithTag t a) (QualifiedWithTag t b) a b +tUnqualifiedL = lens tUnqualified qualifyAs + +-- | A type representing a 'Qualified' value where the domain is guaranteed to +-- be remote. +type Remote = QualifiedWithTag 'QRemote + +-- | Convert a 'Domain' and an @a@ to a 'Remote' value. This is only safe if we +-- already know that the domain is remote. +toRemoteUnsafe :: Domain -> a -> Remote a +toRemoteUnsafe d a = qTagUnsafe $ Qualified a d + +-- | A type representing a 'Qualified' value where the domain is guaranteed to +-- be local. +type Local = QualifiedWithTag 'QLocal + +-- | Convert a 'Domain' and an @a@ to a 'Local' value. This is only safe if we +-- already know that the domain is local. +toLocalUnsafe :: Domain -> a -> Local a +toLocalUnsafe d a = qTagUnsafe $ Qualified a d -- | Convert an unqualified value to a qualified one, with the same tag as the -- given tagged qualified value. -qualifyAs :: Tagged t (Qualified x) -> a -> Tagged t (Qualified a) -qualifyAs (Tagged q) x = Tagged (q $> x) +qualifyAs :: QualifiedWithTag t x -> a -> QualifiedWithTag t a +qualifyAs = ($>) foldQualified :: Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b foldQualified loc f g q - | lDomain loc == qDomain q = - f (toLocal q) + | tDomain loc == qDomain q = + f (qTagUnsafe q) | otherwise = - g (toRemote q) - --- | FUTUREWORK: Maybe delete this, it is only used in printing federation not --- implemented errors -renderQualified :: (a -> Text) -> Qualified a -> Text -renderQualified renderLocal (Qualified localPart domain) = - renderLocal localPart <> "@" <> domainText domain - --- FUTUREWORK: we probably want to use the primed function everywhere. Refactor these two functions to only have one. -partitionRemoteOrLocalIds :: Foldable f => Domain -> f (Qualified a) -> ([Qualified a], [a]) -partitionRemoteOrLocalIds localDomain = foldMap $ \qualifiedId -> - if qDomain qualifiedId == localDomain - then (mempty, [qUnqualified qualifiedId]) - else ([qualifiedId], mempty) - -partitionRemoteOrLocalIds' :: Foldable f => Domain -> f (Qualified a) -> ([Remote a], [a]) -partitionRemoteOrLocalIds' localDomain xs = first (fmap toRemote) $ partitionRemoteOrLocalIds localDomain xs - --- | Index a list of qualified values by domain -partitionQualified :: Foldable f => f (Qualified a) -> Map Domain [a] -partitionQualified = foldr add mempty + g (qTagUnsafe q) + +-- Partition a collection of qualified values into locals and remotes. +-- +-- Note that the local values are returned as unqualified values, as a (probably +-- insignificant) optimisation. Use 'partitionQualifiedAndTag' to get them as +-- 'Local' values. +partitionQualified :: Foldable f => Local x -> f (Qualified a) -> ([a], [Remote a]) +partitionQualified loc = + foldMap $ + foldQualified loc (\l -> ([tUnqualified l], mempty)) (\r -> (mempty, [r])) + +-- | Index a list of qualified values by domain. +indexQualified :: Foldable f => f (Qualified a) -> Map Domain [a] +indexQualified = foldr add mempty where add :: Qualified a -> Map Domain [a] -> Map Domain [a] add (Qualified x domain) = Map.insertWith (<>) domain [x] -partitionRemote :: (Functor f, Foldable f) => f (Remote a) -> [(Domain, [a])] -partitionRemote remotes = Map.assocs $ partitionQualified (unTagged <$> remotes) +indexRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]] +indexRemote = + map (uncurry toRemoteUnsafe) + . Map.assocs + . indexQualified + . fmap qUntagged ---------------------------------------------------------------------- -renderQualifiedId :: Qualified (Id a) -> Text -renderQualifiedId = renderQualified (cs . UUID.toString . toUUID) - deprecatedSchema :: S.HasDescription doc (Maybe Text) => Text -> ValueSchema doc a -> ValueSchema doc a deprecatedSchema new = doc . description ?~ ("Deprecated, use " <> new) @@ -142,19 +154,19 @@ qualifiedSchema name fieldName sch = <$> qUnqualified .= field fieldName sch <*> qDomain .= field "domain" schema -instance ToSchema (Qualified (Id a)) where - schema = qualifiedSchema "UserId" "id" schema +instance KnownIdTag t => ToSchema (Qualified (Id t)) where + schema = qualifiedSchema (idTagName (idTagValue @t) <> "Id") "id" schema instance ToSchema (Qualified Handle) where schema = qualifiedSchema "Handle" "handle" schema -instance ToJSON (Qualified (Id a)) where +instance KnownIdTag t => ToJSON (Qualified (Id t)) where toJSON = schemaToJSON -instance FromJSON (Qualified (Id a)) where +instance KnownIdTag t => FromJSON (Qualified (Id t)) where parseJSON = schemaParseJSON -instance S.ToSchema (Qualified (Id a)) where +instance KnownIdTag t => S.ToSchema (Qualified (Id t)) where declareNamedSchema = schemaToSwagger instance ToJSON (Qualified Handle) where diff --git a/libs/types-common/test/Test/Qualified.hs b/libs/types-common/test/Test/Qualified.hs index 8e11f791037..1787d475a99 100644 --- a/libs/types-common/test/Test/Qualified.hs +++ b/libs/types-common/test/Test/Qualified.hs @@ -22,14 +22,11 @@ where import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) import qualified Data.Aeson.Types as Aeson -import Data.Domain (Domain (..)) import Data.Handle (Handle) -import Data.Id (Id (..), UserId) -import Data.Qualified (Qualified (..), renderQualifiedId) -import qualified Data.UUID as UUID +import Data.Id (UserId) +import Data.Qualified (Qualified (..)) import Imports import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Type.Reflection (typeRep) @@ -42,13 +39,7 @@ tests = testQualifiedSerialization :: [TestTree] testQualifiedSerialization = - [ testCase "render 61a73a52-e526-4892-82a9-3d638d77629f@example.com" $ do - uuid <- - maybe (assertFailure "invalid UUID") pure $ - UUID.fromString "61a73a52-e526-4892-82a9-3d638d77629f" - assertEqual "" "61a73a52-e526-4892-82a9-3d638d77629f@example.com" $ - (renderQualifiedId (Qualified (Id uuid) (Domain "example.com"))), - jsonRoundtrip @(Qualified Handle), + [ jsonRoundtrip @(Qualified Handle), jsonRoundtrip @(Qualified UserId) ] diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index f3524abfb87..7a8f3b5b4a8 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -127,7 +127,10 @@ data RemoteConvMembers = RemoteConvMembers -- fields (muted/archived/hidden) are omitted, since they are not known by the -- remote backend. data RemoteConversation = RemoteConversation - { rcnvMetadata :: ConversationMetadata, + { -- | Id of the conversation, implicitly qualified with the domain of the + -- backend that created this value. + rcnvId :: ConvId, + rcnvMetadata :: ConversationMetadata, rcnvMembers :: RemoteConvMembers } deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index e65b0e0a884..49412c9d859 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -25,7 +25,6 @@ module Wire.API.Conversation ConversationMetadata (..), Conversation (..), mkConversation, - cnvQualifiedId, cnvType, cnvCreator, cnvAccess, @@ -116,9 +115,7 @@ import Wire.API.Routes.MultiTablePaging -- Conversation data ConversationMetadata = ConversationMetadata - { -- | A qualified conversation ID - cnvmQualifiedId :: Qualified ConvId, - cnvmType :: ConvType, + { cnvmType :: ConvType, -- FUTUREWORK: Make this a qualified user ID. cnvmCreator :: UserId, cnvmAccess :: [Access], @@ -143,10 +140,7 @@ conversationMetadataObjectSchema :: ConversationMetadata conversationMetadataObjectSchema = ConversationMetadata - <$> cnvmQualifiedId .= field "qualified_id" schema - <* (qUnqualified . cnvmQualifiedId) - .= optional (field "id" (deprecatedSchema "qualified_id" schema)) - <*> cnvmType .= field "type" schema + <$> cnvmType .= field "type" schema <*> cnvmCreator .= fieldWithDocModifier "creator" @@ -177,7 +171,9 @@ instance ToSchema ConversationMetadata where -- Can be produced from the internal one ('Galley.Data.Types.Conversation') -- by using 'Galley.API.Mapping.conversationView'. data Conversation = Conversation - { cnvMetadata :: ConversationMetadata, + { -- | A qualified conversation ID + cnvQualifiedId :: Qualified ConvId, + cnvMetadata :: ConversationMetadata, cnvMembers :: ConvMembers } deriving stock (Eq, Show, Generic) @@ -197,10 +193,7 @@ mkConversation :: Maybe ReceiptMode -> Conversation mkConversation qid ty uid acc role name mems tid ms rm = - Conversation (ConversationMetadata qid ty uid acc role name tid ms rm) mems - -cnvQualifiedId :: Conversation -> Qualified ConvId -cnvQualifiedId = cnvmQualifiedId . cnvMetadata + Conversation qid (ConversationMetadata ty uid acc role name tid ms rm) mems cnvType :: Conversation -> ConvType cnvType = cnvmType . cnvMetadata @@ -232,7 +225,10 @@ instance ToSchema Conversation where "Conversation" (description ?~ "A conversation object as returned from the server") $ Conversation - <$> cnvMetadata .= conversationMetadataObjectSchema + <$> cnvQualifiedId .= field "qualified_id" schema + <* (qUnqualified . cnvQualifiedId) + .= optional (field "id" (deprecatedSchema "qualified_id" schema)) + <*> cnvMetadata .= conversationMetadataObjectSchema <*> cnvMembers .= field "members" schema modelConversation :: Doc.Model diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs index d23b8022f37..6c17eda72fc 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs @@ -32,10 +32,10 @@ testObject_ConversationList_20Conversation_user_1 = ConversationList { convList = [ Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = RegularConv, + { cnvmType = RegularConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs index 0ea5ad8e869..5b819cdd477 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs @@ -34,10 +34,10 @@ domain = Domain "golden.example.com" testObject_Conversation_user_1 :: Conversation testObject_Conversation_user_1 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = One2OneConv, + { cnvmType = One2OneConv, cnvmCreator = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, @@ -67,10 +67,10 @@ testObject_Conversation_user_1 = testObject_Conversation_user_2 :: Conversation testObject_Conversation_user_2 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), - cnvmType = SelfConv, + { cnvmType = SelfConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [ InviteAccess, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs index 8ec156d9092..6f5e8a6c28a 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs @@ -142,10 +142,10 @@ testObject_Event_user_8 = (read "1864-05-29 19:31:31.226 UTC") ( EdConversation ( Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) (Domain "golden.example.com"), - cnvmType = RegularConv, + { cnvmType = RegularConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [InviteAccess, PrivateAccess, LinkAccess, InviteAccess, InviteAccess, InviteAccess, LinkAccess], diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs index f91466f0dc5..534641eb826 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs @@ -29,10 +29,10 @@ testObject_ConversationsResponse_1 = conv1 :: Conversation conv1 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = One2OneConv, + { cnvmType = One2OneConv, cnvmCreator = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, @@ -62,10 +62,10 @@ conv1 = conv2 :: Conversation conv2 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), - cnvmType = SelfConv, + { cnvmType = SelfConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [ InviteAccess, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs index 1a095aaf335..c1751973c2d 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs @@ -19,7 +19,7 @@ module Test.Wire.API.Golden.Manual.UserClientPrekeyMap where -import Data.Id (ClientId (ClientId, client), Id (Id)) +import Data.Id import qualified Data.UUID as UUID (fromString) import GHC.Exts (IsList (fromList)) import Imports diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index c0a51bd18b5..024f27fb14c 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -69,7 +69,7 @@ import Data.List.Split (chunksOf) import Data.Map.Strict (traverseWithKey) import qualified Data.Map.Strict as Map import Data.Misc (PlainTextPassword (..)) -import Data.Qualified (Qualified (..), partitionQualified, partitionRemoteOrLocalIds) +import Data.Qualified import qualified Data.Set as Set import Galley.Types (UserClients (..)) import Imports @@ -106,14 +106,14 @@ lookupPubClients qid@(Qualified uid domain) = do lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError AppIO (QualifiedUserMap (Set PubClient)) lookupPubClientsBulk qualifiedUids = do - domain <- viewFederationDomain - let (remoteUsers, localUsers) = partitionRemoteOrLocalIds domain qualifiedUids + loc <- qualifyLocal () + let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids remoteUserClientMap <- traverseWithKey (\domain' uids -> getUserClients domain' (GetUserClients uids)) - (partitionQualified remoteUsers) + (indexQualified (fmap qUntagged remoteUsers)) !>> ClientFederationError - localUserClientMap <- Map.singleton domain <$> lookupLocalPubClientsBulk localUsers + localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError AppIO (UserMap (Set PubClient)) diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index fbf217927c5..6f4906622fc 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -51,7 +51,6 @@ import qualified Data.LegalHold as LH import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range -import Data.Tagged import Galley.Types (ConvType (..), cnvType) import Imports import qualified System.Logger.Class as Log @@ -62,13 +61,13 @@ import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) ensureIsActivated :: Local UserId -> MaybeT AppIO () ensureIsActivated lusr = do - active <- lift $ Data.isActivated (lUnqualified lusr) + active <- lift $ Data.isActivated (tUnqualified lusr) guard active ensureNotSameTeam :: Local UserId -> Local UserId -> ConnectionM () ensureNotSameTeam self target = do - selfTeam <- lift $ Intra.getTeamId (lUnqualified self) - targetTeam <- lift $ Intra.getTeamId (lUnqualified target) + selfTeam <- lift $ Intra.getTeamId (tUnqualified self) + targetTeam <- lift $ Intra.getTeamId (tUnqualified target) when (isJust selfTeam && selfTeam == targetTeam) $ throwE ConnectSameBindingTeamUsers @@ -79,7 +78,7 @@ createConnection :: ConnectionM (ResponseForExistedCreated UserConnection) createConnection self con target = do -- basic checks: no need to distinguish between local and remote at this point - when (unTagged self == target) $ + when (qUntagged self == target) $ throwE (InvalidUser target) noteT ConnectNoIdentity $ ensureIsActivated self @@ -97,12 +96,12 @@ createConnectionToLocalUser :: Local UserId -> ConnectionM (ResponseForExistedCreated UserConnection) createConnectionToLocalUser self conn target = do - noteT (InvalidUser (unTagged target)) $ + noteT (InvalidUser (qUntagged target)) $ ensureIsActivated target - checkLegalholdPolicyConflict (lUnqualified self) (lUnqualified target) + checkLegalholdPolicyConflict (tUnqualified self) (tUnqualified target) ensureNotSameTeam self target - s2o <- lift $ Data.lookupConnection self (unTagged target) - o2s <- lift $ Data.lookupConnection target (unTagged self) + s2o <- lift $ Data.lookupConnection self (qUntagged target) + o2s <- lift $ Data.lookupConnection target (qUntagged self) case update <$> s2o <*> o2s of Just rs -> rs @@ -113,26 +112,26 @@ createConnectionToLocalUser self conn target = do insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError AppIO UserConnection insert s2o o2s = lift $ do Log.info $ - logConnection (lUnqualified self) (unTagged target) + logConnection (tUnqualified self) (qUntagged target) . msg (val "Creating connection") - qcnv <- Intra.createConnectConv (unTagged self) (unTagged target) Nothing (Just conn) - s2o' <- Data.insertConnection self (unTagged target) SentWithHistory qcnv - o2s' <- Data.insertConnection target (unTagged self) PendingWithHistory qcnv + qcnv <- Intra.createConnectConv (qUntagged self) (qUntagged target) Nothing (Just conn) + s2o' <- Data.insertConnection self (qUntagged target) SentWithHistory qcnv + o2s' <- Data.insertConnection target (qUntagged self) PendingWithHistory qcnv e2o <- ConnectionUpdated o2s' (ucStatus <$> o2s) - <$> Data.lookupName (lUnqualified self) + <$> Data.lookupName (tUnqualified self) let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing - mapM_ (Intra.onConnectionEvent (lUnqualified self) (Just conn)) [e2o, e2s] + mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return s2o' update :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) update s2o o2s = case (ucStatus s2o, ucStatus o2s) of - (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) - (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) + (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) (Accepted, Accepted) -> return $ Existed s2o (Accepted, Blocked) -> return $ Existed s2o (Sent, Blocked) -> return $ Existed s2o - (Blocked, _) -> throwE $ InvalidTransition (lUnqualified self) + (Blocked, _) -> throwE $ InvalidTransition (tUnqualified self) (_, Blocked) -> change s2o SentWithHistory (_, Sent) -> accept s2o o2s (_, Accepted) -> accept s2o o2s @@ -145,7 +144,7 @@ createConnectionToLocalUser self conn target = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") cnv <- lift $ for (ucConvId s2o) $ Intra.acceptConnectConv self (Just conn) s2o' <- lift $ Data.updateConnection s2o AcceptedWithHistory @@ -157,9 +156,9 @@ createConnectionToLocalUser self conn target = do e2o <- lift $ ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (lUnqualified self) + <$> Data.lookupName (tUnqualified self) let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing - lift $ mapM_ (Intra.onConnectionEvent (lUnqualified self) (Just conn)) [e2o, e2s] + lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return $ Existed s2o' resend :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) @@ -167,7 +166,7 @@ createConnectionToLocalUser self conn target = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Resending connection request") s2o' <- insert (Just s2o) (Just o2s) return $ Existed s2o' @@ -235,9 +234,9 @@ updateConnectionToLocalUser self other newStatus conn = do o2s <- localConnection other self s2o' <- case (ucStatus s2o, ucStatus o2s, newStatus) of -- missing legalhold consent: call 'updateConectionInternal' instead. - (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (lUnqualified self) - (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) - (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) + (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) -- Pending -> {Blocked, Ignored, Accepted} (Pending, _, Blocked) -> block s2o (Pending, _, Ignored) -> change s2o Ignored @@ -273,18 +272,18 @@ updateConnectionToLocalUser self other newStatus conn = do -- no change (old, _, new) | old == new -> return Nothing -- invalid - _ -> throwE $ InvalidTransition (lUnqualified self) + _ -> throwE $ InvalidTransition (tUnqualified self) let s2oUserConn = s2o' lift . for_ s2oUserConn $ \c -> let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing - in Intra.onConnectionEvent (lUnqualified self) conn e2s + in Intra.onConnectionEvent (tUnqualified self) conn e2s return s2oUserConn where accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) accept s2o o2s = do checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") cnv <- lift $ traverse (Intra.acceptConnectConv self conn) (ucConvId s2o) -- Note: The check for @Pending@ accounts for situations in which both @@ -298,14 +297,14 @@ updateConnectionToLocalUser self other newStatus conn = do else Data.updateConnection o2s BlockedWithHistory e2o <- ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (lUnqualified self) - Intra.onConnectionEvent (lUnqualified self) conn e2o + <$> Data.lookupName (tUnqualified self) + Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o AcceptedWithHistory block :: UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) block s2o = lift $ do Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Blocking connection") traverse_ (Intra.blockConv self conn) (ucConvId s2o) Just <$> Data.updateConnection s2o BlockedWithHistory @@ -316,7 +315,7 @@ updateConnectionToLocalUser self other newStatus conn = do when (new `elem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Unblocking connection") cnv <- lift $ traverse (Intra.unblockConv self conn) (ucConvId s2o) when (ucStatus o2s == Sent && new == Accepted) . lift $ do @@ -326,21 +325,21 @@ updateConnectionToLocalUser self other newStatus conn = do else Data.updateConnection o2s BlockedWithHistory e2o :: ConnectionEvent <- ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (lUnqualified self) + <$> Data.lookupName (tUnqualified self) -- TODO: is this correct? shouldnt o2s be sent to other? - Intra.onConnectionEvent (lUnqualified self) conn e2o + Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) cancel s2o o2s = do Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Cancelling connection") 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 + lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled change :: UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) @@ -353,8 +352,8 @@ localConnection :: Local UserId -> ExceptT ConnectionError AppIO UserConnection localConnection la lb = do - lift (Data.lookupConnection la (unTagged lb)) - >>= tryJust (NotConnected (lUnqualified la) (unTagged lb)) + lift (Data.lookupConnection la (qUntagged lb)) + >>= tryJust (NotConnected (tUnqualified la) (qUntagged lb)) mkRelationWithHistory :: HasCallStack => Relation -> Relation -> RelationWithHistory mkRelationWithHistory oldRel = \case @@ -388,7 +387,7 @@ updateConnectionInternal = \case blockForMissingLegalholdConsent self others = do for_ others $ \(qualifyAs self -> other) -> do Log.info $ - logConnection (lUnqualified self) (unTagged other) + logConnection (tUnqualified self) (qUntagged other) . msg (val "Blocking connection (legalhold device present, but missing consent)") s2o <- localConnection self other @@ -398,7 +397,7 @@ updateConnectionInternal = \case 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 + Intra.onConnectionEvent (tUnqualified self) Nothing ev removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError AppIO () removeLHBlocksInvolving self = @@ -435,7 +434,7 @@ updateConnectionInternal = \case 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) + connName <- lift $ Data.lookupName (tUnqualified lfrom) let connEvent = ConnectionUpdated { ucConn = uconnRev', @@ -447,7 +446,7 @@ updateConnectionInternal = \case relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError AppIO RelationWithHistory relationWithHistory self target = lift (Data.lookupRelationWithHistory self target) - >>= tryJust (NotConnected (lUnqualified self) target) + >>= tryJust (NotConnected (tUnqualified self) target) undoRelationHistory :: RelationWithHistory -> RelationWithHistory undoRelationHistory = \case diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 12213cfbd1a..387b04c617c 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -36,7 +36,6 @@ import Control.Error.Util ((??)) import Control.Monad.Trans.Except (runExceptT, throwE) import Data.Id as Id import Data.Qualified -import Data.Tagged import Data.UUID.V4 import Imports import Network.Wai.Utilities.Error @@ -112,7 +111,7 @@ updateOne2OneConv :: updateOne2OneConv _ _ _ _ _ = do -- FUTUREWORK: use galley internal API to update 1-1 conversation and retrieve ID uid <- liftIO nextRandom - unTagged <$> qualifyLocal (Id uid) + qUntagged <$> qualifyLocal (Id uid) -- | Perform a state transition on a connection, handle conversation updates and -- push events. @@ -131,7 +130,7 @@ transitionTo :: transitionTo self _ _ Nothing Nothing = -- This can only happen if someone tries to ignore as a first action on a -- connection. This shouldn't be possible. - throwE (InvalidTransition (lUnqualified self)) + throwE (InvalidTransition (tUnqualified self)) transitionTo self mzcon other Nothing (Just rel) = lift $ do -- update 1-1 connection qcnv <- updateOne2OneConv self mzcon other Nothing rel @@ -140,7 +139,7 @@ transitionTo self mzcon other Nothing (Just rel) = lift $ do connection <- Data.insertConnection self - (unTagged other) + (qUntagged other) (relationWithHistory rel) qcnv @@ -163,7 +162,7 @@ transitionTo self mzcon other (Just connection) (Just rel) = lift $ do pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> AppIO () pushEvent self mzcon connection = do let event = ConnectionUpdated connection Nothing Nothing - Intra.onConnectionEvent (lUnqualified self) mzcon event + Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: Local UserId -> @@ -180,7 +179,7 @@ performLocalAction self mzcon other mconnection action = do response <- sendConnectionAction self other ra !>> ConnectFederationError case (response :: NewConnectionResponse) of NewConnectionResponseOk reaction -> pure reaction - NewConnectionResponseUserNotActivated -> throwE (InvalidUser (unTagged other)) + NewConnectionResponseUserNotActivated -> throwE (InvalidUser (qUntagged other)) pure $ fromMaybe rel1 $ do reactionAction <- (mreaction :: Maybe RemoteConnectionAction) @@ -235,7 +234,7 @@ createConnectionToRemoteUser :: Remote UserId -> ConnectionM (ResponseForExistedCreated UserConnection) createConnectionToRemoteUser self zcon other = do - mconnection <- lift $ Data.lookupConnection self (unTagged other) + mconnection <- lift $ Data.lookupConnection self (qUntagged other) fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: @@ -245,10 +244,10 @@ updateConnectionToRemoteUser :: Maybe ConnId -> ConnectionM (Maybe UserConnection) updateConnectionToRemoteUser self other rel1 zcon = do - mconnection <- lift $ Data.lookupConnection self (unTagged other) + mconnection <- lift $ Data.lookupConnection self (qUntagged other) action <- actionForTransition rel1 - ?? InvalidTransition (lUnqualified self) + ?? InvalidTransition (tUnqualified self) (conn, wasUpdated) <- performLocalAction self zcon other mconnection action pure $ guard wasUpdated $> extract conn where diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index bc054986ca9..0f1f7b5b10e 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -29,7 +29,7 @@ import Control.Error (noteT) import Control.Lens (view) import Control.Monad.Trans.Except import Data.Id (UserId) -import Data.Qualified (Local, lUnqualified) +import Data.Qualified (Local, tUnqualified) import Imports import Wire.API.Connection (Relation (..)) @@ -38,7 +38,7 @@ type ConnectionM = ExceptT ConnectionError AppIO -- Helpers checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () -checkLimit u = noteT (TooManyConnections (lUnqualified u)) $ do +checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do n <- lift $ Data.countConnections u [Accepted, Sent] l <- setUserMaxConnections <$> view settings guard (n < l) diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index a397357e3ba..2e9ea4ac12b 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -33,7 +33,6 @@ import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, UserId) import Data.Qualified -import Data.Tagged (Tagged (unTagged)) import Imports import Network.Wai.Utilities.Error ((!>>)) import Servant (ServerT) @@ -70,8 +69,8 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do if active then do self <- qualifyLocal ncrTo - let other = toRemote $ Qualified ncrFrom originDomain - mconnection <- lift $ Data.lookupConnection self (unTagged other) + let other = toRemoteUnsafe originDomain ncrFrom + mconnection <- lift $ Data.lookupConnection self (qUntagged other) maction <- lift $ performRemoteAction self other mconnection ncrAction pure $ NewConnectionResponseOk maction else pure NewConnectionResponseUserNotActivated diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index baccc478fc8..809a0e1f4d8 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -70,7 +70,7 @@ import Data.Handle (Handle, parseHandle) import Data.Id as Id import qualified Data.Map.Strict as Map import Data.Misc (IpAddr (..)) -import Data.Qualified (Local, Qualified (..), partitionRemoteOrLocalIds) +import Data.Qualified import Data.Range import Data.String.Interpolate as QQ import qualified Data.Swagger as S @@ -950,8 +950,8 @@ listUsersByIdsOrHandles self q = do Public.ListUsersByIds us -> byIds us Public.ListUsersByHandles hs -> do - domain <- viewFederationDomain - let (_remoteHandles, localHandles) = partitionRemoteOrLocalIds domain (fromRange hs) + loc <- qualifyLocal () + let (localHandles, _) = partitionQualified loc (fromRange hs) us <- getIds localHandles Handle.filterHandleResults self =<< byIds us case foundUsers of @@ -1102,7 +1102,7 @@ createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> H createConnectionUnqualified self conn cr = do lself <- qualifyLocal self target <- qualifyLocal (Public.crUser cr) - API.createConnection lself conn (unTagged target) !>> connError + API.createConnection lself conn (qUntagged target) !>> connError createConnection :: UserId -> ConnId -> Qualified UserId -> Handler (Public.ResponseForExistedCreated Public.UserConnection) createConnection self conn target = do @@ -1112,7 +1112,7 @@ createConnection self conn target = do updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) updateLocalConnection self conn other update = do lother <- qualifyLocal other - updateConnection self conn (unTagged lother) update + updateConnection self conn (qUntagged lother) update updateConnection :: UserId -> ConnId -> Qualified UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) updateConnection self conn other update = do @@ -1171,7 +1171,7 @@ listConnections uid Public.GetMultiTablePageRequest {..} = do getLocalConnection :: UserId -> UserId -> Handler (Maybe Public.UserConnection) getLocalConnection self other = do lother <- qualifyLocal other - getConnection self (unTagged lother) + getConnection self (qUntagged lother) getConnection :: UserId -> Qualified UserId -> Handler (Maybe Public.UserConnection) getConnection self other = do diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e39aba706a7..c2741ef9063 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -144,7 +144,7 @@ import Data.List1 (List1) import qualified Data.Map.Strict as Map import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) -import Data.Qualified (Qualified, partitionQualified) +import Data.Qualified (Qualified, indexQualified) import Data.Time.Clock (addUTCTime, diffUTCTime) import Data.UUID.V4 (nextRandom) import qualified Galley.Types.Teams as Team @@ -1140,7 +1140,7 @@ lookupProfiles :: ExceptT FederationError AppIO [UserProfile] lookupProfiles self others = do localDomain <- viewFederationDomain - let userMap = partitionQualified others + let userMap = indexQualified others -- FUTUREWORK(federation): parallelise federator requests here fold <$> traverse (uncurry (getProfiles localDomain)) (Map.assocs userMap) where diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 65a2e3020f1..00899404253 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -107,7 +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.Qualified import Data.Text (unpack) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) @@ -540,8 +540,8 @@ readTurnList = Text.readFile >=> return . fn . mapMaybe fromByteString . fmap Te -------------------------------------------------------------------------------- -- Federation -viewFederationDomain :: MonadReader Env m => m (Domain) +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 +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index dbd7db7d912..342704fc711 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -60,7 +60,6 @@ import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified import Data.Range -import Data.Tagged import Data.Time (getCurrentTime) import Imports hiding (local) import UnliftIO.Async (pooledMapConcurrentlyN_) @@ -74,16 +73,16 @@ insertConnection :: AppIO UserConnection insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (lUnqualified -> ltarget) = + let local (tUnqualified -> ltarget) = write connectionInsert $ - params Quorum (lUnqualified self, ltarget, rel, now, cnv) - let remote (unTagged -> Qualified rtarget domain) = + params Quorum (tUnqualified self, ltarget, rel, now, cnv) + let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionInsert $ - params Quorum (lUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + params Quorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) retry x5 $ foldQualified self local remote target pure $ UserConnection - { ucFrom = lUnqualified self, + { ucFrom = tUnqualified self, ucTo = target, ucStatus = relationDropHistory rel, ucLastUpdate = now, @@ -103,32 +102,32 @@ updateConnection c status = do updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> AppIO UTCTimeMillis updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (lUnqualified -> ltarget) = + let local (tUnqualified -> ltarget) = write connectionUpdate $ - params Quorum (status, now, lUnqualified self, ltarget) - let remote (unTagged -> Qualified rtarget domain) = + params Quorum (status, now, tUnqualified self, ltarget) + let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionUpdate $ - params Quorum (status, now, lUnqualified self, domain, rtarget) + params Quorum (status, now, tUnqualified self, domain, rtarget) retry x5 $ foldQualified self local remote target pure now -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) lookupConnection self target = runMaybeT $ do - let local (lUnqualified -> ltarget) = do + let local (tUnqualified -> 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 + params Quorum (tUnqualified self, ltarget) + pure (rel, time, fmap (qUntagged . qualifyAs self) mcnv) + let remote (qUntagged -> Qualified rtarget domain) = do (rel, time, cdomain, cnv) <- MaybeT . query1 remoteConnectionSelectFrom $ - params Quorum (lUnqualified self, domain, rtarget) + params Quorum (tUnqualified 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, + { ucFrom = tUnqualified self, ucTo = target, ucStatus = relationDropHistory rel, ucLastUpdate = time, @@ -143,10 +142,10 @@ lookupRelationWithHistory :: Qualified UserId -> AppIO (Maybe RelationWithHistory) 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)) + let local (tUnqualified -> ltarget) = + query1 relationSelect (params Quorum (tUnqualified self, ltarget)) + let remote (qUntagged -> Qualified rtarget domain) = + query1 remoteRelationSelect (params Quorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation @@ -161,10 +160,10 @@ lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of Just u -> retry x1 $ - paginate connectionsSelectFrom (paramsP Quorum (lUnqualified lfrom, u) (size + 1)) + paginate connectionsSelectFrom (paramsP Quorum (tUnqualified lfrom, u) (size + 1)) Nothing -> retry x1 $ - paginate connectionsSelect (paramsP Quorum (Identity (lUnqualified lfrom)) (size + 1)) + paginate connectionsSelect (paramsP Quorum (Identity (tUnqualified lfrom)) (size + 1)) where toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim trim p = p {result = take (fromIntegral size) (result p)} @@ -178,7 +177,7 @@ lookupLocalConnectionsPage :: Range 1 1000 Int32 -> m (PageWithState UserConnection) lookupLocalConnectionsPage self pagingState (fromRange -> size) = - fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (lUnqualified self)) size pagingState) + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) -- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. lookupRemoteConnectionsPage :: @@ -191,7 +190,7 @@ lookupRemoteConnectionsPage self pagingState size = fmap (toRemoteUserConnection self) <$> paginateWithState remoteConnectionSelect - (paramsPagingState Quorum (Identity (lUnqualified self)) size pagingState) + (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] @@ -221,8 +220,8 @@ lookupContactListWithRelation u = -- Note: The count is eventually consistent. countConnections :: Local UserId -> [Relation] -> AppIO Int64 countConnections u r = do - rels <- retry x1 . query selectStatus $ params One (Identity (lUnqualified u)) - relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (lUnqualified u)) + rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) + relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) return $ foldl' count 0 rels + foldl' count 0 relsRemote where @@ -309,14 +308,14 @@ toLocalUserConnection :: (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) + UserConnection l (qUntagged (qualifyAs loc r)) rel time (fmap (qUntagged . qualifyAs loc) cid) toRemoteUserConnection :: Local UserId -> (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> UserConnection toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, cid) = - UserConnection (lUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) + UserConnection (tUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 78bd55a5732..002d3921dc9 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -31,7 +31,6 @@ import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) import Data.Qualified -import Data.Tagged import qualified Data.Text as T import Imports import qualified System.Logger.Class as Log @@ -91,7 +90,7 @@ sendConnectionAction :: Remote UserId -> RemoteConnectionAction -> FederationAppIO NewConnectionResponse -sendConnectionAction self (unTagged -> other) action = do - let req = NewConnectionRequest (lUnqualified self) (qUnqualified other) action +sendConnectionAction self (qUntagged -> other) action = do + let req = NewConnectionRequest (tUnqualified self) (qUnqualified other) action Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" - executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (lDomain self) req + executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (tDomain self) req diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 28472c47796..afac8627dde 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -92,7 +92,6 @@ 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)) @@ -543,7 +542,7 @@ createLocalConnectConv :: AppIO ConvId createLocalConnectConv from to cname conn = do debug $ - logConnection (lUnqualified from) (unTagged to) + logConnection (tUnqualified from) (qUntagged to) . remote "galley" . msg (val "Creating connect conversation") r <- galleyRequest POST req @@ -553,10 +552,10 @@ createLocalConnectConv from to cname conn = do where req = path "/i/conversations/connect" - . zUser (lUnqualified from) + . zUser (tUnqualified from) . maybe id (header "Z-Connection" . fromConnId) conn . contentJson - . lbytes (encode $ Connect (lUnqualified to) Nothing cname Nothing) + . lbytes (encode $ Connect (tUnqualified to) Nothing cname Nothing) . expect2xx createConnectConv :: @@ -568,7 +567,7 @@ createConnectConv :: createConnectConv from to cname conn = do lfrom <- ensureLocal from lto <- ensureLocal to - unTagged . qualifyAs lfrom + qUntagged . qualifyAs lfrom <$> createLocalConnectConv lfrom lto cname conn where ensureLocal :: Qualified a -> AppIO (Local a) @@ -587,7 +586,7 @@ acceptLocalConnectConv from conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "accept", "v2"] - . zUser (lUnqualified from) + . zUser (tUnqualified from) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx @@ -595,7 +594,7 @@ acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO C acceptConnectConv from conn = foldQualified from - (acceptLocalConnectConv from conn . lUnqualified) + (acceptLocalConnectConv from conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.blockConvH'. @@ -609,7 +608,7 @@ blockLocalConv lusr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "block"] - . zUser (lUnqualified lusr) + . zUser (tUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx @@ -617,7 +616,7 @@ blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO () blockConv lusr conn = foldQualified lusr - (blockLocalConv lusr conn . lUnqualified) + (blockLocalConv lusr conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.unblockConvH'. @@ -631,7 +630,7 @@ unblockLocalConv lusr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "unblock"] - . zUser (lUnqualified lusr) + . zUser (tUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx @@ -639,7 +638,7 @@ unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Convers unblockConv luid conn = foldQualified luid - (unblockLocalConv luid conn . lUnqualified) + (unblockLocalConv luid conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.getConversationH'. diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index fc9f39ccf15..867bc7c6905 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -215,7 +215,7 @@ testClaimMultiPrekeyBundleSuccess brig1 brig2 = do mkClientMap :: [ClientPrekey] -> Map ClientId (Maybe Prekey) mkClientMap = Map.fromList . map (prekeyClient &&& Just . prekeyData) qmap :: Ord a => [(Qualified a, b)] -> Map Domain (Map a b) - qmap = fmap Map.fromList . partitionQualified . map (sequenceAOf _1) + qmap = fmap Map.fromList . indexQualified . map (sequenceAOf _1) c1 <- generateClientPrekeys brig1 prekeys1 c2 <- generateClientPrekeys brig2 prekeys2 let uc = diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 9c1f82c3519..b5581f1b6cf 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -32,7 +32,6 @@ import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import Data.Time import qualified Data.UUID.Tagged as U import Galley.API.Error @@ -101,7 +100,7 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do qualifiedUserIds = newConvQualifiedUsers body allUsers = toUserList lusr $ - map (unTagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + map (qUntagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds checkedUsers <- checkedConvSize allUsers ensureConnected zusr (ulLocals allUsers) checkRemoteUsersExist (ulRemotes allUsers) @@ -130,7 +129,7 @@ createTeamGroupConv zusr zcon tinfo body = do qualifiedUserIds = newConvQualifiedUsers body allUsers = toUserList lusr $ - map (unTagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + map (qUntagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds convTeam = cnvTeamId tinfo zusrMembership <- Data.teamMember convTeam zusr @@ -238,7 +237,7 @@ createConnectConversation usr conn j = do c <- Data.createConnectConversation lusr x y n now <- liftIO getCurrentTime let lcid = qualifyAs lusr (Data.convId c) - e = Event ConvConnect (unTagged lcid) (unTagged lusr) now (EdConnect j) + e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) notifyCreatedConversation Nothing usr conn c for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> push1 $ diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 512077e7de6..c7476ccfd75 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -27,9 +27,8 @@ import Data.Json.Util (Base64ByteString (..)) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), toRemote) +import Data.Qualified (Qualified (..), qUntagged, toRemoteUnsafe) import qualified Data.Set as Set -import Data.Tagged import qualified Data.Text.Lazy as LT import Galley.API.Error (invalidPayload) import qualified Galley.API.Mapping as Mapping @@ -100,11 +99,10 @@ onConversationCreated domain rc = do getConversations :: Domain -> GetConversationsRequest -> Galley GetConversationsResponse getConversations domain (GetConversationsRequest uid cids) = do - let ruid = toRemote $ Qualified uid domain + let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain GetConversationsResponse - . catMaybes - . map (Mapping.conversationToRemote localDomain ruid) + . mapMaybe (Mapping.conversationToRemote localDomain ruid) <$> Data.localConversations cids getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] @@ -184,8 +182,8 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: error handling for missing / mismatched clients onMessageSent :: Domain -> RemoteMessage ConvId -> Galley () onMessageSent domain rmUnqualified = do - let rm = fmap (Tagged . (`Qualified` domain)) rmUnqualified - let convId = unTagged $ rmConversation rm + let rm = fmap (toRemoteUnsafe domain) rmUnqualified + convId = qUntagged $ rmConversation rm msgMetadata = MessageMetadata { mmNativePush = rmPush rm, diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2f51149b5b4..65b8fd7a92e 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -32,7 +32,7 @@ import Control.Monad.Catch (MonadCatch) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) -import Data.Qualified (Local, Qualified (..), Remote, lUnqualified, partitionRemoteOrLocalIds') +import Data.Qualified import Data.Range import Data.String.Conversions (cs) import Data.Time @@ -453,13 +453,12 @@ rmUser user conn = do where goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley () goConvPages lusr range page = do - localDomain <- viewFederationDomain - let (remoteConvs, localConvs) = partitionRemoteOrLocalIds' localDomain . mtpResults $ page + let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs leaveRemoteConversations lusr remoteConvs when (mtpHasMore page) $ do let nextState = mtpPagingState page - usr = lUnqualified lusr + usr = tUnqualified lusr nextQuery = GetPaginatedConversationIds (Just nextState) range newCids <- Query.conversationIdsPageFrom usr nextQuery goConvPages lusr range newCids @@ -500,7 +499,7 @@ rmUser user conn = do leaveRemoteConversations :: Foldable t => Local UserId -> t (Remote ConvId) -> Galley () leaveRemoteConversations lusr cids = for_ cids $ \cid -> - Update.removeMemberFromRemoteConv cid lusr Nothing (unTagged lusr) + Update.removeMemberFromRemoteConv cid lusr Nothing (qUntagged lusr) deleteLoop :: Galley () deleteLoop = do diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index d4ea7c3ed78..1755eec74cc 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -46,8 +46,8 @@ import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Split (chunksOf) import Data.Misc import Data.Proxy (Proxy (Proxy)) +import Data.Qualified (qUntagged) import Data.Range (toRange) -import Data.Tagged import Galley.API.Error import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) @@ -510,8 +510,8 @@ handleGroupConvPolicyConflicts uid hypotheticalLHStatus = then do for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do lusr <- qualifyLocal (lmId memberNoConsent) - removeMemberFromLocalConv lcnv lusr Nothing (unTagged lusr) + removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) else do for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do lusr <- qualifyLocal (lmId legalholder) - removeMemberFromLocalConv lcnv lusr Nothing (unTagged lusr) + removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index e99921917ec..c9da03d9c97 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -74,7 +74,8 @@ conversationViewMaybe localDomain uid conv = do <> map remoteMemberToOther rothers pure $ Conversation - (Data.convMetadata localDomain conv) + (Qualified (convId conv) localDomain) + (Data.convMetadata conv) (ConvMembers self others) -- | View for a local user of a remote conversation. @@ -85,9 +86,9 @@ conversationViewMaybe localDomain uid conv = do remoteConversationView :: UserId -> MemberStatus -> - RemoteConversation -> + Remote RemoteConversation -> Maybe Conversation -remoteConversationView uid status rconv = do +remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do let mems = rcnvMembers rconv others = rcmOthers mems self = @@ -98,7 +99,7 @@ remoteConversationView uid status rconv = do lmStatus = status, lmConvRoleName = rcmSelfRole mems } - pure $ Conversation (rcnvMetadata rconv) (ConvMembers self others) + pure $ Conversation (Qualified (rcnvId rconv) rDomain) (rcnvMetadata rconv) (ConvMembers self others) -- | Convert a local conversation to a structure to be returned to a remote -- backend. @@ -118,7 +119,8 @@ conversationToRemote localDomain ruid conv = do <> map remoteMemberToOther rothers pure $ RemoteConversation - { rcnvMetadata = Data.convMetadata localDomain conv, + { rcnvId = Data.convId conv, + rcnvMetadata = Data.convMetadata conv, rcnvMembers = RemoteConvMembers { rcmSelfRole = selfRole, diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index ab744e355df..84298638512 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -17,10 +17,9 @@ import Data.Json.Util import Data.List1 (singleton) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), partitionRemote) +import Data.Qualified import qualified Data.Set as Set import Data.Set.Lens -import Data.Tagged (unTagged) import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util @@ -183,13 +182,13 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = getRemoteClients :: [RemoteMember] -> Galley (Map (Domain, UserId) (Set ClientId)) getRemoteClients remoteMembers = do fmap mconcat -- concatenating maps is correct here, because their sets of keys are disjoint - . pooledMapConcurrentlyN 8 (uncurry getRemoteClientsFromDomain) - . partitionRemote + . pooledMapConcurrentlyN 8 getRemoteClientsFromDomain + . indexRemote . map rmId $ remoteMembers where - getRemoteClientsFromDomain :: Domain -> [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) - getRemoteClientsFromDomain domain uids = do + getRemoteClientsFromDomain :: Remote [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) + getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = do let rpc = FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> runFederatedBrig domain rpc @@ -231,7 +230,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do members :: Set (Qualified UserId) members = Set.map (`Qualified` localDomain) (Map.keysSet localMemberMap) - <> Set.fromList (map (unTagged . rmId) remoteMembers) + <> Set.fromList (map (qUntagged . rmId) remoteMembers) isInternal <- view $ options . optSettings . setIntraListing -- check if the sender is part of the conversation diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index ab447495338..7212b123460 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -34,6 +34,7 @@ module Galley.API.Query where import qualified Cassandra as C +import Control.Lens (sequenceAOf) import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS @@ -43,10 +44,9 @@ import Data.Domain (Domain) import Data.Id as Id import qualified Data.Map as Map import Data.Proxy -import Data.Qualified (Qualified (..), Remote, partitionRemote, partitionRemoteOrLocalIds', toRemote) +import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged (unTagged) import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util @@ -100,10 +100,12 @@ getUnqualifiedConversation zusr cnv = do getConversation :: UserId -> Qualified ConvId -> Galley Public.Conversation getConversation zusr cnv = do - localDomain <- viewFederationDomain - if qDomain cnv == localDomain - then getUnqualifiedConversation zusr (qUnqualified cnv) - else getRemoteConversation (toRemote cnv) + lusr <- qualifyLocal zusr + foldQualified + lusr + (getUnqualifiedConversation zusr . tUnqualified) + getRemoteConversation + cnv where getRemoteConversation :: Remote ConvId -> Galley Public.Conversation getRemoteConversation remoteConvId = do @@ -137,9 +139,9 @@ fgcError :: FailedGetConversation -> Wai.Error fgcError (FailedGetConversation _ r) = fgcrError r failedGetConversationRemotely :: - [Qualified ConvId] -> FederationError -> FailedGetConversation + [Remote ConvId] -> FederationError -> FailedGetConversation failedGetConversationRemotely qconvs = - FailedGetConversation qconvs . FailedGetConversationRemotely + FailedGetConversation (map qUntagged qconvs) . FailedGetConversationRemotely failedGetConversationLocally :: [Qualified ConvId] -> FailedGetConversation @@ -162,36 +164,37 @@ getRemoteConversationsWithFailures zusr convs = do -- get self member statuses from the database statusMap <- Data.remoteConversationStatus zusr convs - let remoteView rconv = + let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation + remoteView rconv = Mapping.remoteConversationView zusr ( Map.findWithDefault defMemberStatus - (toRemote (cnvmQualifiedId (FederatedGalley.rcnvMetadata rconv))) + (fmap FederatedGalley.rcnvId rconv) statusMap ) rconv (locallyFound, locallyNotFound) = partition (flip Map.member statusMap) convs localFailures | null locallyNotFound = [] - | otherwise = [failedGetConversationLocally (map unTagged locallyNotFound)] + | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends fmap (bimap (localFailures <>) concat . partitionEithers) - . pooledForConcurrentlyN 8 (partitionRemote locallyFound) - $ \(domain, someConvs) -> do - let req = FederatedGalley.GetConversationsRequest zusr someConvs + . pooledForConcurrentlyN 8 (indexRemote locallyFound) + $ \someConvs -> do + let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes localDomain req - handleFailures (map (flip Qualified domain) someConvs) $ do - rconvs <- gcresConvs <$> executeFederated domain rpc - pure $ catMaybes (map remoteView rconvs) + handleFailures (sequenceAOf tUnqualifiedL someConvs) $ do + rconvs <- gcresConvs <$> executeFederated (tDomain someConvs) rpc + pure $ mapMaybe (remoteView . qualifyAs someConvs) rconvs where handleFailures :: - [Qualified ConvId] -> + [Remote ConvId] -> ExceptT FederationError Galley a -> Galley (Either FailedGetConversation a) - handleFailures qconvs action = runExceptT - . withExceptT (failedGetConversationRemotely qconvs) + handleFailures rconvs action = runExceptT + . withExceptT (failedGetConversationRemotely rconvs) . catchE action $ \e -> do lift . Logger.warn $ @@ -289,9 +292,9 @@ getConversationsInternal user mids mstart msize = do listConversations :: UserId -> Public.ListConversations -> Galley Public.ConversationsResponse listConversations user (Public.ListConversations ids) = do - localDomain <- viewFederationDomain + luser <- qualifyLocal user - let (remoteIds, localIds) = partitionRemoteOrLocalIds' localDomain (fromRange ids) + let (localIds, remoteIds) = partitionQualified luser (fromRange ids) (foundLocalIds, notFoundLocalIds) <- foundsAndNotFounds (Data.localConversationIdsOf user) localIds localInternalConversations <- @@ -304,7 +307,7 @@ listConversations user (Public.ListConversations ids) = do let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures failedConvs = failedConvsLocally <> failedConvsRemotely fetchedOrFailedRemoteIds = Set.fromList $ map Public.cnvQualifiedId remoteConversations <> failedConvs - remoteNotFoundRemoteIds = filter (`Set.notMember` fetchedOrFailedRemoteIds) $ map unTagged remoteIds + remoteNotFoundRemoteIds = filter (`Set.notMember` fetchedOrFailedRemoteIds) $ map qUntagged remoteIds unless (null remoteNotFoundRemoteIds) $ -- FUTUREWORK: This implies that the backends are out of sync. Maybe the -- current user should be considered removed from this conversation at this @@ -320,7 +323,7 @@ listConversations user (Public.ListConversations ids) = do crNotFound = failedConvsLocally <> remoteNotFoundRemoteIds - <> map (`Qualified` localDomain) notFoundLocalIds, + <> map (qUntagged . qualifyAs luser) notFoundLocalIds, crFailed = failedConvsRemotely } where diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 59bf3e4f293..7b1976d83db 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -81,7 +81,6 @@ import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import Data.Time import Galley.API.Error import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) @@ -211,7 +210,7 @@ updateLocalConversationAccess :: Galley (UpdateResult Event) updateLocalConversationAccess lcnv lusr con target = getUpdateResult - . updateLocalConversation lcnv (unTagged lusr) (Just con) + . updateLocalConversation lcnv (qUntagged lusr) (Just con) . ConversationActionAccessUpdate $ target @@ -238,7 +237,7 @@ performAccessUpdateAction qusr conv target = do && CodeAccess `notElem` cupAccess target ) $ lift $ do - key <- mkKey (lUnqualified lcnv) + key <- mkKey (tUnqualified lcnv) Data.deleteCode key ReusableCode -- Depending on a variety of things, some bots and users have to be -- removed from the conversation. We keep track of them using 'State'. @@ -266,18 +265,18 @@ performAccessUpdateAction qusr conv target = do botsL .= [] _ -> return () -- Update Cassandra - lift $ Data.updateConversationAccess (lUnqualified lcnv) target + lift $ Data.updateConversationAccess (tUnqualified lcnv) target -- Remove users and bots lift . void . forkIO $ do let removedUsers = map lmId users \\ map lmId newUsers removedBots = map botMemId bots \\ map botMemId newBots - mapM_ (deleteBot (lUnqualified lcnv)) removedBots + mapM_ (deleteBot (tUnqualified lcnv)) removedBots for_ (nonEmpty removedUsers) $ \victims -> do -- FUTUREWORK: deal with remote members, too, see updateLocalConversation (Jira SQCORE-903) - Data.removeLocalMembersFromLocalConv (lUnqualified lcnv) victims + Data.removeLocalMembersFromLocalConv (tUnqualified lcnv) victims now <- liftIO getCurrentTime - let qvictims = QualifiedUserIdList . map (unTagged . qualifyAs lcnv) . toList $ victims - let e = Event MemberLeave (unTagged lcnv) qusr now (EdMembersLeave qvictims) + let qvictims = QualifiedUserIdList . map (qUntagged . qualifyAs lcnv) . toList $ victims + let e = Event MemberLeave (qUntagged lcnv) qusr now (EdMembersLeave qvictims) -- push event to all clients, including zconn -- since updateConversationAccess generates a second (member removal) event here traverse_ push1 $ @@ -323,7 +322,7 @@ updateLocalConversationReceiptMode :: Galley (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionReceiptModeUpdate update updateRemoteConversationReceiptMode :: @@ -352,11 +351,13 @@ updateConversationMessageTimer :: Public.ConversationMessageTimerUpdate -> Galley (UpdateResult Event) updateConversationMessageTimer usr zcon qcnv update = do - localDomain <- viewFederationDomain lusr <- qualifyLocal usr - if qDomain qcnv == localDomain - then updateLocalConversationMessageTimer lusr zcon (toLocal qcnv) update - else throwM federationNotImplemented + foldQualified + lusr + (updateLocalConversationMessageTimer lusr zcon) + (\_ _ -> throwM federationNotImplemented) + qcnv + update updateLocalConversationMessageTimer :: Local UserId -> @@ -366,7 +367,7 @@ updateLocalConversationMessageTimer :: Galley (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMessageTimerUpdate update -- | Update a local conversation, and notify all local and remote members. @@ -383,7 +384,7 @@ updateLocalConversation lcnv qusr con action = do getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) qusr - (lUnqualified lcnv) + (tUnqualified lcnv) -- perform checks lift $ ensureConversationActionAllowed action conv self @@ -561,7 +562,7 @@ joinConversation zusr zcon cnv access = do addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember lift $ notifyConversationMetadataUpdate - (unTagged lusr) + (qUntagged lusr) (Just zcon) lcnv (convTargets conv <> extraTargets) @@ -605,7 +606,7 @@ performAddMemberAction qusr conv invited role = do tms <- Data.teamMembersLimited tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers ensureAccessRole (Data.convAccessRole conv) userMembershipMap - tcv <- Data.teamConversation tid (lUnqualified lcnv) + tcv <- Data.teamConversation tid (tUnqualified lcnv) when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged ensureConnectedOrSameTeam qusr newUsers @@ -640,7 +641,7 @@ performAddMemberAction qusr conv invited role = do then do for_ convUsersLHStatus $ \(mem, status) -> when (consentGiven status == ConsentNotGiven) $ do - qvictim <- unTagged <$> qualifyLocal (lmId mem) + qvictim <- qUntagged <$> qualifyLocal (lmId mem) void . runMaybeT $ updateLocalConversation lcnv qvictim Nothing $ ConversationActionRemoveMember qvictim @@ -652,7 +653,7 @@ performAddMemberAction qusr conv invited role = do addMembersUnqualified :: UserId -> ConnId -> ConvId -> Public.Invite -> Galley (UpdateResult Event) addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do - qusers <- traverse (fmap unTagged . qualifyLocal) (toNonEmpty users) + qusers <- traverse (fmap qUntagged . qualifyLocal) (toNonEmpty users) addMembers zusr zcon cnv (Public.InviteQualified qusers role) addMembers :: UserId -> ConnId -> ConvId -> Public.InviteQualified -> Galley (UpdateResult Event) @@ -660,7 +661,7 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just zcon) $ + updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ ConversationActionAddMembers users role updateSelfMember :: UserId -> ConnId -> Qualified ConvId -> Public.MemberUpdate -> Galley () @@ -670,18 +671,18 @@ updateSelfMember zusr zcon qcnv update = do unless exists (throwErrorDescriptionType @ConvNotFound) Data.updateSelfMember lusr qcnv lusr update now <- liftIO getCurrentTime - let e = Event MemberStateUpdate qcnv (unTagged lusr) now (EdMemberUpdate (updateData lusr)) + let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) pushConversationEvent (Just zcon) e [zusr] [] where checkLocalMembership lcnv lusr = - isMember (lUnqualified lusr) - <$> Data.members (lUnqualified lcnv) + isMember (tUnqualified lusr) + <$> Data.members (tUnqualified lcnv) checkRemoteMembership rcnv lusr = isJust . Map.lookup rcnv - <$> Data.remoteConversationStatus (lUnqualified lusr) [rcnv] + <$> Data.remoteConversationStatus (tUnqualified lusr) [rcnv] updateData luid = MemberUpdateData - { misTarget = unTagged luid, + { misTarget = qUntagged luid, misOtrMutedStatus = mupOtrMuteStatus update, misOtrMutedRef = mupOtrMuteRef update, misOtrArchived = mupOtrArchive update, @@ -694,7 +695,7 @@ updateSelfMember zusr zcon qcnv update = do updateUnqualifiedSelfMember :: UserId -> ConnId -> ConvId -> Public.MemberUpdate -> Galley () updateUnqualifiedSelfMember zusr zcon cnv update = do lcnv <- qualifyLocal cnv - updateSelfMember zusr zcon (unTagged lcnv) update + updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: UserId -> @@ -707,7 +708,7 @@ updateOtherMemberUnqualified zusr zcon cnv victim update = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv lvictim <- qualifyLocal victim - updateOtherMemberLocalConv lcnv lusr zcon (unTagged lvictim) update + updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: UserId -> @@ -729,9 +730,9 @@ updateOtherMemberLocalConv :: Public.OtherMemberUpdate -> Galley () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - when (unTagged lusr == qvictim) $ + when (qUntagged lusr == qvictim) $ throwM invalidTargetUserOp - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMemberUpdate qvictim update updateOtherMemberRemoteConv :: @@ -747,7 +748,7 @@ removeMemberUnqualified :: UserId -> ConnId -> ConvId -> UserId -> Galley Remove removeMemberUnqualified zusr con cnv victim = do lcnv <- qualifyLocal cnv lvictim <- qualifyLocal victim - removeMemberQualified zusr con (unTagged lcnv) (unTagged lvictim) + removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: UserId -> @@ -765,8 +766,8 @@ removeMemberFromRemoteConv :: Maybe ConnId -> Qualified UserId -> Galley RemoveFromConversationResponse -removeMemberFromRemoteConv (unTagged -> qcnv) lusr _ victim - | unTagged lusr == victim = +removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim + | qUntagged lusr == victim = do let lc = FederatedGalley.LeaveConversationRequest (qUnqualified qcnv) (qUnqualified victim) let rpc = @@ -776,7 +777,7 @@ removeMemberFromRemoteConv (unTagged -> qcnv) lusr _ victim lc t <- liftIO getCurrentTime let successEvent = - Event MemberLeave qcnv (unTagged lusr) t $ + Event MemberLeave qcnv (qUntagged lusr) t $ EdMembersLeave (QualifiedUserIdList [victim]) mapRight (const successEvent) . FederatedGalley.leaveResponse <$> runFederated (qDomain qcnv) rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed @@ -788,7 +789,7 @@ performRemoveMemberAction :: performRemoveMemberAction conv victim = do loc <- qualifyLocal () guard $ isConvMember loc conv victim - let removeLocal u c = Data.removeLocalMembersFromLocalConv c (pure (lUnqualified u)) + let removeLocal u c = Data.removeLocalMembersFromLocalConv c (pure (tUnqualified u)) removeRemote u c = Data.removeRemoteMembersFromLocalConv c (pure u) lift $ foldQualified loc removeLocal removeRemote victim (Data.convId conv) @@ -803,7 +804,7 @@ removeMemberFromLocalConv lcnv lusr con victim = -- FUTUREWORK: actually return errors as part of the response instead of throwing fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT - . updateLocalConversation lcnv (unTagged lusr) con + . updateLocalConversation lcnv (qUntagged lusr) con . ConversationActionRemoveMember $ victim @@ -962,9 +963,12 @@ updateConversationName :: Galley (Maybe Public.Event) updateConversationName zusr zcon qcnv convRename = do lusr <- qualifyLocal zusr - if qDomain qcnv == lDomain lusr - then updateLocalConversationName lusr zcon (toLocal qcnv) convRename - else throwM federationNotImplemented + foldQualified + lusr + (updateLocalConversationName lusr zcon) + (\_ _ -> throwM federationNotImplemented) + qcnv + convRename updateUnqualifiedConversationName :: UserId -> @@ -984,10 +988,10 @@ updateLocalConversationName :: Public.ConversationRename -> Galley (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do - alive <- Data.isConvAlive (lUnqualified lcnv) + alive <- Data.isConvAlive (tUnqualified lcnv) if alive then updateLiveLocalConversationName lusr zcon lcnv convRename - else Nothing <$ Data.deleteConversation (lUnqualified lcnv) + else Nothing <$ Data.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: Local UserId -> @@ -997,7 +1001,7 @@ updateLiveLocalConversationName :: Galley (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionRename rename notifyConversationMetadataUpdate :: @@ -1007,14 +1011,14 @@ notifyConversationMetadataUpdate :: NotificationTargets -> ConversationAction -> Galley Event -notifyConversationMetadataUpdate quid con (Tagged qcnv) targets action = do +notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do localDomain <- viewFederationDomain now <- liftIO getCurrentTime let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = partitionRemote (toList (ntRemotes targets)) - void . pooledForConcurrentlyN 8 rusersByDomain $ \(domain, uids) -> do + let rusersByDomain = indexRemote (toList (ntRemotes targets)) + void . pooledForConcurrentlyN 8 rusersByDomain $ \(qUntagged -> Qualified uids domain) -> do let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action rpc = FederatedGalley.onConversationUpdated @@ -1073,7 +1077,7 @@ addBot zusr zcon b = do (bots, users) <- regularConvChecks lusr c t <- liftIO getCurrentTime Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient) - (e, bm) <- Data.addBotMember (unTagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t + (e, bm) <- Data.addBotMember (qUntagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e) @@ -1087,7 +1091,7 @@ addBot zusr zcon b = do ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) - ensureMemberLimit (toList $ Data.convLocalMembers c) [unTagged botId] + ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] return (bots, users) teamConvChecks cid tid = do tcv <- Data.teamConversation tid cid diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index bd21ee4f924..045588dc954 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -36,7 +36,6 @@ import qualified Data.Map as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set -import Data.Tagged import qualified Data.Text.Lazy as LT import Data.Time import Galley.API.Error @@ -255,7 +254,7 @@ acceptOne2One usr conv conn = do throwM badConvState now <- liftIO getCurrentTime mm <- Data.addMember lcid lusr - let e = memberJoinEvent lusr (unTagged lcid) now mm [] + let e = memberJoinEvent lusr (qUntagged lcid) now mm [] conv' <- if isJust (find ((usr /=) . lmId) mems) then promote else pure conv let mems' = mems <> toList mm for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> @@ -281,11 +280,11 @@ memberJoinEvent :: [RemoteMember] -> Event memberJoinEvent lorig qconv t lmems rmems = - Event MemberJoin qconv (unTagged lorig) t $ + Event MemberJoin qconv (qUntagged lorig) t $ EdMembersJoin (SimpleMembers (map localToSimple lmems <> map remoteToSimple rmems)) where - localToSimple u = SimpleMember (unTagged (qualifyAs lorig (lmId u))) (lmConvRoleName u) - remoteToSimple u = SimpleMember (unTagged (rmId u)) (rmConvRoleName u) + localToSimple u = SimpleMember (qUntagged (qualifyAs lorig (lmId u))) (lmConvRoleName u) + remoteToSimple u = SimpleMember (qUntagged (rmId u)) (rmConvRoleName u) isBot :: LocalMember -> Bool isBot = isJust . lmService @@ -309,7 +308,7 @@ instance IsConvMemberId UserId LocalMember where getConvMember _ conv u = find ((u ==) . lmId) (Data.convLocalMembers conv) instance IsConvMemberId (Local UserId) LocalMember where - getConvMember loc conv = getConvMember loc conv . lUnqualified + getConvMember loc conv = getConvMember loc conv . tUnqualified instance IsConvMemberId (Remote UserId) RemoteMember where getConvMember _ conv u = find ((u ==) . rmId) (Data.convRemoteMembers conv) @@ -327,11 +326,11 @@ class IsConvMember mem where instance IsConvMember LocalMember where convMemberRole = lmConvRoleName - convMemberId loc mem = unTagged (qualifyAs loc (lmId mem)) + convMemberId loc mem = qUntagged (qualifyAs loc (lmId mem)) instance IsConvMember RemoteMember where convMemberRole = rmConvRoleName - convMemberId _ = unTagged . rmId + convMemberId _ = qUntagged . rmId instance IsConvMember (Either LocalMember RemoteMember) where convMemberRole = either convMemberRole convMemberRole @@ -370,7 +369,7 @@ instance Monoid NotificationTargets where instance IsNotificationTarget (Local UserId) where ntAdd _ luid nt = - nt {ntLocals = Set.insert (lUnqualified luid) (ntLocals nt)} + nt {ntLocals = Set.insert (tUnqualified luid) (ntLocals nt)} instance IsNotificationTarget (Remote UserId) where ntAdd _ ruid nt = nt {ntRemotes = Set.insert ruid (ntRemotes nt)} @@ -447,24 +446,8 @@ ensureOtherMember :: Galley (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ - (Left <$> find ((== quid) . (`Qualified` lDomain loc) . lmId) (Data.convLocalMembers conv)) - <|> (Right <$> find ((== quid) . unTagged . rmId) (Data.convRemoteMembers conv)) - --- | Note that we use 2 nearly identical functions but slightly different --- semantics; when using `getSelfMemberQualified`, if that user is _not_ part of --- the conversation, we don't want to disclose that such a conversation with --- that id exists. -getSelfMemberQualified :: - (Foldable t, Monad m) => - Domain -> - Qualified UserId -> - t LocalMember -> - t RemoteMember -> - ExceptT ConvNotFound m (Either LocalMember RemoteMember) -getSelfMemberQualified localDomain qusr@(Qualified usr userDomain) lmems rmems = do - if localDomain == userDomain - then Left <$> getSelfMemberFromLocals usr lmems - else Right <$> getSelfMemberFromRemotes (toRemote qusr) rmems + (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) + <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) getSelfMemberFromRemotes :: (Foldable t, Monad m) => @@ -506,7 +489,7 @@ getQualifiedMember :: getQualifiedMember loc e qusr conv = foldQualified loc - (\lusr -> Left <$> getLocalMember e (lUnqualified lusr) (Data.convLocalMembers conv)) + (\lusr -> Left <$> getLocalMember e (tUnqualified lusr) (Data.convLocalMembers conv)) (\rusr -> Right <$> getRemoteMember e rusr (Data.convRemoteMembers conv)) qusr @@ -603,16 +586,15 @@ viewFederationDomain :: MonadReader Env m => m Domain viewFederationDomain = view (options . optSettings . setFederationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) -qualifyLocal a = fmap (toLocal . Qualified a) viewFederationDomain +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a checkRemoteUsersExist :: (Functor f, Foldable f) => f (Remote UserId) -> Galley () checkRemoteUsersExist = -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain - traverse_ (uncurry checkRemotesFor) - . partitionRemote + traverse_ checkRemotesFor . indexRemote -checkRemotesFor :: Domain -> [UserId] -> Galley () -checkRemotesFor domain uids = do +checkRemotesFor :: Remote [UserId] -> Galley () +checkRemotesFor (qUntagged -> Qualified uids domain) = do let rpc = FederatedBrig.getUsersByIds FederatedBrig.clientRoutes uids users <- runFederatedBrig domain rpc let uids' = @@ -713,9 +695,9 @@ fromNewRemoteConversation d NewRemoteConversation {..} = conv :: Public.Member -> [OtherMember] -> Public.Conversation conv this others = Public.Conversation + rcCnvId ConversationMetadata - { cnvmQualifiedId = rcCnvId, - cnvmType = rcCnvType, + { cnvmType = rcCnvType, -- FUTUREWORK: Document this is the same domain as the conversation -- domain cnvmCreator = qUnqualified rcOrigUserId, @@ -743,9 +725,9 @@ registerRemoteConversationMemberships now localDomain c = do -- FUTUREWORK: parallelise federated requests traverse_ (registerRemoteConversations rc) . Map.keys - . partitionQualified + . indexQualified . nubOrd - . map (unTagged . rmId) + . map (qUntagged . rmId) . Data.convRemoteMembers $ c where diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index afb7d877131..55be7a13813 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -122,7 +122,7 @@ module Galley.Data where import Brig.Types.Code -import Cassandra hiding (Tagged) +import Cassandra import Cassandra.Util import Control.Arrow (second) import Control.Exception (ErrorCall (ErrorCall)) @@ -143,7 +143,6 @@ import qualified Data.Monoid import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import qualified Data.UUID.Tagged as U import Data.UUID.V4 (nextRandom) import Galley.App @@ -544,13 +543,12 @@ toConv cid mms remoteMems conv = f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm conversationMeta :: MonadClient m => Domain -> ConvId -> m (Maybe ConversationMetadata) -conversationMeta localDomain conv = +conversationMeta _localDomain conv = fmap toConvMeta <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) where toConvMeta (t, c, a, r, n, i, _, mt, rm) = ConversationMetadata - (Qualified conv localDomain) t c (defAccess t a) @@ -609,22 +607,22 @@ remoteConversationStatus :: m (Map (Remote ConvId) MemberStatus) remoteConversationStatus uid = fmap mconcat - . pooledMapConcurrentlyN 8 (uncurry (remoteConversationStatusOnDomain uid)) - . partitionRemote + . pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) + . indexRemote -remoteConversationStatusOnDomain :: MonadClient m => UserId -> Domain -> [ConvId] -> m (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomain uid domain convs = +remoteConversationStatusOnDomain :: MonadClient m => UserId -> Remote [ConvId] -> m (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomain uid rconvs = Map.fromList . map toPair - <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, domain, convs)) + <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) where toPair (conv, omus, omur, oar, oarr, hid, hidr) = - ( toRemote (Qualified conv domain), + ( qualifyAs rconvs conv, toMemberStatus (omus, omur, oar, oarr, hid, hidr) ) conversationsRemote :: (MonadClient m) => UserId -> m [Remote ConvId] conversationsRemote usr = do - (\(d, c) -> toRemote $ Qualified c d) <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) + uncurry toRemoteUnsafe <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) createConversation :: MonadClient m => @@ -642,7 +640,7 @@ createConversation :: createConversation lusr name acc role others tinfo mtimer recpt othersConversationRole = do conv <- Id <$> liftIO nextRandom let lconv = qualifyAs lusr conv - usr = lUnqualified lusr + usr = tUnqualified lusr retry x5 $ case tinfo of Nothing -> write Cql.insertConv (params Quorum (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Nothing, mtimer, recpt)) @@ -652,17 +650,17 @@ createConversation lusr name acc role others tinfo mtimer recpt othersConversati addPrepQuery Cql.insertConv (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Just (cnvTeamId ti), mtimer, recpt) addPrepQuery Cql.insertTeamConv (cnvTeamId ti, conv, cnvManaged ti) let newUsers = fmap (,othersConversationRole) (fromConvSize others) - (lmems, rmems) <- addMembers lconv (ulAddLocal (lUnqualified lusr, roleNameWireAdmin) newUsers) + (lmems, rmems) <- addMembers lconv (ulAddLocal (tUnqualified lusr, roleNameWireAdmin) newUsers) pure $ newConv conv RegularConv usr lmems rmems acc role name (cnvTeamId <$> tinfo) mtimer recpt createSelfConversation :: MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> m Conversation createSelfConversation lusr name = do - let usr = lUnqualified lusr + let usr = tUnqualified lusr conv = selfConv usr lconv = qualifyAs lusr conv retry x5 $ write Cql.insertConv (params Quorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - (lmems, rmems) <- addMembers lconv (UserList [lUnqualified lusr] []) + (lmems, rmems) <- addMembers lconv (UserList [tUnqualified lusr] []) pure $ newConv conv SelfConv usr lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing createConnectConversation :: @@ -770,10 +768,9 @@ newConv cid ct usr mems rMems acc role name tid mtimer rMode = convReceiptMode = rMode } -convMetadata :: Domain -> Conversation -> ConversationMetadata -convMetadata localDomain c = +convMetadata :: Conversation -> ConversationMetadata +convMetadata c = ConversationMetadata - (Qualified (convId c) localDomain) (convType c) (convCreator c) (convAccess c) @@ -845,7 +842,7 @@ remoteMemberLists convs = do mkMem (cnv, domain, usr, role) = (cnv, toRemoteMember usr domain role) toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember -toRemoteMember u d = RemoteMember (toRemote (Qualified u d)) +toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) memberLists :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => @@ -871,7 +868,7 @@ lookupRemoteMembers conv = join <$> remoteMemberLists [conv] -- | Add a member to a local conversation, as an admin. addMember :: MonadClient m => Local ConvId -> Local UserId -> m [LocalMember] -addMember c u = fst <$> addMembers c (UserList [lUnqualified u] []) +addMember c u = fst <$> addMembers c (UserList [tUnqualified u] []) class ToUserRole a where toUserRole :: a -> (UserId, RoleName) @@ -897,7 +894,7 @@ addMembers :: Local ConvId -> UserList a -> m ([LocalMember], [RemoteMember]) -addMembers (lUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do +addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do -- batch statement with 500 users are known to be above the batch size limit -- and throw "Batch too large" errors. Therefor we chunk requests and insert -- sequentially. (parallelizing would not aid performance as the partition @@ -920,7 +917,7 @@ addMembers (lUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = retry x5 . batch $ do setType BatchLogged setConsistency Quorum - for_ chunk $ \(unTagged -> Qualified (uid, role) domain) -> do + for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do -- User is remote, so we only add it to the member_remote_user -- table, but the reverse mapping has to be done on the remote -- backend; so we assume an additional call to their backend has @@ -967,15 +964,15 @@ updateSelfMemberLocalConv lcid luid mup = do for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, lUnqualified lcid, lUnqualified luid) + (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery Cql.updateOtrMemberArchived - (a, mupOtrArchiveRef mup, lUnqualified lcid, lUnqualified luid) + (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery Cql.updateMemberHidden - (h, mupHiddenRef mup, lUnqualified lcid, lUnqualified luid) + (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) updateSelfMemberRemoteConv :: MonadClient m => @@ -983,22 +980,22 @@ updateSelfMemberRemoteConv :: Local UserId -> MemberUpdate -> m () -updateSelfMemberRemoteConv (Tagged (Qualified cid domain)) luid mup = do +updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateRemoteOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, domain, cid, lUnqualified luid) + (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery Cql.updateRemoteOtrMemberArchived - (a, mupOtrArchiveRef mup, domain, cid, lUnqualified luid) + (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery Cql.updateRemoteMemberHidden - (h, mupHiddenRef mup, domain, cid, lUnqualified luid) + (h, mupHiddenRef mup, domain, cid, tUnqualified luid) updateOtherMember :: MonadClient m => @@ -1018,14 +1015,14 @@ updateOtherMemberLocalConv :: updateOtherMemberLocalConv lcid quid omu = do let addQuery r - | lDomain lcid == qDomain quid = + | tDomain lcid == qDomain quid = addPrepQuery Cql.updateMemberConvRoleName - (r, lUnqualified lcid, qUnqualified quid) + (r, tUnqualified lcid, qUnqualified quid) | otherwise = addPrepQuery Cql.updateRemoteMemberConvRoleName - (r, lUnqualified lcid, qDomain quid, qUnqualified quid) + (r, tUnqualified lcid, qDomain quid, qUnqualified quid) retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum @@ -1077,7 +1074,7 @@ removeRemoteMembersFromLocalConv cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum - for_ victims $ \(unTagged -> Qualified uid domain) -> + for_ victims $ \(qUntagged -> Qualified uid domain) -> addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) removeLocalMembersFromRemoteConv :: @@ -1114,7 +1111,7 @@ newMemberWithRole (u, r) = } newRemoteMemberWithRole :: Remote (UserId, RoleName) -> RemoteMember -newRemoteMemberWithRole ur@(unTagged -> (Qualified (u, r) _)) = +newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = RemoteMember { rmId = qualifyAs ur u, rmConvRoleName = r diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index 59d31de1558..ffcabd6984e 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -24,7 +24,6 @@ module Galley.Types.UserList where import Data.Qualified -import Data.Tagged import Imports -- | A list of users, partitioned into locals and remotes @@ -35,10 +34,10 @@ data UserList a = UserList deriving (Functor, Foldable, Traversable) toUserList :: Foldable f => Local x -> f (Qualified a) -> UserList a -toUserList loc = uncurry (flip UserList) . partitionRemoteOrLocalIds' (lDomain loc) +toUserList loc = uncurry UserList . partitionQualified loc ulAddLocal :: a -> UserList a -> UserList a ulAddLocal x ul = ul {ulLocals = x : ulLocals ul} ulAll :: Local x -> UserList a -> [Qualified a] -ulAll loc ul = map (unTagged . qualifyAs loc) (ulLocals ul) <> map unTagged (ulRemotes ul) +ulAll loc ul = map (qUntagged . qualifyAs loc) (ulLocals ul) <> map qUntagged (ulRemotes ul) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 065f4f9768f..7d0b95730bf 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1727,7 +1727,6 @@ getConvQualifiedOk = do accessConvMeta :: TestM () accessConvMeta = do - localDomain <- viewFederationDomain g <- view tsGalley alice <- randomUser bob <- randomUser @@ -1736,7 +1735,6 @@ accessConvMeta = do conv <- decodeConvId <$> postConv alice [bob, chuck] (Just "gossip") [] Nothing Nothing let meta = ConversationMetadata - (Qualified conv localDomain) RegularConv alice [InviteAccess] @@ -1846,10 +1844,11 @@ testGetQualifiedRemoteConv = do registerRemoteConv remoteConvId bobQ Nothing (Set.fromList [aliceAsOtherMember]) - let mockConversation = mkConv remoteConvId bobId roleNameWireAdmin [bobAsOtherMember] + let mockConversation = mkConv convId bobId roleNameWireAdmin [bobAsOtherMember] remoteConversationResponse = GetConversationsResponse [mockConversation] expected = Conversation + remoteConvId (rcnvMetadata mockConversation) (ConvMembers aliceAsSelfMember (rcmOthers (rcnvMembers mockConversation))) @@ -1893,7 +1892,7 @@ testGetQualifiedRemoteConvNotFoundOnRemote = do const 404 === statusCode const (Just "no-conversation") === view (at "label") . responseJsonUnsafe @Object --- | Tests getting many conversations given their ids. +-- | Tests getting many converations given their ids. -- -- In this test, Alice is a local user, who will be asking for metadata of these -- conversations: @@ -1948,8 +1947,8 @@ testBulkGetQualifiedConvs = do let bobAsOtherMember = OtherMember bobQ Nothing roleNameWireAdmin carlAsOtherMember = OtherMember carlQ Nothing roleNameWireAdmin - mockConversationA = mkConv remoteConvIdA bobId roleNameWireAdmin [bobAsOtherMember] - mockConversationB = mkConv remoteConvIdB carlId roleNameWireAdmin [carlAsOtherMember] + mockConversationA = mkConv (qUnqualified remoteConvIdA) bobId roleNameWireAdmin [bobAsOtherMember] + mockConversationB = mkConv (qUnqualified remoteConvIdB) carlId roleNameWireAdmin [carlAsOtherMember] req = ListConversations . unsafeRange $ [ localConvId, @@ -1981,8 +1980,8 @@ testBulkGetQualifiedConvs = do let expectedFound = sortOn cnvQualifiedId - $ maybeToList (remoteConversationView alice defMemberStatus mockConversationA) - <> maybeToList (remoteConversationView alice defMemberStatus mockConversationB) + $ maybeToList (remoteConversationView alice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) + <> maybeToList (remoteConversationView alice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) <> [localConv] actualFound = sortOn cnvQualifiedId $ crFound convs assertEqual "found conversations" expectedFound actualFound @@ -2734,7 +2733,7 @@ putRemoteConvMemberOk update = do let bobAsLocal = LocalMember (qUnqualified qbob) defMemberStatus Nothing roleNameWireAdmin let mockConversation = mkConv - qconv + (qUnqualified qconv) (qUnqualified qbob) roleNameWireMember [localMemberToOther remoteDomain bobAsLocal] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 9e5895ab1a2..eace125c2a7 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -110,7 +110,7 @@ getConversationsAllFound = do (map (qUnqualified . cnvQualifiedId) [cnv2]) ) - let c2 = find ((== cnvQualifiedId cnv2) . cnvmQualifiedId . rcnvMetadata) cs + let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) cs liftIO $ do assertEqual diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 452ec2c7f43..ec3bbcc83fc 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1492,7 +1492,7 @@ connectUsers u us = void $ connectUsersWith expect2xx u us connectLocalQualifiedUsers :: UserId -> List1 (Qualified UserId) -> TestM () connectLocalQualifiedUsers u us = do localDomain <- viewFederationDomain - let partitionMap = partitionQualified . toList . toNonEmpty $ us + let partitionMap = indexQualified . toList . toNonEmpty $ us -- FUTUREWORK: connect all users, not just those on the same domain as 'u' case LMap.lookup localDomain partitionMap of Nothing -> err @@ -1848,7 +1848,7 @@ randomEmail = do uid <- liftIO nextRandom return $ Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" -selfConv :: UserId -> Id C +selfConv :: UserId -> ConvId selfConv u = Id (toUUID u) -- TODO: Refactor, as used also in other services @@ -1913,15 +1913,15 @@ someLastPrekeys = ] mkConv :: - Qualified ConvId -> + ConvId -> UserId -> RoleName -> [OtherMember] -> FederatedGalley.RemoteConversation mkConv cnvId creator selfRole otherMembers = FederatedGalley.RemoteConversation + cnvId ( ConversationMetadata - cnvId RegularConv creator [] diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index f1c8b23780f..940178095fe 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -24,7 +24,6 @@ import Data.Containers.ListUtils (nubOrdOn) import Data.Domain import Data.Id import Data.Qualified -import Data.Tagged import Galley.API.Mapping import qualified Galley.Data as Data import Galley.Types.Conversations.Members @@ -51,7 +50,7 @@ tests = testProperty "conversation view metadata is correct" $ \(ConvWithLocalUser c uid) dom -> fmap cnvMetadata (conversationViewMaybe dom uid c) - == Just (Data.convMetadata dom c), + == Just (Data.convMetadata c), testProperty "other members in conversation view do not contain self" $ \(ConvWithLocalUser c uid) dom -> case conversationViewMaybe dom uid c of Nothing -> False @@ -70,24 +69,24 @@ tests = ==> isNothing (conversationViewMaybe dom uid c), testProperty "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> isJust (conversationToRemote dom ruid c), testProperty "self user role in remote conversation view is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> fmap (rcmSelfRole . rcnvMembers) (conversationToRemote dom ruid c) == Just roleNameWireMember, testProperty "remote conversation view metadata is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> fmap (rcnvMetadata) (conversationToRemote dom ruid c) - == Just (Data.convMetadata dom c), + == Just (Data.convMetadata c), testProperty "remote conversation view does not contain self" $ \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of Nothing -> False Just rcnv -> not - ( unTagged ruid + ( qUntagged ruid `elem` (map omQualifiedId (rcmOthers (rcnvMembers rcnv))) ) ] @@ -101,7 +100,7 @@ cnvUids dom c = convUids :: Domain -> Data.Conversation -> [Qualified UserId] convUids dom c = map ((`Qualified` dom) . lmId) (Data.convLocalMembers c) - <> map (unTagged . rmId) (Data.convRemoteMembers c) + <> map (qUntagged . rmId) (Data.convRemoteMembers c) genLocalMember :: Gen LocalMember genLocalMember = From fda14dd2bcbfd9c571dd3e1f98afe43a0188aa77 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 8 Oct 2021 12:01:04 +0200 Subject: [PATCH 13/88] Create remote 1-1 conversations (#1825) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Extract function to create UserList * Add stub for remote 1-1 conversation creation * Compute remote 1-1 conversation IDs * ensureConnected now takes a UserList * Make /conversations/one2one federation-aware Converted the endpoint for creating 1-1 conversations to the new conversation ID algorithm, and enabled the endpoint to create 1-1 conversations with federated users. Note: the case when the conversation needs to be hosted by the remote domain is still not implemented. We probably need a new RPC for this case. * Remove create from UUID Version class The create function cannot be defined for all UUID versions. * Introduce V5 UUIDs and use them for 1-1 conv * Servantify internal endpoint for connect conv * Make recipient field of connect event qualified * Extract function to create legacy connect conv * Add tests for the conversation ID algorithm * write internal with stubs for data functions * Implement a function for creating and updating a 1-1 remote conversation - The function is Galley.API.One2One.iUpsertOne2OneConversation * use schema-profunctor for json instances galley-types: no lax * galley-types rename module to Intra * galley: remove "these" dep galley.cabal * fix impossible example * remove todo * un-nameclash: one2OneConvId -> localOne2OneConvId * remove warning suppression * brig: add rpc function * change api: alwyas return a conv id * Add tests for one2one conversation internal endpoint * Test remote one2one conversation case * Update golden tests after change in connect event * Add CHANGELOG entry * Remove incorrect comment Co-authored-by: Marko Dimjašević Co-authored-by: Stefan Matting --- changelog.d/5-internal/one2one-upsert | 1 + libs/galley-types/galley-types.cabal | 4 +- libs/galley-types/package.yaml | 1 + .../src/Galley/Types/Conversations/Intra.hs | 87 ++++++++ libs/types-common/src/Data/UUID/Tagged.hs | 46 +++-- .../src/Wire/API/Event/Conversation.hs | 5 +- .../golden/testObject_Connect_user_1.json | 4 + .../golden/testObject_Connect_user_2.json | 4 + .../test/golden/testObject_Event_user_10.json | 4 + .../Wire/API/Golden/Generated/Connect_user.hs | 12 +- .../Wire/API/Golden/Generated/Event_user.hs | 5 +- services/brig/src/Brig/IO/Intra.hs | 31 ++- services/galley/galley.cabal | 13 +- services/galley/package.yaml | 6 +- services/galley/src/Galley/API/Create.hs | 191 +++++++++++++----- services/galley/src/Galley/API/Internal.hs | 39 +++- services/galley/src/Galley/API/One2One.hs | 166 +++++++++++++++ services/galley/src/Galley/API/Util.hs | 9 +- services/galley/src/Galley/Data.hs | 73 +++++-- services/galley/src/Galley/Types/UserList.hs | 7 + services/galley/test/integration/API.hs | 64 +++++- services/galley/test/integration/API/Util.hs | 9 +- services/galley/test/unit/Main.hs | 2 + .../test/unit/Test/Galley/API/One2One.hs | 51 +++++ 24 files changed, 711 insertions(+), 123 deletions(-) create mode 100644 changelog.d/5-internal/one2one-upsert create mode 100644 libs/galley-types/src/Galley/Types/Conversations/Intra.hs create mode 100644 services/galley/src/Galley/API/One2One.hs create mode 100644 services/galley/test/unit/Test/Galley/API/One2One.hs diff --git a/changelog.d/5-internal/one2one-upsert b/changelog.d/5-internal/one2one-upsert new file mode 100644 index 00000000000..5371eb9a786 --- /dev/null +++ b/changelog.d/5-internal/one2one-upsert @@ -0,0 +1 @@ +Add internal endpoint to insert or update a 1-1 conversation. This is to be used by brig when updating the status of a connection. diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 891555cac72..8af1c5e5f5a 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 8d07ea070b6384ec247f4473abb198bbb9639f72543920cbe46f561df96963ca +-- hash: d7419acbff460382bb822952b693f55513e729a4e3bcd0ddfdeea9e5285a805b name: galley-types version: 0.81.0 @@ -22,6 +22,7 @@ library Galley.Types Galley.Types.Bot Galley.Types.Bot.Service + Galley.Types.Conversations.Intra Galley.Types.Conversations.Members Galley.Types.Conversations.Roles Galley.Types.Teams @@ -42,6 +43,7 @@ library , exceptions >=0.10.0 , imports , lens >=4.12 + , schema-profunctor , string-conversions , tagged , text >=0.11 diff --git a/libs/galley-types/package.yaml b/libs/galley-types/package.yaml index 3c8971ad0a0..3d84f4036eb 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -21,6 +21,7 @@ library: - exceptions >=0.10.0 - lens >=4.12 - QuickCheck + - schema-profunctor - string-conversions - tagged - text >=0.11 diff --git a/libs/galley-types/src/Galley/Types/Conversations/Intra.hs b/libs/galley-types/src/Galley/Types/Conversations/Intra.hs new file mode 100644 index 00000000000..0cb0ba9afd7 --- /dev/null +++ b/libs/galley-types/src/Galley/Types/Conversations/Intra.hs @@ -0,0 +1,87 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Types.Conversations.Intra + ( DesiredMembership (..), + Actor (..), + UpsertOne2OneConversationRequest (..), + UpsertOne2OneConversationResponse (..), + ) +where + +import qualified Data.Aeson as A +import Data.Aeson.Types (FromJSON, ToJSON) +import Data.Id (ConvId, UserId) +import Data.Qualified +import Data.Schema +import Imports + +data DesiredMembership = Included | Excluded + deriving (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via Schema DesiredMembership + +instance ToSchema DesiredMembership where + schema = + enum @Text "DesiredMembership" $ + mconcat + [ element "included" Included, + element "excluded" Excluded + ] + +data Actor = LocalActor | RemoteActor + deriving (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via Schema Actor + +instance ToSchema Actor where + schema = + enum @Text "Actor" $ + mconcat + [ element "local_actor" LocalActor, + element "remote_actor" RemoteActor + ] + +data UpsertOne2OneConversationRequest = UpsertOne2OneConversationRequest + { uooLocalUser :: Local UserId, + uooRemoteUser :: Remote UserId, + uooActor :: Actor, + uooActorDesiredMembership :: DesiredMembership, + uooConvId :: Maybe (Qualified ConvId) + } + deriving (Show, Generic) + deriving (FromJSON, ToJSON) via Schema UpsertOne2OneConversationRequest + +instance ToSchema UpsertOne2OneConversationRequest where + schema = + object "UpsertOne2OneConversationRequest" $ + UpsertOne2OneConversationRequest + <$> (qUntagged . uooLocalUser) .= field "local_user" (qTagUnsafe <$> schema) + <*> (qUntagged . uooRemoteUser) .= field "remote_user" (qTagUnsafe <$> schema) + <*> uooActor .= field "actor" schema + <*> uooActorDesiredMembership .= field "actor_desired_membership" schema + <*> uooConvId .= field "conversation_id" (optWithDefault A.Null schema) + +newtype UpsertOne2OneConversationResponse = UpsertOne2OneConversationResponse + { uuorConvId :: Qualified ConvId + } + deriving (Show, Generic) + deriving (FromJSON, ToJSON) via Schema UpsertOne2OneConversationResponse + +instance ToSchema UpsertOne2OneConversationResponse where + schema = + object "UpsertOne2OneConversationResponse" $ + UpsertOne2OneConversationResponse + <$> uuorConvId .= field "conversation_id" schema diff --git a/libs/types-common/src/Data/UUID/Tagged.hs b/libs/types-common/src/Data/UUID/Tagged.hs index cd822e7d04a..e3552f0b0ba 100644 --- a/libs/types-common/src/Data/UUID/Tagged.hs +++ b/libs/types-common/src/Data/UUID/Tagged.hs @@ -17,12 +17,16 @@ module Data.UUID.Tagged ( UUID, + toUUID, V4, + V5, Version (..), version, variant, addv4, unpack, + create, + mk, ) where @@ -30,35 +34,43 @@ import Data.Bits import qualified Data.UUID as D import qualified Data.UUID.V4 as D4 import Imports -import Test.QuickCheck (Arbitrary, arbitrary) -- | Versioned UUID. -newtype UUID v = UUID D.UUID deriving (Eq, Ord, Show) +newtype UUID v = UUID {toUUID :: D.UUID} + deriving (Eq, Ord, Show) instance NFData (UUID v) where rnf (UUID a) = seq a () class Version v where - -- | Create a fresh versioned UUID. - create :: IO (UUID v) - -- | Try to turn a plain UUID into a versioned UUID. fromUUID :: D.UUID -> Maybe (UUID v) + fromUUID u = guard (version u == versionValue @v) $> UUID u + + versionValue :: Word32 data V4 instance Version V4 where - create = UUID <$> D4.nextRandom - fromUUID u = case version u of - 4 -> Just (UUID u) - _ -> Nothing - -instance Arbitrary (UUID V4) where - arbitrary = do - a <- arbitrary - b <- retainVersion 4 <$> arbitrary - c <- retainVariant 2 <$> arbitrary - d <- arbitrary - pure $ UUID $ D.fromWords a b c d + versionValue = 4 + +data V5 + +instance Version V5 where + versionValue = 5 + +mk :: forall v. Version v => D.UUID -> UUID v +mk u = UUID $ + case D.toWords u of + (x0, x1, x2, x3) -> + D.fromWords + x0 + (retainVersion (versionValue @v) x1) + (retainVariant 2 x2) + x3 + +-- | Create a fresh UUIDv4. +create :: IO (UUID V4) +create = UUID <$> D4.nextRandom -- | Extract the 'D.UUID' from a versioned UUID. unpack :: UUID v -> D.UUID diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index 0cc3da6702e..d681659225f 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -352,7 +352,7 @@ instance ToSchema SimpleMember where .= (field "conversation_role" schema <|> pure roleNameWireAdmin) data Connect = Connect - { cRecipient :: UserId, + { cRecipient :: Qualified UserId, -- FUTUREWORK: As a follow-up from -- https://github.com/wireapp/wire-server/pull/1726, the message field can -- be removed from this event. @@ -370,7 +370,8 @@ instance ToSchema Connect where connectObjectSchema :: ObjectSchema SwaggerDoc Connect connectObjectSchema = Connect - <$> cRecipient .= field "recipient" schema + <$> cRecipient .= field "qualified_recipient" schema + <* (Just . qUnqualified . cRecipient) .= optField "recipient" Nothing schema <*> cMessage .= lax (field "message" (optWithDefault A.Null schema)) <*> cName .= lax (field "name" (optWithDefault A.Null schema)) <*> cEmail .= lax (field "email" (optWithDefault A.Null schema)) diff --git a/libs/wire-api/test/golden/testObject_Connect_user_1.json b/libs/wire-api/test/golden/testObject_Connect_user_1.json index 551cb7d2b1e..63d654e6666 100644 --- a/libs/wire-api/test/golden/testObject_Connect_user_1.json +++ b/libs/wire-api/test/golden/testObject_Connect_user_1.json @@ -2,5 +2,9 @@ "email": "test email", "message": "E", "name": ".🝊]G", + "qualified_recipient": { + "domain": "foo.example.com", + "id": "00000002-0000-0001-0000-000400000004" + }, "recipient": "00000002-0000-0001-0000-000400000004" } diff --git a/libs/wire-api/test/golden/testObject_Connect_user_2.json b/libs/wire-api/test/golden/testObject_Connect_user_2.json index 8ce9a35dd43..76257ece7c0 100644 --- a/libs/wire-api/test/golden/testObject_Connect_user_2.json +++ b/libs/wire-api/test/golden/testObject_Connect_user_2.json @@ -2,5 +2,9 @@ "email": null, "message": null, "name": null, + "qualified_recipient": { + "domain": "bar.example.com", + "id": "00000005-0000-0007-0000-000200000008" + }, "recipient": "00000005-0000-0007-0000-000200000008" } diff --git a/libs/wire-api/test/golden/testObject_Event_user_10.json b/libs/wire-api/test/golden/testObject_Event_user_10.json index 3ec9ea0854c..7a1f9dcd990 100644 --- a/libs/wire-api/test/golden/testObject_Event_user_10.json +++ b/libs/wire-api/test/golden/testObject_Event_user_10.json @@ -4,6 +4,10 @@ "email": "󲛚", "message": "L", "name": "fq", + "qualified_recipient": { + "domain": "faraway.example.com", + "id": "00000008-0000-0000-0000-000600000001" + }, "recipient": "00000008-0000-0000-0000-000600000001" }, "from": "00007f28-0000-40b1-0000-56ab0000748d", diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs index ad3dcd121da..2e402120580 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs @@ -16,7 +16,9 @@ -- with this program. If not, see . module Test.Wire.API.Golden.Generated.Connect_user where +import Data.Domain import Data.Id (Id (Id)) +import Data.Qualified import qualified Data.UUID as UUID (fromString) import Imports (Maybe (Just, Nothing), fromJust) import Wire.API.Event.Conversation (Connect (..)) @@ -24,7 +26,10 @@ import Wire.API.Event.Conversation (Connect (..)) testObject_Connect_user_1 :: Connect testObject_Connect_user_1 = Connect - { cRecipient = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000400000004")), + { cRecipient = + Qualified + (Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000400000004"))) + (Domain "foo.example.com"), cMessage = Just "E", cName = Just ".\128842]G", cEmail = Just "test email" @@ -33,7 +38,10 @@ testObject_Connect_user_1 = testObject_Connect_user_2 :: Connect testObject_Connect_user_2 = Connect - { cRecipient = Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000200000008")), + { cRecipient = + Qualified + (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000200000008"))) + (Domain "bar.example.com"), cMessage = Nothing, cName = Nothing, cEmail = Nothing diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs index 6f5e8a6c28a..bf7223ebb75 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs @@ -214,7 +214,10 @@ testObject_Event_user_10 = (read "1864-05-25 01:31:49.802 UTC") ( EdConnect ( Connect - { cRecipient = Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000600000001")), + { cRecipient = + Qualified + (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000600000001"))) + (Domain "faraway.example.com"), cMessage = Just "L", cName = Just "fq", cEmail = Just "\992986" diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index afac8627dde..271c72b7f80 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -32,6 +32,7 @@ module Brig.IO.Intra blockConv, unblockConv, getConv, + upsertOne2OneConversation, -- * Clients Brig.IO.Intra.newClient, @@ -93,6 +94,7 @@ import Data.Qualified import Data.Range import qualified Data.Set as Set import Galley.Types (Connect (..), Conversation) +import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest, UpsertOne2OneConversationResponse) import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) import qualified Galley.Types.Teams.Intra as Team @@ -533,7 +535,7 @@ createSelfConv u = do . zUser u . expect2xx --- | Calls 'Galley.API.createConnectConversationH'. +-- | Calls 'Galley.API.Create.createConnectConversation'. createLocalConnectConv :: Local UserId -> Local UserId -> @@ -545,18 +547,17 @@ createLocalConnectConv from to cname conn = do logConnection (tUnqualified from) (qUntagged to) . remote "galley" . msg (val "Creating connect conversation") + let req = + path "/i/conversations/connect" + . zUser (tUnqualified from) + . maybe id (header "Z-Connection" . fromConnId) conn + . contentJson + . lbytes (encode $ Connect (qUntagged to) Nothing cname Nothing) + . expect2xx r <- galleyRequest POST req maybe (error "invalid conv id") return $ fromByteString $ getHeader' "Location" r - where - req = - path "/i/conversations/connect" - . zUser (tUnqualified from) - . maybe id (header "Z-Connection" . fromConnId) conn - . contentJson - . lbytes (encode $ Connect (tUnqualified to) Nothing cname Nothing) - . expect2xx createConnectConv :: Qualified UserId -> @@ -658,6 +659,18 @@ getConv usr cnv = do . zUser usr . expect [status200, status404] +upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> AppIO UpsertOne2OneConversationResponse +upsertOne2OneConversation urequest = do + response <- galleyRequest POST req + case Bilge.statusCode response of + 200 -> decodeBody "galley" response + _ -> throwM internalServerError + where + req = + paths ["i", "conversations", "one2one", "upsert"] + . header "Content-Type" "application/json" + . lbytes (encode urequest) + -- | Calls 'Galley.API.getTeamConversationH'. getTeamConv :: UserId -> TeamId -> ConvId -> AppIO (Maybe Team.TeamConversation) getTeamConv usr tid cnv = do diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index a43ea917332..57fabd19156 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a5b2ec0bd44d4fcabec564b4e7683a01cfb75cdb1c78a6eee520d6c48c95bb1d +-- hash: c121411458d6b0f7118ae1589134cb37711d29cad840e07d0f135663c59cc53a name: galley version: 0.83.0 @@ -35,6 +35,7 @@ library Galley.API.LegalHold.Conflicts Galley.API.Mapping Galley.API.Message + Galley.API.One2One Galley.API.Public Galley.API.Query Galley.API.Teams @@ -87,6 +88,7 @@ library , base >=4.6 && <5 , base64-bytestring >=1.0 , bilge >=0.21.1 + , binary , brig-types >=0.73.1 , bytestring >=0.9 , bytestring-conversion >=0.2 @@ -95,6 +97,7 @@ library , cassava >=0.5.2 , cereal >=0.4 , containers >=0.5 + , cryptonite , currency-codes >=2.0 , data-default >=0.5 , enclosed-exceptions >=1.0 @@ -113,6 +116,7 @@ library , imports , insert-ordered-containers , lens >=4.4 + , memory , metrics-wai >=0.4 , mtl >=2.2 , optparse-applicative >=0.10 @@ -172,6 +176,7 @@ executable galley , base , case-insensitive , extended + , extra >=1.3 , galley , galley-types , imports @@ -230,11 +235,13 @@ executable galley-integration , cereal , containers , cookie + , cql-io , currency-codes , data-timeout , errors , exceptions , extended + , extra >=1.3 , galley , galley-types , gundeck-types @@ -311,6 +318,7 @@ executable galley-migrate-data , containers , exceptions , extended + , extra >=1.3 , galley-types , imports , lens @@ -378,6 +386,7 @@ executable galley-schema , case-insensitive , cassandra-util , extended + , extra >=1.3 , imports , optparse-applicative , raw-strings-qq >=1.0 @@ -399,6 +408,7 @@ test-suite galley-types-tests other-modules: Test.Galley.API Test.Galley.API.Message + Test.Galley.API.One2One Test.Galley.Intra.User Test.Galley.Mapping Test.Galley.Roundtrip @@ -413,6 +423,7 @@ test-suite galley-types-tests , case-insensitive , containers , extended + , extra >=1.3 , galley , galley-types , http-types diff --git a/services/galley/package.yaml b/services/galley/package.yaml index a4bda422abc..2ae2bfe98a5 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -13,6 +13,7 @@ dependencies: - imports - case-insensitive - extended +- extra >=1.3 - safe >=0.3 - ssl-util - raw-strings-qq >=1.0 @@ -31,6 +32,7 @@ library: - base >=4.6 && <5 - base64-bytestring >=1.0 - bilge >=0.21.1 + - binary - brig-types >=0.73.1 - bytestring >=0.9 - bytestring-conversion >=0.2 @@ -38,12 +40,12 @@ library: - cassava >= 0.5.2 - cereal >=0.4 - containers >=0.5 + - cryptonite - currency-codes >=2.0 - data-default >=0.5 - enclosed-exceptions >=1.0 - errors >=2.0 - exceptions >=0.4 - - extra >=1.3 - galley-types >=0.65.0 - gundeck-types >=1.35.2 - HsOpenSSL >=0.11 @@ -56,6 +58,7 @@ library: - http2-client-grpc - insert-ordered-containers - lens >=4.4 + - memory - metrics-wai >=0.4 - mtl >=2.2 - optparse-applicative >=0.10 @@ -162,6 +165,7 @@ executables: - cereal - containers - cookie + - cql-io - currency-codes - metrics-wai - data-timeout diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index b5581f1b6cf..ccd977b2670 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -20,7 +20,7 @@ module Galley.API.Create internalCreateManagedConversationH, createSelfConversation, createOne2OneConversation, - createConnectConversationH, + createConnectConversation, ) where @@ -36,6 +36,7 @@ import Data.Time import qualified Data.UUID.Tagged as U import Galley.API.Error import Galley.API.Mapping +import Galley.API.One2One import Galley.API.Util import Galley.App import qualified Galley.Data as Data @@ -51,6 +52,7 @@ import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Routes.Public.Galley (ConversationResponse) import Wire.API.Routes.Public.Util import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) @@ -96,13 +98,9 @@ createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley Convers createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) - let unqualifiedUserIds = newConvUsers body - qualifiedUserIds = newConvQualifiedUsers body - allUsers = - toUserList lusr $ - map (qUntagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + let allUsers = newConvMembers lusr body checkedUsers <- checkedConvSize allUsers - ensureConnected zusr (ulLocals allUsers) + ensureConnected lusr allUsers checkRemoteUsersExist (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- @@ -125,11 +123,7 @@ createTeamGroupConv :: UserId -> ConnId -> Public.ConvTeamInfo -> Public.NewConv createTeamGroupConv zusr zcon tinfo body = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) - let unqualifiedUserIds = newConvUsers body - qualifiedUserIds = newConvQualifiedUsers body - allUsers = - toUserList lusr $ - map (qUntagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo zusrMembership <- Data.teamMember convTeam zusr @@ -186,75 +180,157 @@ createSelfConversation zusr = do createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do lusr <- qualifyLocal zusr - otherUserId <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [UserId])) - (x, y) <- toUUIDs zusr otherUserId - when (x == y) $ - throwM $ - invalidOp "Cannot create a 1-1 with yourself" - case newConvTeam j of + let allUsers = newConvMembers lusr j + other <- ensureOne (ulAll lusr allUsers) + when (qUntagged lusr == other) $ + throwM (invalidOp "Cannot create a 1-1 with yourself") + mtid <- case newConvTeam j of Just ti | cnvManaged ti -> throwM noManagedTeamConv - | otherwise -> - checkBindingTeamPermissions zusr otherUserId (cnvTeamId ti) - Nothing -> do - ensureConnected zusr [otherUserId] + | otherwise -> do + foldQualified + lusr + (\lother -> checkBindingTeamPermissions lusr lother (cnvTeamId ti)) + (const (pure Nothing)) + other + Nothing -> ensureConnected lusr allUsers $> Nothing n <- rangeCheckedMaybe (newConvName j) - c <- Data.conversation (Data.one2OneConvId x y) - maybe (create lusr x y n $ newConvTeam j) (conversationExisted zusr) c + foldQualified + lusr + (createLegacyOne2OneConversationUnchecked lusr zcon n mtid) + (createOne2OneConversationUnchecked lusr zcon n mtid . qUntagged) + other where verifyMembership tid u = do membership <- Data.teamMember tid u when (isNothing membership) $ throwM noBindingTeamMembers - checkBindingTeamPermissions x y tid = do - zusrMembership <- Data.teamMember tid zusr + checkBindingTeamPermissions lusr lother tid = do + zusrMembership <- Data.teamMember tid (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership Data.teamBinding tid >>= \case Just Binding -> do - verifyMembership tid x - verifyMembership tid y + verifyMembership tid (tUnqualified lusr) + verifyMembership tid (tUnqualified lother) + pure (Just tid) Just _ -> throwM nonBindingTeam Nothing -> throwM teamNotFound - create lusr x y n tinfo = do - c <- Data.createOne2OneConversation lusr x y n (cnvTeamId <$> tinfo) - notifyCreatedConversation Nothing zusr (Just zcon) c - conversationCreated zusr c -createConnectConversationH :: UserId ::: Maybe ConnId ::: JsonRequest Connect -> Galley Response -createConnectConversationH (usr ::: conn ::: req) = do - j <- fromJsonBody req - handleConversationResponse <$> createConnectConversation usr conn j +createLegacyOne2OneConversationUnchecked :: + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Local UserId -> + Galley ConversationResponse +createLegacyOne2OneConversationUnchecked self zcon name mtid other = do + lcnv <- localOne2OneConvId self other + mc <- Data.conversation (tUnqualified lcnv) + case mc of + Just c -> conversationExisted (tUnqualified self) c + Nothing -> do + (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) + c <- Data.createLegacyOne2OneConversation self x y name mtid + notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c + conversationCreated (tUnqualified self) c + +createOne2OneConversationUnchecked :: + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Galley ConversationResponse +createOne2OneConversationUnchecked self zcon name mtid other = do + let create = + foldQualified + self + createOne2OneConversationLocally + createOne2OneConversationRemotely + create (one2OneConvId (qUntagged self) other) self zcon name mtid other + +createOne2OneConversationLocally :: + Local ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Galley ConversationResponse +createOne2OneConversationLocally lcnv self zcon name mtid other = do + mc <- Data.conversation (tUnqualified lcnv) + case mc of + Just c -> conversationExisted (tUnqualified self) c + Nothing -> do + c <- Data.createOne2OneConversation lcnv self other name mtid + notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c + conversationCreated (tUnqualified self) c + +createOne2OneConversationRemotely :: + Remote ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Galley ConversationResponse +createOne2OneConversationRemotely _ _ _ _ _ _ = + throwM federationNotImplemented -createConnectConversation :: UserId -> Maybe ConnId -> Connect -> Galley ConversationResponse +createConnectConversation :: + UserId -> + Maybe ConnId -> + Connect -> + Galley ConversationResponse createConnectConversation usr conn j = do lusr <- qualifyLocal usr - (x, y) <- toUUIDs usr (cRecipient j) + foldQualified + lusr + (\lrcpt -> createLegacyConnectConversation lusr conn lrcpt j) + (createConnectConversationWithRemote lusr conn) + (cRecipient j) + +createConnectConversationWithRemote :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Galley ConversationResponse +createConnectConversationWithRemote _ _ _ = + throwM federationNotImplemented + +createLegacyConnectConversation :: + Local UserId -> + Maybe ConnId -> + Local UserId -> + Connect -> + Galley ConversationResponse +createLegacyConnectConversation lusr conn lrecipient j = do + (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) n <- rangeCheckedMaybe (cName j) - conv <- Data.conversation (Data.one2OneConvId x y) - maybe (create lusr x y n) (update n) conv + conv <- Data.conversation (Data.localOne2OneConvId x y) + maybe (create x y n) (update n) conv where - create lusr x y n = do + create x y n = do c <- Data.createConnectConversation lusr x y n now <- liftIO getCurrentTime let lcid = qualifyAs lusr (Data.convId c) e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) - notifyCreatedConversation Nothing usr conn c - for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> + notifyCreatedConversation Nothing (tUnqualified lusr) conn c + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn - conversationCreated usr c + conversationCreated (tUnqualified lusr) c update n conv = do let mems = Data.convLocalMembers conv - in conversationExisted usr + in conversationExisted (tUnqualified lusr) =<< if - | usr `isMember` mems -> + | (tUnqualified lusr) `isMember` mems -> -- we already were in the conversation, maybe also other connect n conv | otherwise -> do lcid <- qualifyLocal (Data.convId conv) - lusr <- qualifyLocal usr mm <- Data.addMember lcid lusr let conv' = conv @@ -266,7 +342,7 @@ createConnectConversation usr conn j = do connect n conv' else do -- we were not in the conversation, but someone else - conv'' <- acceptOne2One usr conv' conn + conv'' <- acceptOne2One (tUnqualified lusr) conv' conn if Data.convType conv'' == ConnectConv then connect n conv'' else return conv'' @@ -274,15 +350,14 @@ createConnectConversation usr conn j = do | Data.convType conv == ConnectConv = do localDomain <- viewFederationDomain let qconv = Qualified (Data.convId conv) localDomain - qusr = Qualified usr localDomain n' <- case n of Just x -> do Data.updateConversation (Data.convId conv) x return . Just $ fromRange x Nothing -> return $ Data.convName conv t <- liftIO getCurrentTime - let e = Event ConvConnect qconv qusr t (EdConnect j) - for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> + let e = Event ConvConnect qconv (qUntagged lusr) t (EdConnect j) + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> push1 $ p & pushRoute .~ RouteDirect @@ -330,6 +405,11 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route +localOne2OneConvId :: Local UserId -> Local UserId -> Galley (Local ConvId) +localOne2OneConvId self other = do + (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) + pure . qualifyAs self $ Data.localOne2OneConvId x y + toUUIDs :: UserId -> UserId -> Galley (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 @@ -343,3 +423,12 @@ access :: NewConv -> [Access] access a = case Set.toList (newConvAccess a) of [] -> Data.defRegularConvAccess (x : xs) -> x : xs + +newConvMembers :: Local x -> NewConv -> UserList UserId +newConvMembers loc body = + UserList (newConvUsers body) [] + <> toUserList loc (newConvQualifiedUsers body) + +ensureOne :: [a] -> Galley a +ensureOne [x] = pure x +ensureOne _ = throwM (invalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 65b8fd7a92e..925e5456f23 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -43,6 +43,7 @@ import qualified Galley.API.CustomBackend as CustomBackend import Galley.API.Error (throwErrorDescriptionType) import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) +import qualified Galley.API.One2One as One2One import qualified Galley.API.Query as Query import Galley.API.Teams (uncheckedDeleteTeamMember) import qualified Galley.API.Teams as Teams @@ -57,6 +58,7 @@ import qualified Galley.Queue as Q import Galley.Types import Galley.Types.Bot (AddBot, RemoveBot) import Galley.Types.Bot.Service +import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (..)) import Galley.Types.Teams hiding (MemberLeave) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility @@ -79,6 +81,7 @@ import Wire.API.ErrorDescription (MissingLegalholdConsent) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) import Wire.API.Routes.Public (ZOptConn, ZUser) +import Wire.API.Routes.Public.Galley (ConversationVerb) import qualified Wire.API.Team.Feature as Public data InternalApi routes = InternalApi @@ -175,7 +178,29 @@ data InternalApi routes = InternalApi :> ZOptConn :> "i" :> "user" - :> MultiVerb 'DELETE '[Servant.JSON] '[RespondEmpty 200 "Remove a user from Galley"] () + :> MultiVerb 'DELETE '[Servant.JSON] '[RespondEmpty 200 "Remove a user from Galley"] (), + -- This endpoint can lead to the following events being sent: + -- - ConvCreate event to self, if conversation did not exist before + -- - ConvConnect event to self, if other didn't join the connect conversation before + iConnect :: + routes + :- Summary "Create a connect conversation (deprecated)" + :> ZUser + :> ZOptConn + :> "i" + :> "conversations" + :> "connect" + :> ReqBody '[Servant.JSON] Connect + :> ConversationVerb, + iUpsertOne2OneConversation :: + routes + :- Summary "Create or Update a connect or one2one conversation." + :> "i" + :> "conversations" + :> "one2one" + :> "upsert" + :> ReqBody '[Servant.JSON] UpsertOne2OneConversationRequest + :> Post '[Servant.JSON] UpsertOne2OneConversationResponse } deriving (Generic) @@ -250,7 +275,9 @@ servantSitemap = iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, - iDeleteUser = rmUser + iDeleteUser = rmUser, + iConnect = Create.createConnectConversation, + iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation } iGetTeamFeature :: @@ -290,14 +317,6 @@ sitemap = do .&. zauthConnId .&. jsonRequest @NewConvManaged - -- This endpoint can lead to the following events being sent: - -- - ConvCreate event to self, if conversation did not exist before - -- - ConvConnect event to self, if other didn't join the connect conversation before - post "/i/conversations/connect" (continue Create.createConnectConversationH) $ - zauthUserId - .&. opt zauthConnId - .&. jsonRequest @Connect - -- This endpoint can lead to the following events being sent: -- - MemberJoin event to you, if the conversation existed and had < 2 members before -- - MemberJoin event to other, if the conversation existed and only the other was member diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs new file mode 100644 index 00000000000..fa9de3f254b --- /dev/null +++ b/services/galley/src/Galley/API/One2One.hs @@ -0,0 +1,166 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE RecordWildCards #-} + +module Galley.API.One2One + ( one2OneConvId, + iUpsertOne2OneConversation, + ) +where + +import Control.Error (atMay) +import qualified Crypto.Hash as Crypto +import Data.Bits +import Data.ByteArray (convert) +import qualified Data.ByteString as B +import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as L +import Data.Id +import Data.Qualified +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.UUID.Tagged as U +import Galley.App (Galley) +import qualified Galley.Data as Data +import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (..)) +import Galley.Types.UserList (UserList (..)) +import Imports + +-- | The hash function used to obtain the 1-1 conversation ID for a pair of users. +-- +-- /Note/: the hash function must always return byte strings of length > 16. +hash :: ByteString -> ByteString +hash = convert . Crypto.hash @ByteString @Crypto.SHA256 + +-- | A randomly-generated UUID to use as a namespace for the UUIDv5 of 1-1 +-- conversation IDs +namespace :: UUID +namespace = UUID.fromWords 0x9a51edb8 0x060c0d9a 0x0c2950a8 0x5d152982 + +compareDomains :: Ord a => Qualified a -> Qualified a -> Ordering +compareDomains (Qualified a1 dom1) (Qualified a2 dom2) = + compare (dom1, a1) (dom2, a2) + +quidToByteString :: Qualified UserId -> ByteString +quidToByteString (Qualified uid domain) = toByteString' uid <> toByteString' domain + +-- | This function returns the 1-1 conversation for a given pair of users. +-- +-- Let A, B denote the (not necessarily distinct) backends of the two users, +-- with the domain of A less or equal than the domain of B in the lexicographic +-- ordering of their ascii encodings. Given users a@A and b@B, the UUID and +-- owning domain of the unique 1-1 conversation between a and b shall be a +-- deterministic function of the input data, plus some fixed parameters, as +-- described below. +-- +-- __Parameters__ +-- +-- * A (collision-resistant) hash function h with N bits of output, where N +-- s a multiple of 8 strictly larger than 128; this is set to SHA256. +-- * A "namespace" UUID n. +-- +-- __Algorithm__ +-- +-- First, in the special case where A and B are the same backend, assume that +-- the UUID of a is lower than that of b. If that is not the case, swap a +-- and b in the following. This is necessary to ensure that the function we +-- describe below is symmetric in its arguments. +-- Let c be the bytestring obtained as the concatenation of the following 5 +-- components: +-- +-- * the 16 bytes of the namespace n +-- * the 16 bytes of the UUID of a +-- * the ascii encoding of the domain of A +-- * the 16 bytes of the UUID of b +-- * the ascii encoding of the domain of B, +-- +-- and let x = h(c) be its hashed value. The UUID of the 1-1 conversation +-- between a and b is obtained by converting the first 128 bits of x to a UUID +-- V5. Note that our use of V5 here is not strictly compliant with RFC 4122, +-- since we are using a custom hash and not necessarily SHA1. +-- +-- The owning domain for the conversation is set to be A if bit 128 of x (i.e. +-- the most significant bit of the octet at index 16) is 0, and B otherwise. +-- This is well-defined, because we assumed the number of bits of x to be +-- strictly larger than 128. +one2OneConvId :: Qualified UserId -> Qualified UserId -> Qualified ConvId +one2OneConvId a b = case compareDomains a b of + GT -> one2OneConvId b a + _ -> + let c = + mconcat + [ L.toStrict (UUID.toByteString namespace), + quidToByteString a, + quidToByteString b + ] + x = hash c + result = + U.toUUID . U.mk @U.V5 + . fromMaybe UUID.nil + -- fromByteString only returns 'Nothing' when the input is not + -- exactly 16 bytes long, here this should not be a case since + -- 'hash' is supposed to return atleast 16 bytes and we use 'B.take + -- 16' to truncate it + . UUID.fromByteString + . L.fromStrict + . B.take 16 + $ x + domain + | fromMaybe 0 (atMay (B.unpack x) 16) .&. 0x80 == 0 = qDomain a + | otherwise = qDomain b + in Qualified (Id result) domain + +iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley UpsertOne2OneConversationResponse +iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do + let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId + + let dolocal :: Local ConvId -> Galley () + dolocal lconvId = do + mbConv <- Data.conversation (tUnqualified lconvId) + case mbConv of + Nothing -> do + let members = + case (uooActor, uooActorDesiredMembership) of + (LocalActor, Included) -> UserList [tUnqualified uooLocalUser] [] + (LocalActor, Excluded) -> UserList [] [] + (RemoteActor, Included) -> UserList [] [uooRemoteUser] + (RemoteActor, Excluded) -> UserList [] [] + unless (null members) $ + Data.createConnectConversationWithRemote lconvId uooLocalUser members + Just conv -> do + case (uooActor, uooActorDesiredMembership) of + (LocalActor, Included) -> do + void $ Data.addMember lconvId uooLocalUser + unless (null (Data.convRemoteMembers conv)) $ + Data.acceptConnect (tUnqualified lconvId) + (LocalActor, Excluded) -> Data.removeMember (tUnqualified uooLocalUser) (tUnqualified lconvId) + (RemoteActor, Included) -> do + void $ Data.addMembers lconvId (UserList [] [uooRemoteUser]) + unless (null (Data.convLocalMembers conv)) $ + Data.acceptConnect (tUnqualified lconvId) + (RemoteActor, Excluded) -> Data.removeRemoteMembersFromLocalConv (tUnqualified lconvId) (pure uooRemoteUser) + doremote :: Remote ConvId -> Galley () + doremote rconvId = + case (uooActor, uooActorDesiredMembership) of + (LocalActor, Included) -> do + Data.addLocalMembersToRemoteConv (qUntagged rconvId) [tUnqualified uooLocalUser] + (LocalActor, Excluded) -> do + Data.removeLocalMembersFromRemoteConv (qUntagged rconvId) [tUnqualified uooLocalUser] + (RemoteActor, _) -> pure () + + foldQualified uooLocalUser dolocal doremote convId + pure (UpsertOne2OneConversationResponse convId) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 045588dc954..f12365ae722 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -99,18 +99,17 @@ ensureConnectedOrSameTeam (Qualified u domain) uids = do sameTeamUids <- forM uTeams $ \team -> fmap (view userId) <$> Data.teamMembersLimited team uids -- Do not check connections for users that are on the same team - ensureConnected u (uids \\ join sameTeamUids) + ensureConnectedToLocals u (uids \\ join sameTeamUids) -- | Check that the user is connected to everybody else. -- -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: UserId -> [UserId] -> Galley () -ensureConnected _ [] = pure () -ensureConnected u localUserIds = do +ensureConnected :: Local UserId -> UserList UserId -> Galley () +ensureConnected self others = do -- FUTUREWORK(federation, #1262): check remote connections - ensureConnectedToLocals u localUserIds + ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToLocals :: UserId -> [UserId] -> Galley () ensureConnectedToLocals _ [] = pure () diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 55be7a13813..0e3267a7f54 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -68,7 +68,9 @@ module Galley.Data conversationMeta, conversationsRemote, createConnectConversation, + createConnectConversationWithRemote, createConversation, + createLegacyOne2OneConversation, createOne2OneConversation, createSelfConversation, isConvAlive, @@ -112,7 +114,7 @@ module Galley.Data updateClient, -- * Utilities - one2OneConvId, + localOne2OneConvId, newMember, -- * Defaults @@ -156,7 +158,14 @@ import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles -import Galley.Types.Teams hiding (Event, EventType (..), teamConversations, teamMembers) +import Galley.Types.Teams hiding + ( Event, + EventType (..), + self, + teamConversations, + teamMembers, + ) +import qualified Galley.Types.Teams as Teams import Galley.Types.Teams.Intra import Galley.Types.UserList import Galley.Validation @@ -435,7 +444,7 @@ updateTeamMember oldPerms tid uid newPerms = do when (SetBilling `Set.member` lostPerms) $ addPrepQuery Cql.deleteBillingTeamMember (tid, uid) where - permDiff = Set.difference `on` view self + permDiff = Set.difference `on` view Teams.self acquiredPerms = newPerms `permDiff` oldPerms lostPerms = oldPerms `permDiff` newPerms @@ -671,7 +680,7 @@ createConnectConversation :: Maybe (Range 1 256 Text) -> m Conversation createConnectConversation loc a b name = do - let conv = one2OneConvId a b + let conv = localOne2OneConvId a b lconv = qualifyAs loc conv a' = Id . U.unpack $ a retry x5 $ @@ -681,7 +690,20 @@ createConnectConversation loc a b name = do (lmems, rmems) <- addMembers lconv (UserList [a'] []) pure $ newConv conv ConnectConv a' lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing -createOne2OneConversation :: +createConnectConversationWithRemote :: + MonadClient m => + Local ConvId -> + Local UserId -> + UserList UserId -> + m () +createConnectConversationWithRemote lconvId creator m = do + retry x5 $ + write Cql.insertConv (params Quorum (tUnqualified lconvId, ConnectConv, tUnqualified creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) + -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + void $ addMembers lconvId m + +createLegacyOne2OneConversation :: MonadClient m => Local x -> U.UUID U.V4 -> @@ -689,21 +711,36 @@ createOne2OneConversation :: Maybe (Range 1 256 Text) -> Maybe TeamId -> m Conversation -createOne2OneConversation loc a b name ti = do - let conv = one2OneConvId a b +createLegacyOne2OneConversation loc a b name ti = do + let conv = localOne2OneConvId a b lconv = qualifyAs loc conv a' = Id (U.unpack a) b' = Id (U.unpack b) - retry x5 $ case ti of - Nothing -> write Cql.insertConv (params Quorum (conv, One2OneConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + createOne2OneConversation + lconv + (qualifyAs loc a') + (qUntagged (qualifyAs loc b')) + name + ti + +createOne2OneConversation :: + MonadClient m => + Local ConvId -> + Local UserId -> + Qualified UserId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + m Conversation +createOne2OneConversation lconv self other name mtid = do + retry x5 $ case mtid of + Nothing -> write Cql.insertConv (params Quorum (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) Just tid -> batch $ do setType BatchLogged setConsistency Quorum - addPrepQuery Cql.insertConv (conv, One2OneConv, a', privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) - addPrepQuery Cql.insertTeamConv (tid, conv, False) - -- FUTUREWORK: federated one2one - (lmems, rmems) <- addMembers lconv (UserList [a', b'] []) - pure $ newConv conv One2OneConv a' lmems rmems [PrivateAccess] privateRole name ti Nothing Nothing + addPrepQuery Cql.insertConv (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) + addPrepQuery Cql.insertTeamConv (tid, tUnqualified lconv, False) + (lmems, rmems) <- addMembers lconv (toUserList self [qUntagged self, other]) + pure $ newConv (tUnqualified lconv) One2OneConv (tUnqualified self) lmems rmems [PrivateAccess] privateRole name mtid Nothing Nothing updateConversation :: MonadClient m => ConvId -> Range 1 256 Text -> m () updateConversation cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) @@ -736,8 +773,8 @@ acceptConnect cid = retry x5 $ write Cql.updateConvType (params Quorum (One2OneC -- together pairwise, and then setting the version bits (v4) and variant bits -- (variant 2). This means that we always know what the UUID is for a -- one-to-one conversation which hopefully makes them unique. -one2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId -one2OneConvId a b = Id . U.unpack $ U.addv4 a b +localOne2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId +localOne2OneConvId a b = Id . U.unpack $ U.addv4 a b newConv :: ConvId -> @@ -845,7 +882,7 @@ toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) memberLists :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => + (MonadClient m, MonadThrow m) => [ConvId] -> m [[LocalMember]] memberLists convs = do @@ -860,7 +897,7 @@ memberLists convs = do mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) -members :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m [LocalMember] +members :: (MonadClient m, MonadThrow m) => ConvId -> m [LocalMember] members conv = join <$> memberLists [conv] lookupRemoteMembers :: (MonadClient m) => ConvId -> m [RemoteMember] diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index ffcabd6984e..c63148d6b97 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -33,6 +33,13 @@ data UserList a = UserList } deriving (Functor, Foldable, Traversable) +instance Semigroup (UserList a) where + UserList locals1 remotes1 <> UserList locals2 remotes2 = + UserList (locals1 <> locals2) (remotes1 <> remotes2) + +instance Monoid (UserList a) where + mempty = UserList mempty mempty + toUserList :: Foldable f => Local x -> f (Qualified a) -> UserList a toUserList loc = uncurry UserList . partitionQualified loc diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7d0b95730bf..5a3b6e8cb3d 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -59,9 +59,13 @@ import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Ascii as Ascii import Data.Time.Clock (getCurrentTime) +import Database.CQL.IO import Galley.API.Mapping +import Galley.API.One2One (one2OneConvId) +import qualified Galley.Data as Data import Galley.Options (Opts, optFederator) import Galley.Types hiding (LocalMember (..)) +import Galley.Types.Conversations.Intra import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles import qualified Galley.Types.Teams as Teams @@ -215,7 +219,8 @@ tests s = test s "convert invite to code-access conversation" postConvertCodeConv, test s "convert code to team-access conversation" postConvertTeamConv, test s "cannot join private conversation" postJoinConvFail, - test s "remove user" removeUser + test s "remove user" removeUser, + test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests ] emptyFederatedBrig :: FederatedBrig.Api (AsServerT Handler) @@ -1573,11 +1578,11 @@ postConnectConvOk2 :: TestM () postConnectConvOk2 = do alice <- randomUser bob <- randomUser - m <- decodeConvId <$> request alice bob - n <- decodeConvId <$> request alice bob + m <- decodeConvId <$> req alice bob + n <- decodeConvId <$> req alice bob liftIO $ m @=? n where - request alice bob = + req alice bob = postConnectConv alice bob "Alice" "connect with me!" (Just "me@me.com") putConvAcceptOk :: TestM () @@ -2942,3 +2947,54 @@ removeUser = do omService = Nothing, omConvRoleName = roleNameWireAdmin } + +testAllOne2OneConversationRequests :: TestM () +testAllOne2OneConversationRequests = do + for_ [LocalActor, RemoteActor] $ \actor -> + for_ [Included, Excluded] $ \desired -> + for_ [True, False] $ \shouldBeLocal -> + testOne2OneConversationRequest shouldBeLocal actor desired + +testOne2OneConversationRequest :: Bool -> Actor -> DesiredMembership -> TestM () +testOne2OneConversationRequest shouldBeLocal actor desired = do + alice <- qTagUnsafe <$> randomQualifiedUser + (bob, expectedConvId) <- generateRemoteAndConvId alice + db <- view tsCass + + convId <- do + let req = UpsertOne2OneConversationRequest alice bob actor desired Nothing + res <- + iUpsertOne2OneConversation req + responseJsonError res + + liftIO $ convId @?= expectedConvId + + case shouldBeLocal of + True -> do + mems <- runClient db $ do + lmems <- fmap (qUntagged . qualifyAs alice . lmId) <$> Data.members (qUnqualified convId) + rmems <- fmap (qUntagged . rmId) <$> Data.lookupRemoteMembers (qUnqualified convId) + pure (lmems <> rmems) + let actorId = case actor of + LocalActor -> qUntagged alice + RemoteActor -> qUntagged bob + liftIO $ isJust (find (actorId ==) mems) @?= (desired == Included) + liftIO $ filter (actorId /=) mems @?= [] + False -> do + mems <- runClient db $ do + smap <- Data.remoteConversationStatus (tUnqualified alice) [qTagUnsafe convId] + case Map.lookup (qTagUnsafe convId) smap of + Just _ -> pure [qUntagged alice] + _ -> pure [] + when (actor == LocalActor) $ + liftIO $ isJust (find (qUntagged alice ==) mems) @?= (desired == Included) + where + generateRemoteAndConvId :: Local UserId -> TestM (Remote UserId, Qualified ConvId) + generateRemoteAndConvId lUserId = do + other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + let convId = one2OneConvId (qUntagged lUserId) other + isLocal = tDomain lUserId == qDomain convId + if shouldBeLocal == isLocal + then pure (qTagUnsafe other, convId) + else generateRemoteAndConvId lUserId diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index ec3bbcc83fc..aa6549d3ebf 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -71,6 +71,7 @@ import qualified Galley.Options as Opts import qualified Galley.Run as Run import Galley.Types import qualified Galley.Types as Conv +import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..)) import Galley.Types.Conversations.Roles hiding (DeleteConversation) import Galley.Types.Teams hiding (Event, EventType (..)) import qualified Galley.Types.Teams as Team @@ -594,6 +595,7 @@ postO2OConv u1 u2 n = do postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS postConnectConv a b name msg email = do + qb <- Qualified <$> pure b <*> viewFederationDomain g <- view tsGalley post $ g @@ -601,7 +603,7 @@ postConnectConv a b name msg email = do . zUser a . zConn "conn" . zType "access" - . json (Connect b (Just msg) (Just name) email) + . json (Connect qb (Just msg) (Just name) email) putConvAccept :: UserId -> ConvId -> TestM ResponseLBS putConvAccept invited cid = do @@ -2328,3 +2330,8 @@ fedRequestsForDomain domain component = assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs + +iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> TestM ResponseLBS +iUpsertOne2OneConversation req = do + galley <- view tsGalley + post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req) diff --git a/services/galley/test/unit/Main.hs b/services/galley/test/unit/Main.hs index c0a1dbcdd31..bfd608d4db7 100644 --- a/services/galley/test/unit/Main.hs +++ b/services/galley/test/unit/Main.hs @@ -23,6 +23,7 @@ where import Imports import qualified Test.Galley.API import qualified Test.Galley.API.Message +import qualified Test.Galley.API.One2One import qualified Test.Galley.Intra.User import qualified Test.Galley.Mapping import qualified Test.Galley.Roundtrip @@ -34,6 +35,7 @@ main = =<< sequence [ pure Test.Galley.API.tests, pure Test.Galley.API.Message.tests, + pure Test.Galley.API.One2One.tests, pure Test.Galley.Intra.User.tests, pure Test.Galley.Mapping.tests, Test.Galley.Roundtrip.tests diff --git a/services/galley/test/unit/Test/Galley/API/One2One.hs b/services/galley/test/unit/Test/Galley/API/One2One.hs new file mode 100644 index 00000000000..d3f6f0332fe --- /dev/null +++ b/services/galley/test/unit/Test/Galley/API/One2One.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE NumericUnderscores #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- | Tests for one-to-one conversations +module Test.Galley.API.One2One where + +import Data.Id +import Data.List.Extra +import Data.Qualified +import Galley.API.One2One (one2OneConvId) +import Imports +import Test.Tasty +import Test.Tasty.HUnit (Assertion, testCase, (@?=)) +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "one2OneConvId" + [ testProperty "symmetry" one2OneConvIdSymmetry, + testCase "non-collision" one2OneConvIdNonCollision + ] + +one2OneConvIdSymmetry :: Qualified UserId -> Qualified UserId -> Property +one2OneConvIdSymmetry quid1 quid2 = one2OneConvId quid1 quid2 === one2OneConvId quid2 quid1 + +-- | Make sure that we never get the same conversation ID for a pair of +-- (assumingly) distinct qualified user IDs +one2OneConvIdNonCollision :: Assertion +one2OneConvIdNonCollision = do + let len = 10_000 + -- A generator of lists of length 'len' of qualified user ID pairs + let gen = vectorOf len arbitrary + quids <- head <$> sample' gen + anySame (fmap (uncurry one2OneConvId) quids) @?= False From 1087af05756b900811f3c8e1df01aa709c66954b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 8 Oct 2021 15:41:42 +0200 Subject: [PATCH 14/88] Leave a note with a link to a Jira ticket about a flaky test (#1844) --- services/brig/test/integration/API/Provider.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 0d31b984125..535023c2796 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1750,6 +1750,8 @@ svcAssertConvAccessUpdate buf usr upd cnv = liftIO $ do evt <- timeout (5 # Second) $ readChan buf case evt of Just (TestBotMessage e) -> do + -- FUTUREWORK: Sometimes the assertion on the event type fails, but not + -- always. See https://wearezeta.atlassian.net/browse/BE-522. assertEqual "event type" ConvAccessUpdate (evtType e) assertEqual "conv" cnv (evtConv e) assertEqual "user" usr (evtFrom e) From 52966230d8b0f3ebeb52fcd00cdfa6684b89f206 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 11 Oct 2021 12:56:17 +0200 Subject: [PATCH 15/88] Make non-collision test for 1-1 conv ids faster (#1846) The `anySame` function has quadratic runtime, but here we can use an `Ord` instance, and just compare the `nubOrd` lists. This also removes a potential flakyness caused by repeated input pairs (which should be quite likely to happen, given the low entropy of the UUID generator). --- services/galley/test/unit/Test/Galley/API/One2One.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/services/galley/test/unit/Test/Galley/API/One2One.hs b/services/galley/test/unit/Test/Galley/API/One2One.hs index d3f6f0332fe..913a0ed8390 100644 --- a/services/galley/test/unit/Test/Galley/API/One2One.hs +++ b/services/galley/test/unit/Test/Galley/API/One2One.hs @@ -47,5 +47,6 @@ one2OneConvIdNonCollision = do let len = 10_000 -- A generator of lists of length 'len' of qualified user ID pairs let gen = vectorOf len arbitrary - quids <- head <$> sample' gen - anySame (fmap (uncurry one2OneConvId) quids) @?= False + quids <- nubOrd <$> generate gen + let hashes = nubOrd (fmap (uncurry one2OneConvId) quids) + length hashes @?= length quids From 359d6bf614f7ffeabf5ebbc81b61606c749b9f7a Mon Sep 17 00:00:00 2001 From: jschaul Date: Mon, 11 Oct 2021 16:58:48 +0200 Subject: [PATCH 16/88] add comment to test for FUTUREWORK (#1848) --- services/brig/test/integration/API/Search.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index b6e73b4bb1b..301f4d7c60a 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -258,6 +258,9 @@ testReindex brig = do -- This test is currently disabled, because it fails sporadically, probably due -- to imprecisions in ES exact match scoring. -- FUTUREWORK: Find the reason for the failures and fix ES behaviour. +-- See also the "cassandra writetime hypothesis": +-- https://wearezeta.atlassian.net/browse/BE-523 +-- https://github.com/wireapp/wire-server/pull/1798#issuecomment-933174913 _testOrderName :: TestConstraints m => Brig -> m () _testOrderName brig = do searcher <- userId <$> randomUser brig From f9405a39971557da215df9c1eb77e2c03c90590e Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 11 Oct 2021 19:50:02 +0200 Subject: [PATCH 17/88] Fix error in member csv creation (SAML.UserRef decoding error) (#1828) * Add failing test case. * Nit-pick. * Do not git-ignore pem files (at least not all of them). * Fix error message. * More detail in scim error responses. * An idea. * Implement the idea. * FUTUREWORK. --- .gitignore | 3 +- changelog.d/3-bug-fixes/pr-1828 | 1 + libs/wire-api/package.yaml | 3 +- libs/wire-api/src/Wire/API/User.hs | 9 +- libs/wire-api/src/Wire/API/User/Identity.hs | 133 +++++++++++++++--- .../testObject_NewUserPublic_user_1-1.json | 32 ----- .../fromJSON/testObject_NewUser_user_6-2.json | 9 -- .../fromJSON/testObject_NewUser_user_6-4.json | 10 -- .../testObject_ActivationResponse_user_1.json | 4 +- ...testObject_ActivationResponse_user_19.json | 4 +- .../golden/testObject_NewUser_user_6.json | 4 +- .../testObject_UserIdentity_user_16.json | 4 +- .../testObject_UserIdentity_user_5.json | 4 +- .../testObject_UserIdentity_user_8.json | 4 +- .../golden/testObject_UserSSOId_user_2.json | 3 +- .../unit/Test/Wire/API/Golden/FromJSON.hs | 16 +-- .../unit/Test/Wire/API/Golden/Generated.hs | 4 +- .../Generated/ActivationResponse_user.hs | 5 +- .../Wire/API/Golden/Generated/NewUser_user.hs | 4 +- .../API/Golden/Generated/UserIdentity_user.hs | 7 +- .../API/Golden/Generated/UserSSOId_user.hs | 56 +------- libs/wire-api/test/unit/Test/Wire/API/User.hs | 2 +- libs/wire-api/wire-api.cabal | 5 +- services/brig/src/Brig/API/User.hs | 2 +- services/brig/src/Brig/User/Search/Index.hs | 7 +- services/brig/test/integration/API/Team.hs | 5 +- .../brig/test/integration/API/User/Account.hs | 11 +- services/galley/galley.cabal | 7 +- services/galley/package.yaml | 2 +- services/galley/src/Galley/API/Teams.hs | 9 +- services/galley/test/integration/API/Teams.hs | 6 +- services/galley/test/integration/API/Util.hs | 3 +- services/spar/src/Spar/Intra/Brig.hs | 9 +- services/spar/src/Spar/Intra/BrigApp.hs | 46 ++---- services/spar/src/Spar/Scim/User.hs | 24 ++-- .../Test/Spar/Scim/UserSpec.hs | 21 ++- services/spar/test-integration/Util/Core.hs | 6 +- services/spar/test-integration/Util/Scim.hs | 4 +- .../spar/test/Test/Spar/Intra/BrigSpec.hs | 15 +- 39 files changed, 232 insertions(+), 271 deletions(-) create mode 100644 changelog.d/3-bug-fixes/pr-1828 delete mode 100644 libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-1.json delete mode 100644 libs/wire-api/test/golden/fromJSON/testObject_NewUser_user_6-2.json delete mode 100644 libs/wire-api/test/golden/fromJSON/testObject_NewUser_user_6-4.json diff --git a/.gitignore b/.gitignore index c8af0964efe..8e9a7a3b4c7 100644 --- a/.gitignore +++ b/.gitignore @@ -33,7 +33,6 @@ TAGS .stack-docker-profile .metadata *.tix -*.pem .DS_Store services/nginz/src services/.env @@ -99,4 +98,4 @@ i.yaml b.yaml telepresence.log -/.ghci \ No newline at end of file +/.ghci diff --git a/changelog.d/3-bug-fixes/pr-1828 b/changelog.d/3-bug-fixes/pr-1828 new file mode 100644 index 00000000000..f711d6561b3 --- /dev/null +++ b/changelog.d/3-bug-fixes/pr-1828 @@ -0,0 +1 @@ +SAML columns (Issuer, NameID) in CSV files with team members. \ No newline at end of file diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index 18108e1cd3e..9d813db174d 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -16,6 +16,8 @@ dependencies: - servant-swagger-ui - case-insensitive - hscim +- saml2-web-sso +- filepath library: source-dirs: src dependencies: @@ -60,7 +62,6 @@ library: - QuickCheck >=2.14 - quickcheck-instances >=0.3.16 - resourcet - - saml2-web-sso - servant - servant-client - servant-client-core diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 07ab1e05df6..7a98a355eb4 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -120,7 +120,6 @@ import Data.Schema import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Data.Text.Ascii -import qualified Data.Text.Lazy as TL import Data.UUID (UUID, nil) import qualified Data.UUID as UUID import Deriving.Swagger @@ -412,12 +411,12 @@ userSCIMExternalId :: User -> Maybe Text userSCIMExternalId usr = userSSOId >=> ssoIdExtId $ usr where ssoIdExtId :: UserSSOId -> Maybe Text - ssoIdExtId (UserSSOId _ nameIdXML) = case userManagedBy usr of + ssoIdExtId (UserSSOId (SAML.UserRef _ nameIdXML)) = case userManagedBy usr of ManagedByWire -> Nothing ManagedByScim -> - -- FUTUREWORK: keep the CI value, store the original in the database, but always use - -- the CI value for processing. - CI.original . SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (TL.fromStrict nameIdXML)) + -- FUTUREWORK: this is only ignoring case in the email format, and emails should be + -- handled case-insensitively. https://wearezeta.atlassian.net/browse/SQSERVICES-909 + Just . CI.original . SAML.unsafeShowNameID $ nameIdXML ssoIdExtId (UserScimExternalId extId) = pure extId connectedProfile :: User -> UserLegalHoldStatus -> UserProfile diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index f70575cd1a0..55584f1eba1 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -40,28 +40,43 @@ module Wire.API.User.Identity -- * UserSSOId UserSSOId (..), - - -- * Swagger + emailFromSAML, + emailToSAML, + emailToSAMLNameID, + emailFromSAMLNameID, + mkSampleUref, + mkSimpleSampleUref, ) where import Control.Applicative (optional) -import Control.Lens ((.~), (?~)) +import Control.Lens ((.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A import Data.Attoparsec.Text -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.ByteString.Conversion +import qualified Data.CaseInsensitive as CI import Data.Proxy (Proxy (..)) import Data.Schema +import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Time.Clock import Imports +import SAML2.WebSSO.Test.Arbitrary () +import qualified SAML2.WebSSO.Types as SAML +import qualified SAML2.WebSSO.Types.Email as SAMLEmail +import qualified SAML2.WebSSO.XML as SAML +import System.FilePath (()) import qualified Test.QuickCheck as QC import qualified Text.Email.Validate as Email.V +import qualified URI.ByteString as URI +import URI.ByteString.QQ (uri) import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) +import Wire.API.User.Profile (fromName, mkName) -------------------------------------------------------------------------------- -- UserIdentity @@ -267,30 +282,27 @@ isValidPhone = either (const False) (const True) . parseOnly e164 -- | User's external identity. -- --- Morally this is the same thing as 'SAML.UserRef', but we forget the --- structure -- i.e. we just store XML-encoded SAML blobs. If the structure --- of those blobs changes, Brig won't have to deal with it, only Spar will. +-- NB: this type is serialized to the full xml encoding of the `SAML.UserRef` components, but +-- deserialiation is more lenient: it also allows for the `Issuer` to be a plain URL (without +-- xml around it), and the `NameID` to be an email address (=> format "email") or an arbitrary +-- text (=> format "unspecified"). This is for backwards compatibility and general +-- robustness. -- --- FUTUREWORK: rename the data type to @UserSparId@ (not the two constructors, those are ok). +-- FUTUREWORK: we should probably drop this entirely and store saml and scim data in separate +-- database columns. data UserSSOId - = UserSSOId - -- An XML blob pointing to the identity provider that can confirm - -- user's identity. - Text - -- An XML blob specifying the user's ID on the identity provider's side. - Text - | UserScimExternalId - Text + = UserSSOId SAML.UserRef + | UserScimExternalId Text deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserSSOId) --- FUTUREWORK: This schema should ideally be a choice of either tenant+subject, or scim_external_id +-- | FUTUREWORK: This schema should ideally be a choice of either tenant+subject, or scim_external_id -- but this is currently not possible to derive in swagger2 -- Maybe this becomes possible with swagger 3? instance S.ToSchema UserSSOId where declareNamedSchema _ = do - tenantSchema <- S.declareSchemaRef (Proxy @Text) - subjectSchema <- S.declareSchemaRef (Proxy @Text) + tenantSchema <- S.declareSchemaRef (Proxy @Text) -- FUTUREWORK: 'Issuer' + subjectSchema <- S.declareSchemaRef (Proxy @Text) -- FUTUREWORK: 'NameID' scimSchema <- S.declareSchemaRef (Proxy @Text) return $ S.NamedSchema (Just "UserSSOId") $ @@ -304,16 +316,16 @@ instance S.ToSchema UserSSOId where instance ToJSON UserSSOId where toJSON = \case - UserSSOId tenant subject -> A.object ["tenant" A..= tenant, "subject" A..= subject] + UserSSOId (SAML.UserRef tenant subject) -> A.object ["tenant" A..= SAML.encodeElem tenant, "subject" A..= SAML.encodeElem subject] UserScimExternalId eid -> A.object ["scim_external_id" A..= eid] instance FromJSON UserSSOId where parseJSON = A.withObject "UserSSOId" $ \obj -> do - mtenant <- obj A..:? "tenant" - msubject <- obj A..:? "subject" + mtenant <- lenientlyParseSAMLIssuer =<< (obj A..:? "tenant") + msubject <- lenientlyParseSAMLNameID =<< (obj A..:? "subject") meid <- obj A..:? "scim_external_id" case (mtenant, msubject, meid) of - (Just tenant, Just subject, Nothing) -> pure $ UserSSOId tenant subject + (Just tenant, Just subject, Nothing) -> pure $ UserSSOId (SAML.UserRef tenant subject) (Nothing, Nothing, Just eid) -> pure $ UserScimExternalId eid _ -> fail "either need tenant and subject, or scim_external_id, but not both" @@ -331,3 +343,78 @@ instance FromJSON PhoneBudgetTimeout where instance ToJSON PhoneBudgetTimeout where toJSON (PhoneBudgetTimeout t) = A.object ["expires_in" A..= t] + +lenientlyParseSAMLIssuer :: Maybe LText -> A.Parser (Maybe SAML.Issuer) +lenientlyParseSAMLIssuer mbtxt = forM mbtxt $ \txt -> do + let asxml :: Either String SAML.Issuer + asxml = SAML.decodeElem txt + + asurl :: Either String SAML.Issuer + asurl = + first show + . second SAML.Issuer + $ URI.parseURI URI.laxURIParserOptions (cs txt) + + err :: String + err = "lenientlyParseSAMLIssuer: " <> show (asxml, asurl, mbtxt) + + either (const $ fail err) pure $ asxml <|> asurl + +lenientlyParseSAMLNameID :: Maybe LText -> A.Parser (Maybe SAML.NameID) +lenientlyParseSAMLNameID Nothing = pure Nothing +lenientlyParseSAMLNameID (Just txt) = do + let asxml :: Either String SAML.NameID + asxml = SAML.decodeElem txt + + asemail :: Either String SAML.NameID + asemail = + maybe + (Left "not an email") + (fmap emailToSAMLNameID . validateEmail) + (parseEmail (cs txt)) + + astxt :: Either String SAML.NameID + astxt = do + nm <- mkName (cs txt) + SAML.mkNameID (SAML.mkUNameIDUnspecified (fromName nm)) Nothing Nothing Nothing + + err :: String + err = "lenientlyParseSAMLNameID: " <> show (asxml, asemail, astxt, txt) + + either + (const $ fail err) + (pure . Just) + (asxml <|> asemail <|> astxt) + +emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email +emailFromSAML = fromJust . parseEmail . SAMLEmail.render + +emailToSAML :: HasCallStack => Email -> SAMLEmail.Email +emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString + +-- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this +-- function total without all that praying and hoping. +emailToSAMLNameID :: HasCallStack => Email -> SAML.NameID +emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmail + +emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email +emailFromSAMLNameID nid = case nid ^. SAML.nameID of + SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email + _ -> Nothing + +-- | For testing. Create a sample 'SAML.UserRef' value with random seeds to make 'Issuer' and +-- 'NameID' unique. FUTUREWORK: move to saml2-web-sso. +mkSampleUref :: Text -> Text -> SAML.UserRef +mkSampleUref iseed nseed = SAML.UserRef issuer nameid + where + issuer :: SAML.Issuer + issuer = SAML.Issuer ([uri|http://example.com/|] & URI.pathL .~ cs ("/" cs iseed)) + + nameid :: SAML.NameID + nameid = fromRight (error "impossible") $ do + unqualified <- SAML.mkUNameIDEmail $ "me" <> nseed <> "@example.com" + SAML.mkNameID unqualified Nothing Nothing Nothing + +-- | @mkSampleUref "" ""@ +mkSimpleSampleUref :: SAML.UserRef +mkSimpleSampleUref = mkSampleUref "" "" diff --git a/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-1.json b/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-1.json deleted file mode 100644 index 1f1c81c450e..00000000000 --- a/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-1.json +++ /dev/null @@ -1,32 +0,0 @@ -{ - "accent_id": 39125, - "assets": [ - { - "key": "", - "size": "complete", - "type": "image" - }, - { - "key": "(󼊊\u001bp󳢼u]'􅄻", - "type": "image" - }, - { - "key": "􁿐f", - "size": "preview", - "type": "image" - } - ], - "email_code": "cfTQLlhl6H6sYloQXsghILggxWoGhM2WGbxjzm0=", - "label": ">>Mp१𤘇9:󺰽􋼒\u0010D1j󾮢􂊠;􄆇󳸪f#]", - "locale": "so", - "managed_by": "wire", - "name": "\\sY4]u󼛸\u0010󺲻\u001c\u0003 \u001f\u0017􄚐dw;}􆃪@𭂿\r8", - "password": "dX󹊒赲󶻎ht𘙏󴰏\u0007>\u0018\u000bO95\u0015\n(𩝙󻞌嶝f]_𪀮\u00002FQbNS=6g󿷼P𢲾􃨫󰧽􅤹M\u001e7\u0016~\u0017m󽎭\u0006\u0001\u000bkgmBp\u0017w悬𩓯f󹼮%Q\u0004𢔶kP|G𥬅\u0017B-\nJWH(8)4$󱠶<7𭨖\u001cI\u0008A\u0010\r?󹀊\u0008\u00085\u0006󶟨d \u00166􍉶G\u0018\u0008\t=qG􃁰 D\u0002vV\tYpg󸋮吝q\n \u0017L􁼛-􏕋\u0013󺃝F7Q􊔜]揃i?\r\u0010\u001b{=􎕻_?e􇢹%\u000eR󱆼\u001b+\u000ef\u0017q:g\\Rk馍𪝞[l\u0015􉜀VK\njwp\u00043TJྏEj\u0002R7d83ON\u0017q獿\u0019𮣜N8\n\u000f󻦼u:GꓻFZ\u001c<\u0015揤7􉖬tH󿳸;hbS{ꮯ\u001csMs󲷒9B4􀷾35c(~CUc󸇪\\V_XD3me@example.com", + "tenant": "http://example.com/" } } diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json index f4ad262a308..caf5540093f 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json @@ -2,7 +2,7 @@ "email": "R@K", "first": false, "sso_id": { - "subject": "", - "tenant": "" + "subject": "me@example.com", + "tenant": "http://example.com/" } } diff --git a/libs/wire-api/test/golden/testObject_NewUser_user_6.json b/libs/wire-api/test/golden/testObject_NewUser_user_6.json index 9302c14469c..158591955d2 100644 --- a/libs/wire-api/test/golden/testObject_NewUser_user_6.json +++ b/libs/wire-api/test/golden/testObject_NewUser_user_6.json @@ -2,8 +2,8 @@ "assets": [], "name": "test name", "sso_id": { - "subject": "thing", - "tenant": "some" + "subject": "me@example.com", + "tenant": "http://example.com/" }, "team_id": "00007b0e-0000-3489-0000-075c00005be7" } diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json index 56073c95ac1..156ade504d6 100644 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json +++ b/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json @@ -2,7 +2,7 @@ "email": "%x\u0013􀔑\u0004.@G빯t.6", "phone": "+298116118047", "sso_id": { - "subject": "\u0013\u001c", - "tenant": "a\u001c" + "subject": "me@example.com", + "tenant": "http://example.com" } } diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json index 68bd2291d27..902e47fbe87 100644 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json +++ b/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json @@ -2,7 +2,7 @@ "email": null, "phone": "+49198172826", "sso_id": { - "subject": "󴤰", - "tenant": ">􋲗􎚆󾪂" + "subject": "me@example.com", + "tenant": "http://example.com" } } diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json index 5e01fb0c2b1..f9a46004b6f 100644 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json +++ b/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json @@ -2,7 +2,7 @@ "email": null, "phone": "+149548802116267", "sso_id": { - "subject": "", - "tenant": "" + "subject": "me@example.com", + "tenant": "http://example.com" } } diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json index 6de12964221..431a302354b 100644 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json +++ b/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json @@ -1,3 +1,4 @@ { - "scim_external_id": "퀶\u001a\u0002\u000bf\u0008-󿰣qA􄚨\u0005 >jJ" + "subject": "me@example.com", + "tenant": "http://example.com/" } diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs index f0bdbc03201..5c0485a2799 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs @@ -94,25 +94,13 @@ tests = testFromJSONFailureWithMsg @NewUser (Just "all team users must set a password on creation") "testObject_NewUser_user_5-2.json", - testCase "testObject_NewUser_user_6-2.json" $ - testFromJSONFailureWithMsg @NewUser - (Just "sso_id, team_id must be either both present or both absent.") - "testObject_NewUser_user_6-2.json", testCase "testObject_NewUser_user_6-3.json" $ testFromJSONFailureWithMsg @NewUser (Just "sso_id, team_id must be either both present or both absent.") - "testObject_NewUser_user_6-3.json", - testCase "testObject_NewUser_user_6-4.json" $ - testFromJSONFailureWithMsg @NewUser - (Just "team_code, team, invitation_code, sso_id, and the pair (sso_id, team_id) are mutually exclusive") - "testObject_NewUser_user_6-4.json" + "testObject_NewUser_user_6-3.json" ], testGroup "NewUserPublic: failure" $ - [ testCase "testObject_NewUserPublic_user_1-1.json" $ - testFromJSONFailureWithMsg @NewUserPublic - (Just "SSO-managed users are not allowed here.") - "testObject_NewUserPublic_user_1-1.json", - testCase "testObject_NewUserPublic_user_1-2.json" $ + [ testCase "testObject_NewUserPublic_user_1-2.json" $ testFromJSONFailureWithMsg @NewUserPublic (Just "it is not allowed to provide a UUID for the users here.") "testObject_NewUserPublic_user_1-2.json", diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs index 5c2c181d66c..7eacbb74d24 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs @@ -1059,9 +1059,9 @@ tests = testGroup "Golden: Phone_user" $ testObjects [(Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_1, "testObject_Phone_user_1.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_2, "testObject_Phone_user_2.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_3, "testObject_Phone_user_3.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_4, "testObject_Phone_user_4.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_5, "testObject_Phone_user_5.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_6, "testObject_Phone_user_6.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_7, "testObject_Phone_user_7.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_8, "testObject_Phone_user_8.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_9, "testObject_Phone_user_9.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_10, "testObject_Phone_user_10.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_11, "testObject_Phone_user_11.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_12, "testObject_Phone_user_12.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_13, "testObject_Phone_user_13.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_14, "testObject_Phone_user_14.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_15, "testObject_Phone_user_15.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_16, "testObject_Phone_user_16.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_17, "testObject_Phone_user_17.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_18, "testObject_Phone_user_18.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_19, "testObject_Phone_user_19.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_20, "testObject_Phone_user_20.json")], testGroup "Golden: UserSSOId_user" $ - testObjects [(Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_1, "testObject_UserSSOId_user_1.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_2, "testObject_UserSSOId_user_2.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_3, "testObject_UserSSOId_user_3.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_4, "testObject_UserSSOId_user_4.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_5, "testObject_UserSSOId_user_5.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_6, "testObject_UserSSOId_user_6.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_7, "testObject_UserSSOId_user_7.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_8, "testObject_UserSSOId_user_8.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_9, "testObject_UserSSOId_user_9.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_10, "testObject_UserSSOId_user_10.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_11, "testObject_UserSSOId_user_11.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_12, "testObject_UserSSOId_user_12.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_13, "testObject_UserSSOId_user_13.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_14, "testObject_UserSSOId_user_14.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_15, "testObject_UserSSOId_user_15.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_16, "testObject_UserSSOId_user_16.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_17, "testObject_UserSSOId_user_17.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_18, "testObject_UserSSOId_user_18.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_19, "testObject_UserSSOId_user_19.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_20, "testObject_UserSSOId_user_20.json")], + testObjects [(Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_2, "testObject_UserSSOId_user_2.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_9, "testObject_UserSSOId_user_9.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_13, "testObject_UserSSOId_user_13.json")], testGroup "Golden: UserIdentity_user" $ - testObjects [(Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_1, "testObject_UserIdentity_user_1.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_2, "testObject_UserIdentity_user_2.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_3, "testObject_UserIdentity_user_3.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_4, "testObject_UserIdentity_user_4.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_5, "testObject_UserIdentity_user_5.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_6, "testObject_UserIdentity_user_6.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_7, "testObject_UserIdentity_user_7.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_8, "testObject_UserIdentity_user_8.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_9, "testObject_UserIdentity_user_9.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_10, "testObject_UserIdentity_user_10.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_11, "testObject_UserIdentity_user_11.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_12, "testObject_UserIdentity_user_12.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_13, "testObject_UserIdentity_user_13.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_14, "testObject_UserIdentity_user_14.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_15, "testObject_UserIdentity_user_15.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_16, "testObject_UserIdentity_user_16.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_17, "testObject_UserIdentity_user_17.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_18, "testObject_UserIdentity_user_18.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_19, "testObject_UserIdentity_user_19.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_20, "testObject_UserIdentity_user_20.json")], + testObjects [(Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_1, "testObject_UserIdentity_user_1.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_2, "testObject_UserIdentity_user_2.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_3, "testObject_UserIdentity_user_3.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_4, "testObject_UserIdentity_user_4.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_6, "testObject_UserIdentity_user_6.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_7, "testObject_UserIdentity_user_7.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_9, "testObject_UserIdentity_user_9.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_10, "testObject_UserIdentity_user_10.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_11, "testObject_UserIdentity_user_11.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_12, "testObject_UserIdentity_user_12.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_13, "testObject_UserIdentity_user_13.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_14, "testObject_UserIdentity_user_14.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_15, "testObject_UserIdentity_user_15.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_17, "testObject_UserIdentity_user_17.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_18, "testObject_UserIdentity_user_18.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_19, "testObject_UserIdentity_user_19.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_20, "testObject_UserIdentity_user_20.json")], testGroup "Golden: NewPasswordReset_user" $ testObjects [(Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_1, "testObject_NewPasswordReset_user_1.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_2, "testObject_NewPasswordReset_user_2.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_3, "testObject_NewPasswordReset_user_3.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_4, "testObject_NewPasswordReset_user_4.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_5, "testObject_NewPasswordReset_user_5.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_6, "testObject_NewPasswordReset_user_6.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_7, "testObject_NewPasswordReset_user_7.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_8, "testObject_NewPasswordReset_user_8.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_9, "testObject_NewPasswordReset_user_9.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_10, "testObject_NewPasswordReset_user_10.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_11, "testObject_NewPasswordReset_user_11.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_12, "testObject_NewPasswordReset_user_12.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_13, "testObject_NewPasswordReset_user_13.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_14, "testObject_NewPasswordReset_user_14.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_15, "testObject_NewPasswordReset_user_15.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_16, "testObject_NewPasswordReset_user_16.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_17, "testObject_NewPasswordReset_user_17.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_18, "testObject_NewPasswordReset_user_18.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_19, "testObject_NewPasswordReset_user_19.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_20, "testObject_NewPasswordReset_user_20.json")], testGroup "Golden: PasswordResetKey_user" $ diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs index 0b0bfc8cbbf..0b0cdf459e6 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs @@ -31,13 +31,14 @@ import Wire.API.User UserSSOId (UserSSOId, UserScimExternalId), ) import Wire.API.User.Activation (ActivationResponse (..)) +import Wire.API.User.Identity (mkSimpleSampleUref) testObject_ActivationResponse_user_1 :: ActivationResponse testObject_ActivationResponse_user_1 = ActivationResponse { activatedIdentity = SSOIdentity - (UserSSOId "" "\RS") + (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "\165918\rZ\a\ESC", emailDomain = "p\131777\62344"})) Nothing, activatedFirst = False @@ -169,7 +170,7 @@ testObject_ActivationResponse_user_18 = testObject_ActivationResponse_user_19 :: ActivationResponse testObject_ActivationResponse_user_19 = ActivationResponse - { activatedIdentity = SSOIdentity (UserSSOId "" "") (Just (Email {emailLocal = "R", emailDomain = "K"})) Nothing, + { activatedIdentity = SSOIdentity (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "R", emailDomain = "K"})) Nothing, activatedFirst = False } diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs index d197d6bad0d..68039b8ac3e 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs @@ -61,7 +61,7 @@ import Wire.API.User ) import Wire.API.User.Activation (ActivationCode (ActivationCode, fromActivationCode)) import Wire.API.User.Auth (CookieLabel (CookieLabel, cookieLabelText)) -import Wire.API.User.Identity (Phone (..), UserSSOId (UserSSOId)) +import Wire.API.User.Identity (Phone (..), UserSSOId (UserSSOId), mkSimpleSampleUref) testObject_NewUser_user_1 :: NewUser testObject_NewUser_user_1 = @@ -140,7 +140,7 @@ testObject_NewUser_user_6 = (Name {fromName = "test name"}) ) { newUserOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO tid)), - newUserIdentity = Just (SSOIdentity (UserSSOId "some" "thing") Nothing Nothing) + newUserIdentity = Just (SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing Nothing) } where tid = Id (fromJust (UUID.fromString "00007b0e-0000-3489-0000-075c00005be7")) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs index 03453047686..19d70db4709 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs @@ -25,6 +25,7 @@ import Wire.API.User UserIdentity (..), UserSSOId (UserSSOId, UserScimExternalId), ) +import Wire.API.User.Identity (mkSimpleSampleUref) testObject_UserIdentity_user_1 :: UserIdentity testObject_UserIdentity_user_1 = @@ -56,7 +57,7 @@ testObject_UserIdentity_user_4 = testObject_UserIdentity_user_5 :: UserIdentity testObject_UserIdentity_user_5 = - SSOIdentity (UserSSOId ">\1096855\1107590\1043074" "\1001776") Nothing (Just (Phone {fromPhone = "+49198172826"})) + SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing (Just (Phone {fromPhone = "+49198172826"})) testObject_UserIdentity_user_6 :: UserIdentity testObject_UserIdentity_user_6 = PhoneIdentity (Phone {fromPhone = "+03038459796465"}) @@ -65,7 +66,7 @@ testObject_UserIdentity_user_7 :: UserIdentity testObject_UserIdentity_user_7 = PhoneIdentity (Phone {fromPhone = "+805676294"}) testObject_UserIdentity_user_8 :: UserIdentity -testObject_UserIdentity_user_8 = SSOIdentity (UserSSOId "" "") Nothing (Just (Phone {fromPhone = "+149548802116267"})) +testObject_UserIdentity_user_8 = SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing (Just (Phone {fromPhone = "+149548802116267"})) testObject_UserIdentity_user_9 :: UserIdentity testObject_UserIdentity_user_9 = @@ -114,7 +115,7 @@ testObject_UserIdentity_user_15 = PhoneIdentity (Phone {fromPhone = "+0923809422 testObject_UserIdentity_user_16 :: UserIdentity testObject_UserIdentity_user_16 = SSOIdentity - (UserSSOId "a\FS" "\DC3\FS") + (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "%x\DC3\1049873\EOT.", emailDomain = "G\48751t.6"})) (Just (Phone {fromPhone = "+298116118047"})) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs index 5f01be95f04..51d29bcd37b 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs @@ -19,65 +19,13 @@ module Test.Wire.API.Golden.Generated.UserSSOId_user where import Wire.API.User (UserSSOId (..)) - -testObject_UserSSOId_user_1 :: UserSSOId -testObject_UserSSOId_user_1 = UserSSOId "#ph\1052492" "\121009\1055837S\ACK\\\ETB\\" +import Wire.API.User.Identity (mkSimpleSampleUref) testObject_UserSSOId_user_2 :: UserSSOId -testObject_UserSSOId_user_2 = UserScimExternalId "\53302\SUB\STX\vf\b\58777-\1047587qA\1066664\ENQ >jJ" - -testObject_UserSSOId_user_3 :: UserSSOId -testObject_UserSSOId_user_3 = UserSSOId "i\DEL\\\EOT\r\99405\NAK\992986\51508Vi" "\164492\&4X\EM" - -testObject_UserSSOId_user_4 :: UserSSOId -testObject_UserSSOId_user_4 = UserSSOId "0\1078858hK\150460Rc;/[Q9s{" "\1089121\&0\ESC\183599=1.2 , generics-sop , ghc-prim @@ -445,6 +446,7 @@ test-suite wire-api-tests , containers >=0.5 , currency-codes , directory + , filepath , hscim , imports , iso3166-country-codes @@ -454,6 +456,7 @@ test-suite wire-api-tests , pem , pretty , proto-lens + , saml2-web-sso , servant-swagger-ui , string-conversions , swagger2 diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index c2741ef9063..f2021ee936c 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -259,7 +259,7 @@ createUser new = do Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of - (Just ident@(SSOIdentity (UserSSOId _ _) _ _), Just tid') -> Just <$> addUserToTeamSSO account tid' ident + (Just ident@(SSOIdentity (UserSSOId _) _ _), Just tid') -> Just <$> addUserToTeamSSO account tid' ident _ -> pure Nothing pure (activatedTeam <|> joinedTeamInvite <|> joinedTeamSSO) diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index 89a63abf800..ccb2e404140 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -79,7 +79,6 @@ import Imports hiding (log, searchable) import Network.HTTP.Client hiding (path) import Network.HTTP.Types (hContentType, statusCode) import qualified SAML2.WebSSO.Types as SAML -import qualified SAML2.WebSSO.XML as SAML import qualified System.Logger as Log import System.Logger.Class ( Logger, @@ -737,8 +736,6 @@ reindexRowToIndexUser ] idpUrl :: UserSSOId -> Maybe Text - idpUrl (UserSSOId tenant _subject) = - case SAML.decodeElem $ cs tenant of - Left _ -> Nothing - Right (SAML.Issuer uri) -> Just $ (cs . toLazyByteString . serializeURIRef) uri + idpUrl (UserSSOId (SAML.UserRef (SAML.Issuer uri) _subject)) = + Just $ (cs . toLazyByteString . serializeURIRef) uri idpUrl (UserScimExternalId _) = Nothing diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index aa338e22537..d8e695b7831 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -56,6 +56,7 @@ import UnliftIO.Async (mapConcurrently_, pooledForConcurrentlyN_, replicateConcu import Util import Util.AWS as Util import Web.Cookie (parseSetCookie, setCookieName) +import Wire.API.User.Identity (mkSimpleSampleUref) newtype TeamSizeLimit = TeamSizeLimit Word32 @@ -757,7 +758,7 @@ testConnectionSameTeam brig = do testCreateUserInternalSSO :: Brig -> Galley -> Http () testCreateUserInternalSSO brig galley = do teamid <- snd <$> createUserWithTeam brig - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref -- creating users requires both sso_id and team_id postUser' True False "dummy" True False (Just ssoid) Nothing brig !!! const 400 === statusCode @@ -788,7 +789,7 @@ testCreateUserInternalSSO brig galley = do testDeleteUserSSO :: Brig -> Galley -> Http () testDeleteUserSSO brig galley = do (creator, tid) <- createUserWithTeam brig - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref mkuser :: Bool -> Http (Maybe User) mkuser withemail = responseJsonMaybe diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index a7a4de6b242..a4b9646b15f 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -73,6 +73,7 @@ import Util as Util import Util.AWS as Util import Web.Cookie (parseSetCookie) import Wire.API.User (ListUsersQuery (..)) +import Wire.API.User.Identity (mkSampleUref, mkSimpleSampleUref) tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> TestTree tests _ at opts p b c ch g aws = @@ -389,7 +390,7 @@ testCreateUserBlacklist _ brig aws = testCreateUserExternalSSO :: Brig -> Http () testCreateUserExternalSSO brig = do teamid <- Id <$> liftIO UUID.nextRandom - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref p withsso withteam = RequestBodyLBS . encode . object $ ["name" .= ("foo" :: Text)] @@ -1203,7 +1204,7 @@ testUpdateSSOId brig galley = do put ( brig . paths ["i", "users", toByteString' noSuchUserId, "sso-id"] - . Bilge.json (UserSSOId "1" "1") + . Bilge.json (UserSSOId (mkSampleUref "1" "1")) ) !!! const 404 === statusCode let go :: HasCallStack => User -> UserSSOId -> Http () @@ -1230,8 +1231,8 @@ testUpdateSSOId brig galley = do when (not hasEmail) $ do error "not implemented" selfUser <$> (responseJsonError =<< get (brig . path "/self" . zUser (userId member))) - let ssoids1 = [UserSSOId "1" "1", UserSSOId "1" "2"] - ssoids2 = [UserSSOId "2" "1", UserSSOId "2" "2"] + let ssoids1 = [UserSSOId (mkSampleUref "1" "1"), UserSSOId (mkSampleUref "1" "2")] + ssoids2 = [UserSSOId (mkSampleUref "2" "1"), UserSSOId (mkSampleUref "2" "2")] users <- sequence [ mkMember True False, @@ -1325,7 +1326,7 @@ testRestrictedUserCreation opts brig = do -- NOTE: SSO users are anyway not allowed on the `/register` endpoint teamid <- Id <$> liftIO UUID.nextRandom - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref let Object ssoUser = object [ "name" .= Name "Alice", diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 57fabd19156..0c6dbd6d86c 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c121411458d6b0f7118ae1589134cb37711d29cad840e07d0f135663c59cc53a +-- hash: 1daf2eec8d6d9666168a442a3c2856c2d453361e3bbffcc4a17c55d8bbf914f4 name: galley version: 0.83.0 @@ -182,6 +182,7 @@ executable galley , imports , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , ssl-util , tagged @@ -264,6 +265,7 @@ executable galley-integration , raw-strings-qq >=1.0 , retry , safe >=0.3 + , saml2-web-sso >=0.18 , schema-profunctor , servant , servant-client @@ -325,6 +327,7 @@ executable galley-migrate-data , optparse-applicative , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , ssl-util , tagged @@ -391,6 +394,7 @@ executable galley-schema , optparse-applicative , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , ssl-util , tagged @@ -431,6 +435,7 @@ test-suite galley-types-tests , lens , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , servant-swagger , ssl-util diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 2ae2bfe98a5..ead7824b388 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -21,6 +21,7 @@ dependencies: - wire-api-federation - tagged - servant-client +- saml2-web-sso >=0.18 library: source-dirs: src @@ -69,7 +70,6 @@ library: - resourcet >=1.1 - retry >=0.5 - safe-exceptions >=0.1 - - saml2-web-sso >=0.18 - servant - servant-server - servant-swagger diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 330aa44c940..d0221f3206c 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -71,12 +71,11 @@ import qualified Data.LegalHold as LH import qualified Data.List.Extra as List import Data.List1 (list1) import qualified Data.Map.Strict as M -import Data.Misc (HttpsUrl) +import Data.Misc (HttpsUrl, mkHttpsUrl) import Data.Qualified import Data.Range as Range import Data.Set (fromList) import qualified Data.Set as Set -import Data.String.Conversions (cs) import Data.Time.Clock (UTCTime (..), getCurrentTime) import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID @@ -429,7 +428,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do defaultEncodeOptions :: EncodeOptions defaultEncodeOptions = EncodeOptions - { encDelimiter = 44, -- comma + { encDelimiter = fromIntegral (ord ','), encUseCrLf = True, -- to be compatible with Mac and Windows encIncludeHeader = False, -- (so we can flush when the header is on the wire) encQuoting = QuoteAll @@ -476,7 +475,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do userToIdPIssuer :: U.User -> Maybe HttpsUrl userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of - Just (U.UserSSOId issuer _) -> fromByteString' $ cs issuer + Just (U.UserSSOId (SAML.UserRef issuer _)) -> either (const Nothing) Just . mkHttpsUrl $ issuer ^. SAML.fromIssuer Just _ -> Nothing Nothing -> Nothing @@ -489,7 +488,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do samlNamedId :: User -> Maybe Text samlNamedId = userSSOId >=> \case - (UserSSOId _idp nameId) -> CI.original . SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (cs nameId)) + (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId (UserScimExternalId _) -> Nothing bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley Response diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 6b289d65616..ebc335b9fca 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -42,11 +42,10 @@ import Data.Id import qualified Data.LegalHold as LH import Data.List1 import qualified Data.List1 as List1 -import Data.Misc (HttpsUrl, PlainTextPassword (..)) +import Data.Misc (HttpsUrl, PlainTextPassword (..), mkHttpsUrl) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID @@ -66,6 +65,7 @@ import qualified Network.Wai.Utilities.Error as Error import qualified Network.Wai.Utilities.Error as Wai import qualified Proto.TeamEvents as E import qualified Proto.TeamEvents_Fields as E +import qualified SAML2.WebSSO.Types as SAML import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS @@ -277,7 +277,7 @@ testListTeamMembersCsv numMembers = do where userToIdPIssuer :: HasCallStack => U.User -> Maybe HttpsUrl userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of - Just (U.UserSSOId issuer _) -> maybe (error "shouldn't happen") Just . fromByteString' . cs $ issuer + Just (U.UserSSOId (SAML.UserRef (SAML.Issuer issuer) _)) -> either (const $ error "shouldn't happen") Just $ mkHttpsUrl issuer Just _ -> Nothing Nothing -> Nothing diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index aa6549d3ebf..91f7f1d1a9c 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -121,6 +121,7 @@ import qualified Wire.API.Message.Proto as Proto import Wire.API.Routes.MultiTablePaging import Wire.API.User.Client (ClientCapability (..), UserClientsFull (UserClientsFull)) import qualified Wire.API.User.Client as Client +import Wire.API.User.Identity (mkSimpleSampleUref) ------------------------------------------------------------------------------- -- API Operations @@ -396,7 +397,7 @@ addUserToTeamWithRole' role inviter tid = do addUserToTeamWithSSO :: HasCallStack => Bool -> TeamId -> TestM TeamMember addUserToTeamWithSSO hasEmail tid = do - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref user <- responseJsonError =<< postSSOUser "SSO User" hasEmail ssoid tid let uid = Brig.Types.userId user getTeamMember uid tid uid diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index fd118824789..cc0be602d73 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -51,7 +51,6 @@ import Data.ByteString.Conversion import Data.Handle (Handle (fromHandle)) import Data.Id (Id (Id), TeamId, UserId) import Data.Misc (PlainTextPassword) -import Data.String.Conversions import Imports import Network.HTTP.Types.Method import qualified Network.Wai.Utilities.Error as Wai @@ -65,11 +64,9 @@ import Wire.API.User.Scim (ValidExternalId (..), runValidExternalId) ---------------------------------------------------------------------- +-- | FUTUREWORK: this is redundantly defined in "Spar.Intra.BrigApp". veidToUserSSOId :: ValidExternalId -> UserSSOId -veidToUserSSOId = runValidExternalId urefToUserSSOId (UserScimExternalId . fromEmail) - -urefToUserSSOId :: SAML.UserRef -> UserSSOId -urefToUserSSOId (SAML.UserRef t s) = UserSSOId (cs $ SAML.encodeElem t) (cs $ SAML.encodeElem s) +veidToUserSSOId = runValidExternalId UserSSOId (UserScimExternalId . fromEmail) -- | Similar to 'Network.Wire.Client.API.Auth.tokenResponse', but easier: we just need to set the -- cookie in the response, and the redirect will make the client negotiate a fresh auth token. @@ -102,7 +99,7 @@ createBrigUserSAML uref (Id buid) teamid uname managedBy = do newUser = (emptyNewUser uname) { newUserUUID = Just buid, - newUserIdentity = Just (SSOIdentity (urefToUserSSOId uref) Nothing Nothing), + newUserIdentity = Just (SSOIdentity (UserSSOId uref) Nothing Nothing), newUserOrigin = Just (NewUserOriginTeamUser . NewTeamMemberSSO $ teamid), newUserManagedBy = Just managedBy } diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 6c4d2d34f0e..68777a7db07 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -27,10 +27,6 @@ module Spar.Intra.BrigApp veidFromUserSSOId, mkUserName, renderValidExternalId, - emailFromSAML, - emailToSAML, - emailToSAMLNameID, - emailFromSAMLNameID, HavePendingInvitations (..), getBrigUser, getBrigUserTeam, @@ -38,6 +34,12 @@ module Spar.Intra.BrigApp authorizeScimTokenManagement, parseResponse, giveDefaultHandle, + + -- * re-exports, mostly for historical reasons and lazyness + emailFromSAML, + emailToSAML, + emailToSAMLNameID, + emailFromSAMLNameID, ) where @@ -55,7 +57,6 @@ import Imports import Polysemy import Polysemy.Error import qualified SAML2.WebSSO as SAML -import qualified SAML2.WebSSO.Types.Email as SAMLEmail import Spar.Error import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess @@ -66,23 +67,16 @@ import Wire.API.User.Scim (ValidExternalId (..), runValidExternalId) ---------------------------------------------------------------------- +-- | FUTUREWORK: this is redundantly defined in "Spar.Intra.Brig" veidToUserSSOId :: ValidExternalId -> UserSSOId -veidToUserSSOId = runValidExternalId urefToUserSSOId (UserScimExternalId . fromEmail) - -urefToUserSSOId :: SAML.UserRef -> UserSSOId -urefToUserSSOId (SAML.UserRef t s) = UserSSOId (cs $ SAML.encodeElem t) (cs $ SAML.encodeElem s) +veidToUserSSOId = runValidExternalId UserSSOId (UserScimExternalId . fromEmail) veidFromUserSSOId :: MonadError String m => UserSSOId -> m ValidExternalId veidFromUserSSOId = \case - UserSSOId tenant subject -> - case (SAML.decodeElem $ cs tenant, SAML.decodeElem $ cs subject) of - (Right t, Right s) -> do - let uref = SAML.UserRef t s - case urefToEmail uref of - Nothing -> pure $ UrefOnly uref - Just email -> pure $ EmailAndUref email uref - (Left msg, _) -> throwError msg - (_, Left msg) -> throwError msg + UserSSOId uref -> + case urefToEmail uref of + Nothing -> pure $ UrefOnly uref + Just email -> pure $ EmailAndUref email uref UserScimExternalId email -> maybe (throwError "externalId not an email and no issuer") @@ -125,22 +119,6 @@ mkUserName Nothing = renderValidExternalId :: ValidExternalId -> Maybe Text renderValidExternalId = runValidExternalId urefToExternalId (Just . fromEmail) -emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email -emailFromSAML = fromJust . parseEmail . SAMLEmail.render - -emailToSAML :: HasCallStack => Email -> SAMLEmail.Email -emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString - --- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this --- function total without all that praying and hoping. -emailToSAMLNameID :: HasCallStack => Email -> SAML.NameID -emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmail - -emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email -emailFromSAMLNameID nid = case nid ^. SAML.nameID of - SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email - _ -> Nothing - ---------------------------------------------------------------------- getBrigUser :: (HasCallStack, Member BrigAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe User) diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 549a23c89dc..6b1499dcc5b 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -176,7 +176,7 @@ instance ScimTokenInfo -> Scim.User ST.SparTag -> Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) - postUser tokinfo user = createValidScimUser tokinfo =<< validateScimUser tokinfo user + postUser tokinfo user = createValidScimUser tokinfo =<< validateScimUser "post" tokinfo user putUser :: ScimTokenInfo -> @@ -184,7 +184,7 @@ instance Scim.User ST.SparTag -> Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) putUser tokinfo uid newScimUser = - updateValidScimUser tokinfo uid =<< validateScimUser tokinfo newScimUser + updateValidScimUser tokinfo uid =<< validateScimUser "put" tokinfo newScimUser deleteUser :: ScimTokenInfo -> UserId -> Scim.ScimHandler (Sem r) () deleteUser tokeninfo uid = @@ -204,14 +204,15 @@ validateScimUser :: forall m r. (m ~ Scim.ScimHandler (Sem r)) => Members '[Input Opts, IdPEffect.IdP] r => + Text -> -- | Used to decide what IdP to assign the user to ScimTokenInfo -> Scim.User ST.SparTag -> m ST.ValidScimUser -validateScimUser tokinfo user = do +validateScimUser errloc tokinfo user = do mIdpConfig <- tokenInfoToIdP tokinfo richInfoLimit <- lift $ inputs richInfoLimit - validateScimUser' mIdpConfig richInfoLimit user + validateScimUser' errloc mIdpConfig richInfoLimit user tokenInfoToIdP :: Member IdPEffect.IdP r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) tokenInfoToIdP ScimTokenInfo {stiIdP} = do @@ -254,24 +255,26 @@ validateHandle txt = case parseHandle txt of validateScimUser' :: forall m. (MonadError Scim.ScimError m) => + -- | Error location (call site, for debugging) + Text -> -- | IdP that the resulting user will be assigned to Maybe IdP -> -- | Rich info limit Int -> Scim.User ST.SparTag -> m ST.ValidScimUser -validateScimUser' midp richInfoLimit user = do +validateScimUser' errloc midp richInfoLimit user = do unless (isNothing $ Scim.password user) $ throwError $ Scim.badRequest Scim.InvalidValue - (Just "Setting user passwords is not supported for security reasons.") + (Just $ "Setting user passwords is not supported for security reasons. (" <> errloc <> ")") veid <- mkValidExternalId midp (Scim.externalId user) handl <- validateHandle . Text.toLower . Scim.userName $ user -- FUTUREWORK: 'Scim.userName' should be case insensitive; then the toLower here would -- be a little less brittle. uname <- do - let err = throwError . Scim.badRequest Scim.InvalidValue . Just . cs + let err msg = throwError . Scim.badRequest Scim.InvalidValue . Just $ cs msg <> " (" <> errloc <> ")" either err pure $ Brig.mkUserName (Scim.displayName user) veid richInfo <- validateRichInfo (Scim.extra user ^. ST.sueRichInfo) let active = Scim.active user @@ -291,6 +294,9 @@ validateScimUser' midp richInfoLimit user = do <> show richInfoLimit <> " characters, but got " <> show sze + <> " (" + <> cs errloc + <> ")" ) ) { Scim.status = Scim.Status 413 @@ -311,7 +317,7 @@ mkValidExternalId _ Nothing = do throwError $ Scim.badRequest Scim.InvalidValue - (Just "externalId is required for SAML users") + (Just "externalId is required") mkValidExternalId Nothing (Just extid) = do let err = Scim.badRequest @@ -519,7 +525,7 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid newValidScimUser = oldScimStoredUser :: Scim.StoredUser ST.SparTag <- Scim.getUser tokinfo uid oldValidScimUser :: ST.ValidScimUser <- - validateScimUser tokinfo . Scim.value . Scim.thing $ oldScimStoredUser + validateScimUser "recover-old-value" tokinfo . Scim.value . Scim.thing $ oldScimStoredUser -- assertions about new valid scim user that cannot be checked in 'validateScimUser' because -- they differ from the ones in 'createValidScimUser'. diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 24a339cc802..a73b15ed147 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -43,7 +43,6 @@ import qualified Data.Aeson as Aeson import Data.Aeson.Lens (key, _String) import Data.Aeson.QQ (aesonQQ) import Data.Aeson.Types (fromJSON, toJSON) -import qualified Data.Bifunctor as Bifunctor import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv @@ -68,7 +67,6 @@ import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore import qualified Text.XML.DSig as SAML -import qualified URI.ByteString as URI import Util import Util.Invitation (getInvitation, getInvitationCode, headInvitation404, registerInvitation) import qualified Web.Scim.Class.User as Scim.UserC @@ -234,8 +232,9 @@ testCsvData :: UserId -> Maybe Text {- externalId -} -> Maybe UserSSOId -> + Bool -> TestSpar () -testCsvData tid owner uid mbeid mbsaml = do +testCsvData tid owner uid mbeid mbsaml hasissuer = do usersInCsv <- do g <- view teGalley resp <- @@ -254,17 +253,15 @@ testCsvData tid owner uid mbeid mbsaml = do let haveIssuer :: Maybe HttpsUrl haveIssuer = case mbsaml of - Just (UserSSOId issuer _) -> - either (const Nothing) Just - . (mkHttpsUrl <=< Bifunctor.first show . (URI.parseURI URI.laxURIParserOptions)) - $ cs issuer + Just (UserSSOId (SAML.UserRef (SAML.Issuer issuer) _)) -> either (const Nothing) Just $ mkHttpsUrl issuer Just (UserScimExternalId _) -> Nothing Nothing -> Nothing + ('h', haveIssuer) `shouldSatisfy` bool isNothing isJust hasissuer . snd ('i', CsvExport.tExportIdpIssuer export) `shouldBe` ('i', haveIssuer) let haveSubject :: Text haveSubject = case mbsaml of - Just (UserSSOId _ subject) -> either (error . show) (CI.original . SAML.unsafeShowNameID) $ SAML.decodeElem (cs subject) + Just (UserSSOId (SAML.UserRef _ subject)) -> CI.original $ SAML.unsafeShowNameID subject Just (UserScimExternalId _) -> "" Nothing -> "" ('n', CsvExport.tExportSAMLNamedId export) `shouldBe` ('n', haveSubject) @@ -362,7 +359,7 @@ testCreateUserNoIdP = do -- csv download should work let eid = Scim.User.externalId scimUser sml = Nothing - in testCsvData tid owner userid eid sml + in testCsvData tid owner userid eid sml False -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) @@ -438,7 +435,7 @@ testCreateUserWithSamlIdP = do eid = Scim.User.externalId user sml :: HasCallStack => UserSSOId sml = fromJust $ userIdentity >=> ssoIdentity $ brigUser - in testCsvData tid owner uid eid (Just sml) + in testCsvData tid owner uid eid (Just sml) True -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) @@ -1341,9 +1338,7 @@ testBrigSideIsUpdated = do user' <- randomScimUser let userid = scimUserId storedUser _ <- updateUser tok userid user' - validScimUser <- - either (error . show) pure $ - validateScimUser' (Just idp) 999999 user' + validScimUser <- either (error . show) pure $ validateScimUser' "testBrigSideIsUpdated" (Just idp) 999999 user' brigUser <- maybe (error "no brig user") pure =<< runSpar (Intra.getBrigUser Intra.WithPendingInvitations userid) brigUser `userShouldMatch` validScimUser diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index bc20e478566..f51f8789748 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -190,7 +190,7 @@ import qualified Text.XML as XML import qualified Text.XML.Cursor as XML import Text.XML.DSig (SignPrivCreds) import qualified Text.XML.DSig as SAML -import URI.ByteString +import URI.ByteString as URI import Util.Options import Util.Types import qualified Web.Cookie as Web @@ -201,6 +201,7 @@ import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.Invitation as TeamInvitation import Wire.API.User (HandleUpdate (HandleUpdate), UserUpdate) import qualified Wire.API.User as User +import Wire.API.User.Identity (mkSampleUref) import Wire.API.User.IdentityProvider import Wire.API.User.Saml import Wire.API.User.Scim (runValidExternalId) @@ -463,7 +464,8 @@ createTeamMember :: m UserId createTeamMember brigreq galleyreq teamid perms = do let randomtxt = liftIO $ UUID.toText <$> UUID.nextRandom - randomssoid = Brig.UserSSOId <$> randomtxt <*> randomtxt + randomssoid = liftIO $ Brig.UserSSOId <$> (mkSampleUref <$> rnd <*> rnd) + rnd = cs . show <$> randomRIO (0 :: Integer, 10000000) name <- randomtxt ssoid <- randomssoid resp :: ResponseLBS <- diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 71a698d0e1b..689fe08076c 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -622,4 +622,6 @@ userShouldMatch u1 u2 = liftIO $ do -- what we expect a user that comes back from spar to look like in terms of what it looked -- like when we sent it there. whatSparReturnsFor :: HasCallStack => IdP -> Int -> Scim.User.User SparTag -> Either String (Scim.User.User SparTag) -whatSparReturnsFor idp richInfoSizeLimit = either (Left . show) (Right . synthesizeScimUser) . validateScimUser' (Just idp) richInfoSizeLimit +whatSparReturnsFor idp richInfoSizeLimit = + either (Left . show) (Right . synthesizeScimUser) + . validateScimUser' "whatSparReturnsFor" (Just idp) richInfoSizeLimit diff --git a/services/spar/test/Test/Spar/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs index d37e98582f5..d8f6e8edf5b 100644 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test/Test/Spar/Intra/BrigSpec.hs @@ -50,10 +50,9 @@ spec = do ( either (error . show) id $ mkNameID (mkUNameIDTransient "V") (Just "kati") (Just "rolli") (Just "jaan") ) - want = - UserSSOId - "http://wire.com/" - "V" + want = UserSSOId (SAML.UserRef iss nam) + iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" + nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "V" veidToUserSSOId have `shouldBe` want veidFromUserSSOId want `shouldBe` Right have it "another example" $ do @@ -64,10 +63,10 @@ spec = do ( either (error . show) id $ mkNameID (mkUNameIDPersistent "PWkS") (Just "hendrik") Nothing (Just "marye") ) - want = - UserSSOId - "http://wire.com/" - "PWkS" + want = UserSSOId (SAML.UserRef iss nam) + iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" + nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "PWkS" + veidToUserSSOId have `shouldBe` want veidFromUserSSOId want `shouldBe` Right have From 4258f7bcb5ccb86e338408ff9fef0c288de5878e Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 12 Oct 2021 09:28:14 +0200 Subject: [PATCH 18/88] Update One2One conversation when connection status changes (#1850) * move one2oneConvId to galley-types * implement updateOne2OneConv and simple test * add more test cases * Clarify 403 in test * add changelog entry --- changelog.d/6-federation/update-one2ones | 1 + libs/galley-types/galley-types.cabal | 9 +- libs/galley-types/package.yaml | 6 + .../src/Galley/Types/Conversations/One2One.hs | 116 ++++++++++++++++++ .../brig/src/Brig/API/Connection/Remote.hs | 48 ++++++-- services/brig/test/integration/API/User.hs | 6 +- .../test/integration/API/User/Connection.hs | 83 ++++++++++--- services/brig/test/integration/Main.hs | 30 ++++- services/brig/test/integration/Util.hs | 20 +++ services/galley/src/Galley/API/One2One.hs | 95 +------------- 10 files changed, 280 insertions(+), 134 deletions(-) create mode 100644 changelog.d/6-federation/update-one2ones create mode 100644 libs/galley-types/src/Galley/Types/Conversations/One2One.hs diff --git a/changelog.d/6-federation/update-one2ones b/changelog.d/6-federation/update-one2ones new file mode 100644 index 00000000000..1d19a087c9a --- /dev/null +++ b/changelog.d/6-federation/update-one2ones @@ -0,0 +1 @@ +Update One2One conversation when connection status changes diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 8af1c5e5f5a..60a176f4a1d 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: d7419acbff460382bb822952b693f55513e729a4e3bcd0ddfdeea9e5285a805b +-- hash: ccecf8384a3050034fc05928ae9bd039006f4479289f73de11832052791a691f name: galley-types version: 0.81.0 @@ -24,6 +24,7 @@ library Galley.Types.Bot.Service Galley.Types.Conversations.Intra Galley.Types.Conversations.Members + Galley.Types.Conversations.One2One Galley.Types.Conversations.Roles Galley.Types.Teams Galley.Types.Teams.Intra @@ -38,17 +39,23 @@ library QuickCheck , aeson >=0.6 , base >=4 && <5 + , bytestring + , bytestring-conversion , containers >=0.5 + , cryptonite , currency-codes >=2.0 + , errors , exceptions >=0.10.0 , imports , lens >=4.12 + , memory , schema-profunctor , string-conversions , tagged , text >=0.11 , time >=1.4 , types-common >=0.16 + , uuid , wire-api default-language: Haskell2010 diff --git a/libs/galley-types/package.yaml b/libs/galley-types/package.yaml index 3d84f4036eb..d692a08ae4c 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -16,10 +16,15 @@ library: dependencies: - aeson >=0.6 - base >=4 && <5 + - bytestring + - bytestring-conversion - containers >=0.5 + - cryptonite - currency-codes >=2.0 + - errors - exceptions >=0.10.0 - lens >=4.12 + - memory - QuickCheck - schema-profunctor - string-conversions @@ -27,6 +32,7 @@ library: - text >=0.11 - time >=1.4 - types-common >=0.16 + - uuid tests: galley-types-tests: main: Main.hs diff --git a/libs/galley-types/src/Galley/Types/Conversations/One2One.hs b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs new file mode 100644 index 00000000000..bc608b70dab --- /dev/null +++ b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs @@ -0,0 +1,116 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Types.Conversations.One2One (one2OneConvId) where + +import Control.Error (atMay) +import qualified Crypto.Hash as Crypto +import Data.Bits +import Data.ByteArray (convert) +import qualified Data.ByteString as B +import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as L +import Data.Id +import Data.Qualified +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.UUID.Tagged as U +import Imports + +-- | The hash function used to obtain the 1-1 conversation ID for a pair of users. +-- +-- /Note/: the hash function must always return byte strings of length > 16. +hash :: ByteString -> ByteString +hash = convert . Crypto.hash @ByteString @Crypto.SHA256 + +-- | A randomly-generated UUID to use as a namespace for the UUIDv5 of 1-1 +-- conversation IDs +namespace :: UUID +namespace = UUID.fromWords 0x9a51edb8 0x060c0d9a 0x0c2950a8 0x5d152982 + +compareDomains :: Ord a => Qualified a -> Qualified a -> Ordering +compareDomains (Qualified a1 dom1) (Qualified a2 dom2) = + compare (dom1, a1) (dom2, a2) + +quidToByteString :: Qualified UserId -> ByteString +quidToByteString (Qualified uid domain) = toByteString' uid <> toByteString' domain + +-- | This function returns the 1-1 conversation for a given pair of users. +-- +-- Let A, B denote the (not necessarily distinct) backends of the two users, +-- with the domain of A less or equal than the domain of B in the lexicographic +-- ordering of their ascii encodings. Given users a@A and b@B, the UUID and +-- owning domain of the unique 1-1 conversation between a and b shall be a +-- deterministic function of the input data, plus some fixed parameters, as +-- described below. +-- +-- __Parameters__ +-- +-- * A (collision-resistant) hash function h with N bits of output, where N +-- s a multiple of 8 strictly larger than 128; this is set to SHA256. +-- * A "namespace" UUID n. +-- +-- __Algorithm__ +-- +-- First, in the special case where A and B are the same backend, assume that +-- the UUID of a is lower than that of b. If that is not the case, swap a +-- and b in the following. This is necessary to ensure that the function we +-- describe below is symmetric in its arguments. +-- Let c be the bytestring obtained as the concatenation of the following 5 +-- components: +-- +-- * the 16 bytes of the namespace n +-- * the 16 bytes of the UUID of a +-- * the ascii encoding of the domain of A +-- * the 16 bytes of the UUID of b +-- * the ascii encoding of the domain of B, +-- +-- and let x = h(c) be its hashed value. The UUID of the 1-1 conversation +-- between a and b is obtained by converting the first 128 bits of x to a UUID +-- V5. Note that our use of V5 here is not strictly compliant with RFC 4122, +-- since we are using a custom hash and not necessarily SHA1. +-- +-- The owning domain for the conversation is set to be A if bit 128 of x (i.e. +-- the most significant bit of the octet at index 16) is 0, and B otherwise. +-- This is well-defined, because we assumed the number of bits of x to be +-- strictly larger than 128. +one2OneConvId :: Qualified UserId -> Qualified UserId -> Qualified ConvId +one2OneConvId a b = case compareDomains a b of + GT -> one2OneConvId b a + _ -> + let c = + mconcat + [ L.toStrict (UUID.toByteString namespace), + quidToByteString a, + quidToByteString b + ] + x = hash c + result = + U.toUUID . U.mk @U.V5 + . fromMaybe UUID.nil + -- fromByteString only returns 'Nothing' when the input is not + -- exactly 16 bytes long, here this should not be a case since + -- 'hash' is supposed to return atleast 16 bytes and we use 'B.take + -- 16' to truncate it + . UUID.fromByteString + . L.fromStrict + . B.take 16 + $ x + domain + | fromMaybe 0 (atMay (B.unpack x) 16) .&. 0x80 == 0 = qDomain a + | otherwise = qDomain b + in Qualified (Id result) domain diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 387b04c617c..be1c64ecfe6 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -36,7 +36,7 @@ import Control.Error.Util ((??)) import Control.Monad.Trans.Except (runExceptT, throwE) import Data.Id as Id import Data.Qualified -import Data.UUID.V4 +import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (uuorConvId)) import Imports import Network.Wai.Utilities.Error import Wire.API.Connection (relationWithHistory) @@ -107,11 +107,32 @@ updateOne2OneConv :: Remote UserId -> Maybe (Qualified ConvId) -> Relation -> + Actor -> AppIO (Qualified ConvId) -updateOne2OneConv _ _ _ _ _ = do - -- FUTUREWORK: use galley internal API to update 1-1 conversation and retrieve ID - uid <- liftIO nextRandom - qUntagged <$> qualifyLocal (Id uid) +updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do + let request = + UpsertOne2OneConversationRequest + { uooLocalUser = lUsr, + uooRemoteUser = remoteUser, + uooActor = actor, + uooActorDesiredMembership = desiredMembership actor rel, + uooConvId = mbConvId + } + uuorConvId <$> Intra.upsertOne2OneConversation request + where + desiredMembership :: Actor -> Relation -> DesiredMembership + desiredMembership a r = + let isIncluded = + a + `elem` case r of + Accepted -> [LocalActor, RemoteActor] + Blocked -> [] + Pending -> [RemoteActor] + Ignored -> [RemoteActor] + Sent -> [LocalActor] + Cancelled -> [] + MissingLegalholdConsent -> [] + in if isIncluded then Included else Excluded -- | Perform a state transition on a connection, handle conversation updates and -- push events. @@ -126,14 +147,15 @@ transitionTo :: Remote UserId -> Maybe UserConnection -> Maybe Relation -> + Actor -> ConnectionM (ResponseForExistedCreated UserConnection, Bool) -transitionTo self _ _ Nothing Nothing = +transitionTo self _ _ Nothing Nothing _ = -- This can only happen if someone tries to ignore as a first action on a -- connection. This shouldn't be possible. throwE (InvalidTransition (tUnqualified self)) -transitionTo self mzcon other Nothing (Just rel) = lift $ do +transitionTo self mzcon other Nothing (Just rel) actor = lift $ do -- update 1-1 connection - qcnv <- updateOne2OneConv self mzcon other Nothing rel + qcnv <- updateOne2OneConv self mzcon other Nothing rel actor -- create connection connection <- @@ -146,10 +168,10 @@ transitionTo self mzcon other Nothing (Just rel) = lift $ do -- send event pushEvent self mzcon connection pure (Created connection, True) -transitionTo _self _zcon _other (Just connection) Nothing = pure (Existed connection, False) -transitionTo self mzcon other (Just connection) (Just rel) = lift $ do +transitionTo _self _zcon _other (Just connection) Nothing _actor = pure (Existed connection, False) +transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do -- update 1-1 conversation - void $ updateOne2OneConv self Nothing other (ucConvId connection) rel + void $ updateOne2OneConv self Nothing other (ucConvId connection) rel actor -- update connection connection' <- Data.updateConnection connection (relationWithHistory rel) @@ -184,7 +206,7 @@ performLocalAction self mzcon other mconnection action = do fromMaybe rel1 $ do reactionAction <- (mreaction :: Maybe RemoteConnectionAction) transition (RCA reactionAction) rel1 - transitionTo self mzcon other mconnection mrel2 + transitionTo self mzcon other mconnection mrel2 LocalActor where remoteAction :: LocalConnectionAction -> Maybe RemoteConnectionAction remoteAction LocalConnect = Just RemoteConnect @@ -220,7 +242,7 @@ performRemoteAction :: performRemoteAction self other mconnection action = do let rel0 = maybe Cancelled ucStatus mconnection let rel1 = transition (RCA action) rel0 - result <- runExceptT . void $ transitionTo self Nothing other mconnection rel1 + result <- runExceptT . void $ transitionTo self Nothing other mconnection rel1 RemoteActor pure $ either (const (Just RemoteRescind)) (const (reaction rel1)) result where reaction :: Maybe Relation -> Maybe RemoteConnectionAction diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index 0f9fcea946d..8d3a357312d 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -41,8 +41,8 @@ import Test.Tasty hiding (Timeout) import Util import Util.Options.Common -tests :: Opt.Opts -> FedBrigClient -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> DB.ClientState -> IO TestTree -tests conf fbc p b c ch g n aws db = do +tests :: Opt.Opts -> FedBrigClient -> FedGalleyClient -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> DB.ClientState -> IO TestTree +tests conf fbc fgc p b c ch g n aws db = do let cl = ConnectionLimit $ Opt.setUserMaxConnections (Opt.optSettings conf) let at = Opt.setActivationTimeout (Opt.optSettings conf) z <- mkZAuthEnv (Just conf) @@ -52,7 +52,7 @@ tests conf fbc p b c ch g n aws db = do [ API.User.Client.tests cl at conf p b c g, API.User.Account.tests cl at conf p b c ch g aws, API.User.Auth.tests conf p z b g n, - API.User.Connection.tests cl at conf p b c g fbc db, + API.User.Connection.tests cl at conf p b c g fbc fgc db, API.User.Handles.tests cl at conf p b c g, API.User.PasswordReset.tests cl at conf p b c g, API.User.Property.tests cl at conf p b c g, diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 480b0dc5586..b5b63461110 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -46,10 +46,12 @@ import Test.Tasty.HUnit import Util import Wire.API.Connection import qualified Wire.API.Federation.API.Brig as F +import Wire.API.Federation.API.Galley (GetConversationsRequest (..), GetConversationsResponse (gcresConvs), RemoteConvMembers (rcmOthers), RemoteConversation (rcnvMembers)) +import qualified Wire.API.Federation.API.Galley as F import Wire.API.Routes.MultiTablePaging -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> FedBrigClient -> DB.ClientState -> TestTree -tests cl _at opts p b _c g fedBrigClient db = +tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> FedBrigClient -> FedGalleyClient -> DB.ClientState -> TestTree +tests cl _at opts p b _c g fedBrigClient fedGalleyClient db = testGroup "connection" [ test p "post /connections" $ testCreateManualConnections b, @@ -83,15 +85,15 @@ tests cl _at opts p b _c g fedBrigClient db = test p "post /connections - 400 (max conns)" $ testConnectionLimit b cl, test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl, test p "Remote connections: connect with no federation" (testConnectFederationNotAvailable b), - test p "Remote connections: connect OK" (testConnectOK b fedBrigClient), + test p "Remote connections: connect OK" (testConnectOK b g fedBrigClient), test p "Remote connections: connect with Anon" (testConnectWithAnon b fedBrigClient), test p "Remote connections: connection from Anon" (testConnectFromAnon b), - test p "Remote connections: mutual Connect - local action then remote action" (testConnectMutualLocalActionThenRemoteAction opts b fedBrigClient), - test p "Remote connections: mutual Connect - remote action then local action" (testConnectMutualRemoteActionThenLocalAction opts b fedBrigClient), + test p "Remote connections: mutual Connect - local action then remote action" (testConnectMutualLocalActionThenRemoteAction opts b g fedBrigClient), + test p "Remote connections: mutual Connect - remote action then local action" (testConnectMutualRemoteActionThenLocalAction opts b fedBrigClient fedGalleyClient), test p "Remote connections: connect twice" (testConnectFromPending b fedBrigClient), test p "Remote connections: ignore then accept" (testConnectFromIgnored opts b fedBrigClient), test p "Remote connections: ignore, remote cancels, then accept" (testSentFromIgnored opts b fedBrigClient), - test p "Remote connections: block then accept" (testConnectFromBlocked opts b fedBrigClient), + test p "Remote connections: block then accept" (testConnectFromBlocked opts b g fedBrigClient), test p "Remote connections: block, remote cancels, then accept" (testSentFromBlocked opts b fedBrigClient), test p "Remote connections: send then cancel" (testCancel opts b), test p "Remote connections: limits" (testConnectionLimits opts b fedBrigClient) @@ -710,11 +712,16 @@ testConnectFederationNotAvailable brig = do postConnectionQualified brig uid1 quid2 !!! const 422 === statusCode -testConnectOK :: Brig -> FedBrigClient -> Http () -testConnectOK brig fedBrigClient = do - (uid1, quid2) <- localAndRemoteUser brig +testConnectOK :: Brig -> Galley -> FedBrigClient -> Http () +testConnectOK brig galley fedBrigClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + -- The conversation exists uid1 is not a participant however + getConversationQualified galley uid1 convId + !!! statusCode === const 403 + testConnectWithAnon :: Brig -> FedBrigClient -> Http () testConnectWithAnon brig fedBrigClient = do fromUser <- randomId @@ -729,26 +736,54 @@ testConnectFromAnon brig = do remoteUser <- fakeRemoteUser postConnectionQualified brig anonUser remoteUser !!! const 403 === statusCode -testConnectMutualLocalActionThenRemoteAction :: Opt.Opts -> Brig -> FedBrigClient -> Http () -testConnectMutualLocalActionThenRemoteAction opts brig fedBrigClient = do - (uid1, quid2) <- localAndRemoteUser brig +testConnectMutualLocalActionThenRemoteAction :: Opt.Opts -> Brig -> Galley -> FedBrigClient -> Http () +testConnectMutualLocalActionThenRemoteAction opts brig galley fedBrigClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal -- First create a connection request from local to remote user, as this test -- aims to test the behaviour of recieving a mutual request from remote sendConnectionAction brig opts uid1 quid2 Nothing Sent + do + res <- + getConversationQualified galley uid1 convId Brig -> FedBrigClient -> Http () -testConnectMutualRemoteActionThenLocalAction opts brig fedBrigClient = do - (uid1, quid2) <- localAndRemoteUser brig + do + res <- + getConversationQualified galley uid1 convId Brig -> FedBrigClient -> FedGalleyClient -> Http () +testConnectMutualRemoteActionThenLocalAction opts brig fedBrigClient fedGalleyClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal -- First create a connection request from remote to local user, as this test -- aims to test the behaviour of sending a mutual request to remote receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + let request = + GetConversationsRequest + { gcrUserId = qUnqualified quid2, + gcrConvIds = [qUnqualified convId] + } + + res <- F.getConversations fedGalleyClient (qDomain quid2) request + liftIO $ + fmap (fmap omQualifiedId . rcmOthers . rcnvMembers) (gcresConvs res) @?= [[]] + -- The mock response has 'RemoteConnect' as action, because the remote backend -- cannot be sure if the local backend was previously in Ignored state or not sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted @@ -790,15 +825,19 @@ testSentFromIgnored opts brig fedBrigClient = do -- if we accept, and the remote does not want to connect anymore, we transition to 'Sent' sendConnectionAction brig opts uid1 quid2 Nothing Sent -testConnectFromBlocked :: Opt.Opts -> Brig -> FedBrigClient -> Http () -testConnectFromBlocked opts brig fedBrigClient = do - (uid1, quid2) <- localAndRemoteUser brig +testConnectFromBlocked :: Opt.Opts -> Brig -> Galley -> FedBrigClient -> Http () +testConnectFromBlocked opts brig galley fedBrigClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal -- set up an initial 'Blocked' state receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 assertConnectionQualified brig uid1 quid2 Blocked + getConversationQualified galley uid1 convId + !!! statusCode === const 403 + -- if the remote side sends a new connection request, we ignore it receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Blocked @@ -806,6 +845,14 @@ testConnectFromBlocked opts brig fedBrigClient = do -- wants to connect, we transition to 'Accepted' sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + do + res <- + getConversationQualified galley uid1 convId Brig -> FedBrigClient -> Http () testSentFromBlocked opts brig fedBrigClient = do (uid1, quid2) <- localAndRemoteUser brig diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 75906db35c5..d0423fe8ced 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -50,16 +50,21 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai.Utilities.Server (compile) import OpenSSL (withOpenSSL) import Options.Applicative hiding (action) +import Servant.API.Generic (GenericServant, ToServant, ToServantApi) +import Servant.Client (HasClient) import qualified Servant.Client as Servant +import Servant.Client.Generic (AsClientT) import qualified Servant.Client.Generic as Servant import System.Environment (withArgs) import qualified System.Environment.Blank as Blank import qualified System.Logger as Logger import Test.Tasty import Test.Tasty.HUnit -import Util (FedBrigClient) +import Util (FedBrigClient, FedGalleyClient) import Util.Options import Util.Test +import qualified Wire.API.Federation.API.Brig as FedBrig +import qualified Wire.API.Federation.API.Galley as FedGalley data BackendConf = BackendConf { remoteBrig :: Endpoint, @@ -120,9 +125,10 @@ runTests iConf brigOpts otherArgs = do db <- defInitCassandra casKey casHost casPort lg mg <- newManager tlsManagerSettings let fedBrigClient = mkFedBrigClient mg (brig iConf) + let fedGalleyClient = mkFedGalleyClient mg (galley iConf) emailAWSOpts <- parseEmailAWSOpts awsEnv <- AWS.mkEnv lg awsOpts emailAWSOpts mg - userApi <- User.tests brigOpts fedBrigClient mg b c ch g n awsEnv db + userApi <- User.tests brigOpts fedBrigClient fedGalleyClient mg b c ch g n awsEnv db providerApi <- Provider.tests localDomain (provider iConf) mg db b c g searchApis <- Search.tests brigOpts mg g b teamApis <- Team.tests brigOpts mg n b c g awsEnv @@ -214,12 +220,26 @@ parseConfigPaths = do ) mkFedBrigClient :: Manager -> Endpoint -> FedBrigClient -mkFedBrigClient mgr brigEndpoint = Servant.genericClientHoist servantClienMToHttp +mkFedBrigClient = mkFedBrigClientGen @FedBrig.Api + +mkFedGalleyClient :: Manager -> Endpoint -> FedGalleyClient +mkFedGalleyClient = mkFedBrigClientGen @FedGalley.Api + +mkFedBrigClientGen :: + forall routes. + ( HasClient Servant.ClientM (ToServantApi routes), + GenericServant routes (AsClientT (HttpT IO)), + Servant.Client (HttpT IO) (ToServantApi routes) ~ ToServant routes (AsClientT (HttpT IO)) + ) => + Manager -> + Endpoint -> + routes (AsClientT (HttpT IO)) +mkFedBrigClientGen mgr endpoint = Servant.genericClientHoist servantClienMToHttp where servantClienMToHttp :: Servant.ClientM a -> Http a servantClienMToHttp action = liftIO $ do - let brigHost = Text.unpack $ brigEndpoint ^. epHost - brigPort = fromInteger . toInteger $ brigEndpoint ^. epPort + let brigHost = Text.unpack $ endpoint ^. epHost + brigPort = fromInteger . toInteger $ endpoint ^. epPort baseUrl = Servant.BaseUrl Servant.Http brigHost brigPort "" clientEnv = Servant.ClientEnv mgr baseUrl Nothing Servant.defaultMakeClientRequest eitherRes <- Servant.runClientM action clientEnv diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 06cdfa598d8..c23223a0bb4 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -60,6 +60,7 @@ import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (encodeUtf8) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID +import Galley.Types.Conversations.One2One (one2OneConvId) import qualified Galley.Types.Teams as Team import Gundeck.Types.Notification import Imports @@ -75,6 +76,7 @@ import Util.AWS import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.Federation.API.Brig as FedBrig +import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Routes.MultiTablePaging type Brig = Request -> Request @@ -93,6 +95,8 @@ type Spar = Request -> Request type FedBrigClient = FedBrig.Api (AsClientT (HttpT IO)) +type FedGalleyClient = FedGalley.Api (AsClientT (HttpT IO)) + instance ToJSON SESBounceType where toJSON BounceUndetermined = String "Undetermined" toJSON BouncePermanent = String "Permanent" @@ -140,6 +144,22 @@ localAndRemoteUser brig = do quid2 <- fakeRemoteUser pure (uid1, quid2) +localAndRemoteUserWithConvId :: + (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => + Brig -> + Bool -> + m (UserId, Qualified UserId, Qualified ConvId) +localAndRemoteUserWithConvId brig shouldBeLocal = do + quid <- userQualifiedId <$> randomUser brig + let go = do + other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + let convId = one2OneConvId quid other + isLocal = qDomain quid == qDomain convId + if shouldBeLocal == isLocal + then pure (qUnqualified quid, other, convId) + else go + go + fakeRemoteUser :: (HasCallStack, MonadIO m) => m (Qualified UserId) fakeRemoteUser = Qualified <$> randomId <*> pure (Domain "far-away.example.com") diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index fa9de3f254b..d3bd30396a1 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -22,108 +22,15 @@ module Galley.API.One2One ) where -import Control.Error (atMay) -import qualified Crypto.Hash as Crypto -import Data.Bits -import Data.ByteArray (convert) -import qualified Data.ByteString as B -import Data.ByteString.Conversion -import qualified Data.ByteString.Lazy as L import Data.Id import Data.Qualified -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Data.UUID.Tagged as U import Galley.App (Galley) import qualified Galley.Data as Data import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (..)) +import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.UserList (UserList (..)) import Imports --- | The hash function used to obtain the 1-1 conversation ID for a pair of users. --- --- /Note/: the hash function must always return byte strings of length > 16. -hash :: ByteString -> ByteString -hash = convert . Crypto.hash @ByteString @Crypto.SHA256 - --- | A randomly-generated UUID to use as a namespace for the UUIDv5 of 1-1 --- conversation IDs -namespace :: UUID -namespace = UUID.fromWords 0x9a51edb8 0x060c0d9a 0x0c2950a8 0x5d152982 - -compareDomains :: Ord a => Qualified a -> Qualified a -> Ordering -compareDomains (Qualified a1 dom1) (Qualified a2 dom2) = - compare (dom1, a1) (dom2, a2) - -quidToByteString :: Qualified UserId -> ByteString -quidToByteString (Qualified uid domain) = toByteString' uid <> toByteString' domain - --- | This function returns the 1-1 conversation for a given pair of users. --- --- Let A, B denote the (not necessarily distinct) backends of the two users, --- with the domain of A less or equal than the domain of B in the lexicographic --- ordering of their ascii encodings. Given users a@A and b@B, the UUID and --- owning domain of the unique 1-1 conversation between a and b shall be a --- deterministic function of the input data, plus some fixed parameters, as --- described below. --- --- __Parameters__ --- --- * A (collision-resistant) hash function h with N bits of output, where N --- s a multiple of 8 strictly larger than 128; this is set to SHA256. --- * A "namespace" UUID n. --- --- __Algorithm__ --- --- First, in the special case where A and B are the same backend, assume that --- the UUID of a is lower than that of b. If that is not the case, swap a --- and b in the following. This is necessary to ensure that the function we --- describe below is symmetric in its arguments. --- Let c be the bytestring obtained as the concatenation of the following 5 --- components: --- --- * the 16 bytes of the namespace n --- * the 16 bytes of the UUID of a --- * the ascii encoding of the domain of A --- * the 16 bytes of the UUID of b --- * the ascii encoding of the domain of B, --- --- and let x = h(c) be its hashed value. The UUID of the 1-1 conversation --- between a and b is obtained by converting the first 128 bits of x to a UUID --- V5. Note that our use of V5 here is not strictly compliant with RFC 4122, --- since we are using a custom hash and not necessarily SHA1. --- --- The owning domain for the conversation is set to be A if bit 128 of x (i.e. --- the most significant bit of the octet at index 16) is 0, and B otherwise. --- This is well-defined, because we assumed the number of bits of x to be --- strictly larger than 128. -one2OneConvId :: Qualified UserId -> Qualified UserId -> Qualified ConvId -one2OneConvId a b = case compareDomains a b of - GT -> one2OneConvId b a - _ -> - let c = - mconcat - [ L.toStrict (UUID.toByteString namespace), - quidToByteString a, - quidToByteString b - ] - x = hash c - result = - U.toUUID . U.mk @U.V5 - . fromMaybe UUID.nil - -- fromByteString only returns 'Nothing' when the input is not - -- exactly 16 bytes long, here this should not be a case since - -- 'hash' is supposed to return atleast 16 bytes and we use 'B.take - -- 16' to truncate it - . UUID.fromByteString - . L.fromStrict - . B.take 16 - $ x - domain - | fromMaybe 0 (atMay (B.unpack x) 16) .&. 0x80 == 0 = qDomain a - | otherwise = qDomain b - in Qualified (Id result) domain - iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley UpsertOne2OneConversationResponse iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId From c6906f8f4e7ff49cdfcfedcac64ef9ef36491ac3 Mon Sep 17 00:00:00 2001 From: zebot Date: Wed, 13 Oct 2021 12:10:17 +0200 Subject: [PATCH 19/88] chore: [charts] Update webapp version (#1836) Co-authored-by: Zebot --- charts/webapp/values.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index fe21eb3aac3..cd36874f5c5 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: 2021-09-06-staging.3-v0.28.24-e6e306b + tag: "2021-10-04-production.0-v0.28.29-0-188919c" service: https: externalPort: 443 From 93febef7db94232b588c8a611784b4de2da699d5 Mon Sep 17 00:00:00 2001 From: zebot Date: Wed, 13 Oct 2021 12:10:27 +0200 Subject: [PATCH 20/88] chore: [charts] Update team-settings version (#1835) Co-authored-by: Zebot --- charts/team-settings/values.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/charts/team-settings/values.yaml b/charts/team-settings/values.yaml index 61f8968d85c..a1f9621f581 100644 --- a/charts/team-settings/values.yaml +++ b/charts/team-settings/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/team-settings - tag: "4.0.0-v0.28.21-b92fca-2" + tag: "4.2.0-v0.28.29-0-1e2ef75" service: https: externalPort: 443 From 46b02b1a5da7928781555c684fa3b8fbbc9118f2 Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Wed, 13 Oct 2021 16:59:44 +0200 Subject: [PATCH 21/88] update to latest SFT. (#1849) * update to latest SFT. * Add changelog entry for SFT Co-authored-by: jschaul --- changelog.d/0-release-notes/sft-2-1-15 | 1 + charts/sftd/Chart.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/0-release-notes/sft-2-1-15 diff --git a/changelog.d/0-release-notes/sft-2-1-15 b/changelog.d/0-release-notes/sft-2-1-15 new file mode 100644 index 00000000000..5d9fd71dacf --- /dev/null +++ b/changelog.d/0-release-notes/sft-2-1-15 @@ -0,0 +1 @@ +Upgrade SFT to 2.1.15 diff --git a/charts/sftd/Chart.yaml b/charts/sftd/Chart.yaml index bd8b66f8026..c619f35d92a 100644 --- a/charts/sftd/Chart.yaml +++ b/charts/sftd/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.42 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 2.0.127 +appVersion: 2.1.15 From e8ce5fbc6ba107324150f8b92e64ee92d8c6e484 Mon Sep 17 00:00:00 2001 From: jschaul Date: Wed, 13 Oct 2021 17:06:02 +0200 Subject: [PATCH 22/88] Upgrade webapp/team-settings: changelog entries for #1835 and #1836 (#1856) --- changelog.d/0-release-notes/team-settings-upgrade | 1 + changelog.d/0-release-notes/webapp-upgrade | 1 + 2 files changed, 2 insertions(+) create mode 100644 changelog.d/0-release-notes/team-settings-upgrade create mode 100644 changelog.d/0-release-notes/webapp-upgrade diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade new file mode 100644 index 00000000000..f03f4845b0b --- /dev/null +++ b/changelog.d/0-release-notes/team-settings-upgrade @@ -0,0 +1 @@ +Upgrade team settings to Release: [v4.2.0](https://github.com/wireapp/wire-team-settings/releases/tag/v4.2.0) and image tag: 4.2.0-v0.28.29-0-1e2ef75 diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade new file mode 100644 index 00000000000..cc3ced05b21 --- /dev/null +++ b/changelog.d/0-release-notes/webapp-upgrade @@ -0,0 +1 @@ +Upgrade Webapp to Release: 2021-10-04-production.0 and image tag: 2021-10-04-production.0-v0.28.29-0-188919c From 62c837eca1860238de56010dd064c04771b9286d Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Wed, 13 Oct 2021 19:23:21 +0200 Subject: [PATCH 23/88] Fix SFTD in umbrella chart (#1677) * Fix SFTD in umbrella chart * changelog Co-authored-by: jschaul --- changelog.d/3-bug-fixes/pr-1677 | 1 + charts/sftd/templates/configmap-join-call.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/3-bug-fixes/pr-1677 diff --git a/changelog.d/3-bug-fixes/pr-1677 b/changelog.d/3-bug-fixes/pr-1677 new file mode 100644 index 00000000000..21385b64e1f --- /dev/null +++ b/changelog.d/3-bug-fixes/pr-1677 @@ -0,0 +1 @@ +Fix an issue related to installing the SFT helm chart as a sub chart to the wire-server chart. diff --git a/charts/sftd/templates/configmap-join-call.yaml b/charts/sftd/templates/configmap-join-call.yaml index 63885741468..fd4ec86717a 100644 --- a/charts/sftd/templates/configmap-join-call.yaml +++ b/charts/sftd/templates/configmap-join-call.yaml @@ -14,7 +14,7 @@ data: location /healthz { return 204; } location ~ ^/sfts/([a-z0-9\-]+)/(.*) { - proxy_pass http://$1.sftd.${POD_NAMESPACE}.svc.cluster.local:8585/$2; + proxy_pass http://$1.{{ include "sftd.fullname" . }}.${POD_NAMESPACE}.svc.cluster.local:8585/$2; } } From 99961a4d9d69d2359f59ef878166eb8b6b060ae0 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Wed, 13 Oct 2021 19:24:10 +0200 Subject: [PATCH 24/88] Move SFTD public IP docs to the top (#1672) It's the thing people confuse the most. Hopefully people will get it wrong less now --- charts/sftd/README.md | 51 ++++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 25 deletions(-) diff --git a/charts/sftd/README.md b/charts/sftd/README.md index c785f580092..2d0fa74a076 100644 --- a/charts/sftd/README.md +++ b/charts/sftd/README.md @@ -111,6 +111,32 @@ able to reach the restund servers on their public IPs. More exotic setups _are_ possible but are currently *not* officially supported. Please contact us if you have different constraints. +### No public IP on default interface + +Often on-prem or at certain cloud providers your nodes will not have directly routable public IP addresses +but are deployed in 1:1 NAT. This chart is able to auto-detect this scenario if your cloud providers adds +an `ExternalIP` field to your kubernetes node objects. + +On on-prem you should set an `wire.com/external-ip` annotation on your kubernetes nodes so that sftd is aware +of its external IP when it gets scheduled on a node. + +If you use our kubespray playbooks to bootstrap kubernetes, you simply have to +set the `external_ip` field in your `group_vars` +```yaml +# inventory/group_vars/k8s-cluster +node_annotations: + wire.com/external-ip: {{ external_ip }} +``` +And the `external_ip` is set in the inventory per node: +``` +node0 ansible_host=.... ip=... external_ip=aaa.xxx.yyy.zzz +``` + +If you are hosting Kubernetes through other means you can annotate your nodes manually: +``` +$ kubectl annotate node $HOSTNAME wire.com/external-ip=$EXTERNAL_IP +``` + ## Rollout Kubernetes will shut down pods and start new ones when rolling out a release. Any calls @@ -193,31 +219,6 @@ helm install wire-prod charts/wire-server --set 'nodeSelector.wire\.com/role=sft helm install wire-staging charts/wire-server --set 'nodeSelector.wire\.com/role=sftd-staging' ...other-flags ``` -## No public IP on default interface - -Often on-prem or at certain cloud providers your nodes will not have directly routable public IP addresses -but are deployed in 1:1 NAT. This chart is able to auto-detect this scenario if your cloud providers adds -an `ExternalIP` field to your kubernetes node objects. - -On on-prem you should set an `wire.com/external-ip` annotation on your kubernetes nodes so that sftd is aware -of its external IP when it gets scheduled on a node. - -If you use our kubespray playbooks to bootstrap kubernetes, you simply have to -set the `external_ip` field in your `group_vars` -```yaml -# inventory/group_vars/k8s-cluster -node_annotations: - wire.com/external-ip: {{ external_ip }} -``` -And the `external_ip` is set in the inventory per node: -``` -node0 ansible_host=.... ip=... external_ip=aaa.xxx.yyy.zzz -``` - -If you are hosting Kubernetes through other means you can annotate your nodes manually: -``` -$ kubectl annotate node $HOSTNAME wire.com/external-ip=$EXTERNAL_IP -``` ## Port conflicts and `hostNetwork` From 3497d6e8f9e8524f53dc4bb680d83033af39eae1 Mon Sep 17 00:00:00 2001 From: Lucendio Date: Wed, 13 Oct 2021 19:28:29 +0200 Subject: [PATCH 25/88] [charts:sftd] Introduce flag to enable TURN discovery (#1519) * [charts:sftd] Introduce flag to enable TURN discovery * -f integrate review feedback * changelog Co-authored-by: jschaul --- changelog.d/2-features/pr-1519 | 1 + charts/sftd/templates/statefulset.yaml | 7 ++++++- charts/sftd/values.yaml | 4 ++++ 3 files changed, 11 insertions(+), 1 deletion(-) create mode 100644 changelog.d/2-features/pr-1519 diff --git a/changelog.d/2-features/pr-1519 b/changelog.d/2-features/pr-1519 new file mode 100644 index 00000000000..80b6a161ed5 --- /dev/null +++ b/changelog.d/2-features/pr-1519 @@ -0,0 +1 @@ +SFT: allow using TURN discovery using 'turnDiscoveryEnabled' diff --git a/charts/sftd/templates/statefulset.yaml b/charts/sftd/templates/statefulset.yaml index cfdf064a839..391931b1a0b 100644 --- a/charts/sftd/templates/statefulset.yaml +++ b/charts/sftd/templates/statefulset.yaml @@ -83,7 +83,12 @@ spec: else ACCESS_ARGS="-A ${EXTERNAL_IP}" fi - exec sftd -I "${POD_IP}" -M "${POD_IP}" ${ACCESS_ARGS} -u "https://{{ required "must specify host" .Values.host }}/sfts/${POD_NAME}" + exec sftd \ + -I "${POD_IP}" \ + -M "${POD_IP}" \ + ${ACCESS_ARGS} \ + {{ if .Values.turnDiscoveryEnabled }}-T{{ end }} \ + -u "https://{{ required "must specify host" .Values.host }}/sfts/${POD_NAME}" ports: - name: sft containerPort: 8585 diff --git a/charts/sftd/values.yaml b/charts/sftd/values.yaml index 4a186e8ee9b..6c889fc6299 100644 --- a/charts/sftd/values.yaml +++ b/charts/sftd/values.yaml @@ -81,3 +81,7 @@ joinCall: # Overrides the image tag whose default is the chart appVersion. tag: "1.19.5" +# Allow SFT instances to choose/consider using a TURN server for themselves as a proxy when +# trying to establish a connection to clients +# DOCS: https://docs.wire.com/understand/sft.html#prerequisites +turnDiscoveryEnabled: false From 1e2cd55183a77157efa1580b38e90ce8c6186b91 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 14 Oct 2021 08:20:43 +0200 Subject: [PATCH 26/88] Check extended key usage of server certificates (#1855) * Test that server key usage is checked for fed cert * Reject certificates without server usage flag --- .../6-federation/check-server-cert-usage | 1 + services/federator/federator.cabal | 5 +++- services/federator/src/Federator/Remote.hs | 4 +-- .../federator/test/resources/unit/README.md | 5 ++++ .../unit/localhost.client-only-key.pem | 28 +++++++++++++++++++ .../resources/unit/localhost.client-only.pem | 18 ++++++++++++ .../test/unit/Test/Federator/Remote.hs | 18 ++++++++++++ 7 files changed, 76 insertions(+), 3 deletions(-) create mode 100644 changelog.d/6-federation/check-server-cert-usage create mode 100644 services/federator/test/resources/unit/README.md create mode 100644 services/federator/test/resources/unit/localhost.client-only-key.pem create mode 100644 services/federator/test/resources/unit/localhost.client-only.pem diff --git a/changelog.d/6-federation/check-server-cert-usage b/changelog.d/6-federation/check-server-cert-usage new file mode 100644 index 00000000000..7953d9292d5 --- /dev/null +++ b/changelog.d/6-federation/check-server-cert-usage @@ -0,0 +1 @@ +Server certificates without the "serverAuth" extended usage flag are now rejected when connecting to a remote federator. diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index ade0ac73324..7bd2efef164 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9a181e3a92130220d845ad959ca6e02a217b07a38602513bff4c9376a4ffe145 +-- hash: 9cb4007a4aa28024c1ac5077eb0840c877b7fd3a7afee0b48a9c218a54afc40a name: federator version: 1.0.0 @@ -25,9 +25,12 @@ extra-source-files: test/resources/unit/localhost-dot-key.pem test/resources/unit/localhost-dot.pem test/resources/unit/localhost-key.pem + test/resources/unit/localhost.client-only-key.pem + test/resources/unit/localhost.client-only.pem test/resources/unit/localhost.example.com-key.pem test/resources/unit/localhost.example.com.pem test/resources/unit/localhost.pem + test/resources/unit/README.md test/resources/unit/second-federator.example.com-key.pem test/resources/unit/second-federator.example.com.pem test/resources/unit/unit-ca-key.pem diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 38e6a143f91..b305c8857a3 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -143,8 +143,8 @@ mkGrpcClient target@(SrvTarget host port) = do { TLS.onServerCertificate = X509.validate X509.HashSHA256 - (X509.defaultHooks {X509.hookValidateName = validateDomainName}) - X509.defaultChecks, + X509.defaultHooks {X509.hookValidateName = validateDomainName} + X509.defaultChecks {X509.checkLeafKeyPurpose = [X509.KeyUsagePurpose_ServerAuth]}, TLS.onCertificateRequest = \_ -> pure (Just (settings ^. creds)) }, TLS.clientShared = def {TLS.sharedCAStore = settings ^. caStore} diff --git a/services/federator/test/resources/unit/README.md b/services/federator/test/resources/unit/README.md new file mode 100644 index 00000000000..3ccc5801090 --- /dev/null +++ b/services/federator/test/resources/unit/README.md @@ -0,0 +1,5 @@ +localhost.client-only.pem has been created with: + +``` +openssl x509 -req -in <(openssl req -nodes -newkey rsa:2048 -keyout localhost.client-only-key.pem -out /dev/stdout -subj "/") -CA unit-ca.pem -CAkey unit-ca-key.pem -out localhost.client-only.pem -set_serial 0 -extfile <(echo 'subjectAltName = DNS:*integration.example.com, DNS:localhost'; echo 'extendedKeyUsage = clientAuth') +``` diff --git a/services/federator/test/resources/unit/localhost.client-only-key.pem b/services/federator/test/resources/unit/localhost.client-only-key.pem new file mode 100644 index 00000000000..4a8fb596562 --- /dev/null +++ b/services/federator/test/resources/unit/localhost.client-only-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQC6Zp5uNWp581WJ +BwrneDnQRAuecmAHjnUwF1c/EAe/GJ3vO7erBU9//vDvGutNwZRXYrrGV1Jy2WY3 +dADk513M0vc2OcOBWxKo+8svsio2rCLhTwDpR91DIINP8SjPRYxX9qSY8C8hRdxI +cER1EcwIf20EM5qL/shYl2p0wIpXQuwV3FwQGMELmkSzrb5kyq8tCPa2vzPtT5Lq +G50PyhcvnmPj/D0IpxalfOjLDvkeAXyEb79yTyuY3zDOFY2QjqJcxQkWu9uQH94L +3aMKIX2D8VCiPGbZTAKcW6BQACHjd74Kq6eyHW66C6lXBr0P2BDVAn8/w/Nduw/h +lZuUvMTLAgMBAAECggEBAK6b2EcmtHI+Vl7BAR7pSUblpviq7XfGo9ID20+QpaEF +31Qt3ZRPqjQdTfa9gbRZ5KqjKpEHVY2ORqklenzymrR23uql25T+ChHPpHsua0rB +nv7t8c2U6xipiThGkNLwtFHmEjPNsmh5t6sHt6junfFL5IQuDtSbO3N5i1iI0E6C +IZPmnkCOqQI+FjesJXvRgEwqJPDFlHNWTRAV751K1dBQsvsYSEetrR/+JGV8fgF6 +vmFsaYmbLzeuGMg2I3tgiD0s5MdgWu6OvasZUS2OyGv2IPX9fWId5YoIcneVDE6X +q1Yw0nuF6Tf+jwVJEvk6telRhEJACx7p0Nkw65kC9SkCgYEA4O60hkRwzrwPhxXq +ZskZ3jjsAN+pL7PCWzPFJ4UxhJAlAdPpB48DM9D1u76sJkK5y5FhA7glFmNfH5eM +HX2LVB/oQNzjKzJp4o2e0WEb3Asvzo3koCTNEbMCPhOlmx8T5s/+HTndFPS34BYB +epa9TJTWz5CPz8uBIuaQfH0SMt8CgYEA1CV9r7GOcdVqPOO8+VdqXAuIvMyYpzFQ +ETNlU5A3G2kbmlViJTEGLHC1tiJe5cv6Kt74uFdR7pl+0Hba67Q8vZLWuj0aRwc7 +EzmpXYSkpSi2+q3ntuTjMGmWx9ZmOldNmBiarm850lAsGrx9TNahZfzk9fZVif6m +h6y6t5fw95UCgYAJsF6YVgRh81nb4MbLDKiPmPYZh4jbJCwgD5fTfvpGEot1i7JD +ABcMOVkMcEcsEr28FhQOu/TlBPzI+JcxggHpasJvYNRsPOywtJb9v+gaT2UMybHq +cAthUsuq7t+4Udtimt0AV0i9qVjuTyRbKnkW/mZOZJS9R6/VWAcrRZvuEwKBgQCb +HOZvBdXu6WoKJ0HO1dmQf2Z1FOswo9+1E+0sUi/YvNtP1soyA0xORgK2rx7PynqZ +yfn1XvMrD9QnPCAJYvleavTRq0eBU4ogHnL1S7zOfZx8YZcgpO5wQWPbramFUrwL +T0IZ9H1EhxYYXmUHP4828Ne/92LHyQed/+9tuYyYmQKBgQC2lzwQQAVRTM2sVHt2 +r/szB4/QXZpBcXUiUJoVdI2NETuSwxf6XhxiXtI6NPYIWjNiA+dZyWA/AY+EeMJL +9OPV/OtZArHILYHP1lyABs5ZwSC/qorkqct601T5+rjJyd8RVLJe+iWIrDEvU2V1 +inC3V5SG3R5wDEzBfQRuxnKfpA== +-----END PRIVATE KEY----- diff --git a/services/federator/test/resources/unit/localhost.client-only.pem b/services/federator/test/resources/unit/localhost.client-only.pem new file mode 100644 index 00000000000..57b05bbeb1b --- /dev/null +++ b/services/federator/test/resources/unit/localhost.client-only.pem @@ -0,0 +1,18 @@ +-----BEGIN CERTIFICATE----- +MIIC2zCCAcOgAwIBAgIBADANBgkqhkiG9w0BAQsFADAZMRcwFQYDVQQDEw5jYS5l +eGFtcGxlLmNvbTAeFw0yMTEwMTMwODAwMTRaFw0yMTExMTIwODAwMTRaMAAwggEi +MA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQC6Zp5uNWp581WJBwrneDnQRAue +cmAHjnUwF1c/EAe/GJ3vO7erBU9//vDvGutNwZRXYrrGV1Jy2WY3dADk513M0vc2 +OcOBWxKo+8svsio2rCLhTwDpR91DIINP8SjPRYxX9qSY8C8hRdxIcER1EcwIf20E +M5qL/shYl2p0wIpXQuwV3FwQGMELmkSzrb5kyq8tCPa2vzPtT5LqG50PyhcvnmPj +/D0IpxalfOjLDvkeAXyEb79yTyuY3zDOFY2QjqJcxQkWu9uQH94L3aMKIX2D8VCi +PGbZTAKcW6BQACHjd74Kq6eyHW66C6lXBr0P2BDVAn8/w/Nduw/hlZuUvMTLAgMB +AAGjRzBFMC4GA1UdEQQnMCWCGCppbnRlZ3JhdGlvbi5leGFtcGxlLmNvbYIJbG9j +YWxob3N0MBMGA1UdJQQMMAoGCCsGAQUFBwMCMA0GCSqGSIb3DQEBCwUAA4IBAQBB +wCeqw5FGB8GuZG9nEbRinfPKcMKNidy9zh/ppS6HyqOLuls3mAOgvdNZugUFsZq9 +RSOXofk8lAP8bwaZubp4VB2DSf/EsJoFXydPgT5TDqGVcBRGXJ0EKxqjonWbjOlR +69BwNsE8nZ/vmTY+5RdyUJNCy+CUtXSRmggYa8ix5WqZFOGZ0BmOM+vzw98OuhH2 +eZa9+e27fHiL1UVhS70RaMNixVai0cx8U+k2ntMCSbEbPoE25QWzfJEu6D7teh4c +nFv+6I5vZ/0g2z28h6Or/N6Bp2svvuuo5iyRzrWMPldHrbyP+zDh0A7Qtf8Io1Fv +LadoTB43UaTNaYdrwq2K +-----END CERTIFICATE----- diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 618c78dc855..3535f859d1e 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -101,6 +101,18 @@ testValidatesCertificateWrongHostname = "refuses to connect with server" [ testCase "when the server's certificate doesn't match the hostname" $ bracket (startMockServer certForWrongDomain) (Async.cancel . fst) $ \(_, port) -> do + tlsSettings <- mkTLSSettingsOrThrow settings + eitherClient <- + Polysemy.runM + . Polysemy.runError + . Polysemy.runInputConst tlsSettings + $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + case eitherClient of + Left (RemoteErrorTLSException _ _) -> pure () + Left x -> assertFailure $ "Expected TLS failure, got: " <> show x + Right _ -> assertFailure "Expected connection with the server to fail", + testCase "when the server's certificate does not have the server key usage flag" $ + bracket (startMockServer certWithoutServerKeyUsage) (Async.cancel . fst) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings eitherClient <- Polysemy.runM @@ -122,6 +134,12 @@ certForLocalhostDot = WarpTLS.tlsSettings "test/resources/unit/localhost-dot.pem certForWrongDomain :: WarpTLS.TLSSettings certForWrongDomain = WarpTLS.tlsSettings "test/resources/unit/localhost.example.com.pem" "test/resources/unit/localhost.example.com-key.pem" +certWithoutServerKeyUsage :: WarpTLS.TLSSettings +certWithoutServerKeyUsage = + WarpTLS.tlsSettings + "test/resources/unit/localhost.client-only.pem" + "test/resources/unit/localhost.client-only-key.pem" + startMockServer :: MonadIO m => WarpTLS.TLSSettings -> m (Async.Async (), Warp.Port) startMockServer tlsSettings = liftIO $ do (port, sock) <- bindRandomPortTCP "*6" From f10295c24b30048608e4d4c422233fc9df3e6979 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 14 Oct 2021 13:45:54 +0200 Subject: [PATCH 27/88] Access updates affect remote users (#1854) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Rename NotificationTargets to BotsAndMembers * Refactor logic to remove users after access update - Avoid using lenses and state; since there are only two updates, these can be threaded manually pretty easily. - Rename the `NotificationTargets` type to `BotsAndMembers`, and use that instead of pairs (or triples) in the access update function. This endpoint is still not properly federation-aware, since remote members are not removed, and local member removals are not propagated to remotes. Co-authored-by: Stefan Matting * Re-enable multiple victim when removing members This is useful to batch removals occurring after an access update to a conversation. * Remove and notify remotes on access update * Access update removal tests * Remove duplication in test conversation creation Co-authored-by: Paolo Capriotti Co-authored-by: Marko Dimjašević --- .../6-federation/access-update-remove-remotes | 1 + .../Federation/Golden/ConversationUpdate.hs | 2 +- .../testObject_ConversationUpdate2.json | 12 +- .../src/Wire/API/Conversation/Action.hs | 10 +- services/galley/src/Galley/API/Federation.hs | 7 +- services/galley/src/Galley/API/Update.hs | 128 ++++++------ services/galley/src/Galley/API/Util.hs | 67 ++++--- services/galley/test/integration/API.hs | 186 ++++++++++++++---- .../galley/test/integration/API/Federation.hs | 23 ++- .../test/integration/API/MessageTimer.hs | 7 +- services/galley/test/integration/API/Roles.hs | 14 +- services/galley/test/integration/API/Util.hs | 83 +++++--- 12 files changed, 359 insertions(+), 181 deletions(-) create mode 100644 changelog.d/6-federation/access-update-remove-remotes diff --git a/changelog.d/6-federation/access-update-remove-remotes b/changelog.d/6-federation/access-update-remove-remotes new file mode 100644 index 00000000000..448f53770ac --- /dev/null +++ b/changelog.d/6-federation/access-update-remove-remotes @@ -0,0 +1 @@ +Remove remote guests as well as local ones when "Guests and services" is disabled in a group conversation, and propagate removal to remote members. diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs index 1535c7c458e..e73413673e8 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs @@ -70,5 +70,5 @@ testObject_ConversationUpdate2 = cuConvId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")), cuAlreadyPresentUsers = [chad, dee], - cuAction = ConversationActionRemoveMember (qAlice) + cuAction = ConversationActionRemoveMembers (pure qAlice) } diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json index 3a0490a2535..e398d32ebce 100644 --- a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json +++ b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json @@ -9,11 +9,13 @@ ], "time": "1864-04-12T12:22:43.673Z", "action": { - "tag": "ConversationActionRemoveMember", - "contents": { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000100004007" - } + "tag": "ConversationActionRemoveMembers", + "contents": [ + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100004007" + } + ] }, "conv_id": "00000000-0000-0000-0000-000100000006" } \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index c96a77bc3ea..855376d8528 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -38,7 +38,7 @@ import Wire.API.Util.Aeson (CustomEncoded (..)) -- Used to send notifications to users and to remote backends. data ConversationAction = ConversationActionAddMembers (NonEmpty (Qualified UserId)) RoleName - | ConversationActionRemoveMember (Qualified UserId) + | ConversationActionRemoveMembers (NonEmpty (Qualified UserId)) | ConversationActionRename ConversationRename | ConversationActionMessageTimerUpdate ConversationMessageTimerUpdate | ConversationActionReceiptModeUpdate ConversationReceiptModeUpdate @@ -57,9 +57,9 @@ conversationActionToEvent :: conversationActionToEvent now quid qcnv (ConversationActionAddMembers newMembers role) = Event MemberJoin qcnv quid now $ EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers)) -conversationActionToEvent now quid qcnv (ConversationActionRemoveMember removedMember) = +conversationActionToEvent now quid qcnv (ConversationActionRemoveMembers removedMembers) = Event MemberLeave qcnv quid now $ - EdMembersLeave (QualifiedUserIdList [removedMember]) + EdMembersLeave (QualifiedUserIdList (toList removedMembers)) conversationActionToEvent now quid qcnv (ConversationActionRename rename) = Event ConvRename qcnv quid now (EdConvRename rename) conversationActionToEvent now quid qcnv (ConversationActionMessageTimerUpdate update) = @@ -74,8 +74,8 @@ conversationActionToEvent now quid qcnv (ConversationActionAccessUpdate update) conversationActionTag :: Qualified UserId -> ConversationAction -> Action conversationActionTag _ (ConversationActionAddMembers _ _) = AddConversationMember -conversationActionTag qusr (ConversationActionRemoveMember victim) - | qusr == victim = LeaveConversation +conversationActionTag qusr (ConversationActionRemoveMembers victims) + | pure qusr == victims = LeaveConversation | otherwise = RemoveConversationMember conversationActionTag _ (ConversationActionRename _) = ModifyConversationName conversationActionTag _ (ConversationActionMessageTimerUpdate _) = ModifyConversationMessageTimer diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index c7476ccfd75..8e63653b402 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -133,8 +133,8 @@ onConversationUpdated requestingDomain cu = do let localUsers = getLocalUsers localDomain toAdd Data.addLocalMembersToRemoteConv qconvId localUsers pure localUsers - ConversationActionRemoveMember toRemove -> do - let localUsers = getLocalUsers localDomain (pure toRemove) + ConversationActionRemoveMembers toRemove -> do + let localUsers = getLocalUsers localDomain toRemove Data.removeLocalMembersFromRemoteConv qconvId localUsers pure [] ConversationActionRename _ -> pure [] @@ -175,7 +175,8 @@ leaveConversation requestingDomain lc = do . runMaybeT . void . API.updateLocalConversation lcnv leaver Nothing - . ConversationActionRemoveMember + . ConversationActionRemoveMembers + . pure $ leaver -- FUTUREWORK: report errors to the originating backend diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 7b1976d83db..ad643767047 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -230,7 +230,6 @@ performAccessUpdateAction :: performAccessUpdateAction qusr conv target = do lcnv <- qualifyLocal (Data.convId conv) guard $ Data.convAccessData conv /= target - let (bots, users) = localBotsAndUsers (Data.convLocalMembers conv) -- Remove conversation codes if CodeAccess is revoked when ( CodeAccess `elem` Data.convAccess conv @@ -239,54 +238,52 @@ performAccessUpdateAction qusr conv target = do $ lift $ do key <- mkKey (tUnqualified lcnv) Data.deleteCode key ReusableCode - -- Depending on a variety of things, some bots and users have to be - -- removed from the conversation. We keep track of them using 'State'. - (newUsers, newBots) <- lift . flip execStateT (users, bots) $ do - -- We might have to remove non-activated members - -- TODO(akshay): Remove Ord instance for AccessRole. It is dangerous - -- to make assumption about the order of roles and implement policy - -- based on those assumptions. - when - ( Data.convAccessRole conv > ActivatedAccessRole - && cupAccessRole target <= ActivatedAccessRole - ) - $ do - mIds <- map lmId <$> use usersL - activated <- fmap User.userId <$> lift (lookupActivatedUsers mIds) - let isActivated user = lmId user `elem` activated - usersL %= filter isActivated - -- In a team-only conversation we also want to remove bots and guests - case (cupAccessRole target, Data.convTeam conv) of - (TeamAccessRole, Just tid) -> do - currentUsers <- use usersL - onlyTeamUsers <- flip filterM currentUsers $ \user -> - lift $ isJust <$> Data.teamMember tid (lmId user) - assign usersL onlyTeamUsers - botsL .= [] - _ -> return () + + -- Determine bots and members to be removed + let filterBotsAndMembers = filterActivated >=> filterTeammates + let current = convBotsAndMembers conv -- initial bots and members + desired <- lift $ filterBotsAndMembers current -- desired bots and members + let toRemove = bmDiff current desired -- bots and members to be removed + -- Update Cassandra lift $ Data.updateConversationAccess (tUnqualified lcnv) target - -- Remove users and bots lift . void . forkIO $ do - let removedUsers = map lmId users \\ map lmId newUsers - removedBots = map botMemId bots \\ map botMemId newBots - mapM_ (deleteBot (tUnqualified lcnv)) removedBots - for_ (nonEmpty removedUsers) $ \victims -> do - -- FUTUREWORK: deal with remote members, too, see updateLocalConversation (Jira SQCORE-903) - Data.removeLocalMembersFromLocalConv (tUnqualified lcnv) victims - now <- liftIO getCurrentTime - let qvictims = QualifiedUserIdList . map (qUntagged . qualifyAs lcnv) . toList $ victims - let e = Event MemberLeave (qUntagged lcnv) qusr now (EdMembersLeave qvictims) - -- push event to all clients, including zconn - -- since updateConversationAccess generates a second (member removal) event here - traverse_ push1 $ - newPushLocal ListComplete (qUnqualified qusr) (ConvEvent e) (recipient <$> users) - void . forkIO $ void $ External.deliver (newBots `zip` repeat e) + -- Remove bots + traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) + + -- Update current bots and members + let current' = current {bmBots = bmBots desired} + + -- Remove users and notify everyone + void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do + let action = ConversationActionRemoveMembers usersToRemove + void . runMaybeT $ performAction qusr conv action + notifyConversationMetadataUpdate qusr Nothing lcnv current' action where - usersL :: Lens' ([LocalMember], [BotMember]) [LocalMember] - usersL = _1 - botsL :: Lens' ([LocalMember], [BotMember]) [BotMember] - botsL = _2 + filterActivated :: BotsAndMembers -> Galley BotsAndMembers + filterActivated bm + | ( Data.convAccessRole conv > ActivatedAccessRole + && cupAccessRole target <= ActivatedAccessRole + ) = do + activated <- map User.userId <$> lookupActivatedUsers (toList (bmLocals bm)) + -- FUTUREWORK: should we also remove non-activated remote users? + pure $ bm {bmLocals = Set.fromList activated} + | otherwise = pure bm + + filterTeammates :: BotsAndMembers -> Galley BotsAndMembers + filterTeammates bm = do + -- In a team-only conversation we also want to remove bots and guests + case (cupAccessRole target, Data.convTeam conv) of + (TeamAccessRole, Just tid) -> do + onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> + isJust <$> Data.teamMember tid user + pure $ + BotsAndMembers + { bmLocals = Set.fromList onlyTeamUsers, + bmBots = mempty, + bmRemotes = mempty + } + _ -> pure bm updateConversationReceiptMode :: UserId -> @@ -398,7 +395,7 @@ updateLocalConversation lcnv qusr con action = do qusr con lcnv - (convTargets conv <> extraTargets) + (convBotsAndMembers conv <> extraTargets) action' getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) @@ -410,12 +407,12 @@ performAction :: Qualified UserId -> Data.Conversation -> ConversationAction -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT Galley (BotsAndMembers, ConversationAction) performAction qusr conv action = case action of ConversationActionAddMembers members role -> performAddMemberAction qusr conv members role - ConversationActionRemoveMember member -> do - performRemoveMemberAction conv member + ConversationActionRemoveMembers members -> do + performRemoveMemberAction conv (toList members) pure (mempty, action) ConversationActionRename rename -> lift $ do cn <- rangeChecked (cupName rename) @@ -565,7 +562,7 @@ joinConversation zusr zcon cnv access = do (qUntagged lusr) (Just zcon) lcnv - (convTargets conv <> extraTargets) + (convBotsAndMembers conv <> extraTargets) action -- | Add users to a conversation without performing any checks. Return extra @@ -574,19 +571,19 @@ addMembersToLocalConversation :: Local ConvId -> UserList UserId -> RoleName -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT Galley (BotsAndMembers, ConversationAction) addMembersToLocalConversation lcnv users role = do (lmems, rmems) <- lift $ Data.addMembers lcnv (fmap (,role) users) neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users let action = ConversationActionAddMembers neUsers role - pure (ntFromMembers lmems rmems, action) + pure (bmFromMembers lmems rmems, action) performAddMemberAction :: Qualified UserId -> Data.Conversation -> NonEmpty (Qualified UserId) -> RoleName -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT Galley (BotsAndMembers, ConversationAction) performAddMemberAction qusr conv invited role = do lcnv <- lift $ qualifyLocal (Data.convId conv) let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited @@ -644,7 +641,7 @@ performAddMemberAction qusr conv invited role = do qvictim <- qUntagged <$> qualifyLocal (lmId mem) void . runMaybeT $ updateLocalConversation lcnv qvictim Nothing $ - ConversationActionRemoveMember qvictim + ConversationActionRemoveMembers (pure qvictim) else throwErrorDescriptionType @MissingLegalholdConsent checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () @@ -784,14 +781,16 @@ removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim performRemoveMemberAction :: Data.Conversation -> - Qualified UserId -> + [Qualified UserId] -> MaybeT Galley () -performRemoveMemberAction conv victim = do +performRemoveMemberAction conv victims = do loc <- qualifyLocal () - guard $ isConvMember loc conv victim - let removeLocal u c = Data.removeLocalMembersFromLocalConv c (pure (tUnqualified u)) - removeRemote u c = Data.removeRemoteMembersFromLocalConv c (pure u) - lift $ foldQualified loc removeLocal removeRemote victim (Data.convId conv) + let presentVictims = filter (isConvMember loc conv) victims + guard . not . null $ presentVictims + + let (lvictims, rvictims) = partitionQualified loc presentVictims + traverse_ (lift . Data.removeLocalMembersFromLocalConv (Data.convId conv)) (nonEmpty lvictims) + traverse_ (lift . Data.removeRemoteMembersFromLocalConv (Data.convId conv)) (nonEmpty rvictims) -- | Remove a member from a local conversation. removeMemberFromLocalConv :: @@ -805,7 +804,8 @@ removeMemberFromLocalConv lcnv lusr con victim = fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT . updateLocalConversation lcnv (qUntagged lusr) con - . ConversationActionRemoveMember + . ConversationActionRemoveMembers + . pure $ victim -- OTR @@ -1008,7 +1008,7 @@ notifyConversationMetadataUpdate :: Qualified UserId -> Maybe ConnId -> Local ConvId -> - NotificationTargets -> + BotsAndMembers -> ConversationAction -> Galley Event notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do @@ -1017,7 +1017,7 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = indexRemote (toList (ntRemotes targets)) + let rusersByDomain = indexRemote (toList (bmRemotes targets)) void . pooledForConcurrentlyN 8 rusersByDomain $ \(qUntagged -> Qualified uids domain) -> do let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action rpc = @@ -1028,7 +1028,7 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d runFederatedGalley domain rpc -- notify local participants and bots - pushConversationEvent con e (ntLocals targets) (ntBots targets) $> e + pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f12365ae722..c6a940d3552 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -346,47 +346,60 @@ ulNewMembers loc conv (UserList locals remotes) = -- of the user id. Local user IDs get added to the local targets, remote user IDs -- to remote targets, and qualified user IDs get added to the appropriate list -- according to whether they are local or remote, by making a runtime check. -class IsNotificationTarget uid where - ntAdd :: Local x -> uid -> NotificationTargets -> NotificationTargets +class IsBotOrMember uid where + bmAdd :: Local x -> uid -> BotsAndMembers -> BotsAndMembers -data NotificationTargets = NotificationTargets - { ntLocals :: Set UserId, - ntRemotes :: Set (Remote UserId), - ntBots :: Set BotMember +data BotsAndMembers = BotsAndMembers + { bmLocals :: Set UserId, + bmRemotes :: Set (Remote UserId), + bmBots :: Set BotMember } -instance Semigroup NotificationTargets where - NotificationTargets locals1 remotes1 bots1 - <> NotificationTargets locals2 remotes2 bots2 = - NotificationTargets +bmQualifiedMembers :: Local x -> BotsAndMembers -> [Qualified UserId] +bmQualifiedMembers loc bm = + map (qUntagged . qualifyAs loc) (toList (bmLocals bm)) + <> map qUntagged (toList (bmRemotes bm)) + +instance Semigroup BotsAndMembers where + BotsAndMembers locals1 remotes1 bots1 + <> BotsAndMembers locals2 remotes2 bots2 = + BotsAndMembers (locals1 <> locals2) (remotes1 <> remotes2) (bots1 <> bots2) -instance Monoid NotificationTargets where - mempty = NotificationTargets mempty mempty mempty +instance Monoid BotsAndMembers where + mempty = BotsAndMembers mempty mempty mempty + +instance IsBotOrMember (Local UserId) where + bmAdd _ luid bm = + bm {bmLocals = Set.insert (tUnqualified luid) (bmLocals bm)} -instance IsNotificationTarget (Local UserId) where - ntAdd _ luid nt = - nt {ntLocals = Set.insert (tUnqualified luid) (ntLocals nt)} +instance IsBotOrMember (Remote UserId) where + bmAdd _ ruid bm = bm {bmRemotes = Set.insert ruid (bmRemotes bm)} -instance IsNotificationTarget (Remote UserId) where - ntAdd _ ruid nt = nt {ntRemotes = Set.insert ruid (ntRemotes nt)} +instance IsBotOrMember (Qualified UserId) where + bmAdd loc = foldQualified loc (bmAdd loc) (bmAdd loc) -instance IsNotificationTarget (Qualified UserId) where - ntAdd loc = foldQualified loc (ntAdd loc) (ntAdd loc) +bmDiff :: BotsAndMembers -> BotsAndMembers -> BotsAndMembers +bmDiff bm1 bm2 = + BotsAndMembers + { bmLocals = Set.difference (bmLocals bm1) (bmLocals bm2), + bmRemotes = Set.difference (bmRemotes bm1) (bmRemotes bm2), + bmBots = Set.difference (bmBots bm1) (bmBots bm2) + } -ntFromMembers :: [LocalMember] -> [RemoteMember] -> NotificationTargets -ntFromMembers lmems rusers = case localBotsAndUsers lmems of +bmFromMembers :: [LocalMember] -> [RemoteMember] -> BotsAndMembers +bmFromMembers lmems rusers = case localBotsAndUsers lmems of (bots, lusers) -> - NotificationTargets - { ntLocals = Set.fromList (map lmId lusers), - ntRemotes = Set.fromList (map rmId rusers), - ntBots = Set.fromList bots + BotsAndMembers + { bmLocals = Set.fromList (map lmId lusers), + bmRemotes = Set.fromList (map rmId rusers), + bmBots = Set.fromList bots } -convTargets :: Data.Conversation -> NotificationTargets -convTargets conv = ntFromMembers (Data.convLocalMembers conv) (Data.convRemoteMembers conv) +convBotsAndMembers :: Data.Conversation -> BotsAndMembers +convBotsAndMembers conv = bmFromMembers (Data.convLocalMembers conv) (Data.convRemoteMembers conv) localBotsAndUsers :: Foldable f => f LocalMember -> ([BotMember], [LocalMember]) localBotsAndUsers = foldMap botOrUser diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 5a3b6e8cb3d..c0a63c5ebd9 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -218,6 +218,7 @@ tests s = test s "join code-access conversation" postJoinCodeConvOk, test s "convert invite to code-access conversation" postConvertCodeConv, test s "convert code to team-access conversation" postConvertTeamConv, + test s "local and remote guests are removed when access changes" testAccessUpdateGuestRemoved, test s "cannot join private conversation" postJoinConvFail, test s "remove user" removeUser, test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests @@ -539,7 +540,12 @@ postMessageQualifiedLocalOwningBackendSuccess = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do @@ -607,7 +613,12 @@ postMessageQualifiedLocalOwningBackendMissingClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp -- Missing Bob, chadClient2 and Dee @@ -673,7 +684,12 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR3 cannon bobUnqualified chadUnqualified nonMemberUnqualified $ \(wsBob, wsChad, wsNonMember) -> do @@ -760,7 +776,12 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp let brigApi = @@ -881,7 +902,12 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do @@ -1148,6 +1174,68 @@ postConvertTeamConv = do -- team members (dave) can still join postJoinCodeConv dave j !!! const 200 === statusCode +testAccessUpdateGuestRemoved :: TestM () +testAccessUpdateGuestRemoved = do + -- alice, bob are in a team + (tid, alice, [bob]) <- createBindingTeamWithQualifiedMembers 2 + + -- charlie is a local guest + charlie <- randomQualifiedUser + connectUsers (qUnqualified alice) (pure (qUnqualified charlie)) + + -- dee is a remote guest + let remoteDomain = Domain "far-away.example.com" + dee <- Qualified <$> randomId <*> pure remoteDomain + let deeProfile = mkProfile dee (Name "dee") + + -- they are all in a local conversation + conv <- + responseJsonError + =<< postConvWithRemoteUsers + remoteDomain + [deeProfile] + (qUnqualified alice) + defNewConv + { newConvQualifiedUsers = [bob, charlie, dee], + newConvTeam = Just (ConvTeamInfo tid False) + } + do + -- conversation access role changes to team only + opts <- view tsGConf + (_, reqs) <- withTempMockFederator opts remoteDomain (const ()) $ do + putQualifiedAccessUpdate + (qUnqualified alice) + (cnvQualifiedId conv) + (ConversationAccessData mempty TeamAccessRole) + !!! const 200 === statusCode + + -- charlie and dee are kicked out + -- + -- note that removing users happens asynchronously, so this check should + -- happen while the mock federator is still available + WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $ + wsAssertMembersLeave (cnvQualifiedId conv) alice [charlie, dee] + + -- dee's remote receives a notification + liftIO . assertBool "remote users are not notified" . isJust . flip find reqs $ \freq -> + let req = F.request freq + in and + [ fmap F.component req == Just F.Galley, + fmap F.path req == Just "/federation/on-conversation-updated", + fmap (fmap FederatedGalley.cuAction . eitherDecode . LBS.fromStrict . F.body) req + == Just (Right (ConversationActionRemoveMembers (charlie :| [dee]))) + ] + + -- only alice and bob remain + conv2 <- + responseJsonError + =<< getConvQualified (qUnqualified alice) (cnvQualifiedId conv) + randomId - postConvQualified alice [bob] Nothing [] Nothing Nothing !!! do - const 422 === statusCode + postConvQualified + alice + defNewConv {newConvQualifiedUsers = [bob]} + !!! do + const 422 === statusCode postConvQualifiedNonExistentUser :: TestM () postConvQualifiedNonExistentUser = do @@ -1500,17 +1591,11 @@ postConvQualifiedNonExistentUser = do bob = Qualified bobId remoteDomain charlie = Qualified charlieId remoteDomain opts <- view tsGConf - _g <- view tsGalley - (resp, _) <- - withTempMockFederator - opts - remoteDomain - (const [mkProfile charlie (Name "charlie")]) - (postConvQualified alice [bob, charlie] (Just "remote gossip") [] Nothing Nothing) - liftIO $ do - statusCode resp @?= 400 - let err = responseJsonUnsafe resp :: Object - (err ^. at "label") @?= Just "unknown-remote-user" + void . withTempMockFederator opts remoteDomain (const [mkProfile charlie (Name "charlie")]) $ + postConvQualified alice defNewConv {newConvQualifiedUsers = [bob, charlie]} + !!! do + const 400 === statusCode + const (Right "unknown-remote-user") === fmap label . responseJsonEither postConvQualifiedFederationNotEnabled :: TestM () postConvQualifiedFederationNotEnabled = do @@ -1725,7 +1810,14 @@ getConvQualifiedOk = do bob <- randomQualifiedUser chuck <- randomQualifiedUser connectLocalQualifiedUsers alice (list1 bob [chuck]) - conv <- decodeConvId <$> postConvQualified alice [bob, chuck] (Just "gossip") [] Nothing Nothing + conv <- + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [bob, chuck], + newConvName = Just "gossip" + } getConv alice conv !!! const 200 === statusCode getConv (qUnqualified bob) conv !!! const 200 === statusCode getConv (qUnqualified chuck) conv !!! const 200 === statusCode @@ -1773,13 +1865,12 @@ testAddRemoteMember = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain opts <- view tsGConf - g <- view tsGalley (resp, reqs) <- withTempMockFederator opts remoteDomain (respond remoteBob) - (postQualifiedMembers' g alice (remoteBob :| []) convId) + (postQualifiedMembers alice (remoteBob :| []) convId) liftIO $ do map F.domain reqs @?= replicate 2 (domainText remoteDomain) map (fmap F.path . F.request) reqs @@ -2014,13 +2105,12 @@ testAddRemoteMemberFailure = do remoteCharlie = Qualified charlieId remoteDomain convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing opts <- view tsGConf - g <- view tsGalley (resp, _) <- withTempMockFederator opts remoteDomain (const [mkProfile remoteCharlie (Name "charlie")]) - (postQualifiedMembers' g alice (remoteBob :| [remoteCharlie]) convId) + (postQualifiedMembers alice (remoteBob :| [remoteCharlie]) convId) liftIO $ statusCode resp @?= 400 let err = responseJsonUnsafe resp :: Object liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" @@ -2033,13 +2123,12 @@ testAddDeletedRemoteUser = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing opts <- view tsGConf - g <- view tsGalley (resp, _) <- withTempMockFederator opts remoteDomain (const [(mkProfile remoteBob (Name "bob")) {profileDeleted = True}]) - (postQualifiedMembers' g alice (remoteBob :| []) convId) + (postQualifiedMembers alice (remoteBob :| []) convId) liftIO $ statusCode resp @?= 400 let err = responseJsonUnsafe resp :: Object liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" @@ -2062,7 +2151,6 @@ testAddRemoteMemberInvalidDomain = do -- on environments where federation isn't configured (such as our production as of May 2021) testAddRemoteMemberFederationDisabled :: TestM () testAddRemoteMemberFederationDisabled = do - g <- view tsGalley alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing @@ -2071,7 +2159,7 @@ testAddRemoteMemberFederationDisabled = do -- This is the case on staging/production in May 2021. let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ - postQualifiedMembers' g alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 400 === statusCode const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe -- federator endpoint being configured in brig and/or galley, but not being @@ -2080,7 +2168,7 @@ testAddRemoteMemberFederationDisabled = do -- Port 1 should always be wrong hopefully. let federatorUnavailable :: Opts = opts & optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ - postQualifiedMembers' g alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 500 === statusCode const (Just "federation-not-available") === fmap label . responseJsonUnsafe @@ -2198,7 +2286,14 @@ deleteMembersConvLocalQualifiedOk = do [alice, bob, eve] <- randomUsers 3 let [qAlice, qBob, qEve] = (`Qualified` localDomain) <$> [alice, bob, eve] connectUsers alice (list1 bob [eve]) - conv <- decodeConvId <$> postConvQualified alice [qBob, qEve] (Just "federated gossip") [] Nothing Nothing + conv <- + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [qBob, qEve], + newConvName = Just "federated gossip" + } let qconv = Qualified conv localDomain deleteMemberQualified bob qBob qconv !!! const 200 === statusCode deleteMemberQualified bob qBob qconv !!! const 404 === statusCode @@ -2224,7 +2319,13 @@ deleteLocalMemberConvLocalQualifiedOk = do qEve = Qualified eve remoteDomain connectUsers alice (singleton bob) - convId <- decodeConvId <$> postConvWithRemoteUser remoteDomain (mkProfile qEve (Name "Eve")) alice [qBob, qEve] + convId <- + decodeConvId + <$> postConvWithRemoteUsers + remoteDomain + [mkProfile qEve (Name "Eve")] + alice + defNewConv {newConvQualifiedUsers = [qBob, qEve]} let qconvId = Qualified convId localDomain opts <- view tsGConf @@ -2280,7 +2381,10 @@ deleteRemoteMemberConvLocalQualifiedOk = do (convId, _) <- withTempMockFederator' opts remoteDomain1 mockedResponse $ - decodeConvId <$> postConvQualified alice [qBob, qChad, qDee, qEve] Nothing [] Nothing Nothing + decodeConvId + <$> postConvQualified + alice + defNewConv {newConvQualifiedUsers = [qBob, qChad, qDee, qEve]} let qconvId = Qualified convId localDomain (respDel, federatedRequests) <- @@ -2425,7 +2529,12 @@ putQualifiedConvRenameWithRemotesOk = do qbob <- randomQualifiedUser let bob = qUnqualified qbob - resp <- postConvWithRemoteUser remoteDomain (mkProfile qalice (Name "Alice")) bob [qalice] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile qalice (Name "Alice")] + bob + defNewConv {newConvQualifiedUsers = [qalice]} let qconv = decodeQualifiedConvId resp opts <- view tsGConf @@ -2819,7 +2928,12 @@ putReceiptModeWithRemotesOk = do qbob <- randomQualifiedUser let bob = qUnqualified qbob - resp <- postConvWithRemoteUser remoteDomain (mkProfile qalice (Name "Alice")) bob [qalice] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile qalice (Name "Alice")] + bob + defNewConv {newConvQualifiedUsers = [qalice]} let qconv = decodeQualifiedConvId resp opts <- view tsGConf diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index eace125c2a7..0a16eeb34c6 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -89,7 +89,11 @@ getConversationsAllFound = do cnv2 <- responseJsonError - =<< postConvWithRemoteUser (qDomain aliceQ) (mkProfile aliceQ (Name "alice")) bob [aliceQ, carlQ] + =<< postConvWithRemoteUsers + (qDomain aliceQ) + [mkProfile aliceQ (Name "alice")] + bob + defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} getConvs bob (Just $ Left [qUnqualified (cnvQualifiedId cnv2)]) Nothing !!! do const 200 === statusCode @@ -216,7 +220,7 @@ removeLocalUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [alice], FedGalley.cuAction = - ConversationActionRemoveMember qAlice + ConversationActionRemoveMembers (pure qAlice) } WS.bracketR c alice $ \ws -> do @@ -278,7 +282,7 @@ removeRemoteUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [alice, charlie, dee], FedGalley.cuAction = - ConversationActionRemoveMember user + ConversationActionRemoveMembers (pure user) } WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do @@ -476,7 +480,12 @@ leaveConversationSuccess = do (convId, _) <- withTempMockFederator' opts remoteDomain1 mockedResponse $ - decodeConvId <$> postConvQualified alice [qBob, qChad, qDee, qEve] Nothing [] Nothing Nothing + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [qBob, qChad, qDee, qEve] + } let qconvId = Qualified convId localDomain (_, federatedRequests) <- @@ -616,7 +625,11 @@ sendMessage = do (convId, requests1) <- withTempMockFederator opts remoteDomain responses1 $ fmap decodeConvId $ - postConvQualified aliceId [bob, chad] Nothing [] Nothing Nothing + postConvQualified + aliceId + defNewConv + { newConvQualifiedUsers = [bob, chad] + } Int -> TestM (TeamId, Qualified UserId, [Qualified UserId]) +createBindingTeamWithQualifiedMembers num = do + localDomain <- viewFederationDomain + (tid, owner, users) <- createBindingTeamWithMembers num + pure (tid, Qualified owner localDomain, map (`Qualified` localDomain) users) + getTeams :: UserId -> TestM TeamList getTeams u = do g <- view tsGalley @@ -538,30 +544,48 @@ createOne2OneTeamConv u1 u2 n tid = do postConv :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> TestM ResponseLBS postConv u us name a r mtimer = postConvWithRole u us name a r mtimer roleNameWireAdmin -postConvQualified :: (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => UserId -> [Qualified UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> m ResponseLBS -postConvQualified u us name a r mtimer = postConvWithRoleQualified us u [] name a r mtimer roleNameWireAdmin +defNewConv :: NewConv +defNewConv = NewConv [] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin -postConvWithRemoteUser :: Domain -> UserProfile -> UserId -> [Qualified UserId] -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUser remoteDomain user creatorUnqualified members = - postConvWithRemoteUsers remoteDomain [user] creatorUnqualified members +postConvQualified :: + (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => + UserId -> + NewConv -> + m ResponseLBS +postConvQualified u n = do + g <- viewGalley + post $ + g + . path "/conversations" + . zUser u + . zConn "conn" + . zType "access" + . json (NewConvUnmanaged n) -postConvWithRemoteUsers :: Domain -> [UserProfile] -> UserId -> [Qualified UserId] -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUsers remoteDomain users creatorUnqualified members = do +postConvWithRemoteUsers :: + HasCallStack => + Domain -> + [UserProfile] -> + UserId -> + NewConv -> + TestM (Response (Maybe LByteString)) +postConvWithRemoteUsers remoteDomain profiles u n = do opts <- view tsGConf fmap fst $ - withTempMockFederator - opts - remoteDomain - respond - $ postConvQualified creatorUnqualified members (Just "federated gossip") [] Nothing Nothing + withTempMockFederator opts remoteDomain respond $ + postConvQualified u n {newConvName = setName (newConvName n)} Value respond req | fmap F.component (F.request req) == Just F.Brig = - toJSON users + toJSON profiles | otherwise = toJSON () + setName :: Maybe Text -> Maybe Text + setName Nothing = Just "federated gossip" + setName x = x + postTeamConv :: TeamId -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> TestM ResponseLBS postTeamConv tid u us name a r mtimer = do g <- view tsGalley @@ -569,13 +593,17 @@ postTeamConv tid u us name a r mtimer = do post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv postConvWithRole :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> TestM ResponseLBS -postConvWithRole = postConvWithRoleQualified [] - -postConvWithRoleQualified :: (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => [Qualified UserId] -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> m ResponseLBS -postConvWithRoleQualified qualifiedUsers u unqualifiedUsers name a r mtimer role = do - g <- viewGalley - let conv = NewConvUnmanaged $ NewConv unqualifiedUsers qualifiedUsers name (Set.fromList a) r Nothing mtimer Nothing role - post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv +postConvWithRole u members name access arole timer role = + postConvQualified + u + defNewConv + { newConvUsers = members, + newConvName = name, + newConvAccess = Set.fromList access, + newConvAccessRole = arole, + newConvMessageTimer = timer, + newConvUsersRole = role + } postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS postConvWithReceipt u us name a r mtimer rcpt = do @@ -826,13 +854,14 @@ listRemoteConvs remoteDomain uid = do allConvs <- fmap mtpResults . responseJsonError @_ @ConvIdsPage =<< listConvIds uid paginationOpts qDomain qcnv == remoteDomain) allConvs -postQualifiedMembers :: UserId -> NonEmpty (Qualified UserId) -> ConvId -> TestM ResponseLBS +postQualifiedMembers :: + (HasGalley m, MonadIO m, MonadHttp m) => + UserId -> + NonEmpty (Qualified UserId) -> + ConvId -> + m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- view tsGalley - postQualifiedMembers' g zusr invitees conv - -postQualifiedMembers' :: (MonadIO m, MonadHttp m) => (Request -> Request) -> UserId -> NonEmpty (Qualified UserId) -> ConvId -> m ResponseLBS -postQualifiedMembers' g zusr invitees conv = do + g <- viewGalley let invite = Public.InviteQualified invitees roleNameWireAdmin post $ g @@ -1423,7 +1452,7 @@ assertRemoveUpdate req qconvId remover alreadyPresentUsers victim = liftIO $ do FederatedGalley.cuOrigUserId cu @?= remover FederatedGalley.cuConvId cu @?= qUnqualified qconvId sort (FederatedGalley.cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers - FederatedGalley.cuAction cu @?= ConversationActionRemoveMember victim + FederatedGalley.cuAction cu @?= ConversationActionRemoveMembers (pure victim) ------------------------------------------------------------------------------- -- Helpers From b0e329aec483ce863524f94884b56208f10343e9 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 14 Oct 2021 17:54:44 +0200 Subject: [PATCH 28/88] Change tag (#1859) --- changelog.d/0-release-notes/team-settings-upgrade | 2 +- charts/team-settings/values.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade index f03f4845b0b..147a2a0bd08 100644 --- a/changelog.d/0-release-notes/team-settings-upgrade +++ b/changelog.d/0-release-notes/team-settings-upgrade @@ -1 +1 @@ -Upgrade team settings to Release: [v4.2.0](https://github.com/wireapp/wire-team-settings/releases/tag/v4.2.0) and image tag: 4.2.0-v0.28.29-0-1e2ef75 +Upgrade team settings to Release: [v4.2.0](https://github.com/wireapp/wire-team-settings/releases/tag/v4.2.0) and image tag: 4.2.0-v0.28.28-1e2ef7 diff --git a/charts/team-settings/values.yaml b/charts/team-settings/values.yaml index a1f9621f581..9e702663516 100644 --- a/charts/team-settings/values.yaml +++ b/charts/team-settings/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/team-settings - tag: "4.2.0-v0.28.29-0-1e2ef75" + tag: "4.2.0-v0.28.28-1e2ef7" service: https: externalPort: 443 From a64968ba81898cce5c2867a1d385fd55f29992b2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Fri, 15 Oct 2021 13:40:38 +0530 Subject: [PATCH 29/88] Check connections when adding remote users to a conv (#1842) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Delete stale FUTUREWORK * Brig: delete deprecated 'GET /i/users/connections-status` endpoint * brig: Servantify POST /i/users/connection-status * brig: Add internal endpoint to get qualified connection statuses * Brig: Support creating accepted connections for tests The endpoint just creates DB entries without actually contacting the remote backend. This is very useful when galley tests need a remote connection to exist * wire-api: roundtrip test for To/FromByteString @Relation The instances were deleted couple of commits ago. * Check conn between adder and remotes when adding remotes to conv * Check connection between conversation creator and remote members * Do connection checking in onConversationCreated in the federation API * Make existing federation tests succeed again by sprinkling some connections * Add a (still failing) test for on-conversation-crated * Add more connections to pass federation API tests * onConvCreated: Ensure creator of conv is included as other member * More coverage for onConvCreated * onConvUpdated: Only allow connected users to add local users * Add test case: Only unconnected users to add * Fix integration tests Co-authored-by: Marko Dimjašević Co-authored-by: jschaul Co-authored-by: Stefan Matting Co-authored-by: Paolo Capriotti --- .../delete-internal-get-conn-status | 1 + changelog.d/6-federation/check-connections | 1 + changelog.d/6-federation/fix-remote-conv | 1 + libs/brig-types/src/Brig/Types/Connection.hs | 24 +-- libs/brig-types/src/Brig/Types/Intra.hs | 26 --- libs/types-common/src/Data/Qualified.hs | 6 + .../src/Wire/API/Federation/API/Galley.hs | 6 +- libs/wire-api/src/Wire/API/Connection.hs | 37 ++-- .../src/Wire/API/Routes/Internal/Brig.hs | 26 +++ .../API/Routes/Internal/Brig/Connection.hs | 73 ++++++++ .../Test/Wire/API/Roundtrip/ByteString.hs | 2 - libs/wire-api/wire-api.cabal | 3 +- services/brig/src/Brig/API/Connection.hs | 20 +++ services/brig/src/Brig/API/Internal.hs | 48 +++--- services/brig/src/Brig/API/User.hs | 3 +- services/brig/src/Brig/Data/Connection.hs | 62 ++++++- .../test/integration/API/User/Connection.hs | 57 ++++++- .../brig/test/integration/API/User/Util.hs | 2 +- .../test/integration/Federation/End2end.hs | 72 +++++--- .../brig/test/integration/Federation/Util.hs | 7 + services/galley/src/Galley/API/Federation.hs | 95 +++++++---- services/galley/src/Galley/API/LegalHold.hs | 6 +- services/galley/src/Galley/API/Update.hs | 22 ++- services/galley/src/Galley/API/Util.hs | 20 ++- services/galley/src/Galley/Intra/User.hs | 29 +++- services/galley/test/integration/API.hs | 159 +++++++++--------- .../galley/test/integration/API/Federation.hs | 115 ++++++++++++- .../test/integration/API/MessageTimer.hs | 1 + services/galley/test/integration/API/Roles.hs | 3 + .../test/integration/API/Teams/LegalHold.hs | 3 +- services/galley/test/integration/API/Util.hs | 58 ++++++- tools/stern/src/Stern/Intra.hs | 8 +- 32 files changed, 731 insertions(+), 265 deletions(-) create mode 100644 changelog.d/5-internal/delete-internal-get-conn-status create mode 100644 changelog.d/6-federation/check-connections create mode 100644 changelog.d/6-federation/fix-remote-conv create mode 100644 libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs diff --git a/changelog.d/5-internal/delete-internal-get-conn-status b/changelog.d/5-internal/delete-internal-get-conn-status new file mode 100644 index 00000000000..ce78ab05b0d --- /dev/null +++ b/changelog.d/5-internal/delete-internal-get-conn-status @@ -0,0 +1 @@ +Brig: Delete deprecated `GET /i/users/connections-status` endpoint. \ No newline at end of file diff --git a/changelog.d/6-federation/check-connections b/changelog.d/6-federation/check-connections new file mode 100644 index 00000000000..ee2c5674c77 --- /dev/null +++ b/changelog.d/6-federation/check-connections @@ -0,0 +1 @@ +Check connections when adding remote users to a local conversation and local users to remote conversations. diff --git a/changelog.d/6-federation/fix-remote-conv b/changelog.d/6-federation/fix-remote-conv new file mode 100644 index 00000000000..e3932e6d28b --- /dev/null +++ b/changelog.d/6-federation/fix-remote-conv @@ -0,0 +1 @@ +The creator of a conversation now appears as a member when the conversation is fetched from a remote backend diff --git a/libs/brig-types/src/Brig/Types/Connection.hs b/libs/brig-types/src/Brig/Types/Connection.hs index dc80c88c750..73bb4a802a9 100644 --- a/libs/brig-types/src/Brig/Types/Connection.hs +++ b/libs/brig-types/src/Brig/Types/Connection.hs @@ -25,7 +25,6 @@ module Brig.Types.Connection ( module C, UserIds (..), - ConnectionsStatusRequest (..), UpdateConnectionsInternal (..), -- * re-exports @@ -40,6 +39,7 @@ where import Brig.Types.Common as C import Data.Aeson import Data.Id (UserId) +import Data.Qualified import Imports import Wire.API.Arbitrary import Wire.API.Connection @@ -51,13 +51,6 @@ data UserIds = UserIds {cUsers :: [UserId]} deriving (Eq, Show, Generic) --- | Data that is passed to the @\/i\/users\/connections-status@ endpoint. -data ConnectionsStatusRequest = ConnectionsStatusRequest - { csrFrom :: ![UserId], - csrTo :: !(Maybe [UserId]) - } - deriving (Eq, Show, Generic) - -- FUTUREWORK: This needs to get Qualified IDs when implementing -- Legalhold + Federation, as it's used in the internal -- putConnectionInternal / galley->Brig "/i/users/connections-status" @@ -67,6 +60,8 @@ data ConnectionsStatusRequest = ConnectionsStatusRequest data UpdateConnectionsInternal = BlockForMissingLHConsent UserId [UserId] | RemoveLHBlocksInvolving UserId + | -- | This must only be used by tests + CreateConnectionForTest UserId (Qualified UserId) deriving (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UpdateConnectionsInternal) @@ -86,16 +81,3 @@ instance ToJSON UserIds where toJSON (UserIds us) = object ["ids" .= us] - -instance FromJSON ConnectionsStatusRequest where - parseJSON = withObject "ConnectionsStatusRequest" $ \o -> do - csrFrom <- o .: "from" - csrTo <- o .: "to" - pure ConnectionsStatusRequest {..} - -instance ToJSON ConnectionsStatusRequest where - toJSON ConnectionsStatusRequest {csrFrom, csrTo} = - object - [ "from" .= csrFrom, - "to" .= csrTo - ] diff --git a/libs/brig-types/src/Brig/Types/Intra.hs b/libs/brig-types/src/Brig/Types/Intra.hs index 7093688a1a9..1a29afb02f1 100644 --- a/libs/brig-types/src/Brig/Types/Intra.hs +++ b/libs/brig-types/src/Brig/Types/Intra.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -- This file is part of the Wire Server implementation. @@ -24,7 +23,6 @@ module Brig.Types.Intra ( AccountStatus (..), AccountStatusUpdate (..), AccountStatusResp (..), - ConnectionStatus (..), UserAccount (..), NewUserScimInvitation (..), UserSet (..), @@ -91,30 +89,6 @@ instance FromJSON AccountStatusUpdate where instance ToJSON AccountStatusUpdate where toJSON s = object ["status" .= suStatus s] -------------------------------------------------------------------------------- --- ConnectionStatus - -data ConnectionStatus = ConnectionStatus - { csFrom :: !UserId, - csTo :: !UserId, - csStatus :: !Relation - } - deriving (Eq, Show, Generic) - -instance FromJSON ConnectionStatus where - parseJSON = withObject "connection-status" $ \o -> - ConnectionStatus <$> o .: "from" - <*> o .: "to" - <*> o .: "status" - -instance ToJSON ConnectionStatus where - toJSON cs = - object - [ "from" .= csFrom cs, - "to" .= csTo cs, - "status" .= csStatus cs - ] - ------------------------------------------------------------------------------- -- UserAccount diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 84b6eb1572a..a1b9209d2bc 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -36,6 +36,7 @@ module Data.Qualified foldQualified, partitionQualified, indexQualified, + bucketQualified, indexRemote, deprecatedSchema, ) @@ -131,6 +132,11 @@ indexQualified = foldr add mempty add :: Qualified a -> Map Domain [a] -> Map Domain [a] add (Qualified x domain) = Map.insertWith (<>) domain [x] +-- | Bucket a list of qualified values by domain. +bucketQualified :: Foldable f => f (Qualified a) -> [Qualified [a]] +bucketQualified = map (\(d, a) -> Qualified a d) . Map.assocs . indexQualified + +-- FUTUREWORK: Rename this to 'bucketRemote' indexRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]] indexRemote = map (uncurry toRemoteUnsafe) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 7a8f3b5b4a8..bdb02efccb3 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -151,7 +151,11 @@ newtype GetConversationsResponse = GetConversationsResponse data NewRemoteConversation conv = NewRemoteConversation { -- | The time when the conversation was created rcTime :: UTCTime, - -- | The user that created the conversation + -- | The user that created the conversation. + -- + -- FUTUREWORK: Make this unqualified and assume that this user has the same domain + -- as the backend invoking this RPC. Otehrwise a third party can figure out + -- connections. rcOrigUserId :: Qualified UserId, -- | The conversation ID, local to the backend invoking the RPC rcCnvId :: conv, diff --git a/libs/wire-api/src/Wire/API/Connection.hs b/libs/wire-api/src/Wire/API/Connection.hs index 7a6e51d9067..612c867f265 100644 --- a/libs/wire-api/src/Wire/API/Connection.hs +++ b/libs/wire-api/src/Wire/API/Connection.hs @@ -48,17 +48,16 @@ where import Control.Applicative (optional) import Control.Lens ((?~)) import Data.Aeson as Aeson -import Data.Attoparsec.ByteString (takeByteString) -import Data.ByteString.Conversion import Data.Id import Data.Json.Util (UTCTimeMillis) import Data.Qualified (Qualified (qUnqualified), deprecatedSchema) import Data.Range import qualified Data.Schema as P +import Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc -import Data.Swagger.Schema as S import Data.Text as Text import Imports +import Servant.API import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..)) import Wire.API.Routes.MultiTablePaging @@ -173,6 +172,9 @@ data Relation deriving (Arbitrary) via (GenericUniform Relation) deriving (FromJSON, ToJSON, S.ToSchema) via (P.Schema Relation) +instance S.ToParamSchema Relation where + toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString + -- | 'updateConnectionInternal', requires knowledge of the previous state (before -- 'MissingLegalholdConsent'), but the clients don't need that information. To avoid having -- to change the API, we introduce an internal variant of 'Relation' with surjective mapping @@ -245,20 +247,19 @@ instance P.ToSchema Relation where P.element "missing-legalhold-consent" MissingLegalholdConsent ] -instance FromByteString Relation where - parser = - takeByteString >>= \case - "accepted" -> return Accepted - "blocked" -> return Blocked - "pending" -> return Pending - "ignored" -> return Ignored - "sent" -> return Sent - "cancelled" -> return Cancelled - "missing-legalhold-consent" -> return MissingLegalholdConsent - x -> fail $ "Invalid relation-type " <> show x - -instance ToByteString Relation where - builder = \case +instance FromHttpApiData Relation where + parseQueryParam = \case + "accepted" -> return Accepted + "blocked" -> return Blocked + "pending" -> return Pending + "ignored" -> return Ignored + "sent" -> return Sent + "cancelled" -> return Cancelled + "missing-legalhold-consent" -> return MissingLegalholdConsent + x -> Left $ "Invalid relation-type " <> x + +instance ToHttpApiData Relation where + toQueryParam = \case Accepted -> "accepted" Blocked -> "blocked" Pending -> "pending" @@ -267,7 +268,7 @@ instance ToByteString Relation where Cancelled -> "cancelled" MissingLegalholdConsent -> "missing-legalhold-consent" --------------------------------------------------------------------------------- +---------------- -- Requests -- | Payload type for a connection request from one user to another. diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index ed89cf2c5e8..51e34b18d40 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -36,6 +36,8 @@ import qualified Servant import Servant.Swagger (HasSwagger (toSwagger)) import Servant.Swagger.Internal.Orphans () import Servant.Swagger.UI +import Wire.API.Connection +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Brig.EJPD import qualified Wire.API.Team.Feature as ApiFt @@ -85,12 +87,36 @@ type DeleteAccountFeatureConfig = :> "conferenceCalling" :> Delete '[Servant.JSON] NoContent +type GetAllConnectionsUnqualified = + Summary "Get all connections of a given user" + :> "users" + :> "connections-status" + :> ReqBody '[Servant.JSON] ConnectionsStatusRequest + :> QueryParam' + [ Optional, + Strict, + Description "Only returns connections with the given relation, if omitted, returns all connections" + ] + "filter" + Relation + :> Post '[Servant.JSON] [ConnectionStatus] + +type GetAllConnections = + Summary "Get all connections of a given user" + :> "users" + :> "connections-status" + :> "v2" + :> ReqBody '[Servant.JSON] ConnectionsStatusRequestV2 + :> Post '[Servant.JSON] [ConnectionStatusV2] + type API = "i" :> ( EJPDRequest :<|> GetAccountFeatureConfig :<|> PutAccountFeatureConfig :<|> DeleteAccountFeatureConfig + :<|> GetAllConnectionsUnqualified + :<|> GetAllConnections ) type SwaggerDocsAPI = "api" :> "internal" :> SwaggerSchemaUI "swagger-ui" "swagger.json" diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs new file mode 100644 index 00000000000..1132c6f920f --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE RecordWildCards #-} + +module Wire.API.Routes.Internal.Brig.Connection where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Id +import Data.Qualified +import Data.Schema +import qualified Data.Swagger as S +import Imports +import Wire.API.Connection + +data ConnectionsStatusRequest = ConnectionsStatusRequest + { csrFrom :: ![UserId], + csrTo :: !(Maybe [UserId]) + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionsStatusRequest) + +instance ToSchema ConnectionsStatusRequest where + schema = + object "ConnectionsStatusRequest" $ + ConnectionsStatusRequest + <$> csrFrom .= field "from" (array schema) + <*> csrTo .= optField "to" Nothing (array schema) + +data ConnectionsStatusRequestV2 = ConnectionsStatusRequestV2 + { csrv2From :: ![UserId], + csrv2To :: !(Maybe [Qualified UserId]), + csrv2Relation :: !(Maybe Relation) + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionsStatusRequestV2) + +instance ToSchema ConnectionsStatusRequestV2 where + schema = + object "ConnectionsStatusRequestV2" $ + ConnectionsStatusRequestV2 + <$> csrv2From .= field "from" (array schema) + <*> csrv2To .= optField "to" Nothing (array schema) + <*> csrv2Relation .= optField "relation" Nothing schema + +data ConnectionStatus = ConnectionStatus + { csFrom :: !UserId, + csTo :: !UserId, + csStatus :: !Relation + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionStatus) + +instance ToSchema ConnectionStatus where + schema = + object "ConnectionStatus" $ + ConnectionStatus + <$> csFrom .= field "from" schema + <*> csTo .= field "to" schema + <*> csStatus .= field "status" schema + +data ConnectionStatusV2 = ConnectionStatusV2 + { csv2From :: !UserId, + csv2To :: !(Qualified UserId), + csv2Status :: !Relation + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionStatusV2) + +instance ToSchema ConnectionStatusV2 where + schema = + object "ConnectionStatusV2" $ + ConnectionStatusV2 + <$> csv2From .= field "from" schema + <*> csv2To .= field "qualified_to" schema + <*> csv2Status .= field "status" schema diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs index d79ed2a6708..58a2e1c27b5 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs @@ -26,7 +26,6 @@ import qualified Wire.API.Arbitrary as Arbitrary () import qualified Wire.API.Asset.V3 as Asset.V3 import qualified Wire.API.Asset.V3.Resumable as Asset.V3.Resumable import qualified Wire.API.Call.Config as Call.Config -import qualified Wire.API.Connection as Connection import qualified Wire.API.Conversation.Code as Conversation.Code import qualified Wire.API.Conversation.Role as Conversation.Role import qualified Wire.API.Properties as Properties @@ -58,7 +57,6 @@ tests = testRoundTrip @Call.Config.Transport, testRoundTrip @Call.Config.TurnHost, testRoundTrip @Call.Config.TurnURI, - testRoundTrip @Connection.Relation, testRoundTrip @Conversation.Code.Key, testRoundTrip @Conversation.Code.Value, testRoundTrip @Conversation.Role.RoleName, diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index f4694d109cd..623fa0c173f 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: d2c9713a3cbd002394d82471bd12407b388620823e1087fb4dd300cbecde7c25 +-- hash: 2d17ec32d1990b4f59c918291cd7a1286d20e5c54ad921ecd5eb9d01b4b9f1c8 name: wire-api version: 0.1.0 @@ -50,6 +50,7 @@ library Wire.API.Push.Token Wire.API.Push.V2.Token Wire.API.Routes.Internal.Brig + Wire.API.Routes.Internal.Brig.Connection Wire.API.Routes.Internal.Brig.EJPD Wire.API.Routes.MultiTablePaging Wire.API.Routes.MultiTablePaging.State diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 6f4906622fc..d2e1a1d08f1 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -51,6 +51,7 @@ import qualified Data.LegalHold as LH import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range +import qualified Data.UUID.V4 as UUID import Galley.Types (ConvType (..), cnvType) import Imports import qualified System.Logger.Class as Log @@ -381,6 +382,14 @@ updateConnectionInternal = \case self <- qualifyLocal uid blockForMissingLegalholdConsent self others RemoveLHBlocksInvolving uid -> removeLHBlocksInvolving =<< qualifyLocal uid + CreateConnectionForTest usr other -> do + lusr <- qualifyLocal usr + lift $ + foldQualified + lusr + (createLocalConnectionUnchecked lusr) + (createRemoteConnectionUnchecked lusr) + other where -- inspired by @block@ in 'updateConnection'. blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError AppIO () @@ -465,6 +474,17 @@ updateConnectionInternal = \case SentWithHistory -> SentWithHistory CancelledWithHistory -> CancelledWithHistory +createLocalConnectionUnchecked :: Local UserId -> Local UserId -> AppIO () +createLocalConnectionUnchecked self other = do + qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) + void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv + void $ Data.insertConnection other (qUntagged self) AcceptedWithHistory qcnv + +createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> AppIO () +createRemoteConnectionUnchecked self other = do + qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) + void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv + lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO UserConnectionList lookupConnections from start size = do lusr <- qualifyLocal from diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 225c4784ee7..9ad43d1bdb1 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -33,6 +33,7 @@ import qualified Brig.API.User as API import Brig.API.Util (validateHandle) import Brig.App import qualified Brig.Data.Client as Data +import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) @@ -55,6 +56,7 @@ import Data.Handle (Handle) import Data.Id as Id import qualified Data.List1 as List1 import qualified Data.Map.Strict as Map +import Data.Qualified import qualified Data.Set as Set import Galley.Types (UserClients (..)) import Imports hiding (head) @@ -70,6 +72,7 @@ import Servant.Swagger.UI import qualified System.Logger.Class as Log import Wire.API.ErrorDescription import qualified Wire.API.Routes.Internal.Brig as BrigIRoutes +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as ApiFt import Wire.API.User import Wire.API.User.Client (UserClientsFull (..)) @@ -84,6 +87,8 @@ servantSitemap = :<|> getAccountFeatureConfig :<|> putAccountFeatureConfig :<|> deleteAccountFeatureConfig + :<|> getConnectionsStatusUnqualified + :<|> getConnectionsStatus -- | Responds with 'Nothing' if field is NULL in existing user or user does not exist. getAccountFeatureConfig :: UserId -> Handler ApiFt.TeamFeatureStatusNoConfig @@ -131,13 +136,6 @@ sitemap = do -- - MemberLeave event to members for all conversations the user was in (via galley) delete "/i/users/:uid" (continue deleteUserNoVerifyH) $ capture "uid" - get "/i/users/connections-status" (continue deprecatedGetConnectionsStatusH) $ - query "users" - .&. opt (query "filter") - post "/i/users/connections-status" (continue getConnectionsStatusH) $ - accept "application" "json" - .&. jsonRequest @ConnectionsStatusRequest - .&. opt (query "filter") put "/i/connections/connection-update" (continue updateConnectionInternalH) $ accept "application" "json" @@ -450,20 +448,25 @@ getAccountStatusH (_ ::: usr) = do Just s -> json $ AccountStatusResp s Nothing -> setStatus status404 empty -getConnectionsStatusH :: - JSON ::: JsonRequest ConnectionsStatusRequest ::: Maybe Relation -> - Handler Response -getConnectionsStatusH (_ ::: req ::: flt) = do - body <- parseJsonBody req - json <$> lift (getConnectionsStatus body flt) - -getConnectionsStatus :: ConnectionsStatusRequest -> Maybe Relation -> AppIO [ConnectionStatus] -getConnectionsStatus ConnectionsStatusRequest {csrFrom, csrTo} flt = do +getConnectionsStatusUnqualified :: ConnectionsStatusRequest -> Maybe Relation -> Handler [ConnectionStatus] +getConnectionsStatusUnqualified ConnectionsStatusRequest {csrFrom, csrTo} flt = lift $ do r <- maybe (API.lookupConnectionStatus' csrFrom) (API.lookupConnectionStatus csrFrom) csrTo return $ maybe r (filterByRelation r) flt where filterByRelation l rel = filter ((== rel) . csStatus) l +getConnectionsStatus :: ConnectionsStatusRequestV2 -> Handler [ConnectionStatusV2] +getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do + loc <- qualifyLocal () + conns <- lift $ case mtos of + Nothing -> Data.lookupAllStatuses =<< qualifyLocal froms + Just tos -> do + let getStatusesForOneDomain = foldQualified loc (Data.lookupLocalConnectionStatuses froms) (Data.lookupRemoteConnectionStatuses froms) + concat <$> mapM getStatusesForOneDomain (bucketQualified tos) + pure $ maybe conns (filterByRelation conns) mrel + where + filterByRelation l rel = filter ((== rel) . csv2Status) l + revokeIdentityH :: Either Email Phone -> Handler Response revokeIdentityH emailOrPhone = do lift $ API.revokeIdentity emailOrPhone @@ -599,19 +602,6 @@ getContactListH (_ ::: uid) = do contacts <- lift $ API.lookupContactList uid return $ json $ UserIds contacts --- Deprecated - --- Deprecated and to be removed after new versions of brig and galley are --- deployed. Reason for deprecation: it returns N^2 things (which is not --- needed), it doesn't scale, and it accepts everything in URL parameters, --- which doesn't work when the list of users is long. -deprecatedGetConnectionsStatusH :: List UserId ::: Maybe Relation -> Handler Response -deprecatedGetConnectionsStatusH (users ::: flt) = do - r <- lift $ API.lookupConnectionStatus (fromList users) (fromList users) - return . json $ maybe r (filterByRelation r) flt - where - filterByRelation l rel = filter ((== rel) . csStatus) l - -- Utilities ifNothing :: Utilities.Error -> Maybe a -> Handler a diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index f2021ee936c..79f827f616d 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -154,6 +152,7 @@ import Network.Wai.Utilities import qualified System.Logger.Class as Log import System.Logger.Message import Wire.API.Federation.Client (FederationError (..)) +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Member (legalHoldStatus) data AllowSCIMUpdates diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 342704fc711..cc1d9f0543d 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -32,6 +32,9 @@ module Brig.Data.Connection lookupConnectionStatus', lookupContactList, lookupContactListWithRelation, + lookupLocalConnectionStatuses, + lookupRemoteConnectionStatuses, + lookupAllStatuses, countConnections, deleteConnections, remoteConnectionInsert, @@ -49,7 +52,6 @@ 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 @@ -62,8 +64,9 @@ import Data.Qualified import Data.Range import Data.Time (getCurrentTime) import Imports hiding (local) -import UnliftIO.Async (pooledMapConcurrentlyN_) +import UnliftIO.Async (pooledMapConcurrentlyN, pooledMapConcurrentlyN_) import Wire.API.Connection +import Wire.API.Routes.Internal.Brig.Connection insertConnection :: Local UserId -> @@ -204,6 +207,41 @@ lookupConnectionStatus' from = map toConnectionStatus <$> retry x1 (query connectionStatusSelect' (params Quorum (Identity from))) +lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> AppIO [ConnectionStatusV2] +lookupLocalConnectionStatuses froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query relationsSelect (params Quorum (from, tUnqualified tos))) + +lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> AppIO [ConnectionStatusV2] +lookupRemoteConnectionStatuses froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query remoteRelationsSelect (params Quorum (from, tDomain tos, tUnqualified tos))) + +lookupAllStatuses :: Local [UserId] -> AppIO [ConnectionStatusV2] +lookupAllStatuses lfroms = do + let froms = tUnqualified lfroms + concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms + where + lookupAndCombine :: UserId -> AppIO [ConnectionStatusV2] + lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u + + lookupLocalStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupLocalStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) + <$> retry x1 (query relationsSelectAll (params Quorum (Identity from))) + lookupRemoteStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupRemoteStatuses from = + map (\(d, u, r) -> toConnectionStatusV2 from d u r) + <$> retry x1 (query remoteRelationsSelectAll (params Quorum (Identity from))) + -- | See 'lookupContactListWithRelation'. lookupContactList :: UserId -> AppIO [UserId] lookupContactList u = @@ -257,9 +295,19 @@ connectionSelect = "SELECT left, right, status, last_update, conv FROM connectio relationSelect :: PrepQuery R (UserId, UserId) (Identity RelationWithHistory) relationSelect = "SELECT status FROM connection WHERE left = ? AND right = ?" +relationsSelect :: PrepQuery R (UserId, [UserId]) (UserId, RelationWithHistory) +relationsSelect = "SELECT right, status FROM connection where left = ? AND right IN ?" + +relationsSelectAll :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +relationsSelectAll = "SELECT right, status FROM connection where left = ?" + +-- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of +-- the table. connectionStatusSelect :: PrepQuery R ([UserId], [UserId]) (UserId, UserId, RelationWithHistory) connectionStatusSelect = "SELECT left, right, status FROM connection WHERE left IN ? AND right IN ?" +-- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of +-- the table. connectionStatusSelect' :: PrepQuery R (Identity [UserId]) (UserId, UserId, RelationWithHistory) connectionStatusSelect' = "SELECT left, right, status FROM connection WHERE left IN ?" @@ -301,6 +349,12 @@ 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 = ?" +remoteRelationsSelect :: PrepQuery R (UserId, Domain, [UserId]) (UserId, RelationWithHistory) +remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user IN ?" + +remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) +remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?" + -- Conversions toLocalUserConnection :: @@ -319,3 +373,7 @@ toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel + +toConnectionStatusV2 :: UserId -> Domain -> UserId -> RelationWithHistory -> ConnectionStatusV2 +toConnectionStatusV2 from toDomain toUser relWithHistory = + ConnectionStatusV2 from (Qualified toUser toDomain) (relationDropHistory relWithHistory) diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index b5b63461110..e2678598c97 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -28,7 +28,6 @@ import Bilge.Assert import Brig.Data.Connection (remoteConnectionInsert) import qualified Brig.Options as Opt import Brig.Types -import Brig.Types.Intra import qualified Cassandra as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion @@ -48,6 +47,7 @@ import Wire.API.Connection import qualified Wire.API.Federation.API.Brig as F import Wire.API.Federation.API.Galley (GetConversationsRequest (..), GetConversationsResponse (gcresConvs), RemoteConvMembers (rcmOthers), RemoteConversation (rcnvMembers)) import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> FedBrigClient -> FedGalleyClient -> DB.ClientState -> TestTree @@ -96,7 +96,8 @@ tests cl _at opts p b _c g fedBrigClient fedGalleyClient db = test p "Remote connections: block then accept" (testConnectFromBlocked opts b g fedBrigClient), test p "Remote connections: block, remote cancels, then accept" (testSentFromBlocked opts b fedBrigClient), test p "Remote connections: send then cancel" (testCancel opts b), - test p "Remote connections: limits" (testConnectionLimits opts b fedBrigClient) + test p "Remote connections: limits" (testConnectionLimits opts b fedBrigClient), + test p "post /users/connections-status/v2 : All connections" (testInternalGetConnStatusesAll b opts fedBrigClient) ] testCreateConnectionInvalidUser :: Brig -> Http () @@ -929,3 +930,55 @@ testConnectionLimits opts brig fedBrigClient = do postConnectionQualified brig uid1 quid2 !!! do const 403 === statusCode const (Just "connection-limit") === fmap Error.label . responseJsonMaybe + +testInternalGetConnStatusesAll :: Brig -> Opt.Opts -> FedBrigClient -> Http () +testInternalGetConnStatusesAll brig opts fedBrigClient = do + quids <- replicateM 2 $ userQualifiedId <$> randomUser brig + let uids = qUnqualified <$> quids + + localUsers@(localUser1 : _) <- replicateM 5 $ userQualifiedId <$> randomUser brig + let remoteDomain1 = Domain "remote1.example.com" + remoteDomain1Users@(remoteDomain1User1 : _) <- replicateM 5 $ (`Qualified` remoteDomain1) <$> randomId + let remoteDomain2 = Domain "remote2.example.com" + remoteDomain2Users@(remoteDomain2User1 : _) <- replicateM 5 $ (`Qualified` remoteDomain2) <$> randomId + + for_ uids $ \uid -> do + -- Create 5 local connections, accept 1 + for_ localUsers $ \qOther -> do + postConnectionQualified brig uid qOther sendConnectionAction brig opts uid qOther Nothing Sent + receiveConnectionAction brig fedBrigClient uid remoteDomain1User1 F.RemoteConnect (Just F.RemoteConnect) Accepted + + -- Create 5 remote connections with remote2, accept 1 + for_ remoteDomain2Users $ \qOther -> sendConnectionAction brig opts uid qOther Nothing Sent + receiveConnectionAction brig fedBrigClient uid remoteDomain2User1 F.RemoteConnect (Just F.RemoteConnect) Accepted + + allStatuses :: [ConnectionStatusV2] <- + responseJsonError =<< getConnStatusInternal brig (ConnectionsStatusRequestV2 uids Nothing Nothing) + remoteDomain1Users <> remoteDomain2Users + sort (map csv2To allStatuses) @?= sort (allUsers <> allUsers) + length (filter ((== Sent) . csv2Status) allStatuses) @?= 24 + length (filter ((== Accepted) . csv2Status) allStatuses) @?= 6 + + acceptedRemoteDomain1Only :: [ConnectionStatusV2] <- + responseJsonError =<< getConnStatusInternal brig (ConnectionsStatusRequestV2 uids (Just remoteDomain1Users) (Just Accepted)) + (csv2From x, csv2To x)) + sortOn ordFn acceptedRemoteDomain1Only @?= sortOn ordFn (map (\u -> ConnectionStatusV2 u remoteDomain1User1 Accepted) uids) + +getConnStatusInternal :: (MonadIO m, MonadHttp m) => (Request -> Request) -> ConnectionsStatusRequestV2 -> m (Response (Maybe LByteString)) +getConnStatusInternal brig req = + post $ + brig + . path "/i/users/connections-status/v2" + . json req diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 88febee65a3..77cfd2e45a4 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -24,7 +24,6 @@ import Bilge.Assert import Brig.Data.PasswordReset import Brig.Options (Opts) import Brig.Types -import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Auth hiding (user) import qualified Brig.ZAuth @@ -54,6 +53,7 @@ import Util import qualified Wire.API.Federation.API.Brig as F import Wire.API.Federation.GRPC.Types hiding (body, path) import qualified Wire.API.Federation.GRPC.Types as F +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging (LocalOrRemoteTable, MultiTablePagingState) newtype ConnectionLimit = ConnectionLimit Int64 diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 867bc7c6905..d197a6b3c8f 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -39,7 +39,7 @@ import qualified Data.ProtoLens as Protolens import Data.Qualified import Data.Range (checked) import qualified Data.Set as Set -import Federation.Util (generateClientPrekeys, getConvQualified) +import Federation.Util (connectUsersEnd2End, generateClientPrekeys, getConvQualified) import Gundeck.Types.Notification (ntfTransient) import Imports import qualified System.Logger as Log @@ -244,8 +244,8 @@ testAddRemoteUsersToLocalConv brig1 galley1 brig2 galley2 = do let newConv = NewConvUnmanaged $ NewConv [] [] (Just "gossip") mempty Nothing Nothing Nothing Nothing roleNameWireAdmin convId <- - cnvQualifiedId . responseJsonUnsafe - <$> post + fmap cnvQualifiedId . responseJsonError + =<< post ( galley1 . path "/conversations" . zUser (userId alice) @@ -254,6 +254,8 @@ testAddRemoteUsersToLocalConv brig1 galley1 brig2 galley2 = do . json newConv ) + connectUsersEnd2End brig1 brig2 (userQualifiedId alice) (userQualifiedId bob) + let invite = InviteQualified (userQualifiedId bob :| []) roleNameWireAdmin post ( galley1 @@ -287,7 +289,12 @@ testRemoveRemoteUserFromLocalConv brig1 galley1 brig2 galley2 = do let aliceId = userQualifiedId alice let bobId = userQualifiedId bob - convId <- cnvQualifiedId . responseJsonUnsafe <$> createConversation galley1 (userId alice) [bobId] + connectUsersEnd2End brig1 brig2 aliceId bobId + + convId <- + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (userId alice) [bobId] + getConversationQualified galley1 (userId alice) convId liftIO $ map omQualifiedId (cmOthers (cnvMembers aliceConvBeforeDelete)) @?= [bobId] @@ -324,7 +331,12 @@ leaveRemoteConversation brig1 galley1 brig2 galley2 = do let aliceId = userQualifiedId alice let bobId = userQualifiedId bob - convId <- cnvQualifiedId . responseJsonUnsafe <$> createConversation galley1 (userId alice) [bobId] + connectUsersEnd2End brig1 brig2 aliceId bobId + + convId <- + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (userId alice) [bobId] + getConversationQualified galley1 (userId alice) convId liftIO $ map omQualifiedId (cmOthers (cnvMembers aliceConvBeforeDelete)) @?= [bobId] @@ -360,9 +372,13 @@ testRemoteUsersInNewConv :: Brig -> Galley -> Brig -> Galley -> Http () testRemoteUsersInNewConv brig1 galley1 brig2 galley2 = do alice <- randomUser brig1 bob <- randomUser brig2 + + connectUsersEnd2End brig1 brig2 (userQualifiedId alice) (userQualifiedId bob) convId <- - cnvQualifiedId . responseJsonUnsafe - <$> createConversation galley1 (userId alice) [userQualifiedId bob] + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (userId alice) [userQualifiedId bob] + createConversation galley1 (userId alice) [userQualifiedId bob] - cnv2 <- responseJsonUnsafe <$> createConversation galley2 (userId bob) [userQualifiedId alice] + cnv1 <- + responseJsonError + =<< createConversation galley1 (userId alice) [userQualifiedId bob] + createConversation galley2 (userId bob) [userQualifiedId alice] + fmap (qUnqualified . cnvQualifiedId) . responseJsonError + =<< createConversation galley2 (userId bob) [userQualifiedId alice] + addClient - brig1 - (userId alice) - (defNewClient PermanentClientType [] (someLastPrekeys !! 0)) + fmap clientId . responseJsonError + =<< addClient brig1 (userId alice) (defNewClient PermanentClientType [] (someLastPrekeys !! 0)) + addClient - brig2 - (userId bob) - (defNewClient PermanentClientType [] (someLastPrekeys !! 1)) + fmap clientId . responseJsonError + =<< addClient brig2 (userId bob) (defNewClient PermanentClientType [] (someLastPrekeys !! 1)) + createConversation galley1 (userId alice) [userQualifiedId bob] + fmap (qUnqualified . cnvQualifiedId) . responseJsonError + =<< createConversation galley1 (userId alice) [userQualifiedId bob] + Brig -> Qualified UserId -> Qualified UserId -> Http () +connectUsersEnd2End brig1 brig2 quid1 quid2 = do + postConnectionQualified brig1 (qUnqualified quid1) quid2 + !!! const 201 === statusCode + putConnectionQualified brig2 (qUnqualified quid2) quid1 Accepted + !!! const 200 === statusCode diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 8e63653b402..359f301ba11 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -16,6 +16,7 @@ -- with this program. If not, see . module Galley.API.Federation where +import Brig.Types.Connection (Relation (Accepted)) import Control.Lens (itraversed, (<.>)) import Control.Monad.Catch (throwM) import Control.Monad.Trans.Maybe (runMaybeT) @@ -24,10 +25,10 @@ import Data.Containers.ListUtils (nubOrd) import Data.Domain import Data.Id (ConvId, UserId) import Data.Json.Util (Base64ByteString (..)) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), qUntagged, toRemoteUnsafe) +import Data.Qualified (Qualified (..), Remote, partitionQualified, qUntagged, qualifyAs, toRemoteUnsafe) import qualified Data.Set as Set import qualified Data.Text.Lazy as LT import Galley.API.Error (invalidPayload) @@ -37,6 +38,7 @@ import qualified Galley.API.Update as API import Galley.API.Util import Galley.App (Galley) import qualified Galley.Data as Data +import Galley.Intra.User (getConnections) import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) import Imports import Servant (ServerT) @@ -60,6 +62,7 @@ import Wire.API.Federation.API.Galley RemoteMessage (..), ) import qualified Wire.API.Federation.API.Galley as FederationAPIGalley +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..)) import Wire.API.ServantProto (FromProto (..)) import Wire.API.User.Client (userClientMap) @@ -78,20 +81,25 @@ federationSitemap = onConversationCreated :: Domain -> NewRemoteConversation ConvId -> Galley () onConversationCreated domain rc = do - let qrc = fmap (`Qualified` domain) rc + let qrc = fmap (toRemoteUnsafe domain) rc localDomain <- viewFederationDomain - let localUsers = - foldMap (\om -> guard (qDomain (omQualifiedId om) == localDomain) $> omQualifiedId om) + let (localMembers, remoteMembers) = + Set.partition (\om -> qDomain (omQualifiedId om) == localDomain) . rcMembers $ rc - localUserIds = fmap qUnqualified localUsers - unless (null localUsers) $ do - Data.addLocalMembersToRemoteConv (rcCnvId qrc) localUserIds - forM_ (fromNewRemoteConversation localDomain qrc) $ \(mem, c) -> do + localUserIds = qUnqualified . omQualifiedId <$> Set.toList localMembers + + addedUserIds <- addLocalUsersToRemoteConv (rcCnvId qrc) (rcOrigUserId rc) localUserIds + + let connectedLocalMembers = Set.filter (\m -> (qUnqualified . omQualifiedId) m `Set.member` addedUserIds) localMembers + -- Make sure to notify only about local users connected to the adder + let qrcConnected = qrc {rcMembers = Set.union remoteMembers connectedLocalMembers} + + forM_ (fromNewRemoteConversation localDomain qrcConnected) $ \(mem, c) -> do let event = Event ConvCreate - (rcCnvId qrc) + (qUntagged (rcCnvId qrc)) (rcOrigUserId rc) (rcTime rc) (EdConversation c) @@ -113,7 +121,9 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai onConversationUpdated :: Domain -> ConversationUpdate -> Galley () onConversationUpdated requestingDomain cu = do localDomain <- viewFederationDomain - let qconvId = Qualified (cuConvId cu) requestingDomain + loc <- qualifyLocal () + let rconvId = toRemoteUnsafe requestingDomain (cuConvId cu) + qconvId = qUntagged rconvId -- Note: we generally do not send notifications to users that are not part of -- the conversation (from our point of view), to prevent spam from the remote @@ -128,37 +138,62 @@ onConversationUpdated requestingDomain cu = do -- are not in the conversations are being removed or have their membership state -- updated, we do **not** add them to the list of targets, because we have no -- way to make sure that they are actually supposed to receive that notification. - extraTargets <- case cuAction cu of - ConversationActionAddMembers toAdd _ -> do - let localUsers = getLocalUsers localDomain toAdd - Data.addLocalMembersToRemoteConv qconvId localUsers - pure localUsers + (mActualAction, extraTargets) <- case cuAction cu of + ConversationActionAddMembers toAdd role -> do + let (localUsers, remoteUsers) = partitionQualified loc toAdd + addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (cuOrigUserId cu) localUsers + let allAddedUsers = map (qUntagged . qualifyAs loc) addedLocalUsers <> map qUntagged remoteUsers + case allAddedUsers of + [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. + (u : us) -> pure (Just $ ConversationActionAddMembers (u :| us) role, addedLocalUsers) ConversationActionRemoveMembers toRemove -> do let localUsers = getLocalUsers localDomain toRemove Data.removeLocalMembersFromRemoteConv qconvId localUsers - pure [] - ConversationActionRename _ -> pure [] - ConversationActionMessageTimerUpdate _ -> pure [] - ConversationActionMemberUpdate _ _ -> pure [] - ConversationActionReceiptModeUpdate _ -> pure [] - ConversationActionAccessUpdate _ -> pure [] - - -- Send notifications - let event = conversationActionToEvent (cuTime cu) (cuOrigUserId cu) qconvId (cuAction cu) - targets = nubOrd $ presentUsers <> extraTargets + pure (Just $ cuAction cu, []) + ConversationActionRename _ -> pure (Just $ cuAction cu, []) + ConversationActionMessageTimerUpdate _ -> pure (Just $ cuAction cu, []) + ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, []) + ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, []) + ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, []) unless allUsersArePresent $ Log.warn $ Log.field "conversation" (toByteString' (cuConvId cu)) - Log.~~ Log.field "domain" (toByteString' requestingDomain) - Log.~~ Log.msg + . Log.field "domain" (toByteString' requestingDomain) + . Log.msg ( "Attempt to send notification about conversation update \ \to users not in the conversation" :: ByteString ) - -- FUTUREWORK: support bots? - pushConversationEvent Nothing event targets [] + -- Send notifications + for_ mActualAction $ \action -> do + let event = conversationActionToEvent (cuTime cu) (cuOrigUserId cu) qconvId action + targets = nubOrd $ presentUsers <> extraTargets + + -- FUTUREWORK: support bots? + pushConversationEvent Nothing event targets [] + +addLocalUsersToRemoteConv :: Remote ConvId -> Qualified UserId -> [UserId] -> Galley (Set UserId) +addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do + connStatus <- getConnections localUsers (Just [qAdder]) (Just Accepted) + let localUserIdsSet = Set.fromList localUsers + connected = Set.fromList $ fmap csv2From connStatus + unconnected = Set.difference localUserIdsSet connected + connectedList = Set.toList connected + + -- FUTUREWORK: Consider handling the discrepancy between the views of the + -- conversation-owning backend and the local backend + unless (Set.null unconnected) $ + Log.warn $ + Log.msg ("A remote user is trying to add unconnected local users to a remote conversation" :: Text) + . Log.field "remote_user" (show qAdder) + . Log.field "local_unconnected_users" (show unconnected) + + -- Update the local view of the remote conversation by adding only those local + -- users that are connected to the adder + Data.addLocalMembersToRemoteConv (qUntagged remoteConvId) connectedList + pure connected -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 1755eec74cc..bd40fa575f6 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -34,7 +34,6 @@ where import Brig.Types.Client.Prekey import Brig.Types.Connection (UpdateConnectionsInternal (..)) -import Brig.Types.Intra (ConnectionStatus (..)) import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) import Control.Exception (assert) @@ -59,7 +58,7 @@ import qualified Galley.Data.LegalHold as LegalHoldData import qualified Galley.Data.TeamFeatures as TeamFeatures import qualified Galley.External.LegalHoldService as LHService import qualified Galley.Intra.Client as Client -import Galley.Intra.User (getConnections, putConnectionInternal) +import Galley.Intra.User (getConnectionsUnqualified, putConnectionInternal) import qualified Galley.Options as Opts import Galley.Types (LocalMember, lmConvRoleName, lmId) import Galley.Types.Teams as Team @@ -73,6 +72,7 @@ import qualified System.Logger.Class as Log import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public @@ -415,7 +415,7 @@ changeLegalholdStatus tid uid old new = do -- FUTUREWORK: make this async? blockNonConsentingConnections :: UserId -> Galley () blockNonConsentingConnections uid = do - conns <- getConnections [uid] Nothing Nothing + conns <- getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do conflicts <- mconcat <$> findConflicts conns blockConflicts uid conflicts diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index ad643767047..4a4dce798e7 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -125,7 +125,8 @@ import Wire.API.ErrorDescription import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Client (HasFederatorConfig (..)) +import Wire.API.Federation.Error (federationNotConfigured, federationNotImplemented) import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util (UpdateResult (..)) @@ -591,7 +592,7 @@ performAddMemberAction qusr conv invited role = do ensureMemberLimit (toList (Data.convLocalMembers conv)) newMembers ensureAccess conv InviteAccess checkLocals lcnv (Data.convTeam conv) (ulLocals newMembers) - checkRemoteUsersExist (ulRemotes newMembers) + checkRemotes (ulRemotes newMembers) checkLHPolicyConflictsLocal lcnv (ulLocals newMembers) checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) addMembersToLocalConversation lcnv newMembers role @@ -611,6 +612,23 @@ performAddMemberAction qusr conv invited role = do ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) ensureConnectedOrSameTeam qusr newUsers + checkRemotes :: [Remote UserId] -> Galley () + checkRemotes remotes = do + -- if federator is not configured, we fail early, so we avoid adding + -- remote members to the database + unless (null remotes) $ do + endpoint <- federatorEndpoint + when (isNothing endpoint) $ + throwM federationNotConfigured + + loc <- qualifyLocal () + foldQualified + loc + ensureConnectedToRemotes + (\_ _ -> throwM federationNotImplemented) + qusr + remotes + checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley () checkLHPolicyConflictsLocal lcnv newUsers = do let convUsers = Data.convLocalMembers conv diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index c6a940d3552..fae4c5a54c6 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -108,18 +108,25 @@ ensureConnectedOrSameTeam (Qualified u domain) uids = do -- that they are connected). ensureConnected :: Local UserId -> UserList UserId -> Galley () ensureConnected self others = do - -- FUTUREWORK(federation, #1262): check remote connections ensureConnectedToLocals (tUnqualified self) (ulLocals others) + ensureConnectedToRemotes self (ulRemotes others) ensureConnectedToLocals :: UserId -> [UserId] -> Galley () ensureConnectedToLocals _ [] = pure () ensureConnectedToLocals u uids = do (connsFrom, connsTo) <- - getConnections [u] (Just uids) (Just Accepted) - `concurrently` getConnections uids (Just [u]) (Just Accepted) + getConnectionsUnqualified [u] (Just uids) (Just Accepted) + `concurrently` getConnectionsUnqualified uids (Just [u]) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ throwErrorDescriptionType @NotConnected +ensureConnectedToRemotes :: Local UserId -> [Remote UserId] -> Galley () +ensureConnectedToRemotes _ [] = pure () +ensureConnectedToRemotes u remotes = do + acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) + when (length acceptedConns /= length remotes) $ + throwErrorDescriptionType @NotConnected + ensureReAuthorised :: UserId -> Maybe PlainTextPassword -> Galley () ensureReAuthorised u secret = do reAuthed <- reAuthUser u (ReAuthUser secret) @@ -675,13 +682,14 @@ toNewRemoteConversation now localDomain Data.Conversation {..} = -- conversation. fromNewRemoteConversation :: Domain -> - NewRemoteConversation (Qualified ConvId) -> + NewRemoteConversation (Remote ConvId) -> [(Public.Member, Public.Conversation)] fromNewRemoteConversation d NewRemoteConversation {..} = let membersView = fmap (second Set.toList) . setHoles $ rcMembers + creatorOther = OtherMember rcOrigUserId Nothing roleNameWireAdmin in foldMap ( \(me, others) -> - guard (inDomain me) $> let mem = toMember me in (mem, conv mem others) + guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) ) membersView where @@ -707,7 +715,7 @@ fromNewRemoteConversation d NewRemoteConversation {..} = conv :: Public.Member -> [OtherMember] -> Public.Conversation conv this others = Public.Conversation - rcCnvId + (qUntagged rcCnvId) ConversationMetadata { cnvmType = rcCnvType, -- FUTUREWORK: Document this is the same domain as the conversation diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 3a8b52c3cfc..29a077222a6 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -17,6 +17,7 @@ module Galley.Intra.User ( getConnections, + getConnectionsUnqualified, putConnectionInternal, deleteBot, reAuthUser, @@ -32,7 +33,7 @@ where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC -import Brig.Types.Connection (ConnectionsStatusRequest (..), Relation (..), UpdateConnectionsInternal (..), UserIds (..)) +import Brig.Types.Connection (Relation (..), UpdateConnectionsInternal (..), UserIds (..)) import Brig.Types.Intra import Brig.Types.User (User) import Control.Monad.Catch (throwM) @@ -40,6 +41,7 @@ import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Conversion import Data.Id +import Data.Qualified import Galley.App import Galley.Intra.Util import Imports @@ -48,6 +50,7 @@ import qualified Network.HTTP.Client.Internal as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.User.RichInfo (RichInfo) -- | Get statuses of all connections between two groups of users (the usual @@ -55,9 +58,9 @@ import Wire.API.User.RichInfo (RichInfo) -- several users to one). -- -- When a connection does not exist, it is skipped. --- Calls 'Brig.API.getConnectionsStatusH'. -getConnections :: [UserId] -> Maybe [UserId] -> Maybe Relation -> Galley [ConnectionStatus] -getConnections uFrom uTo rlt = do +-- Calls 'Brig.API.Internal.getConnectionsStatusUnqualified'. +getConnectionsUnqualified :: [UserId] -> Maybe [UserId] -> Maybe Relation -> Galley [ConnectionStatus] +getConnectionsUnqualified uFrom uTo rlt = do (h, p) <- brigReq r <- call "brig" $ @@ -70,6 +73,24 @@ getConnections uFrom uTo rlt = do where rfilter = queryItem "filter" . (pack . map toLower . show) +-- | Get statuses of all connections between two groups of users (the usual +-- pattern is to check all connections from one user to several, or from +-- several users to one). +-- +-- When a connection does not exist, it is skipped. +-- Calls 'Brig.API.Internal.getConnectionsStatus'. +getConnections :: [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley [ConnectionStatusV2] +getConnections [] _ _ = pure [] +getConnections uFrom uTo rlt = do + (h, p) <- brigReq + r <- + call "brig" $ + method POST . host h . port p + . path "/i/users/connections-status/v2" + . json (ConnectionsStatusRequestV2 uFrom uTo rlt) + . expect2xx + parseResponse (mkError status502 "server-error") r + putConnectionInternal :: UpdateConnectionsInternal -> Galley Status putConnectionInternal updateConn = do (h, p) <- brigReq diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index c0a63c5ebd9..4ea430c9b94 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -37,7 +37,7 @@ import Bilge hiding (timeout) import Bilge.Assert import Brig.Types import qualified Control.Concurrent.Async as Async -import Control.Lens (at, ix, preview, view, (.~), (?~), (^.)) +import Control.Lens (at, ix, preview, view, (.~), (?~)) import Control.Monad.Except (MonadError (throwError)) import Data.Aeson hiding (json) import qualified Data.ByteString as BS @@ -140,8 +140,9 @@ tests s = test s "M:N conversation creation must have randomId + postConvQualified alice defNewConv {newConvQualifiedUsers = [bob]} + !!! const 403 === statusCode + postConvQualifiedNonExistentDomain :: TestM () postConvQualifiedNonExistentDomain = do alice <- randomUser bob <- flip Qualified (Domain "non-existent.example.com") <$> randomId + connectWithRemoteUser alice bob postConvQualified alice defNewConv {newConvQualifiedUsers = [bob]} !!! do const 422 === statusCode -postConvQualifiedNonExistentUser :: TestM () -postConvQualifiedNonExistentUser = do - alice <- randomUser - bobId <- randomId - charlieId <- randomId - let remoteDomain = Domain "far-away.example.com" - bob = Qualified bobId remoteDomain - charlie = Qualified charlieId remoteDomain - opts <- view tsGConf - void . withTempMockFederator opts remoteDomain (const [mkProfile charlie (Name "charlie")]) $ - postConvQualified alice defNewConv {newConvQualifiedUsers = [bob, charlie]} - !!! do - const 400 === statusCode - const (Right "unknown-remote-user") === fmap label . responseJsonEither - postConvQualifiedFederationNotEnabled :: TestM () postConvQualifiedFederationNotEnabled = do g <- view tsGalley alice <- randomUser bob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId opts <- view tsGConf + connectWithRemoteUser alice bob let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ postConvHelper g alice [bob] !!! do @@ -1852,8 +1857,6 @@ leaveConnectConversation = do let c = maybe (error "invalid connect conversation") (qUnqualified . cnvQualifiedId) (responseJsonUnsafe bdy) deleteMemberUnqualified alice alice c !!! const 403 === statusCode --- FUTUREWORK: Add more tests for scenarios of federation. --- See also the comment in Galley.API.Update.addMembers for some other checks that are necessary. testAddRemoteMember :: TestM () testAddRemoteMember = do qalice <- randomQualifiedUser @@ -1864,21 +1867,24 @@ testAddRemoteMember = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain + + postQualifiedMembers alice (remoteBob :| []) convId !!! do + const 403 === statusCode + const (Right (Just "not-connected")) === fmap (view (at "label")) . responseJsonEither @Object + + connectWithRemoteUser alice remoteBob + opts <- view tsGConf (resp, reqs) <- - withTempMockFederator - opts - remoteDomain - (respond remoteBob) - (postQualifiedMembers alice (remoteBob :| []) convId) + withTempMockFederator opts remoteDomain (respond remoteBob) $ + postQualifiedMembers alice (remoteBob :| []) convId + (pure resp postConv alice [] (Just "gossip") [] Nothing Nothing let localConvId = cnvQualifiedId localConv @@ -2095,54 +2105,19 @@ testBulkGetQualifiedConvs = do assertEqual "not founds" expectedNotFound actualNotFound assertEqual "failures" [remoteConvIdCFailure] (crFailed convs) -testAddRemoteMemberFailure :: TestM () -testAddRemoteMemberFailure = do - alice <- randomUser - bobId <- randomId - charlieId <- randomId - let remoteDomain = Domain "far-away.example.com" - remoteBob = Qualified bobId remoteDomain - remoteCharlie = Qualified charlieId remoteDomain - convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - opts <- view tsGConf - (resp, _) <- - withTempMockFederator - opts - remoteDomain - (const [mkProfile remoteCharlie (Name "charlie")]) - (postQualifiedMembers alice (remoteBob :| [remoteCharlie]) convId) - liftIO $ statusCode resp @?= 400 - let err = responseJsonUnsafe resp :: Object - liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" - -testAddDeletedRemoteUser :: TestM () -testAddDeletedRemoteUser = do - alice <- randomUser - bobId <- randomId - let remoteDomain = Domain "far-away.example.com" - remoteBob = Qualified bobId remoteDomain - convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - opts <- view tsGConf - (resp, _) <- - withTempMockFederator - opts - remoteDomain - (const [(mkProfile remoteBob (Name "bob")) {profileDeleted = True}]) - (postQualifiedMembers alice (remoteBob :| []) convId) - liftIO $ statusCode resp @?= 400 - let err = responseJsonUnsafe resp :: Object - liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" - testAddRemoteMemberInvalidDomain :: TestM () testAddRemoteMemberInvalidDomain = do alice <- randomUser bobId <- randomId let remoteBob = Qualified bobId (Domain "invalid.example.com") convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + + connectWithRemoteUser alice remoteBob + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 422 === statusCode - const (Just "/federation/get-users-by-ids") + const (Just "/federation/on-conversation-updated") === preview (ix "data" . ix "path") . responseJsonUnsafe @Value const (Just "invalid.example.com") === preview (ix "data" . ix "domain") . responseJsonUnsafe @Value @@ -2154,6 +2129,8 @@ testAddRemoteMemberFederationDisabled = do alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + connectWithRemoteUser alice remoteBob + opts <- view tsGConf -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. @@ -2161,7 +2138,20 @@ testAddRemoteMemberFederationDisabled = do withSettingsOverrides federatorNotConfigured $ postQualifiedMembers alice (remoteBob :| []) convId !!! do const 400 === statusCode - const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe + const (Right "federation-not-enabled") === fmap label . responseJsonEither + + -- the member is not actually added to the conversation + conv <- responseJsonError =<< getConv alice convId randomId + convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + connectWithRemoteUser alice remoteBob + + opts <- view tsGConf -- federator endpoint being configured in brig and/or galley, but not being -- available (i.e. no service listing on that IP/port) can happen due to a -- misconfiguration of federator. That should give a 500. @@ -2170,7 +2160,12 @@ testAddRemoteMemberFederationDisabled = do withSettingsOverrides federatorUnavailable $ postQualifiedMembers alice (remoteBob :| []) convId !!! do const 500 === statusCode - const (Just "federation-not-available") === fmap label . responseJsonUnsafe + const (Right "federation-not-available") === fmap label . responseJsonEither + + -- in this case, we discover that federation is unavailable too late, and the + -- member has already been added to the conversation + conv <- responseJsonError =<< getConv alice convId postConv alice [bob, chuck] (Just "gossip") [] Nothing Nothing let qconv = Qualified conv (qDomain qalice) - e <- responseJsonUnsafe <$> (postMembers alice (singleton eve) conv postConvWithRemoteUsers @@ -2364,6 +2360,7 @@ deleteRemoteMemberConvLocalQualifiedOk = do qDee <- (`Qualified` remoteDomain1) <$> randomId qEve <- (`Qualified` remoteDomain2) <$> randomId connectUsers alice (singleton bob) + mapM_ (connectWithRemoteUser alice) [qChad, qDee, qEve] opts <- view tsGConf let mockedResponse fedReq = do @@ -2381,10 +2378,11 @@ deleteRemoteMemberConvLocalQualifiedOk = do (convId, _) <- withTempMockFederator' opts remoteDomain1 mockedResponse $ - decodeConvId - <$> postConvQualified + fmap decodeConvId $ + postConvQualified alice defNewConv {newConvQualifiedUsers = [qBob, qChad, qDee, qEve]} + randomId <*> pure remoteDomain qconv <- Qualified <$> randomId <*> pure remoteDomain + connectWithRemoteUser alice qbob + fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime let cu = @@ -2928,6 +2931,8 @@ putReceiptModeWithRemotesOk = do qbob <- randomQualifiedUser let bob = qUnqualified qbob + connectWithRemoteUser bob qalice + resp <- postConvWithRemoteUsers remoteDomain @@ -2996,7 +3001,11 @@ removeUser = do [alice, bob, carl] <- replicateM 3 randomQualifiedUser dee <- (`Qualified` remoteDomain) <$> randomId let [alice', bob', carl'] = qUnqualified <$> [alice, bob, carl] + connectUsers alice' (list1 bob' [carl']) + connectWithRemoteUser alice' dee + connectWithRemoteUser bob' dee + conv1 <- decodeConvId <$> postConv alice' [bob'] (Just "gossip") [] Nothing Nothing conv2 <- decodeConvId <$> postConv alice' [bob', carl'] (Just "gossip2") [] Nothing Nothing conv3 <- decodeConvId <$> postConv alice' [carl'] (Just "gossip3") [] Nothing Nothing diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 0a16eeb34c6..f114ee2ac83 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -64,7 +64,9 @@ tests s = "federation" [ test s "POST /federation/get-conversations : All Found" getConversationsAllFound, test s "POST /federation/get-conversations : Conversations user is not a part of are excluded from result" getConversationsNotPartOf, + test s "POST /federation/on-conversation-created : Add local user to remote conversation" onConvCreated, test s "POST /federation/on-conversation-updated : Add local user to remote conversation" addLocalUser, + test s "POST /federation/on-conversation-updated : Add only unconnected local users to remote conversation" addUnconnectedUsersOnly, test s "POST /federation/on-conversation-updated : Notify local user about other members joining" addRemoteUser, test s "POST /federation/on-conversation-updated : Remove a local user from a remote conversation" removeLocalUser, test s "POST /federation/on-conversation-updated : Remove a remote user from a remote conversation" removeRemoteUser, @@ -85,7 +87,9 @@ getConversationsAllFound = do -- create & get group conv aliceQ <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") carlQ <- randomQualifiedUser + connectUsers bob (singleton (qUnqualified carlQ)) + connectWithRemoteUser bob aliceQ cnv2 <- responseJsonError @@ -151,6 +155,36 @@ getConversationsNotPartOf = do (GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1]) liftIO $ assertEqual "conversation list not empty" [] cs +onConvCreated :: TestM () +onConvCreated = do + c <- view tsCannon + (alice, qAlice) <- randomUserTuple + let remoteDomain = Domain "bobland.example.com" + qBob <- Qualified <$> randomId <*> pure remoteDomain + qDee <- Qualified <$> randomId <*> pure remoteDomain + + (charlie, qCharlie) <- randomUserTuple + conv <- randomId + let qconv = Qualified conv remoteDomain + + connectWithRemoteUser alice qBob + -- Remote Bob creates a conversation with local Alice and Charlie; + -- however Bob is not connected to Charlie but only to Alice. + let requestMembers = Set.fromList (map asOtherMember [qAlice, qCharlie, qDee]) + + WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do + registerRemoteConv qconv qBob (Just "gossip") requestMembers + liftIO $ do + let expectedSelf = alice + expectedOthers = [(qBob, roleNameWireAdmin), (qDee, roleNameWireMember)] + expectedFrom = qBob + -- since Charlie is not connected to Bob; expect a conversation with Alice&Bob only + WS.assertMatch_ (5 # Second) wsA $ + wsAssertConvCreateWithRole qconv expectedFrom expectedSelf expectedOthers + WS.assertNoEvent (1 # Second) [wsC] + convs <- listRemoteConvs remoteDomain alice + liftIO $ convs @?= [Qualified conv remoteDomain] + addLocalUser :: TestM () addLocalUser = do localDomain <- viewFederationDomain @@ -161,8 +195,13 @@ addLocalUser = do bob <- randomId let qbob = Qualified bob remoteDomain charlie <- randomUser + dee <- randomUser + let qdee = Qualified dee localDomain conv <- randomId let qconv = Qualified conv remoteDomain + + connectWithRemoteUser alice qbob + fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime let cu = @@ -172,16 +211,65 @@ addLocalUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [charlie], FedGalley.cuAction = - ConversationActionAddMembers (pure qalice) roleNameWireMember + ConversationActionAddMembers (qalice :| [qdee]) roleNameWireMember } - WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do + WS.bracketRN c [alice, charlie, dee] $ \[wsA, wsC, wsD] -> do FedGalley.onConversationUpdated fedGalleyClient remoteDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ wsAssertMemberJoinWithRole qconv qbob [qalice] roleNameWireMember + -- Since charlie is not really present in the conv, they don't get any + -- notifications WS.assertNoEvent (1 # Second) [wsC] - convs <- listRemoteConvs remoteDomain alice - liftIO $ convs @?= [Qualified conv remoteDomain] + -- Since dee is not connected to bob, they don't get any notifications + WS.assertNoEvent (1 # Second) [wsD] + aliceConvs <- listRemoteConvs remoteDomain alice + liftIO $ aliceConvs @?= [Qualified conv remoteDomain] + deeConvs <- listRemoteConvs remoteDomain dee + liftIO $ deeConvs @?= [] + +addUnconnectedUsersOnly :: TestM () +addUnconnectedUsersOnly = do + c <- view tsCannon + (alice, qAlice) <- randomUserTuple + (_charlie, qCharlie) <- randomUserTuple + + let remoteDomain = Domain "bobland.example.com" + qBob <- Qualified <$> randomId <*> pure remoteDomain + conv <- randomId + let qconv = Qualified conv remoteDomain + + -- Bob is connected to Alice + -- Bob is not connected to Charlie + connectWithRemoteUser alice qBob + let requestMembers = Set.fromList (map asOtherMember [qAlice]) + + now <- liftIO getCurrentTime + fedGalleyClient <- view tsFedGalleyClient + + WS.bracketR c alice $ \wsA -> do + -- Remote Bob creates a conversation with local Alice + registerRemoteConv qconv qBob (Just "gossip") requestMembers + liftIO $ do + let expectedSelf = alice + expectedOthers = [(qBob, roleNameWireAdmin)] + expectedFrom = qBob + WS.assertMatch_ (5 # Second) wsA $ + wsAssertConvCreateWithRole qconv expectedFrom expectedSelf expectedOthers + + -- Bob attempts to add unconnected Charlie (possible abuse) + let cu = + FedGalley.ConversationUpdate + { FedGalley.cuTime = now, + FedGalley.cuOrigUserId = qBob, + FedGalley.cuConvId = conv, + FedGalley.cuAlreadyPresentUsers = [alice], + FedGalley.cuAction = + ConversationActionAddMembers (qCharlie :| []) roleNameWireMember + } + -- Alice receives no notifications from this + FedGalley.onConversationUpdated fedGalleyClient remoteDomain cu + WS.assertNoEvent (5 # Second) [wsA] -- | This test invokes the federation endpoint: -- @@ -223,6 +311,7 @@ removeLocalUser = do ConversationActionRemoveMembers (pure qAlice) } + connectWithRemoteUser alice qBob WS.bracketR c alice $ \ws -> do FedGalley.onConversationUpdated fedGalleyClient remoteDomain cuAdd afterAddition <- listRemoteConvs remoteDomain alice @@ -273,6 +362,7 @@ removeRemoteUser = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime + mapM_ (`connectWithRemoteUser` qBob) [alice, dee] registerRemoteConv qconv qBob (Just "gossip") (Set.fromList [aliceAsOtherMember, deeAsOtherMember, eveAsOtherMember]) let cuRemove user = @@ -320,6 +410,7 @@ notifyUpdate extras action etype edata = do mkMember quid = OtherMember quid Nothing roleNameWireMember fedGalleyClient <- view tsFedGalleyClient + mapM_ (`connectWithRemoteUser` qbob) [alice] registerRemoteConv qconv qbob @@ -431,7 +522,8 @@ addRemoteUser = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime - let asOtherMember quid = OtherMember quid Nothing roleNameWireMember + mapM_ (flip connectWithRemoteUser qbob . qUnqualified) [qalice, qdee] + registerRemoteConv qconv qbob (Just "gossip") (Set.fromList (map asOtherMember [qalice, qdee, qeve])) -- The conversation owning @@ -440,16 +532,17 @@ addRemoteUser = do { FedGalley.cuTime = now, FedGalley.cuOrigUserId = qbob, FedGalley.cuConvId = qUnqualified qconv, - FedGalley.cuAlreadyPresentUsers = (map qUnqualified [qalice, qcharlie]), + FedGalley.cuAlreadyPresentUsers = map qUnqualified [qalice, qcharlie], FedGalley.cuAction = ConversationActionAddMembers (qdee :| [qeve, qflo]) roleNameWireMember } WS.bracketRN c (map qUnqualified [qalice, qcharlie, qdee, qflo]) $ \[wsA, wsC, wsD, wsF] -> do FedGalley.onConversationUpdated fedGalleyClient bdom cu void . liftIO $ do - WS.assertMatchN_ (5 # Second) [wsA, wsD, wsF] $ - wsAssertMemberJoinWithRole qconv qbob [qeve, qdee, qflo] roleNameWireMember + WS.assertMatchN_ (5 # Second) [wsA, wsD] $ + wsAssertMemberJoinWithRole qconv qbob [qeve, qdee] roleNameWireMember WS.assertNoEvent (1 # Second) [wsC] + WS.assertNoEvent (1 # Second) [wsF] leaveConversationSuccess :: TestM () leaveConversationSuccess = do @@ -463,6 +556,9 @@ leaveConversationSuccess = do qDee <- (`Qualified` remoteDomain1) <$> randomId qEve <- (`Qualified` remoteDomain2) <$> randomId connectUsers alice (singleton bob) + connectWithRemoteUser alice qChad + connectWithRemoteUser alice qDee + connectWithRemoteUser alice qEve opts <- view tsGConf let mockedResponse fedReq = do @@ -535,6 +631,7 @@ onMessageSent = do fedGalleyClient <- view tsFedGalleyClient -- only add alice to the remote conversation + connectWithRemoteUser alice qbob let cu = FedGalley.ConversationUpdate { FedGalley.cuTime = now, @@ -616,6 +713,8 @@ sendMessage = do let chad = Qualified chadId remoteDomain chadProfile = mkProfile chad (Name "Chad") + connectWithRemoteUser aliceId bob + connectWithRemoteUser aliceId chad -- conversation opts <- view tsGConf let responses1 req diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index 87e48a2427c..d7b435cc24a 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -149,6 +149,7 @@ messageTimerChangeWithRemotes = do qalice <- Qualified <$> randomId <*> pure remoteDomain qbob <- randomQualifiedUser let bob = qUnqualified qbob + connectWithRemoteUser bob qalice resp <- postConvWithRemoteUsers diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index 3c9be9a35e7..a90682dd957 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -167,6 +167,7 @@ roleUpdateRemoteMember = do qcharlie <- Qualified <$> randomId <*> pure remoteDomain let bob = qUnqualified qbob + traverse_ (connectWithRemoteUser bob) [qalice, qcharlie] resp <- postConvWithRemoteUsers remoteDomain @@ -238,6 +239,7 @@ roleUpdateWithRemotes = do charlie = qUnqualified qcharlie connectUsers bob (singleton charlie) + connectWithRemoteUser bob qalice resp <- postConvWithRemoteUsers remoteDomain @@ -298,6 +300,7 @@ accessUpdateWithRemotes = do charlie = qUnqualified qcharlie connectUsers bob (singleton charlie) + connectWithRemoteUser bob qalice resp <- postConvWithRemoteUsers remoteDomain diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index d5b1b2cbb6f..4ba95817758 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -31,7 +31,7 @@ import Bilge hiding (accept, head, timeout, trace) import Bilge.Assert import qualified Bilge.TestSession as BilgeTest import Brig.Types.Client -import Brig.Types.Intra (ConnectionStatus (ConnectionStatus), UserSet (..)) +import Brig.Types.Intra (UserSet (..)) import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) import Brig.Types.Test.Arbitrary () @@ -91,6 +91,7 @@ import Wire.API.Connection (UserConnection) import qualified Wire.API.Connection as Conn import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember) import qualified Wire.API.Message as Msg +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.User (UserProfile (..)) import Wire.API.User.Client (UserClients (..), UserClientsFull (userClientsFull)) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index dedf01e17a3..92871f49cf1 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -25,7 +25,7 @@ import Bilge hiding (timeout) import Bilge.Assert import Bilge.TestSession import Brig.Types -import Brig.Types.Intra (ConnectionStatus (ConnectionStatus), UserAccount (..), UserSet (..)) +import Brig.Types.Intra (UserAccount (..), UserSet (..)) import Brig.Types.Team.Invitation import Brig.Types.User.Auth (CookieLabel (..)) import Control.Lens hiding (from, to, (#), (.=)) @@ -73,7 +73,7 @@ import Galley.Types import qualified Galley.Types as Conv import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..)) import Galley.Types.Conversations.Roles hiding (DeleteConversation) -import Galley.Types.Teams hiding (Event, EventType (..)) +import Galley.Types.Teams hiding (Event, EventType (..), self) import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra import Gundeck.Types.Notification @@ -108,7 +108,7 @@ import Web.Cookie import Wire.API.Conversation import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action -import Wire.API.Event.Conversation (_EdMembersJoin, _EdMembersLeave) +import Wire.API.Event.Conversation (_EdConversation, _EdMembersJoin, _EdMembersLeave) import qualified Wire.API.Event.Team as TE import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley @@ -118,6 +118,7 @@ import qualified Wire.API.Federation.GRPC.Types as F import qualified Wire.API.Federation.Mock as Mock import Wire.API.Message import qualified Wire.API.Message.Proto as Proto +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging import Wire.API.User.Client (ClientCapability (..), UserClientsFull (UserClientsFull)) import qualified Wire.API.User.Client as Client @@ -548,7 +549,7 @@ defNewConv :: NewConv defNewConv = NewConv [] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin postConvQualified :: - (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => + (HasCallStack, HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => UserId -> NewConv -> m ResponseLBS @@ -1235,6 +1236,9 @@ getTeamQueue' zusr msince msize onlyLast = do ] ) +asOtherMember :: Qualified UserId -> OtherMember +asOtherMember quid = OtherMember quid Nothing roleNameWireMember + registerRemoteConv :: Qualified ConvId -> Qualified UserId -> Maybe Text -> Set OtherMember -> TestM () registerRemoteConv convId originUser name othMembers = do fedGalleyClient <- view tsFedGalleyClient @@ -1568,6 +1572,25 @@ connectUsersWith fn u = mapM connectTo ) return (r1, r2) +connectWithRemoteUser :: + (MonadReader TestSetup m, MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => + UserId -> + Qualified UserId -> + m () +connectWithRemoteUser self other = do + let req = CreateConnectionForTest self other + b <- view tsBrig + put + ( b + . zUser self + . contentJson + . zConn "conn" + . paths ["i", "connections", "connection-update"] + . json req + ) + !!! const 200 + === statusCode + -- | A copy of 'postConnection' from Brig integration tests. postConnection :: UserId -> UserId -> TestM ResponseLBS postConnection from to = do @@ -1584,6 +1607,16 @@ postConnection from to = do RequestBodyLBS . encode $ ConnectionRequest to (unsafeRange "some conv name") +postConnectionQualified :: UserId -> Qualified UserId -> TestM ResponseLBS +postConnectionQualified from (Qualified toUser toDomain) = do + brig <- view tsBrig + post $ + brig + . paths ["/connections", toByteString' toDomain, toByteString' toUser] + . contentJson + . zUser from + . zConn "conn" + -- | A copy of 'putConnection' from Brig integration tests. putConnection :: UserId -> UserId -> Relation -> TestM ResponseLBS putConnection from to r = do @@ -1635,6 +1668,11 @@ assertConnections u cstat = do randomUsers :: Int -> TestM [UserId] randomUsers n = replicateM n randomUser +randomUserTuple :: HasCallStack => TestM (UserId, Qualified UserId) +randomUserTuple = do + qUid <- randomQualifiedUser + pure (qUnqualified qUid, qUid) + randomUser :: HasCallStack => TestM UserId randomUser = qUnqualified <$> randomUser' False True True @@ -2294,6 +2332,18 @@ checkConvCreateEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do Conv.EdConversation x -> (qUnqualified . cnvQualifiedId) x @?= cid other -> assertFailure $ "Unexpected event data: " <> show other +wsAssertConvCreateWithRole :: HasCallStack => Qualified ConvId -> Qualified UserId -> UserId -> [(Qualified UserId, RoleName)] -> Notification -> IO () +wsAssertConvCreateWithRole conv eventFrom selfMember otherMembers n = do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= conv + evtType e @?= Conv.ConvCreate + evtFrom e @?= eventFrom + fmap (memId . cmSelf . cnvMembers) (evtData e ^? _EdConversation) @?= Just selfMember + fmap (sort . cmOthers . cnvMembers) (evtData e ^? _EdConversation) @?= Just (sort (toOtherMember <$> otherMembers)) + where + toOtherMember (quid, role) = OtherMember quid Nothing role + checkTeamDeleteEvent :: HasCallStack => TeamId -> WS.WebSocket -> TestM () checkTeamDeleteEvent tid w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= False diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 86adc975301..e930aa76e03 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -96,6 +96,7 @@ import Stern.Types import System.Logger.Class hiding (Error, name, (.=)) import qualified System.Logger.Class as Log import UnliftIO.Exception hiding (Handler) +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Routes.Internal.Brig.EJPD as EJPD import qualified Wire.API.Team.Feature as Public @@ -171,20 +172,19 @@ getUsersConnections :: List UserId -> Handler [ConnectionStatus] getUsersConnections uids = do info $ msg "Getting user connections" b <- view brig + let reqBody = ConnectionsStatusRequest (fromList uids) Nothing r <- catchRpcErrors $ rpc' "brig" b - ( method GET + ( method POST . path "/i/users/connections-status" - . queryItem "users" users + . Bilge.json reqBody . expect2xx ) info $ msg ("Response" ++ show r) parseResponse (mkError status502 "bad-upstream") r - where - users = BS.intercalate "," $ map toByteString' (fromList uids) getUserProfiles :: Either [UserId] [Handle] -> Handler [UserAccount] getUserProfiles uidsOrHandles = do From e0b355610a28aad4e24ca506dfc23c91a656cb1e Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 18 Oct 2021 13:41:52 +0200 Subject: [PATCH 30/88] Make conversation creator unqualified in on-conversation-created RPC (#1858) * Unqualify rcOrigId in `on-conversation-created` Also add some Remote and Local tags to various functions. * Simplify partitioning in onConversationCreated * Improve comment about creator ID in RPC * Ensure creator in the conv domain in tests Co-authored-by: jschaul --- changelog.d/6-federation/unqualify-creator-id | 1 + .../src/Wire/API/Federation/API/Galley.hs | 15 +++---- services/galley/src/Galley/API/Federation.hs | 40 +++++++++++-------- services/galley/src/Galley/API/One2One.hs | 4 +- services/galley/src/Galley/API/Util.hs | 16 +++++--- services/galley/src/Galley/Data.hs | 10 ++--- services/galley/test/integration/API.hs | 21 +++++----- .../galley/test/integration/API/Federation.hs | 10 ++--- services/galley/test/integration/API/Util.hs | 2 +- 9 files changed, 67 insertions(+), 52 deletions(-) create mode 100644 changelog.d/6-federation/unqualify-creator-id diff --git a/changelog.d/6-federation/unqualify-creator-id b/changelog.d/6-federation/unqualify-creator-id new file mode 100644 index 00000000000..ba68724e09e --- /dev/null +++ b/changelog.d/6-federation/unqualify-creator-id @@ -0,0 +1 @@ +Make the conversation creator field in the `on-conversation-created` RPC unqualified. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index bdb02efccb3..8da62aaba63 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -22,7 +22,7 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Id (ClientId, ConvId, UserId) import Data.Json.Util (Base64ByteString) import Data.Misc (Milliseconds) -import Data.Qualified (Qualified) +import Data.Qualified import Data.Time.Clock (UTCTime) import Imports import Servant.API (JSON, Post, ReqBody, Summary, (:>)) @@ -151,12 +151,10 @@ newtype GetConversationsResponse = GetConversationsResponse data NewRemoteConversation conv = NewRemoteConversation { -- | The time when the conversation was created rcTime :: UTCTime, - -- | The user that created the conversation. - -- - -- FUTUREWORK: Make this unqualified and assume that this user has the same domain - -- as the backend invoking this RPC. Otehrwise a third party can figure out - -- connections. - rcOrigUserId :: Qualified UserId, + -- | The user that created the conversation. This is implicitly qualified + -- by the requesting domain, since it is impossible to create a regular/group + -- conversation on a remote backend. + rcOrigUserId :: UserId, -- | The conversation ID, local to the backend invoking the RPC rcCnvId :: conv, -- | The conversation type @@ -173,6 +171,9 @@ data NewRemoteConversation conv = NewRemoteConversation deriving stock (Eq, Show, Generic, Functor) deriving (ToJSON, FromJSON) via (CustomEncoded (NewRemoteConversation conv)) +rcRemoteOrigUserId :: NewRemoteConversation (Remote ConvId) -> Remote UserId +rcRemoteOrigUserId rc = qualifyAs (rcCnvId rc) (rcOrigUserId rc) + data ConversationUpdate = ConversationUpdate { cuTime :: UTCTime, cuOrigUserId :: Qualified UserId, diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 359f301ba11..3f1a7f2433b 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -28,7 +28,7 @@ import Data.Json.Util (Base64ByteString (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), Remote, partitionQualified, qUntagged, qualifyAs, toRemoteUnsafe) +import Data.Qualified import qualified Data.Set as Set import qualified Data.Text.Lazy as LT import Galley.API.Error (invalidPayload) @@ -82,26 +82,34 @@ federationSitemap = onConversationCreated :: Domain -> NewRemoteConversation ConvId -> Galley () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc - localDomain <- viewFederationDomain - let (localMembers, remoteMembers) = - Set.partition (\om -> qDomain (omQualifiedId om) == localDomain) - . rcMembers - $ rc - localUserIds = qUnqualified . omQualifiedId <$> Set.toList localMembers + loc <- qualifyLocal () + let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (rcMembers rc))) - addedUserIds <- addLocalUsersToRemoteConv (rcCnvId qrc) (rcOrigUserId rc) localUserIds + addedUserIds <- + addLocalUsersToRemoteConv + (rcCnvId qrc) + (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrc)) + localUserIds - let connectedLocalMembers = Set.filter (\m -> (qUnqualified . omQualifiedId) m `Set.member` addedUserIds) localMembers + let connectedMembers = + Set.filter + ( foldQualified + loc + (flip Set.member addedUserIds . tUnqualified) + (const True) + . omQualifiedId + ) + (rcMembers rc) -- Make sure to notify only about local users connected to the adder - let qrcConnected = qrc {rcMembers = Set.union remoteMembers connectedLocalMembers} + let qrcConnected = qrc {rcMembers = connectedMembers} - forM_ (fromNewRemoteConversation localDomain qrcConnected) $ \(mem, c) -> do + forM_ (fromNewRemoteConversation loc qrcConnected) $ \(mem, c) -> do let event = Event ConvCreate - (qUntagged (rcCnvId qrc)) - (rcOrigUserId rc) - (rcTime rc) + (qUntagged (rcCnvId qrcConnected)) + (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrcConnected)) + (rcTime qrcConnected) (EdConversation c) pushConversationEvent Nothing event [Public.memId mem] [] @@ -148,7 +156,7 @@ onConversationUpdated requestingDomain cu = do (u : us) -> pure (Just $ ConversationActionAddMembers (u :| us) role, addedLocalUsers) ConversationActionRemoveMembers toRemove -> do let localUsers = getLocalUsers localDomain toRemove - Data.removeLocalMembersFromRemoteConv qconvId localUsers + Data.removeLocalMembersFromRemoteConv rconvId localUsers pure (Just $ cuAction cu, []) ConversationActionRename _ -> pure (Just $ cuAction cu, []) ConversationActionMessageTimerUpdate _ -> pure (Just $ cuAction cu, []) @@ -192,7 +200,7 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do -- Update the local view of the remote conversation by adding only those local -- users that are connected to the adder - Data.addLocalMembersToRemoteConv (qUntagged remoteConvId) connectedList + Data.addLocalMembersToRemoteConv remoteConvId connectedList pure connected -- FUTUREWORK: actually return errors as part of the response instead of throwing diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index d3bd30396a1..d9be593d5f0 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -64,9 +64,9 @@ iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do doremote rconvId = case (uooActor, uooActorDesiredMembership) of (LocalActor, Included) -> do - Data.addLocalMembersToRemoteConv (qUntagged rconvId) [tUnqualified uooLocalUser] + Data.addLocalMembersToRemoteConv rconvId [tUnqualified uooLocalUser] (LocalActor, Excluded) -> do - Data.removeLocalMembersFromRemoteConv (qUntagged rconvId) [tUnqualified uooLocalUser] + Data.removeLocalMembersFromRemoteConv rconvId [tUnqualified uooLocalUser] (RemoteActor, _) -> pure () foldQualified uooLocalUser dolocal doremote convId diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index fae4c5a54c6..0b89f64612a 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -655,7 +655,7 @@ toNewRemoteConversation :: toNewRemoteConversation now localDomain Data.Conversation {..} = NewRemoteConversation { rcTime = now, - rcOrigUserId = Qualified convCreator localDomain, + rcOrigUserId = convCreator, rcCnvId = convId, rcCnvType = convType, rcCnvAccess = convAccess, @@ -681,12 +681,16 @@ toNewRemoteConversation now localDomain Data.Conversation {..} = -- be sent out to users informing them that they were added to a new -- conversation. fromNewRemoteConversation :: - Domain -> + Local x -> NewRemoteConversation (Remote ConvId) -> [(Public.Member, Public.Conversation)] -fromNewRemoteConversation d NewRemoteConversation {..} = +fromNewRemoteConversation loc rc@NewRemoteConversation {..} = let membersView = fmap (second Set.toList) . setHoles $ rcMembers - creatorOther = OtherMember rcOrigUserId Nothing roleNameWireAdmin + creatorOther = + OtherMember + (qUntagged (rcRemoteOrigUserId rc)) + Nothing + roleNameWireAdmin in foldMap ( \(me, others) -> guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) @@ -694,7 +698,7 @@ fromNewRemoteConversation d NewRemoteConversation {..} = membersView where inDomain :: OtherMember -> Bool - inDomain = (== d) . qDomain . omQualifiedId + inDomain = (== tDomain loc) . qDomain . omQualifiedId setHoles :: Ord a => Set a -> [(a, Set a)] setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s -- Currently this function creates a Member with default conversation attributes @@ -720,7 +724,7 @@ fromNewRemoteConversation d NewRemoteConversation {..} = { cnvmType = rcCnvType, -- FUTUREWORK: Document this is the same domain as the conversation -- domain - cnvmCreator = qUnqualified rcOrigUserId, + cnvmCreator = rcOrigUserId, cnvmAccess = rcCnvAccess, cnvmAccessRole = rcCnvAccessRole, cnvmName = rcCnvName, diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 0e3267a7f54..502d9df4bf6 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -966,9 +966,9 @@ addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = -- | Set local users as belonging to a remote conversation. This is invoked by a -- remote galley when users from the current backend are added to conversations -- on the remote end. -addLocalMembersToRemoteConv :: MonadClient m => Qualified ConvId -> [UserId] -> m () +addLocalMembersToRemoteConv :: MonadClient m => Remote ConvId -> [UserId] -> m () addLocalMembersToRemoteConv _ [] = pure () -addLocalMembersToRemoteConv qconv users = do +addLocalMembersToRemoteConv rconv users = do -- FUTUREWORK: consider using pooledMapConcurrentlyN for_ (List.chunksOf 32 users) $ \chunk -> retry x5 . batch $ do @@ -977,7 +977,7 @@ addLocalMembersToRemoteConv qconv users = do for_ chunk $ \u -> addPrepQuery Cql.insertUserRemoteConv - (u, qDomain qconv, qUnqualified qconv) + (u, tDomain rconv, tUnqualified rconv) updateSelfMember :: MonadClient m => @@ -1117,12 +1117,12 @@ removeRemoteMembersFromLocalConv cnv victims = do removeLocalMembersFromRemoteConv :: MonadClient m => -- | The conversation to remove members from - Qualified ConvId -> + Remote ConvId -> -- | Members to remove local to this backend [UserId] -> m () removeLocalMembersFromRemoteConv _ [] = pure () -removeLocalMembersFromRemoteConv (Qualified conv convDomain) victims = +removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = retry x5 . batch $ do setType BatchLogged setConsistency Quorum diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 4ea430c9b94..82036ae0ad2 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -287,7 +287,6 @@ postConvOk = do rsp <- postConv alice [bob, jane] (Just nameMaxSize) [] Nothing Nothing postConv alice [] (Just "gossip") [] Nothing Nothing let localConvId = cnvQualifiedId localConv @@ -2046,10 +2047,10 @@ testBulkGetQualifiedConvs = do localConvIdNotParticipating <- decodeQualifiedConvId <$> postConv (qUnqualified eve) [] (Just "gossip about alice!") [] Nothing Nothing let aliceAsOtherMember = OtherMember aliceQ Nothing roleNameWireAdmin - registerRemoteConv remoteConvIdA bobQ Nothing (Set.fromList [aliceAsOtherMember]) - registerRemoteConv remoteConvIdB carlQ Nothing (Set.fromList [aliceAsOtherMember]) - registerRemoteConv remoteConvIdBNotFoundOnRemote carlQ Nothing (Set.fromList [aliceAsOtherMember]) - registerRemoteConv remoteConvIdCFailure carlQ Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdA bobId Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdB carlId Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdBNotFoundOnRemote carlId Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdCFailure deeId Nothing (Set.fromList [aliceAsOtherMember]) let bobAsOtherMember = OtherMember bobQ Nothing roleNameWireAdmin carlAsOtherMember = OtherMember carlQ Nothing roleNameWireAdmin @@ -3018,7 +3019,7 @@ removeUser = do let nc = FederatedGalley.NewRemoteConversation { FederatedGalley.rcTime = now, - FederatedGalley.rcOrigUserId = dee, + FederatedGalley.rcOrigUserId = qUnqualified dee, FederatedGalley.rcCnvId = conv4, FederatedGalley.rcCnvType = RegularConv, FederatedGalley.rcCnvAccess = [], diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index f114ee2ac83..c2cb673e5e6 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -173,7 +173,7 @@ onConvCreated = do let requestMembers = Set.fromList (map asOtherMember [qAlice, qCharlie, qDee]) WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do - registerRemoteConv qconv qBob (Just "gossip") requestMembers + registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") requestMembers liftIO $ do let expectedSelf = alice expectedOthers = [(qBob, roleNameWireAdmin), (qDee, roleNameWireMember)] @@ -249,7 +249,7 @@ addUnconnectedUsersOnly = do WS.bracketR c alice $ \wsA -> do -- Remote Bob creates a conversation with local Alice - registerRemoteConv qconv qBob (Just "gossip") requestMembers + registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") requestMembers liftIO $ do let expectedSelf = alice expectedOthers = [(qBob, roleNameWireAdmin)] @@ -363,7 +363,7 @@ removeRemoteUser = do now <- liftIO getCurrentTime mapM_ (`connectWithRemoteUser` qBob) [alice, dee] - registerRemoteConv qconv qBob (Just "gossip") (Set.fromList [aliceAsOtherMember, deeAsOtherMember, eveAsOtherMember]) + registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") (Set.fromList [aliceAsOtherMember, deeAsOtherMember, eveAsOtherMember]) let cuRemove user = FedGalley.ConversationUpdate @@ -413,7 +413,7 @@ notifyUpdate extras action etype edata = do mapM_ (`connectWithRemoteUser` qbob) [alice] registerRemoteConv qconv - qbob + bob (Just "gossip") (Set.fromList (map mkMember (qalice : extras))) @@ -524,7 +524,7 @@ addRemoteUser = do mapM_ (flip connectWithRemoteUser qbob . qUnqualified) [qalice, qdee] - registerRemoteConv qconv qbob (Just "gossip") (Set.fromList (map asOtherMember [qalice, qdee, qeve])) + registerRemoteConv qconv (qUnqualified qbob) (Just "gossip") (Set.fromList (map asOtherMember [qalice, qdee, qeve])) -- The conversation owning let cu = diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 92871f49cf1..a310a1b744d 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1239,7 +1239,7 @@ getTeamQueue' zusr msince msize onlyLast = do asOtherMember :: Qualified UserId -> OtherMember asOtherMember quid = OtherMember quid Nothing roleNameWireMember -registerRemoteConv :: Qualified ConvId -> Qualified UserId -> Maybe Text -> Set OtherMember -> TestM () +registerRemoteConv :: Qualified ConvId -> UserId -> Maybe Text -> Set OtherMember -> TestM () registerRemoteConv convId originUser name othMembers = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime From 50512f90b12510bce5a440c7e83c9defa2a0b97a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 18 Oct 2021 17:26:04 +0200 Subject: [PATCH 31/88] Parallelise RPCs (#1860) * Add runFederatedConcurrently utility * Paralellise remote conversation notification * Add Local and Remote tags to profile functions * Parallelise RPCs for fetching profiles * Rename indexRemote to bucketRemote This makes it consistent with indexQualified and bucketQualified. * Move traverseWithErrors to Util module * Parallelise claimMultiPrekeyBundles --- changelog.d/6-federation/parallel-rpcs | 1 + libs/types-common/src/Data/Qualified.hs | 18 +++++-- .../src/Wire/API/Federation/Client.hs | 8 +-- libs/wire-api/src/Wire/API/Team/LegalHold.hs | 2 +- libs/wire-api/src/Wire/API/User/Client.hs | 8 +++ services/brig/src/Brig/API/Client.hs | 51 ++++++++++++------- services/brig/src/Brig/API/Public.hs | 16 +++--- services/brig/src/Brig/API/User.hs | 46 ++++++++++------- services/brig/src/Brig/API/Util.hs | 15 +++++- services/brig/src/Brig/Federation/Client.hs | 4 +- services/brig/src/Brig/User/API/Handle.hs | 32 +++++++----- services/brig/src/Brig/User/API/Search.hs | 3 +- services/galley/src/Galley/API/Message.hs | 2 +- services/galley/src/Galley/API/Query.hs | 2 +- services/galley/src/Galley/API/Update.hs | 2 +- services/galley/src/Galley/API/Util.hs | 43 ++++++++-------- services/galley/src/Galley/Data.hs | 2 +- 17 files changed, 161 insertions(+), 94 deletions(-) create mode 100644 changelog.d/6-federation/parallel-rpcs diff --git a/changelog.d/6-federation/parallel-rpcs b/changelog.d/6-federation/parallel-rpcs new file mode 100644 index 00000000000..53d9fb8d3fe --- /dev/null +++ b/changelog.d/6-federation/parallel-rpcs @@ -0,0 +1 @@ +Make federated requests to multiple backends in parallel. diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index a1b9209d2bc..4bce70e078a 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -22,6 +22,7 @@ module Data.Qualified ( -- * Qualified Qualified (..), + qToPair, QualifiedWithTag, tUnqualified, tUnqualifiedL, @@ -35,15 +36,17 @@ module Data.Qualified qualifyAs, foldQualified, partitionQualified, + partitionQualifiedAndTag, indexQualified, bucketQualified, - indexRemote, + bucketRemote, deprecatedSchema, ) where import Control.Lens (Lens, lens, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Bifunctor (first) import Data.Domain (Domain) import Data.Handle (Handle (..)) import Data.Id @@ -62,6 +65,9 @@ data Qualified a = Qualified } deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) +qToPair :: Qualified a -> (Domain, a) +qToPair (Qualified x dom) = (dom, x) + data QTag = QLocal | QRemote deriving (Eq, Show) @@ -125,6 +131,11 @@ partitionQualified loc = foldMap $ foldQualified loc (\l -> ([tUnqualified l], mempty)) (\r -> (mempty, [r])) +partitionQualifiedAndTag :: Foldable f => Local x -> f (Qualified a) -> ([Local a], [Remote a]) +partitionQualifiedAndTag loc = + first (map (qualifyAs loc)) + . partitionQualified loc + -- | Index a list of qualified values by domain. indexQualified :: Foldable f => f (Qualified a) -> Map Domain [a] indexQualified = foldr add mempty @@ -136,9 +147,8 @@ indexQualified = foldr add mempty bucketQualified :: Foldable f => f (Qualified a) -> [Qualified [a]] bucketQualified = map (\(d, a) -> Qualified a d) . Map.assocs . indexQualified --- FUTUREWORK: Rename this to 'bucketRemote' -indexRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]] -indexRemote = +bucketRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]] +bucketRemote = map (uncurry toRemoteUnsafe) . Map.assocs . indexQualified diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index ee39c5ed596..423c7788a59 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -123,14 +123,16 @@ data FederationError | FederationNotImplemented | FederationNotConfigured | FederationCallFailure FederationClientFailure - deriving (Show, Eq) + deriving (Show, Eq, Typeable) + +instance Exception FederationError data FederationClientFailure = FederationClientFailure { fedFailDomain :: Domain, fedFailPath :: ByteString, fedFailError :: FederationClientError } - deriving (Show, Eq) + deriving (Show, Eq, Typeable) data FederationClientError = FederationClientInvalidMethod HTTP.Method @@ -139,7 +141,7 @@ data FederationClientError | FederationClientOutwardError Proto.OutwardError | FederationClientInwardError Proto.InwardError | FederationClientServantError Servant.ClientError - deriving (Show, Eq) + deriving (Show, Eq, Typeable) callRemote :: MonadIO m => GrpcClient -> Proto.ValidatedFederatedRequest -> m (GRpcReply Proto.OutwardResponse) callRemote fedClient call = liftIO $ gRpcCall @'MsgProtoBuf @Proto.Outward @"Outward" @"call" fedClient (Proto.validatedFederatedRequestToFederatedRequest call) diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index b03769225e7..7dd7fc70999 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -350,7 +350,7 @@ data LegalholdProtectee | -- | add UserId here if you want to protect bots as well (or just remove and use -- 'ProtectedUser', but then you'll loose the user type information). UnprotectedBot - | -- | FUTUREWORK: protection against legalhold when looking up prekeys accross federated + | -- | FUTUREWORK: protection against legalhold when looking up prekeys across federated -- instances. LegalholdPlusFederationNotImplemented deriving (Show, Eq, Ord, Generic) diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 58f3b573d2a..6e601ecbb81 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -30,6 +30,7 @@ module Wire.API.User.Client QualifiedUserClientMap (..), QualifiedUserClientPrekeyMap (..), mkQualifiedUserClientPrekeyMap, + qualifiedUserClientPrekeyMapFromList, UserClientsFull (..), userClientsFullToUserClients, UserClients (..), @@ -84,6 +85,7 @@ import Data.Id import Data.Json.Util import qualified Data.Map.Strict as Map import Data.Misc (Latitude (..), Location, Longitude (..), PlainTextPassword (..), latitude, location, longitude, modelLocation) +import Data.Qualified import Data.Schema import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set @@ -308,6 +310,12 @@ instance ToSchema QualifiedUserClientPrekeyMap where mkQualifiedUserClientPrekeyMap :: Map Domain UserClientPrekeyMap -> QualifiedUserClientPrekeyMap mkQualifiedUserClientPrekeyMap = coerce +qualifiedUserClientPrekeyMapFromList :: + [Qualified UserClientPrekeyMap] -> + QualifiedUserClientPrekeyMap +qualifiedUserClientPrekeyMapFromList = + mkQualifiedUserClientPrekeyMap . Map.fromList . map qToPair + -------------------------------------------------------------------------------- -- UserClients diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 024f27fb14c..e601a81ecf7 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -45,6 +45,7 @@ module Brig.API.Client where import Brig.API.Types +import Brig.API.Util import Brig.App import qualified Brig.Data.Client as Data import qualified Brig.Data.User as Data @@ -71,17 +72,16 @@ import qualified Data.Map.Strict as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set -import Galley.Types (UserClients (..)) import Imports import Network.Wai.Utilities import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log import UnliftIO.Async (Concurrently (Concurrently, runConcurrently)) import Wire.API.Federation.API.Brig (GetUserClients (GetUserClients)) +import Wire.API.Federation.Client (FederationError (..)) import qualified Wire.API.Message as Message import Wire.API.Team.LegalHold (LegalholdProtectee (..)) -import Wire.API.User.Client (ClientCapabilityList (..), QualifiedUserClientPrekeyMap (..), QualifiedUserClients (..), UserClientPrekeyMap, mkQualifiedUserClientPrekeyMap, mkUserClientPrekeyMap) -import qualified Wire.API.User.Client as Client +import Wire.API.User.Client import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) lookupLocalClient :: UserId -> ClientId -> AppIO (Maybe Client) @@ -126,14 +126,14 @@ addClient u con ip new = do acc <- lift (Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) return loc <- maybe (return Nothing) locationOf ip maxPermClients <- fromMaybe Opt.defUserMaxPermClients <$> Opt.setUserMaxPermClients <$> view settings - let caps :: Maybe (Set Client.ClientCapability) + let caps :: Maybe (Set ClientCapability) caps = updlhdev $ newClientCapabilities new where updlhdev = if newClientType new == LegalHoldClientType then Just . maybe (Set.singleton lhcaps) (Set.insert lhcaps) else id - lhcaps = Client.ClientSupportsLegalholdImplicitConsent + lhcaps = ClientSupportsLegalholdImplicitConsent (clt, old, count) <- Data.addClient u clientId' new maxPermClients loc caps !>> ClientDataError let usr = accountUser acc lift $ do @@ -186,7 +186,7 @@ claimPrekey protectee u d c = do claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) claimLocalPrekey protectee user client = do - guardLegalhold protectee (Client.mkUserClients [(user, [client])]) + guardLegalhold protectee (mkUserClients [(user, [client])]) lift $ do prekey <- Data.claimPrekey user client when (isNothing prekey) (noPrekeys user client) @@ -205,7 +205,7 @@ claimPrekeyBundle protectee domain uid = do claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError AppIO PrekeyBundle claimLocalPrekeyBundle protectee u = do clients <- map clientId <$> Data.lookupClients u - guardLegalhold protectee (Client.mkUserClients [(u, clients)]) + guardLegalhold protectee (mkUserClients [(u, clients)]) PrekeyBundle u . catMaybes <$> lift (mapM (Data.claimPrekey u) clients) claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError AppIO PrekeyBundle @@ -214,18 +214,33 @@ claimRemotePrekeyBundle quser = do claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError AppIO QualifiedUserClientPrekeyMap claimMultiPrekeyBundles protectee quc = do - localDomain <- viewFederationDomain - fmap (mkQualifiedUserClientPrekeyMap . Map.fromList) - -- FUTUREWORK(federation): parallelise federator requests here - . traverse (\(domain, uc) -> (domain,) <$> claim localDomain domain (UserClients uc)) - . Map.assocs - . qualifiedUserClients - $ quc + loc <- qualifyLocal () + let (locals, remotes) = + partitionQualifiedAndTag + loc + ( map + (fmap UserClients . uncurry (flip Qualified)) + (Map.assocs (qualifiedUserClients quc)) + ) + localPrekeys <- traverse claimLocal locals + remotePrekeys <- + traverseConcurrentlyWithErrors + claimRemote + remotes + !>> ClientFederationError + pure . qualifiedUserClientPrekeyMapFromList $ localPrekeys <> remotePrekeys where - claim :: Domain -> Domain -> UserClients -> ExceptT ClientError AppIO UserClientPrekeyMap - claim localDomain domain uc - | domain == localDomain = claimLocalMultiPrekeyBundles protectee uc - | otherwise = Federation.claimMultiPrekeyBundle domain uc !>> ClientFederationError + claimRemote :: + Remote UserClients -> + ExceptT FederationError AppIO (Qualified UserClientPrekeyMap) + claimRemote ruc = + qUntagged . qualifyAs ruc + <$> Federation.claimMultiPrekeyBundle (tDomain ruc) (tUnqualified ruc) + + claimLocal :: Local UserClients -> ExceptT ClientError AppIO (Qualified UserClientPrekeyMap) + claimLocal luc = + qUntagged . qualifyAs luc + <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO UserClientPrekeyMap claimLocalMultiPrekeyBundles protectee userClients = do diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 809a0e1f4d8..3ed826d0889 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -918,7 +918,9 @@ getUserUnqualifiedH self uid = do getUser self (Qualified uid domain) getUser :: UserId -> Qualified UserId -> Handler (Maybe Public.UserProfile) -getUser self qualifiedUserId = API.lookupProfile self qualifiedUserId !>> fedError +getUser self qualifiedUserId = do + lself <- qualifyLocal self + API.lookupProfile lself qualifiedUserId !>> fedError getUserDisplayNameH :: JSON ::: UserId -> Handler Response getUserDisplayNameH (_ ::: self) = do @@ -946,14 +948,14 @@ listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do listUsersByIdsOrHandles :: UserId -> Public.ListUsersQuery -> Handler [Public.UserProfile] listUsersByIdsOrHandles self q = do + lself <- qualifyLocal self foundUsers <- case q of Public.ListUsersByIds us -> - byIds us + byIds lself us Public.ListUsersByHandles hs -> do - loc <- qualifyLocal () - let (localHandles, _) = partitionQualified loc (fromRange hs) + let (localHandles, _) = partitionQualified lself (fromRange hs) us <- getIds localHandles - Handle.filterHandleResults self =<< byIds us + Handle.filterHandleResults lself =<< byIds lself us case foundUsers of [] -> throwStd $ notFound "None of the specified ids or handles match any users" _ -> pure foundUsers @@ -963,8 +965,8 @@ listUsersByIdsOrHandles self q = do localUsers <- catMaybes <$> traverse (lift . API.lookupHandle) localHandles domain <- viewFederationDomain pure $ map (`Qualified` domain) localUsers - byIds :: [Qualified UserId] -> Handler [Public.UserProfile] - byIds uids = API.lookupProfiles self uids !>> fedError + byIds :: Local UserId -> [Qualified UserId] -> Handler [Public.UserProfile] + byIds lself uids = API.lookupProfiles lself uids !>> fedError newtype GetActivationCodeResp = GetActivationCodeResp (Public.ActivationKey, Public.ActivationCode) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 79f827f616d..cf8e9247013 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -91,7 +91,7 @@ where import qualified Brig.API.Error as Error import qualified Brig.API.Handler as API (Handler) import Brig.API.Types -import Brig.API.Util (fetchUserIdentity, validateHandle) +import Brig.API.Util import Brig.App import qualified Brig.Code as Code import Brig.Data.Activation (ActivationEvent (..)) @@ -127,13 +127,11 @@ import Brig.User.Handle.Blacklist import Brig.User.Phone import qualified Brig.User.Search.TeamSize as TeamSize import Control.Arrow ((&&&)) -import Control.Concurrent.Async (mapConcurrently, mapConcurrently_) import Control.Error import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.ByteString.Conversion import qualified Data.Currency as Currency -import Data.Domain (Domain) import Data.Handle (Handle) import Data.Id as Id import Data.Json.Util @@ -142,7 +140,7 @@ import Data.List1 (List1) import qualified Data.Map.Strict as Map import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) -import Data.Qualified (Qualified, indexQualified) +import Data.Qualified import Data.Time.Clock (addUTCTime, diffUTCTime) import Data.UUID.V4 (nextRandom) import qualified Galley.Types.Teams as Team @@ -151,6 +149,7 @@ import Imports import Network.Wai.Utilities import qualified System.Logger.Class as Log import System.Logger.Message +import UnliftIO.Async import Wire.API.Federation.Client (FederationError (..)) import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Member (legalHoldStatus) @@ -1123,8 +1122,12 @@ userGC u = case (userExpire u) of deleteUserNoVerify (userId u) return u -lookupProfile :: UserId -> Qualified UserId -> ExceptT FederationError AppIO (Maybe UserProfile) -lookupProfile self other = listToMaybe <$> lookupProfiles self [other] +lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError AppIO (Maybe UserProfile) +lookupProfile self other = + listToMaybe + <$> lookupProfilesFromDomain + self + (fmap pure other) -- | Obtain user profiles for a list of users as they can be seen by -- a given user 'self'. User 'self' can see the 'FullProfile' of any other user 'other', @@ -1133,22 +1136,27 @@ lookupProfile self other = listToMaybe <$> lookupProfiles self [other] -- If 'self' is an unknown 'UserId', return '[]'. lookupProfiles :: -- | User 'self' on whose behalf the profiles are requested. - UserId -> + Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> ExceptT FederationError AppIO [UserProfile] -lookupProfiles self others = do - localDomain <- viewFederationDomain - let userMap = indexQualified others - -- FUTUREWORK(federation): parallelise federator requests here - fold <$> traverse (uncurry (getProfiles localDomain)) (Map.assocs userMap) - where - getProfiles localDomain domain uids - | localDomain == domain = lift (lookupLocalProfiles (Just self) uids) - | otherwise = lookupRemoteProfiles domain uids - -lookupRemoteProfiles :: Domain -> [UserId] -> ExceptT FederationError AppIO [UserProfile] -lookupRemoteProfiles = Federation.getUsersByIds +lookupProfiles self others = + fmap concat $ + traverseConcurrentlyWithErrors + (lookupProfilesFromDomain self) + (bucketQualified others) + +lookupProfilesFromDomain :: + Local UserId -> Qualified [UserId] -> ExceptT FederationError AppIO [UserProfile] +lookupProfilesFromDomain self = + foldQualified + self + (lift . lookupLocalProfiles (Just (tUnqualified self)) . tUnqualified) + lookupRemoteProfiles + +lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError AppIO [UserProfile] +lookupRemoteProfiles (qUntagged -> Qualified uids domain) = + Federation.getUsersByIds domain uids -- FUTUREWORK: This function encodes a few business rules about exposing email -- ids, but it is also very complex. Maybe this can be made easy by extracting a diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 358f5d665e1..05d22451cf4 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -22,6 +22,7 @@ module Brig.API.Util logInvitationCode, validateHandle, logEmail, + traverseConcurrentlyWithErrors, ) where @@ -33,7 +34,7 @@ import qualified Brig.Data.User as Data import Brig.Types import Brig.Types.Intra (accountUser) import Control.Monad.Catch (throwM) -import Control.Monad.Trans.Except (throwE) +import Control.Monad.Trans.Except import Data.Handle (Handle, parseHandle) import Data.Id import Data.Maybe @@ -42,6 +43,8 @@ import Data.Text.Ascii (AsciiText (toText)) import Imports import System.Logger (Msg) import qualified System.Logger as Log +import UnliftIO.Async +import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> Handler [UserProfile] @@ -73,3 +76,13 @@ logEmail email = logInvitationCode :: InvitationCode -> (Msg -> Msg) logInvitationCode code = Log.field "invitation_code" (toText $ fromInvitationCode code) + +-- | Traverse concurrently and fail on first error. +traverseConcurrentlyWithErrors :: + (Traversable t, Exception e) => + (a -> ExceptT e AppIO b) -> + t a -> + ExceptT e AppIO (t b) +traverseConcurrentlyWithErrors f = + ExceptT . try . (traverse (either throwIO pure) =<<) + . pooledMapConcurrentlyN 8 (runExceptT . f) diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 002d3921dc9..a6a33b550fd 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -46,8 +46,8 @@ type FederationAppIO = ExceptT FederationError AppIO -- FUTUREWORK: Maybe find a way to tranform 'clientRoutes' into a client which -- only uses 'FederationAppIO' monad, then boilerplate in this module can all be -- deleted. -getUserHandleInfo :: Qualified Handle -> FederationAppIO (Maybe UserProfile) -getUserHandleInfo (Qualified handle domain) = do +getUserHandleInfo :: Remote Handle -> FederationAppIO (Maybe UserProfile) +getUserHandleInfo (qUntagged -> Qualified handle domain) = do Log.info $ Log.msg $ T.pack "Brig-federation: handle lookup call on remote backend" executeFederated domain $ getUserByHandle clientRoutes handle diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index 0481d4c26da..4ef90c1bb37 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -26,14 +26,14 @@ where import Brig.API.Error (fedError) import Brig.API.Handler (Handler) import qualified Brig.API.User as API -import Brig.App (settings, viewFederationDomain) +import Brig.App import qualified Brig.Data.User as Data import qualified Brig.Federation.Client as Federation import Brig.Options (searchSameTeamOnly) import Control.Lens (view) import Data.Handle (Handle, fromHandle) import Data.Id (UserId) -import Data.Qualified (Qualified (..)) +import Data.Qualified import Imports import Network.Wai.Utilities ((!>>)) import qualified System.Logger.Class as Log @@ -42,19 +42,23 @@ import qualified Wire.API.User as Public import Wire.API.User.Search import qualified Wire.API.User.Search as Public --- FUTUREWORK: use 'runMaybeT' to simplify this. getHandleInfo :: UserId -> Qualified Handle -> Handler (Maybe Public.UserProfile) getHandleInfo self handle = do - domain <- viewFederationDomain - if qDomain handle == domain - then getLocalHandleInfo self (qUnqualified handle) - else getRemoteHandleInfo - where - getRemoteHandleInfo = do - Log.info $ Log.msg (Log.val "getHandleInfo - remote lookup") Log.~~ Log.field "domain" (show (qDomain handle)) - Federation.getUserHandleInfo handle !>> fedError + lself <- qualifyLocal self + foldQualified + lself + (getLocalHandleInfo lself . tUnqualified) + getRemoteHandleInfo + handle -getLocalHandleInfo :: UserId -> Handle -> Handler (Maybe Public.UserProfile) +getRemoteHandleInfo :: Remote Handle -> Handler (Maybe Public.UserProfile) +getRemoteHandleInfo handle = do + Log.info $ + Log.msg (Log.val "getHandleInfo - remote lookup") + . Log.field "domain" (show (tDomain handle)) + Federation.getUserHandleInfo handle !>> fedError + +getLocalHandleInfo :: Local UserId -> Handle -> Handler (Maybe Public.UserProfile) getLocalHandleInfo self handle = do Log.info $ Log.msg $ Log.val "getHandleInfo - local lookup" maybeOwnerId <- lift $ API.lookupHandle handle @@ -67,12 +71,12 @@ getLocalHandleInfo self handle = do return $ listToMaybe owner -- | Checks search permissions and filters accordingly -filterHandleResults :: UserId -> [Public.UserProfile] -> Handler [Public.UserProfile] +filterHandleResults :: Local UserId -> [Public.UserProfile] -> Handler [Public.UserProfile] filterHandleResults searchingUser us = do sameTeamSearchOnly <- fromMaybe False <$> view (settings . searchSameTeamOnly) if sameTeamSearchOnly then do - fromTeam <- lift $ Data.lookupUserTeam searchingUser + fromTeam <- lift $ Data.lookupUserTeam (tUnqualified searchingUser) return $ case fromTeam of Just team -> filter (\x -> Public.profileTeam x == Just team) us Nothing -> us diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index ecaccf457b5..b0c3a8f6c33 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -188,13 +188,14 @@ searchLocally searcherId searchTerm maybeMaxResults = do exactHandleSearch :: TeamSearchInfo -> Handler (Maybe Contact) exactHandleSearch teamSearchInfo = do + lsearcherId <- qualifyLocal searcherId let searchedHandleMaybe = parseHandle searchTerm exactHandleResult <- case searchedHandleMaybe of Nothing -> pure Nothing Just searchedHandle -> contactFromProfile - <$$> HandleAPI.getLocalHandleInfo searcherId searchedHandle + <$$> HandleAPI.getLocalHandleInfo lsearcherId searchedHandle pure $ case teamSearchInfo of Search.TeamOnly t -> if Just t == (contactTeam =<< exactHandleResult) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 84298638512..1df97be4f34 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -183,7 +183,7 @@ getRemoteClients :: [RemoteMember] -> Galley (Map (Domain, UserId) (Set ClientId getRemoteClients remoteMembers = do fmap mconcat -- concatenating maps is correct here, because their sets of keys are disjoint . pooledMapConcurrentlyN 8 getRemoteClientsFromDomain - . indexRemote + . bucketRemote . map rmId $ remoteMembers where diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 7212b123460..e05ee412497 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -181,7 +181,7 @@ getRemoteConversationsWithFailures zusr convs = do -- request conversations from remote backends fmap (bimap (localFailures <>) concat . partitionEithers) - . pooledForConcurrentlyN 8 (indexRemote locallyFound) + . pooledForConcurrentlyN 8 (bucketRemote locallyFound) $ \someConvs -> do let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes localDomain req diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 4a4dce798e7..618834640f6 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -1035,7 +1035,7 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = indexRemote (toList (bmRemotes targets)) + let rusersByDomain = bucketRemote (toList (bmRemotes targets)) void . pooledForConcurrentlyN 8 rusersByDomain $ \(qUntagged -> Qualified uids domain) -> do let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action rpc = diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 0b89f64612a..41274df90a6 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -58,7 +58,7 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) import Network.Wai.Utilities -import UnliftIO (concurrently) +import UnliftIO.Async import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription @@ -610,7 +610,7 @@ qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a checkRemoteUsersExist :: (Functor f, Foldable f) => f (Remote UserId) -> Galley () checkRemoteUsersExist = -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain - traverse_ checkRemotesFor . indexRemote + traverse_ checkRemotesFor . bucketRemote checkRemotesFor :: Remote [UserId] -> Galley () checkRemotesFor (qUntagged -> Qualified uids domain) = do @@ -636,10 +636,26 @@ runFederated remoteDomain rpc = do runExceptT (executeFederated remoteDomain rpc) >>= either (throwM . federationErrorToWai) pure +runFederatedConcurrently :: + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedGalleyRPC c b) -> + Galley [Remote b] +runFederatedConcurrently xs rpc = + pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> + qualifyAs r <$> runFederated (tDomain r) (rpc r) + +runFederatedConcurrently_ :: + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedGalleyRPC c ()) -> + Galley () +runFederatedConcurrently_ xs = void . runFederatedConcurrently xs + -- | Convert an internal conversation representation 'Data.Conversation' to -- 'NewRemoteConversation' to be sent over the wire to a remote backend that will -- reconstruct this into multiple public-facing --- 'Wire.API.Conversation.Convevrsation' values, one per user from that remote +-- 'Wire.API.Conversation.Conversation' values, one per user from that remote -- backend. -- -- FUTUREWORK: Include the team ID as well once it becomes qualified. @@ -745,23 +761,10 @@ registerRemoteConversationMemberships :: Data.Conversation -> Galley () registerRemoteConversationMemberships now localDomain c = do - let rc = toNewRemoteConversation now localDomain c - -- FUTUREWORK: parallelise federated requests - traverse_ (registerRemoteConversations rc) - . Map.keys - . indexQualified - . nubOrd - . map (qUntagged . rmId) - . Data.convRemoteMembers - $ c - where - registerRemoteConversations :: - NewRemoteConversation ConvId -> - Domain -> - Galley () - registerRemoteConversations rc domain = do - let rpc = FederatedGalley.onConversationCreated FederatedGalley.clientRoutes localDomain rc - runFederated domain rpc + let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) + rc = toNewRemoteConversation now localDomain c + runFederatedConcurrently_ allRemoteMembers $ \_ -> + FederatedGalley.onConversationCreated FederatedGalley.clientRoutes localDomain rc -------------------------------------------------------------------------------- -- Legalhold diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 502d9df4bf6..65feff542b8 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -617,7 +617,7 @@ remoteConversationStatus :: remoteConversationStatus uid = fmap mconcat . pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) - . indexRemote + . bucketRemote remoteConversationStatusOnDomain :: MonadClient m => UserId -> Remote [ConvId] -> m (Map (Remote ConvId) MemberStatus) remoteConversationStatusOnDomain uid rconvs = From 7e02f4a16faad27a3e5f67c84af8801490b1453c Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 19 Oct 2021 10:46:45 +0200 Subject: [PATCH 32/88] Close GRPC client after making a request to a remote federator (#1865) * Add Resource effect to InternalServer stack * Ensure GRPC clients are closed after a request --- changelog.d/6-federation/close-grpc-client | 1 + .../src/Wire/API/Federation/GRPC/Client.hs | 19 +++++++++++---- .../federator/src/Federator/InternalServer.hs | 3 +++ services/federator/src/Federator/Remote.hs | 24 ++++++++++++++++--- 4 files changed, 39 insertions(+), 8 deletions(-) create mode 100644 changelog.d/6-federation/close-grpc-client diff --git a/changelog.d/6-federation/close-grpc-client b/changelog.d/6-federation/close-grpc-client new file mode 100644 index 00000000000..750ae3d9b6e --- /dev/null +++ b/changelog.d/6-federation/close-grpc-client @@ -0,0 +1 @@ +Close GRPC client after making a request to a remote federator. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs index 805fea7f841..ec6a2aa44c1 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs @@ -15,7 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Federation.GRPC.Client where +module Wire.API.Federation.GRPC.Client + ( GrpcClientErr (..), + createGrpcClient, + grpcClientError, + ) +where import Control.Exception import qualified Data.Text as T @@ -32,11 +37,15 @@ createGrpcClient :: MonadIO m => GrpcClientConfig -> m (Either GrpcClientErr Grp createGrpcClient cfg = do res <- liftIO $ try @IOException $ setupGrpcClient' cfg pure $ case res of - Left err -> Left (GrpcClientErr (T.pack (show err <> errorInfo))) - Right (Left err) -> Left (GrpcClientErr (T.pack (show err <> errorInfo))) + Left err -> Left (grpcClientError (Just cfg) err) + Right (Left err) -> Left (grpcClientError (Just cfg) err) Right (Right client) -> Right client - where - errorInfo = addressToErrInfo $ _grpcClientConfigAddress cfg + +grpcClientError :: Exception e => Maybe GrpcClientConfig -> e -> GrpcClientErr +grpcClientError mcfg err = + GrpcClientErr . T.pack $ + displayException err + <> maybe "" (\cfg -> " " <> addressToErrInfo (_grpcClientConfigAddress cfg)) mcfg addressToErrInfo :: Address -> String addressToErrInfo = \case diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index 936464fc30a..ab1404bbc3b 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -45,6 +45,7 @@ import qualified Polysemy.Error as Polysemy import Polysemy.IO (embedToMonadIO) import qualified Polysemy.Input as Polysemy import qualified Polysemy.Reader as Polysemy +import qualified Polysemy.Resource as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log import Wire.API.Federation.GRPC.Client (GrpcClientErr (..)) @@ -134,6 +135,7 @@ serveOutward env port = do Polysemy.Error ServerError, Polysemy.Reader RunSettings, Polysemy.Input TLSSettings, + Polysemy.Resource, Embed IO, Embed Federator ] @@ -143,6 +145,7 @@ serveOutward env port = do runAppT env . runM -- Embed Federator . embedToMonadIO @Federator -- Embed IO + . Polysemy.runResource -- Resource . Polysemy.runInputSem (embed @IO (readIORef (view tls env))) -- Input TLSSettings . Polysemy.runReader (view runSettings env) -- Reader RunSettings . absorbServerError diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index b305c8857a3..1fe137d8035 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -28,6 +28,7 @@ module Federator.Remote where import Control.Lens ((^.)) +import Control.Monad.Except import Data.Default (def) import Data.Domain (Domain, domainText) import Data.String.Conversions (cs) @@ -42,12 +43,14 @@ import Mu.GRpc.Client.Optics (GRpcReply) import Mu.GRpc.Client.Record (GRpcMessageProtocol (MsgProtoBuf)) import Mu.GRpc.Client.TyApps (gRpcCall) import Network.GRPC.Client.Helpers +import Network.HTTP2.Client.Exceptions import Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Polysemy import qualified Polysemy.Error as Polysemy import qualified Polysemy.Input as Polysemy import qualified Polysemy.Reader as Polysemy +import qualified Polysemy.Resource as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log import qualified System.Logger.Message as Log @@ -72,7 +75,8 @@ interpretRemote :: DiscoverFederator, TinyLog, Polysemy.Reader RunSettings, - Polysemy.Input TLSSettings + Polysemy.Input TLSSettings, + Polysemy.Resource ] r => Sem (Remote ': r) a -> @@ -82,8 +86,8 @@ interpretRemote = interpret $ \case target <- Polysemy.mapError (RemoteErrorDiscoveryFailure vDomain) $ discoverFederatorWithError vDomain - client <- mkGrpcClient target - callInward client vRequest + Polysemy.bracket (mkGrpcClient target) (closeGrpcClient target) $ \client -> + callInward client vRequest callInward :: MonadIO m => GrpcClient -> Request -> m (GRpcReply InwardResponse) callInward client request = @@ -154,6 +158,20 @@ mkGrpcClient target@(SrvTarget host port) = do . Polysemy.fromEither =<< Polysemy.fromExceptionVia (RemoteErrorTLSException target) (createGrpcClient cfg') +closeGrpcClient :: + Members '[Embed IO, Polysemy.Error RemoteError] r => + SrvTarget -> + GrpcClient -> + Sem r () +closeGrpcClient target = + Polysemy.mapError handle + . Polysemy.fromEitherM + . runExceptT + . close + where + handle :: ClientError -> RemoteError + handle = RemoteErrorClientFailure target . grpcClientError Nothing + logRemoteErrors :: Members '[Polysemy.Error RemoteError, TinyLog] r => Sem r x -> From 78645cb8d9bdad8c868a2e27734c01ccf530dc5e Mon Sep 17 00:00:00 2001 From: jschaul Date: Tue, 19 Oct 2021 16:09:08 +0200 Subject: [PATCH 33/88] Allow using kind cluster with imagePullPolicy=Never (#1862) * Allow using kind cluster with imagePullPolicy=Never drive-by fix: create namespace if it doesn't exist yet * Update helm version in nix-shell to fit version used elsewhere * set kind kubeconfig permissions correctly * fixup helmfile * Hi CI --- Makefile | 5 +++-- changelog.d/5-internal/reenable-kind | 1 + hack/bin/integration-setup-federation.sh | 3 ++- hack/bin/integration-setup.sh | 3 ++- hack/helm_vars/wire-server/kind-values.yaml | 22 ------------------- .../{values.yaml => values.yaml.gotmpl} | 22 +++++++++---------- hack/helmfile-single.yaml | 2 +- hack/helmfile.yaml | 13 +++++++++-- shell.nix | 10 ++++----- 9 files changed, 36 insertions(+), 45 deletions(-) create mode 100644 changelog.d/5-internal/reenable-kind delete mode 100644 hack/helm_vars/wire-server/kind-values.yaml rename hack/helm_vars/wire-server/{values.yaml => values.yaml.gotmpl} (92%) diff --git a/Makefile b/Makefile index 96f406dc6c8..465c03ca2d0 100644 --- a/Makefile +++ b/Makefile @@ -403,6 +403,7 @@ kind-reset: kind-delete kind-cluster .local/kind-kubeconfig: mkdir -p $(CURDIR)/.local kind get kubeconfig --name $(KIND_CLUSTER_NAME) > $(CURDIR)/.local/kind-kubeconfig + chmod 0600 $(CURDIR)/.local/kind-kubeconfig # This guard is a fail-early way to save needing to debug nginz container not # starting up in the second namespace of the kind cluster in some cases. Error @@ -429,11 +430,11 @@ guard-inotify: .PHONY: kind-integration-setup kind-integration-setup: guard-inotify .local/kind-kubeconfig - ENABLE_KIND_VALUES="1" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-setup + HELMFILE_ENV="kind" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-setup .PHONY: kind-integration-test kind-integration-test: .local/kind-kubeconfig - ENABLE_KIND_VALUES="1" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-test + HELMFILE_ENV="kind" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-test kind-integration-e2e: .local/kind-kubeconfig cd services/brig && KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig ./federation-tests.sh $(NAMESPACE) diff --git a/changelog.d/5-internal/reenable-kind b/changelog.d/5-internal/reenable-kind new file mode 100644 index 00000000000..118fbbad0a2 --- /dev/null +++ b/changelog.d/5-internal/reenable-kind @@ -0,0 +1 @@ +Update helm to 3.6.3 in developer tooling (nix-shell) diff --git a/hack/bin/integration-setup-federation.sh b/hack/bin/integration-setup-federation.sh index f78febbf5e0..a8f02904977 100755 --- a/hack/bin/integration-setup-federation.sh +++ b/hack/bin/integration-setup-federation.sh @@ -5,6 +5,7 @@ set -euo pipefail DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." export NAMESPACE=${NAMESPACE:-test-integration} +HELMFILE_ENV=${HELMFILE_ENV:-default} CHARTS_DIR="${TOP_LEVEL}/.local/charts" . "$DIR/helm_overrides.sh" @@ -38,7 +39,7 @@ export FEDERATION_DOMAIN_2="federation-test-helper.$FEDERATION_DOMAIN_BASE" echo "Installing charts..." -helmfile --file ${TOP_LEVEL}/hack/helmfile.yaml sync +helmfile --environment "$HELMFILE_ENV" --file "${TOP_LEVEL}/hack/helmfile.yaml" sync # wait for fakeSNS to create resources. TODO, cleaner: make initiate-fake-aws-sns a post hook. See cassandra-migrations chart for an example. resourcesReady() { diff --git a/hack/bin/integration-setup.sh b/hack/bin/integration-setup.sh index 267c712a99b..991efc43451 100755 --- a/hack/bin/integration-setup.sh +++ b/hack/bin/integration-setup.sh @@ -5,6 +5,7 @@ set -euo pipefail DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." export NAMESPACE=${NAMESPACE:-test-integration} +HELMFILE_ENV=${HELMFILE_ENV:-default} CHARTS_DIR="${TOP_LEVEL}/.local/charts" . "$DIR/helm_overrides.sh" @@ -24,7 +25,7 @@ export FEDERATION_DOMAIN="federation-test-helper.$FEDERATION_DOMAIN_BASE" echo "Installing charts..." -helmfile --file "${TOP_LEVEL}/hack/helmfile-single.yaml" sync +helmfile --environment "$HELMFILE_ENV" --file "${TOP_LEVEL}/hack/helmfile-single.yaml" sync # wait for fakeSNS to create resources. TODO, cleaner: make initiate-fake-aws-sns a post hook. See cassandra-migrations chart for an example. resourcesReady() { diff --git a/hack/helm_vars/wire-server/kind-values.yaml b/hack/helm_vars/wire-server/kind-values.yaml deleted file mode 100644 index b2c077854e9..00000000000 --- a/hack/helm_vars/wire-server/kind-values.yaml +++ /dev/null @@ -1,22 +0,0 @@ -cassandra-migrations: - imagePullPolicy: Never -elasticsearch-index: - imagePullPolicy: Never -brig: - imagePullPolicy: Never -cannon: - imagePullPolicy: Never -cargohold: - imagePullPolicy: Never -galley: - imagePullPolicy: Never -gundeck: - imagePullPolicy: Never -nginz: - imagePullPolicy: Never -proxy: - imagePullPolicy: Never -spar: - imagePullPolicy: Never -federator: - imagePullPolicy: Never diff --git a/hack/helm_vars/wire-server/values.yaml b/hack/helm_vars/wire-server/values.yaml.gotmpl similarity index 92% rename from hack/helm_vars/wire-server/values.yaml rename to hack/helm_vars/wire-server/values.yaml.gotmpl index 7a9fc90a534..c872b4c04a6 100644 --- a/hack/helm_vars/wire-server/values.yaml +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -15,12 +15,12 @@ tags: sftd: false cassandra-migrations: - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} cassandra: host: cassandra-ephemeral replicaCount: 1 elasticsearch-index: - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} elasticsearch: host: elasticsearch-ephemeral index: directory_test @@ -29,7 +29,7 @@ elasticsearch-index: brig: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -106,7 +106,7 @@ brig: enableFederationTests: true cannon: replicaCount: 2 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -115,7 +115,7 @@ cannon: drainTimeout: 0 cargohold: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -130,7 +130,7 @@ cargohold: awsSecretKey: dummysecret galley: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} config: cassandra: host: cassandra-ephemeral @@ -160,7 +160,7 @@ galley: awsSecretKey: dummysecret gundeck: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -188,7 +188,7 @@ gundeck: awsSecretKey: dummysecret nginz: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} nginx_conf: env: staging external_env_domain: zinfra.io @@ -199,7 +199,7 @@ nginz: publicKeys: 0UW38se1yeoc5bVNEvf5LyrHWGZkyvcGTVilK2geGdU= proxy: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} secrets: proxy_config: |- secrets { @@ -211,7 +211,7 @@ proxy: } spar: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -237,7 +237,7 @@ federator: replicaCount: 1 resources: requests: {} - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} config: optSettings: federationStrategy: diff --git a/hack/helmfile-single.yaml b/hack/helmfile-single.yaml index 3adbdf425a1..8d5c81a0413 100644 --- a/hack/helmfile-single.yaml +++ b/hack/helmfile-single.yaml @@ -56,7 +56,7 @@ releases: namespace: '{{ .Values.namespace }}' chart: '../.local/charts/wire-server' values: - - './helm_vars/wire-server/values.yaml' + - './helm_vars/wire-server/values.yaml.gotmpl' - './helm_vars/wire-server/certificates-namespace1.yaml' set: - name: brig.config.optSettings.setFederationDomain diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml index 724a6161465..578cef0d9a4 100644 --- a/hack/helmfile.yaml +++ b/hack/helmfile.yaml @@ -9,6 +9,7 @@ helmDefaults: wait: true timeout: 600 devel: true + createNamespace: true environments: default: @@ -17,6 +18,14 @@ environments: - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN_1" }} - namespaceFed2: {{ requiredEnv "NAMESPACE_2" }} - federationDomainFed2: {{ requiredEnv "FEDERATION_DOMAIN_2" }} + - imagePullPolicy: Always + kind: + values: + - namespace: {{ requiredEnv "NAMESPACE_1" }} + - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN_1" }} + - namespaceFed2: {{ requiredEnv "NAMESPACE_2" }} + - federationDomainFed2: {{ requiredEnv "FEDERATION_DOMAIN_2" }} + - imagePullPolicy: Never repositories: - name: stable @@ -92,7 +101,7 @@ releases: namespace: '{{ .Values.namespace }}' chart: '../.local/charts/wire-server' values: - - './helm_vars/wire-server/values.yaml' + - './helm_vars/wire-server/values.yaml.gotmpl' - './helm_vars/wire-server/certificates-namespace1.yaml' set: - name: brig.config.optSettings.setFederationDomain @@ -104,7 +113,7 @@ releases: namespace: '{{ .Values.namespaceFed2 }}' chart: '../.local/charts/wire-server' values: - - './helm_vars/wire-server/values.yaml' + - './helm_vars/wire-server/values.yaml.gotmpl' - './helm_vars/wire-server/certificates-namespace2.yaml' set: - name: brig.config.optSettings.setFederationDomain diff --git a/shell.nix b/shell.nix index 88bfff74941..334f8007c3d 100644 --- a/shell.nix +++ b/shell.nix @@ -58,13 +58,13 @@ let helm = staticBinaryInTarball { pname = "helm"; - version = "3.1.1"; + version = "3.6.3"; - darwinAmd64Url = "https://get.helm.sh/helm-v3.1.1-darwin-amd64.tar.gz"; - darwinAmd64Sha256 = "2ce00e6c44ba18fbcbec21c493476e919128710d480789bb35bd228ae695cd66"; + darwinAmd64Url = "https://get.helm.sh/helm-v3.6.3-darwin-amd64.tar.gz"; + darwinAmd64Sha256 = "0djjvgla8cw27h8s4y6jby19f74j58byb2vfv590cd03vlbzz8c4"; - linuxAmd64Url = "https://get.helm.sh/helm-v3.1.1-linux-amd64.tar.gz"; - linuxAmd64Sha256 = "cdd7ad304e2615c583dde0ffb0cb38fc1336cd7ce8ff3b5f237434dcadb28c98"; + linuxAmd64Url = "https://get.helm.sh/helm-v3.6.3-linux-amd64.tar.gz"; + linuxAmd64Sha256 = "0qp28fq137b07haz4vsdbc5biagh60dcs29jj70ksqi5k6201h87"; }; helmfile = staticBinary { From 852d8b7c19e857c9e2ec9adc983b8a5f9baa56ed Mon Sep 17 00:00:00 2001 From: jschaul Date: Wed, 20 Oct 2021 10:51:16 +0200 Subject: [PATCH 34/88] disable flaky test in gundeck (#1867) * disable flaky test in gundeck * Hi CI --- services/gundeck/test/unit/ThreadBudget.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/services/gundeck/test/unit/ThreadBudget.hs b/services/gundeck/test/unit/ThreadBudget.hs index b84154e88f4..2d03c388279 100644 --- a/services/gundeck/test/unit/ThreadBudget.hs +++ b/services/gundeck/test/unit/ThreadBudget.hs @@ -143,15 +143,16 @@ mkWatcher tbs logHistory = do tests :: TestTree tests = testGroup "thread budgets" $ - [ testCase "unit test" testThreadBudgets, + [ -- flaky test case as described in https://wearezeta.atlassian.net/browse/BE-527 + -- testCase "unit test" testThreadBudgets, testProperty "qc stm (sequential)" propSequential ] ---------------------------------------------------------------------- -- deterministic unit test -testThreadBudgets :: Assertion -testThreadBudgets = do +_testThreadBudgets :: Assertion +_testThreadBudgets = do let timeUnits n = MilliSeconds $ lengthOfTimeUnit * n lengthOfTimeUnit = 5 -- if you make this larger, the test will run more slowly, and be -- less likely to have timing issues. if you make it too small, some of the calls to From ab296beff74235e647a68d6f5f018f7040ecacfe Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 20 Oct 2021 10:53:34 +0200 Subject: [PATCH 35/88] Check connections when creating group and team convs with remote members (#1870) * Remove unnecessary remote domain from mock federator * Remove unnecessary check for remote users' existence in createConv Since we check for connections, we don't need to also find out if the users exist. * Check remote connections when creating team conv Just like for regular group conversations, do not fetch profiles, and instead check both local and remote connections. Also added failure tests for team conversation creation with unconnected locals or remotes. * Remove opts argument for mock federator * Add CHANGELOG entries Co-authored-by: Paolo Capriotti --- .../5-internal/simplify-mock-federator | 1 + .../6-federation/check-connections-create | 1 + .../src/Wire/API/Federation/Mock.hs | 8 +- .../Test/Wire/API/Federation/ClientSpec.hs | 11 +-- services/brig/test/integration/API/Search.hs | 2 +- .../brig/test/integration/API/User/Util.hs | 4 +- .../brig/test/integration/Federation/Util.hs | 6 +- services/galley/src/Galley/API/Create.hs | 3 +- services/galley/test/integration/API.hs | 81 ++++++++----------- .../galley/test/integration/API/Federation.hs | 20 ++--- .../test/integration/API/MessageTimer.hs | 6 +- services/galley/test/integration/API/Roles.hs | 16 +--- services/galley/test/integration/API/Util.hs | 49 +++++------ 13 files changed, 82 insertions(+), 126 deletions(-) create mode 100644 changelog.d/5-internal/simplify-mock-federator create mode 100644 changelog.d/6-federation/check-connections-create diff --git a/changelog.d/5-internal/simplify-mock-federator b/changelog.d/5-internal/simplify-mock-federator new file mode 100644 index 00000000000..8bbbdcf8ddf --- /dev/null +++ b/changelog.d/5-internal/simplify-mock-federator @@ -0,0 +1 @@ +Simplify mock federator interface by removing unnecessary arguments. diff --git a/changelog.d/6-federation/check-connections-create b/changelog.d/6-federation/check-connections-create new file mode 100644 index 00000000000..4f6f007f1ab --- /dev/null +++ b/changelog.d/6-federation/check-connections-create @@ -0,0 +1 @@ +Check connections when creating group and team conversations with remote members. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs b/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs index 54c02573299..f3afde0400b 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs @@ -87,7 +87,7 @@ stopMockFederator ref = flushState :: IORef MockState -> IO () flushState = flip modifyIORef $ \s -> s {receivedRequests = [], effectfulResponse = error "No mock response provided"} -initState :: Domain -> Domain -> MockState +initState :: Domain -> MockState initState = MockState [] (error "No mock response provided") (error "server not started") (error "No port selected yet") -- | Run an action with access to a mock federator. @@ -113,15 +113,16 @@ withMockFederator ref resp action = do withMockFederatorClient :: (MonadIO m, MonadMask m) => + Domain -> IORef MockState -> (FederatedRequest -> ServerErrorIO OutwardResponse) -> FederatorClient component (ExceptT e m) a -> ExceptT String m (Either e a, ReceivedRequests) -withMockFederatorClient ref resp action = withMockFederator ref resp $ \st -> do +withMockFederatorClient target ref resp action = withMockFederator ref resp $ \st -> do let cfg = grpcClientConfigSimple "127.0.0.1" (fromInteger (serverPort st)) False client <- fmapLT (Text.unpack . reason) (ExceptT (createGrpcClient cfg)) lift . runExceptT $ - runFederatorClientWith client (stateTarget st) (stateOrigin st) action + runFederatorClientWith client target (stateOrigin st) action -- | Like 'withMockFederator', but spawn a new instance of the mock federator -- just for this action. @@ -157,7 +158,6 @@ data MockState = MockState effectfulResponse :: FederatedRequest -> ServerErrorIO OutwardResponse, serverThread :: Async.Async (), serverPort :: Integer, - stateTarget :: Domain, stateOrigin :: Domain } diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs index 4dd1e784abb..8ea3f3e1cfd 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs @@ -38,9 +38,10 @@ import Wire.API.User (UserProfile) spec :: Spec spec = do + let target = Domain "target.example.com" stateRef <- runIO . newIORef $ - initState (Domain "target.example.com") (Domain "origin.example.com") + initState (Domain "origin.example.com") beforeAll (assertRightT (startMockFederator stateRef)) . afterAll_ (stopMockFederator stateRef) . before_ (flushState stateRef) @@ -50,7 +51,7 @@ spec = do expectedResponse :: Maybe UserProfile <- generate arbitrary (actualResponse, sentRequests) <- - assertRightT . withMockFederatorClient stateRef (const (mkSuccessResponse expectedResponse)) $ + assertRightT . withMockFederatorClient target stateRef (const (mkSuccessResponse expectedResponse)) $ Brig.getUserByHandle Brig.clientRoutes handle sentRequests `shouldBe` [FederatedRequest "target.example.com" (Just $ Request Brig "/federation/get-user-by-handle" (LBS.toStrict (Aeson.encode handle)) "origin.example.com")] @@ -61,7 +62,7 @@ spec = do someErr <- generate arbitrary (actualResponse, _) <- - assertRightT . withMockFederatorClient stateRef (const (mkErrorResponse someErr)) $ + assertRightT . withMockFederatorClient target stateRef (const (mkErrorResponse someErr)) $ Brig.getUserByHandle Brig.clientRoutes handle first fedFailError actualResponse @@ -71,7 +72,7 @@ spec = do handle <- generate arbitrary (actualResponse, _) <- - assertRightT . withMockFederatorClient stateRef (error "some IO error!") $ + assertRightT . withMockFederatorClient target stateRef (error "some IO error!") $ Brig.getUserByHandle Brig.clientRoutes handle case actualResponse of @@ -86,7 +87,7 @@ spec = do handle <- generate arbitrary (actualResponse, _) <- - assertRightT . withMockFederatorClient stateRef (const (throwError $ Mu.ServerError Mu.NotFound "Just testing")) $ + assertRightT . withMockFederatorClient target stateRef (const (throwError $ Mu.ServerError Mu.NotFound "Just testing")) $ Brig.getUserByHandle Brig.clientRoutes handle first fedFailError actualResponse diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 301f4d7c60a..1febe169a7d 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -450,7 +450,7 @@ testSearchOtherDomain opts brig = do -- a mocked federator started and stopped during this test otherSearchResult :: [Contact] <- liftIO $ generate arbitrary let mockResponse = OutwardResponseBody (cs $ Aeson.encode otherSearchResult) - (results, _) <- liftIO . withTempMockFederator opts (Domain "non-existent.example.com") mockResponse $ do + (results, _) <- liftIO . withTempMockFederator opts mockResponse $ do executeSearchWithDomain brig (userId user) "someSearchText" (Domain "non-existent.example.com") let expectedResult = SearchResult diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 77cfd2e45a4..c72a8181287 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -361,7 +361,7 @@ sendConnectionAction brig opts uid1 quid2 reaction expectedRel = do let mockConnectionResponse = F.NewConnectionResponseOk reaction mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) (res, reqs) <- - liftIO . withTempMockFederator opts (qDomain quid2) mockResponse $ + liftIO . withTempMockFederator opts mockResponse $ postConnectionQualified brig uid1 quid2 liftIO $ do @@ -388,7 +388,7 @@ sendConnectionUpdateAction brig opts uid1 quid2 reaction expectedRel = do let mockConnectionResponse = F.NewConnectionResponseOk reaction mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) void $ - liftIO . withTempMockFederator opts (qDomain quid2) mockResponse $ + liftIO . withTempMockFederator opts mockResponse $ putConnectionQualified brig uid1 quid2 expectedRel !!! const 200 === statusCode assertConnectionQualified brig uid1 quid2 expectedRel diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index 2fc0616bfd2..9566c994d19 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -84,8 +84,8 @@ withMockFederator opts ref resp action = assertRightT } withSettingsOverrides opts' action -withTempMockFederator :: Opt.Opts -> Domain -> OutwardResponse -> Session a -> IO (a, Mock.ReceivedRequests) -withTempMockFederator opts targetDomain resp action = assertRightT +withTempMockFederator :: Opt.Opts -> OutwardResponse -> Session a -> IO (a, Mock.ReceivedRequests) +withTempMockFederator opts resp action = assertRightT . Mock.withTempMockFederator st0 (const (pure resp)) $ \st -> lift $ do let opts' = @@ -95,7 +95,7 @@ withTempMockFederator opts targetDomain resp action = assertRightT } withSettingsOverrides opts' action where - st0 = Mock.initState targetDomain (Domain "example.com") + st0 = Mock.initState (Domain "example.com") generateClientPrekeys :: Brig -> [(Prekey, LastPrekey)] -> Http (Qualified UserId, [ClientPrekey]) generateClientPrekeys brig prekeys = do diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index ccd977b2670..a23e127b57e 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -101,7 +101,6 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do let allUsers = newConvMembers lusr body checkedUsers <- checkedConvSize allUsers ensureConnected lusr allUsers - checkRemoteUsersExist (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- Data.createConversation @@ -146,7 +145,7 @@ createTeamGroupConv zusr zcon tinfo body = do -- Team members are always considered to be connected, so we only check -- 'ensureConnected' for non-team-members. ensureConnectedToLocals zusr (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) - checkRemoteUsersExist (ulRemotes allUsers) + ensureConnectedToRemotes lusr (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) conv <- Data.createConversation diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 82036ae0ad2..4fc812f8977 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -141,8 +141,8 @@ tests s = test s "fail to create conversation when blocked" postConvFailBlocked, test s "fail to create conversation when blocked by qualified member" postConvQualifiedFailBlocked, test s "fail to create conversation with remote users when remote user is not connected" postConvQualifiedNoConnection, + test s "fail to create team conversation with remote users when remote user is not connected" postTeamConvQualifiedNoConnection, test s "fail to create conversation with remote users when remote user's domain doesn't exist" postConvQualifiedNonExistentDomain, - -- test s "fail to create conversation with remote users when remote user doesn't exist" postConvQualifiedNonExistentUser, test s "fail to create conversation with remote users when federation not configured" postConvQualifiedFederationNotEnabled, test s "create self conversation" postSelfConvOk, test s "create 1:1 conversation" postO2OConvOk, @@ -542,8 +542,6 @@ postMessageQualifiedLocalOwningBackendSuccess = do -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile deeRemote (Name "Dee")] aliceUnqualified defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp @@ -616,8 +614,6 @@ postMessageQualifiedLocalOwningBackendMissingClients = do -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile deeRemote (Name "Dee")] aliceUnqualified defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp @@ -688,8 +684,6 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile deeRemote (Name "Dee")] aliceUnqualified defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp @@ -781,8 +775,6 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile deeRemote (Name "Dee")] aliceUnqualified defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp @@ -908,8 +900,6 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile deeRemote (Name "Dee")] aliceUnqualified defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp @@ -1190,14 +1180,13 @@ testAccessUpdateGuestRemoved = do -- dee is a remote guest let remoteDomain = Domain "far-away.example.com" dee <- Qualified <$> randomId <*> pure remoteDomain - let deeProfile = mkProfile dee (Name "dee") + + connectWithRemoteUser (qUnqualified alice) dee -- they are all in a local conversation conv <- responseJsonError =<< postConvWithRemoteUsers - remoteDomain - [deeProfile] (qUnqualified alice) defNewConv { newConvQualifiedUsers = [bob, charlie, dee], @@ -1208,8 +1197,7 @@ testAccessUpdateGuestRemoved = do c <- view tsCannon WS.bracketRN c (map qUnqualified [alice, bob, charlie]) $ \[wsA, wsB, wsC] -> do -- conversation access role changes to team only - opts <- view tsGConf - (_, reqs) <- withTempMockFederator opts remoteDomain (const ()) $ do + (_, reqs) <- withTempMockFederator (const ()) $ do putQualifiedAccessUpdate (qUnqualified alice) (cnvQualifiedId conv) @@ -1589,6 +1577,26 @@ postConvQualifiedNoConnection = do postConvQualified alice defNewConv {newConvQualifiedUsers = [bob]} !!! const 403 === statusCode +postTeamConvQualifiedNoConnection :: TestM () +postTeamConvQualifiedNoConnection = do + (tid, alice, _) <- createBindingTeamWithQualifiedMembers 1 + bob <- randomQualifiedId (Domain "bob.example.com") + charlie <- randomQualifiedUser + postConvQualified + (qUnqualified alice) + defNewConv + { newConvQualifiedUsers = [bob], + newConvTeam = Just (ConvTeamInfo tid False) + } + !!! const 403 === statusCode + postConvQualified + (qUnqualified alice) + defNewConv + { newConvQualifiedUsers = [charlie], + newConvTeam = Just (ConvTeamInfo tid False) + } + !!! const 403 === statusCode + postConvQualifiedNonExistentDomain :: TestM () postConvQualifiedNonExistentDomain = do alice <- randomUser @@ -1873,9 +1881,8 @@ testAddRemoteMember = do connectWithRemoteUser alice remoteBob - opts <- view tsGConf (resp, reqs) <- - withTempMockFederator opts remoteDomain (respond remoteBob) $ + withTempMockFederator (respond remoteBob) $ postQualifiedMembers alice (remoteBob :| []) convId do let success = pure . F.OutwardResponseBody . LBS.toStrict . encode case F.domain fedReq of @@ -2319,16 +2319,13 @@ deleteLocalMemberConvLocalQualifiedOk = do convId <- decodeConvId <$> postConvWithRemoteUsers - remoteDomain - [mkProfile qEve (Name "Eve")] alice defNewConv {newConvQualifiedUsers = [qBob, qEve]} let qconvId = Qualified convId localDomain - opts <- view tsGConf let mockReturnEve = onlyMockedFederatedBrigResponse [(qEve, "Eve")] (respDel, fedRequests) <- - withTempMockFederator opts remoteDomain mockReturnEve $ + withTempMockFederator mockReturnEve $ deleteMemberQualified alice qBob qconvId let [galleyFederatedRequest] = fedRequestsForDomain remoteDomain F.Galley fedRequests assertRemoveUpdate galleyFederatedRequest qconvId qAlice [qUnqualified qEve] qBob @@ -2363,7 +2360,6 @@ deleteRemoteMemberConvLocalQualifiedOk = do connectUsers alice (singleton bob) mapM_ (connectWithRemoteUser alice) [qChad, qDee, qEve] - opts <- view tsGConf let mockedResponse fedReq = do let success :: ToJSON a => a -> IO F.OutwardResponse success = pure . F.OutwardResponseBody . LBS.toStrict . encode @@ -2378,7 +2374,7 @@ deleteRemoteMemberConvLocalQualifiedOk = do _ -> success () (convId, _) <- - withTempMockFederator' opts remoteDomain1 mockedResponse $ + withTempMockFederator' mockedResponse $ fmap decodeConvId $ postConvQualified alice @@ -2387,7 +2383,7 @@ deleteRemoteMemberConvLocalQualifiedOk = do let qconvId = Qualified convId localDomain (respDel, federatedRequests) <- - withTempMockFederator' opts remoteDomain1 mockedResponse $ + withTempMockFederator' mockedResponse $ deleteMemberQualified alice qChad qconvId liftIO $ do statusCode respDel @?= 200 @@ -2428,10 +2424,9 @@ leaveRemoteConvQualifiedOk = do joinMockedFederatedResponses (mockedFederatedBrigResponse [(qBob, "Bob")]) mockedFederatedGalleyResponse - opts <- view tsGConf (resp, fedRequests) <- - withTempMockFederator opts remoteDomain mockResponses $ + withTempMockFederator mockResponses $ deleteMemberQualified alice qAlice qconv let leaveRequest = fromJust . decodeStrict . F.body . fromJust . F.request . Imports.head $ @@ -2532,17 +2527,14 @@ putQualifiedConvRenameWithRemotesOk = do resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile qalice (Name "Alice")] bob defNewConv {newConvQualifiedUsers = [qalice]} do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putQualifiedConversationName bob qconv "gossip++" !!! const 200 === statusCode req <- assertOne requests @@ -2856,11 +2848,8 @@ putRemoteConvMemberOk update = do roleNameWireMember [localMemberToOther remoteDomain bobAsLocal] remoteConversationResponse = GetConversationsResponse [mockConversation] - opts <- view tsGConf (rs, _) <- withTempMockFederator - opts - remoteDomain (const remoteConversationResponse) $ getConvQualified alice qconv do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putQualifiedReceiptMode bob qconv (ReceiptMode 43) !!! const 200 === statusCode req <- assertOne requests @@ -3032,9 +3018,8 @@ removeUser = do FederatedGalley.onConversationCreated fedGalleyClient remoteDomain nc WS.bracketR3 c alice' bob' carl' $ \(wsA, wsB, wsC) -> do - opts <- view tsGConf (_, fedRequests) <- - withTempMockFederator opts remoteDomain (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ + withTempMockFederator (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ deleteUser bob' !!! const 200 === statusCode req <- assertOne fedRequests diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index c2cb673e5e6..2217ba41e15 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -94,8 +94,6 @@ getConversationsAllFound = do cnv2 <- responseJsonError =<< postConvWithRemoteUsers - (qDomain aliceQ) - [mkProfile aliceQ (Name "alice")] bob defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} @@ -560,7 +558,6 @@ leaveConversationSuccess = do connectWithRemoteUser alice qDee connectWithRemoteUser alice qEve - opts <- view tsGConf let mockedResponse fedReq = do let success :: ToJSON a => a -> IO F.OutwardResponse success = pure . F.OutwardResponseBody . LBS.toStrict . A.encode @@ -575,7 +572,7 @@ leaveConversationSuccess = do _ -> success () (convId, _) <- - withTempMockFederator' opts remoteDomain1 mockedResponse $ + withTempMockFederator' mockedResponse $ decodeConvId <$> postConvQualified alice @@ -586,7 +583,7 @@ leaveConversationSuccess = do (_, federatedRequests) <- WS.bracketR2 c alice bob $ \(wsAlice, wsBob) -> do - withTempMockFederator' opts remoteDomain1 mockedResponse $ do + withTempMockFederator' mockedResponse $ do g <- viewGalley let leaveRequest = FedGalley.LeaveConversationRequest convId (qUnqualified qChad) respBS <- @@ -695,7 +692,7 @@ onMessageSent = do -- alice local, bob and chad remote in a local conversation -- bob sends a message (using the RPC), we test that alice receives it and that -- a call is made to the onMessageSent RPC to inform chad -sendMessage :: HasCallStack => TestM () +sendMessage :: TestM () sendMessage = do cannon <- view tsCannon let remoteDomain = Domain "far-away.example.com" @@ -716,13 +713,12 @@ sendMessage = do connectWithRemoteUser aliceId bob connectWithRemoteUser aliceId chad -- conversation - opts <- view tsGConf let responses1 req | fmap F.component (F.request req) == Just F.Brig = toJSON [bobProfile, chadProfile] | otherwise = toJSON () (convId, requests1) <- - withTempMockFederator opts remoteDomain responses1 $ + withTempMockFederator responses1 $ fmap decodeConvId $ postConvQualified aliceId @@ -732,11 +728,9 @@ sendMessage = do pure xs + [galleyReq] <- case requests1 of + xs@[_] -> pure xs _ -> assertFailure "unexpected number of requests" - fmap F.component (F.request brigReq) @?= Just F.Brig - fmap F.path (F.request brigReq) @?= Just "/federation/get-users-by-ids" fmap F.component (F.request galleyReq) @?= Just F.Galley fmap F.path (F.request galleyReq) @?= Just "/federation/on-conversation-created" let conv = Qualified convId localDomain @@ -766,7 +760,7 @@ sendMessage = do ] ) | otherwise = toJSON () - (_, requests2) <- withTempMockFederator opts remoteDomain responses2 $ do + (_, requests2) <- withTempMockFederator responses2 $ do WS.bracketR cannon aliceId $ \ws -> do g <- viewGalley msresp <- diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index d7b435cc24a..ddaf4828f30 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -49,7 +49,6 @@ import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Galley as F import qualified Wire.API.Federation.GRPC.Types as F import qualified Wire.API.Team.Member as Member -import Wire.API.User.Profile (Name (..)) tests :: IO TestSetup -> TestTree tests s = @@ -153,16 +152,13 @@ messageTimerChangeWithRemotes = do resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile qalice (Name "Alice")] bob defNewConv {newConvQualifiedUsers = [qalice]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf WS.bracketR c bob $ \wsB -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putMessageTimerUpdateQualified bob qconv (ConversationMessageTimerUpdate timer1sec) !!! const 200 === statusCode diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index a90682dd957..da7fb3861a7 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -44,7 +44,6 @@ import TestSetup import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Galley as F import qualified Wire.API.Federation.GRPC.Types as F -import Wire.API.User tests :: IO TestSetup -> TestTree tests s = @@ -170,16 +169,13 @@ roleUpdateRemoteMember = do traverse_ (connectWithRemoteUser bob) [qalice, qcharlie] resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile qalice (Name "Alice"), mkProfile qcharlie (Name "Charlie")] bob defNewConv {newConvQualifiedUsers = [qalice, qcharlie]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf WS.bracketR c bob $ \wsB -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putOtherMemberQualified bob qcharlie @@ -242,16 +238,13 @@ roleUpdateWithRemotes = do connectWithRemoteUser bob qalice resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile qalice (Name "Alice")] bob defNewConv {newConvQualifiedUsers = [qalice, qcharlie]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf WS.bracketR2 c bob charlie $ \(wsB, wsC) -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putOtherMemberQualified bob qcharlie @@ -303,17 +296,14 @@ accessUpdateWithRemotes = do connectWithRemoteUser bob qalice resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile qalice (Name "Alice")] bob defNewConv {newConvQualifiedUsers = [qalice, qcharlie]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf let access = ConversationAccessData (Set.singleton CodeAccess) NonActivatedAccessRole WS.bracketR2 c bob charlie $ \(wsB, wsC) -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putQualifiedAccessUpdate bob qconv access !!! const 200 === statusCode diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index a310a1b744d..6cbaadd04f5 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -130,12 +130,15 @@ import Wire.API.User.Identity (mkSimpleSampleUref) -- | A class for monads with access to a Galley instance class HasGalley m where viewGalley :: m GalleyR + viewGalleyOpts :: m Opts.Opts instance HasGalley TestM where viewGalley = view tsGalley + viewGalleyOpts = view tsGConf instance (HasGalley m, Monad m) => HasGalley (SessionT m) where viewGalley = lift viewGalley + viewGalleyOpts = lift viewGalleyOpts symmPermissions :: [Perm] -> Permissions symmPermissions p = let s = Set.fromList p in fromJust (newPermissions s s) @@ -565,24 +568,15 @@ postConvQualified u n = do postConvWithRemoteUsers :: HasCallStack => - Domain -> - [UserProfile] -> UserId -> NewConv -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUsers remoteDomain profiles u n = do - opts <- view tsGConf +postConvWithRemoteUsers u n = do fmap fst $ - withTempMockFederator opts remoteDomain respond $ + withTempMockFederator (const ()) $ postConvQualified u n {newConvName = setName (newConvName n)} Value - respond req - | fmap F.component (F.request req) == Just F.Brig = - toJSON profiles - | otherwise = toJSON () - setName :: Maybe Text -> Maybe Text setName Nothing = Just "federated gossip" setName x = x @@ -685,8 +679,7 @@ postProteusMessageQualifiedWithMockFederator :: TestM (ResponseLBS, Mock.ReceivedRequests) postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat brigApi galleyApi = do localDomain <- viewFederationDomain - opts <- view tsGConf - withTempServantMockFederator opts brigApi galleyApi localDomain (Domain "far-away.example.com") $ + withTempServantMockFederator brigApi galleyApi localDomain $ postProteusMessageQualified senderUser senderClient convId recipients dat strat postProteusMessageQualified :: @@ -2174,43 +2167,39 @@ mkProfile quid name = -- expected request. withTempMockFederator :: (MonadIO m, ToJSON a, HasGalley m, MonadMask m) => - Opts.Opts -> - Domain -> (FederatedRequest -> a) -> SessionT m b -> m (b, Mock.ReceivedRequests) -withTempMockFederator opts targetDomain resp = withTempMockFederator' opts targetDomain (pure . oresp) +withTempMockFederator resp = withTempMockFederator' (pure . oresp) where oresp = OutwardResponseBody . Lazy.toStrict . encode . resp withTempMockFederator' :: (MonadIO m, HasGalley m, MonadMask m) => - Opts.Opts -> - Domain -> (FederatedRequest -> IO F.OutwardResponse) -> SessionT m b -> m (b, Mock.ReceivedRequests) -withTempMockFederator' opts targetDomain resp action = assertRightT - . Mock.withTempMockFederator st0 (lift . resp) - $ \st -> lift $ do - let opts' = - opts & Opts.optFederator - ?~ Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort st)) - withSettingsOverrides opts' action +withTempMockFederator' resp action = do + opts <- viewGalleyOpts + assertRightT + . Mock.withTempMockFederator st0 (lift . resp) + $ \st -> lift $ do + let opts' = + opts & Opts.optFederator + ?~ Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort st)) + withSettingsOverrides opts' action where - st0 = Mock.initState targetDomain (Domain "example.com") + st0 = Mock.initState (Domain "example.com") withTempServantMockFederator :: (MonadMask m, MonadIO m, HasGalley m) => - Opts.Opts -> FederatedBrig.Api (AsServerT Handler) -> FederatedGalley.Api (AsServerT Handler) -> Domain -> - Domain -> SessionT m b -> m (b, Mock.ReceivedRequests) -withTempServantMockFederator opts brigApi galleyApi originDomain targetDomain = - withTempMockFederator' opts targetDomain mock +withTempServantMockFederator brigApi galleyApi originDomain = + withTempMockFederator' mock where server :: ServerT (ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api) Handler server = genericServerT brigApi :<|> genericServerT galleyApi From 0aa86a7ac0b7217033211ad4405b84a14a97709b Mon Sep 17 00:00:00 2001 From: jschaul Date: Wed, 20 Oct 2021 16:09:40 +0200 Subject: [PATCH 36/88] minor Readme: document usage of helm charts (#1307) --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 992c2e30746..f5d86ab3e72 100644 --- a/README.md +++ b/README.md @@ -63,8 +63,8 @@ It also contains - **build**: Build scripts and Dockerfiles for some platforms - **deploy**: (Work-in-progress) - how to run wire-server in an ephemeral, in-memory demo mode - **doc**: Documentation -- **hack**: scripts and configuration for kubernetes helm chart development/releases mainly used by CI -- **charts**: kubernetes helm charts +- **hack**: scripts and configuration for kuberentes helm chart development/releases mainly used by CI +- **charts**: Kubernetes Helm charts. The charts are mirroed to S3 and can be used with `helm repo add wire https://s3-eu-west-1.amazonaws.com/public.wire.com/charts`. See the [Administrator's Guide](https://docs.wire.com) for more info. ## Architecture Overview From edbf52c0634007a490b5e7f8afc3a444a67f32b7 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 20 Oct 2021 16:56:50 +0200 Subject: [PATCH 37/88] Support deleting conversations with federated users (#1861) * Refactor: Use pushConversationEvent * add onConversationDeleted RPC * deleteTeamConversation: rpc onConversationDeleted * Data.deleteConversation: remove remotes * add changelog entry * wire-api: extend ConversationAction * onConversationDeleted -> onConversationUpdated * fix compilation * remove duplicated import * cosmetic change * fix call to withTempServantMockFederator --- changelog.d/6-federation/delete-conversations | 1 + .../src/Wire/API/Conversation/Action.hs | 4 ++ services/galley/src/Galley/API/Federation.hs | 3 ++ services/galley/src/Galley/API/Teams.hs | 22 ++------- services/galley/src/Galley/API/Update.hs | 17 +++++++ services/galley/src/Galley/API/Util.hs | 15 +++++- services/galley/src/Galley/Data.hs | 13 +++-- services/galley/test/integration/API.hs | 49 ++++++++++++++++++- .../galley/test/integration/API/Federation.hs | 49 +++++++++++++++++++ services/galley/test/integration/API/Teams.hs | 23 +++------ services/galley/test/integration/API/Util.hs | 10 ++++ 11 files changed, 167 insertions(+), 39 deletions(-) create mode 100644 changelog.d/6-federation/delete-conversations diff --git a/changelog.d/6-federation/delete-conversations b/changelog.d/6-federation/delete-conversations new file mode 100644 index 00000000000..6fcac46d765 --- /dev/null +++ b/changelog.d/6-federation/delete-conversations @@ -0,0 +1 @@ +Support deleting conversations with federated users diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index 855376d8528..a7bf22c23b2 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -44,6 +44,7 @@ data ConversationAction | ConversationActionReceiptModeUpdate ConversationReceiptModeUpdate | ConversationActionMemberUpdate (Qualified UserId) OtherMemberUpdate | ConversationActionAccessUpdate ConversationAccessData + | ConversationActionDelete deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform ConversationAction) deriving (ToJSON, FromJSON) via (CustomEncoded ConversationAction) @@ -71,6 +72,8 @@ conversationActionToEvent now quid qcnv (ConversationActionMemberUpdate target ( in Event MemberStateUpdate qcnv quid now (EdMemberUpdate update) conversationActionToEvent now quid qcnv (ConversationActionAccessUpdate update) = Event ConvAccessUpdate qcnv quid now (EdConvAccessUpdate update) +conversationActionToEvent now quid qcnv ConversationActionDelete = + Event ConvDelete qcnv quid now EdConvDelete conversationActionTag :: Qualified UserId -> ConversationAction -> Action conversationActionTag _ (ConversationActionAddMembers _ _) = AddConversationMember @@ -82,3 +85,4 @@ conversationActionTag _ (ConversationActionMessageTimerUpdate _) = ModifyConvers conversationActionTag _ (ConversationActionReceiptModeUpdate _) = ModifyConversationReceiptMode conversationActionTag _ (ConversationActionMemberUpdate _ _) = ModifyOtherConversationMember conversationActionTag _ (ConversationActionAccessUpdate _) = ModifyConversationAccess +conversationActionTag _ ConversationActionDelete = DeleteConversation diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 3f1a7f2433b..3870705d46f 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -163,6 +163,9 @@ onConversationUpdated requestingDomain cu = do ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, []) ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, []) ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, []) + ConversationActionDelete -> do + Data.removeLocalMembersFromRemoteConv rconvId presentUsers + pure (Just $ cuAction cu, []) unless allUsersArePresent $ Log.warn $ diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index d0221f3206c..dd1c93e023f 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -82,6 +82,7 @@ import qualified Data.UUID.Util as UUID import Galley.API.Error as Galley import Galley.API.LegalHold import qualified Galley.API.Teams.Notifications as APITeamQueue +import qualified Galley.API.Update as API import Galley.API.Util import Galley.App import qualified Galley.Data as Data @@ -89,7 +90,6 @@ import qualified Galley.Data.LegalHold as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) import qualified Galley.Data.TeamFeatures as TeamFeatures -import qualified Galley.Data.Types as Data import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push @@ -762,22 +762,10 @@ getTeamConversation zusr tid cid = do Data.teamConversation tid cid >>= maybe (throwErrorDescriptionType @ConvNotFound) pure deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley () -deleteTeamConversation zusr zcon tid cid = do - localDomain <- viewFederationDomain - let qconvId = Qualified cid localDomain - qusr = Qualified zusr localDomain - (bots, cmems) <- localBotsAndUsers <$> Data.members cid - ensureActionAllowed Roles.DeleteConversation =<< getSelfMemberFromLocalsLegacy zusr cmems - flip Data.deleteCode Data.ReusableCode =<< Data.mkKey cid - now <- liftIO getCurrentTime - let ce = Conv.Event Conv.ConvDelete qconvId qusr now Conv.EdConvDelete - let recps = fmap recipient cmems - let convPush = newPushLocal ListComplete zusr (ConvEvent ce) recps <&> pushConn .~ Just zcon - pushSome $ maybeToList convPush - void . forkIO $ void $ External.deliver (bots `zip` repeat ce) - -- TODO: we don't delete bots here, but we should do that, since every - -- bot user can only be in a single conversation - Data.removeTeamConv tid cid +deleteTeamConversation zusr zcon _tid cid = do + lusr <- qualifyLocal zusr + lconv <- qualifyLocal cid + void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley Response getSearchVisibilityH (uid ::: tid ::: _) = do diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 618834640f6..ac0f1a5c3b5 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -36,6 +36,7 @@ module Galley.API.Update updateLocalConversation, updateConversationAccessUnqualified, updateConversationAccess, + deleteLocalConversation, -- * Managing Members addMembersUnqualified, @@ -368,6 +369,15 @@ updateLocalConversationMessageTimer lusr con lcnv update = updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMessageTimerUpdate update +deleteLocalConversation :: + Local UserId -> + ConnId -> + Local ConvId -> + Galley (UpdateResult Event) +deleteLocalConversation lusr con lcnv = + getUpdateResult $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete + -- | Update a local conversation, and notify all local and remote members. updateLocalConversation :: Local ConvId -> @@ -435,6 +445,13 @@ performAction qusr conv action = case action of ConversationActionAccessUpdate update -> do performAccessUpdateAction qusr conv update pure (mempty, action) + ConversationActionDelete -> lift $ do + let cid = Data.convId conv + (`Data.deleteCode` ReusableCode) =<< mkKey cid + case Data.convTeam conv of + Nothing -> Data.deleteConversation cid + Just tid -> Data.removeTeamConv tid cid + pure (mempty, action) addCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response addCodeH (usr ::: zcon ::: cnv) = diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 41274df90a6..3b5485c09f4 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -65,7 +65,7 @@ import Wire.API.ErrorDescription import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client (FederationClientFailure, FederatorClient, executeFederated) -import Wire.API.Federation.Error (federationErrorToWai) +import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) import Wire.API.Federation.GRPC.Types (Component (..)) import qualified Wire.API.User as User @@ -162,6 +162,19 @@ ensureConversationActionAllowed action conv self = do -- extra action-specific checks case action of ConversationActionAddMembers _ role -> ensureConvRoleNotElevated self role + ConversationActionDelete -> do + case Data.convTeam conv of + Just tid -> do + foldQualified + loc + ( \lusr -> do + void $ + Data.teamMember tid (tUnqualified lusr) + >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + ) + (\_ -> throwM federationNotImplemented) + (convMemberId loc self) + Nothing -> pure () ConversationActionAccessUpdate target -> do -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and -- so on; users are not supposed to be able to make other conversations diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 65feff542b8..04353e202e9 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -137,7 +137,7 @@ import Data.Id as Id import Data.Json.Util (UTCTimeMillis (..)) import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import qualified Data.List.Extra as List -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List.Split (chunksOf) import qualified Data.Map.Strict as Map import Data.Misc (Milliseconds) @@ -762,8 +762,15 @@ updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessa deleteConversation :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m () deleteConversation cid = do retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) - mm <- members cid - for_ mm $ \m -> removeMember (lmId m) cid + + localMembers <- members cid + for_ (nonEmpty localMembers) $ \ms -> + removeLocalMembersFromLocalConv cid (lmId <$> ms) + + remoteMembers <- lookupRemoteMembers cid + for_ (nonEmpty remoteMembers) $ \ms -> + removeRemoteMembersFromLocalConv cid (rmId <$> ms) + retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) acceptConnect :: MonadClient m => ConvId -> m () diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 4fc812f8977..31e12d7970c 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -87,7 +87,9 @@ import Wire.API.Conversation import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley - ( GetConversationsResponse (..), + ( Api (onConversationUpdated), + ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuOrigUserId), + GetConversationsResponse (..), RemoteConvMembers (..), RemoteConversation (..), ) @@ -163,6 +165,7 @@ tests s = test s "fail to add members when not connected" postMembersFail, test s "fail to add too many members" postTooManyMembersFail, test s "add remote members" testAddRemoteMember, + test s "delete conversation with remote members" testDeleteTeamConversationWithRemoteMembers, test s "get conversations/:domain/:cnv - local" testGetQualifiedLocalConv, test s "get conversations/:domain/:cnv - local, not found" testGetQualifiedLocalConvNotFound, test s "get conversations/:domain/:cnv - local, not participating" testGetQualifiedLocalConvNotParticipating, @@ -1909,6 +1912,50 @@ testAddRemoteMember = do toJSON [mkProfile bob (Name "bob")] | otherwise = toJSON () +testDeleteTeamConversationWithRemoteMembers :: TestM () +testDeleteTeamConversationWithRemoteMembers = do + (alice, tid) <- createBindingTeam + localDomain <- viewFederationDomain + let qalice = Qualified alice localDomain + + bobId <- randomId + let remoteDomain = Domain "far-away.example.com" + remoteBob = Qualified bobId remoteDomain + + convId <- decodeConvId <$> postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing + let _qconvId = Qualified convId localDomain + + connectWithRemoteUser alice remoteBob + + let brigApi = emptyFederatedBrig + galleyApi = + emptyFederatedGalley + { onConversationUpdated = \_domain _update -> pure () + } + + (_, received) <- withTempServantMockFederator brigApi galleyApi localDomain $ do + postQualifiedMembers alice (remoteBob :| []) convId + !!! const 200 === statusCode + + deleteTeamConv tid convId alice + !!! const 200 === statusCode + + liftIO $ do + let convUpdates = mapMaybe parseFedRequest received + convUpdate <- case (filter ((== ConversationActionDelete) . cuAction) convUpdates) of + [] -> assertFailure "No ConversationUpdate requests received" + [convDelete] -> pure convDelete + _ -> assertFailure "Multiple ConversationUpdate requests received" + cuAlreadyPresentUsers convUpdate @?= [bobId] + cuOrigUserId convUpdate @?= qalice + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Maybe a + parseFedRequest fr = + case F.request fr of + Just r -> + (decode . cs) (F.body r) + Nothing -> Nothing + testGetQualifiedLocalConv :: TestM () testGetQualifiedLocalConv = do alice <- randomUser diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 2217ba41e15..5a7941bf2fa 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -75,6 +75,7 @@ tests s = test s "POST /federation/on-conversation-updated : Notify local user about member update" notifyMemberUpdate, test s "POST /federation/on-conversation-updated : Notify local user about receipt mode update" notifyReceiptMode, test s "POST /federation/on-conversation-updated : Notify local user about access update" notifyAccess, + test s "POST /federation/on-conversation-updated : Notify local users about a deleted conversation" notifyDeletedConversation, test s "POST /federation/leave-conversation : Success" leaveConversationSuccess, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, test s "POST /federation/send-message : Post a message sent from another backend" sendMessage @@ -488,6 +489,54 @@ notifyMemberUpdate = do MemberStateUpdate (EdMemberUpdate d) +notifyDeletedConversation :: TestM () +notifyDeletedConversation = do + c <- view tsCannon + + qalice <- randomQualifiedUser + let alice = qUnqualified qalice + + bob <- randomId + conv <- randomId + let bobDomain = Domain "bob.example.com" + qbob = Qualified bob bobDomain + qconv = Qualified conv bobDomain + mkMember quid = OtherMember quid Nothing roleNameWireMember + + mapM_ (`connectWithRemoteUser` qbob) [alice] + registerRemoteConv + qconv + bob + (Just "gossip") + (Set.fromList (map mkMember [qalice])) + + fedGalleyClient <- view tsFedGalleyClient + + do + aliceConvs <- listRemoteConvs bobDomain alice + liftIO $ aliceConvs @?= [qconv] + + WS.bracketR c alice $ \wsAlice -> do + now <- liftIO getCurrentTime + let cu = + FedGalley.ConversationUpdate + { FedGalley.cuTime = now, + FedGalley.cuOrigUserId = qbob, + FedGalley.cuConvId = qUnqualified qconv, + FedGalley.cuAlreadyPresentUsers = [alice], + FedGalley.cuAction = ConversationActionDelete + } + FedGalley.onConversationUpdated fedGalleyClient bobDomain cu + + liftIO $ do + WS.assertMatch_ (5 # Second) wsAlice $ \n -> do + let e = List1.head (WS.unpackPayload n) + ConvDelete @=? evtType e + + do + aliceConvs <- listRemoteConvs bobDomain alice + liftIO $ aliceConvs @?= [] + -- TODO: test adding non-existing users -- TODO: test adding resulting in an empty notification diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index ebc335b9fca..4529b88c4ff 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1161,7 +1161,6 @@ testDeleteBindingTeam ownerHasPassword = do testDeleteTeamConv :: TestM () testDeleteTeamConv = do localDomain <- viewFederationDomain - g <- view tsGalley c <- view tsCannon owner <- Util.randomUser let p = Util.symmPermissions [DoNotUseDeprecatedDeleteConversation] @@ -1179,14 +1178,9 @@ testDeleteTeamConv = do for_ [owner, member ^. userId, extern] $ \u -> Util.assertConvMember u cid1 for_ [owner, member ^. userId] $ \u -> Util.assertConvMember u cid2 WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do - delete - ( g - . paths ["teams", toByteString' tid, "conversations", toByteString' cid2] - . zUser (member ^. userId) - . zConn "conn" - ) - !!! const 200 - === statusCode + deleteTeamConv tid cid2 (member ^. userId) + !!! const 200 === statusCode + -- We no longer send duplicate conv deletion events -- i.e., as both a regular "conversation.delete" to all -- conversation members and as "team.conversation-delete" @@ -1195,14 +1189,9 @@ testDeleteTeamConv = do checkConvDeleteEvent qcid2 wsOwner checkConvDeleteEvent qcid2 wsMember WS.assertNoEvent timeout [wsOwner, wsMember] - delete - ( g - . paths ["teams", toByteString' tid, "conversations", toByteString' cid1] - . zUser (member ^. userId) - . zConn "conn" - ) - !!! const 200 - === statusCode + + deleteTeamConv tid cid1 (member ^. userId) + !!! const 200 === statusCode -- We no longer send duplicate conv deletion events -- i.e., as both a regular "conversation.delete" to all -- conversation members and as "team.conversation-delete" diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 6cbaadd04f5..dbfe877d178 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -587,6 +587,16 @@ postTeamConv tid u us name a r mtimer = do let conv = NewConvUnmanaged $ NewConv us [] name (Set.fromList a) r (Just (ConvTeamInfo tid False)) mtimer Nothing roleNameWireAdmin post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv +deleteTeamConv :: (HasGalley m, MonadIO m, MonadHttp m) => TeamId -> ConvId -> UserId -> m ResponseLBS +deleteTeamConv tid convId zusr = do + g <- viewGalley + delete + ( g + . paths ["teams", toByteString' tid, "conversations", toByteString' convId] + . zUser zusr + . zConn "conn" + ) + postConvWithRole :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> TestM ResponseLBS postConvWithRole u members name access arole timer role = postConvQualified From 5632e0c097fcfbe80f0628f0ea5ef25c8cd37f5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 20 Oct 2021 18:19:59 +0200 Subject: [PATCH 38/88] Remove a leftover TODO that was addressed (#1868) --- libs/wire-api/src/Wire/API/Routes/Public/Brig.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index d275ad368c9..abeb005178a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -117,7 +117,6 @@ data Api routes = Api -- - MemberLeave event to members for all conversations the user was in (via galley) deleteSelf :: routes - -- TODO: Add custom AsUnion :- Summary "Initiate account deletion." :> Description "if the account has a verified identity, a verification \ From af37dfc3bb3ba3d534d16b6fce5ff33021364e7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 21 Oct 2021 09:51:07 +0200 Subject: [PATCH 39/88] In Conversation Endpoints Make the members.self ID Qualified (#1866) * Make the self member's ID qualified * Simplify conversation view functions * Unrelated small change: remove a cycle of qualifying a conversation ID in a test * Introduce qualifyLocal to the BotNet monad --- .../1-api-changes/self-member-id-qualified | 2 + libs/api-bot/src/Network/Wire/Bot/Assert.hs | 8 +-- libs/api-bot/src/Network/Wire/Bot/Monad.hs | 5 ++ .../src/Wire/API/Conversation/Member.hs | 7 +- .../golden/testObject_ConvMembers_user_1.json | 4 ++ .../golden/testObject_ConvMembers_user_2.json | 4 ++ ...onversationList_20Conversation_user_1.json | 4 ++ .../testObject_Conversation_user_1.json | 4 ++ .../testObject_Conversation_user_2.json | 4 ++ .../testObject_ConversationsResponse_1.json | 8 +++ .../test/golden/testObject_Event_user_8.json | 4 ++ .../test/golden/testObject_Member_user_1.json | 4 ++ .../test/golden/testObject_Member_user_2.json | 4 ++ .../API/Golden/Generated/ConvMembers_user.hs | 4 +- .../ConversationList_20Conversation_user.hs | 5 +- .../API/Golden/Generated/Conversation_user.hs | 8 +-- .../Wire/API/Golden/Generated/Event_user.hs | 2 +- .../Wire/API/Golden/Generated/Member_user.hs | 9 ++- .../Golden/Manual/ConversationsResponse.hs | 15 +++-- .../brig/test/integration/API/Provider.hs | 67 +++++++++---------- services/brig/test/integration/Util.hs | 6 +- services/galley/src/Galley/API/Federation.hs | 2 +- services/galley/src/Galley/API/Mapping.hs | 29 ++++---- services/galley/src/Galley/API/Query.hs | 6 +- services/galley/src/Galley/API/Util.hs | 2 +- services/galley/test/integration/API.hs | 57 +++++++++------- .../galley/test/integration/API/Federation.hs | 4 +- .../test/integration/API/MessageTimer.hs | 15 +++-- services/galley/test/integration/API/Roles.hs | 4 +- services/galley/test/integration/API/Teams.hs | 61 ++++++++++------- .../test/integration/API/Teams/LegalHold.hs | 44 ++++++------ services/galley/test/integration/API/Util.hs | 21 ++++-- .../galley/test/unit/Test/Galley/Mapping.hs | 40 +++++------ .../lib/src/Network/Wire/Simulations.hs | 3 +- .../src/Network/Wire/Simulations/SmokeTest.hs | 3 +- 35 files changed, 284 insertions(+), 185 deletions(-) create mode 100644 changelog.d/1-api-changes/self-member-id-qualified diff --git a/changelog.d/1-api-changes/self-member-id-qualified b/changelog.d/1-api-changes/self-member-id-qualified new file mode 100644 index 00000000000..0b7ac33985a --- /dev/null +++ b/changelog.d/1-api-changes/self-member-id-qualified @@ -0,0 +1,2 @@ +The member.self ID in conversation endpoints is qualified and available as +"qualified_id". The old unqualified "id" is still available. diff --git a/libs/api-bot/src/Network/Wire/Bot/Assert.hs b/libs/api-bot/src/Network/Wire/Bot/Assert.hs index 4140b3ff33a..b94a1367c81 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Assert.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Assert.hs @@ -21,7 +21,7 @@ module Network.Wire.Bot.Assert where import Data.Id (ConvId, UserId) -import Data.Qualified (qUnqualified) +import Data.Qualified (Local, QualifiedWithTag (qUntagged), qUnqualified, qualifyAs) import qualified Data.Set as Set import Imports import Network.Wire.Bot.Monad @@ -31,7 +31,7 @@ import Network.Wire.Client.API.User assertConvCreated :: (HasCallStack, MonadBotNet m) => - ConvId -> + Local ConvId -> -- | The creator of the conversation. Bot -> -- | The other users in the conversation. @@ -41,14 +41,14 @@ assertConvCreated c b bs = do let everyone = b : bs forM_ bs $ \u -> let others = Set.fromList . filter (/= botId u) . map botId $ everyone - in assertEvent u TConvCreate (convCreate (botId u) others) + in assertEvent u TConvCreate (convCreate (qUntagged . qualifyAs c . botId $ u) others) where convCreate self others = \case EConvCreate e -> let cnv = convEvtData e mems = cnvMembers cnv omems = Set.fromList (map (qUnqualified . omQualifiedId) (cmOthers mems)) - in (qUnqualified . cnvQualifiedId $ cnv) == c + in cnvQualifiedId cnv == qUntagged c && convEvtFrom e == botId b && cnvType cnv == RegularConv && memId (cmSelf mems) == self diff --git a/libs/api-bot/src/Network/Wire/Bot/Monad.hs b/libs/api-bot/src/Network/Wire/Bot/Monad.hs index 5c78e8b8518..45f65c4e3d4 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Monad.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Monad.hs @@ -88,6 +88,7 @@ module Network.Wire.Bot.Monad BotNetException (..), BotNetFailure (..), try, + qualifyLocal, ) where @@ -104,6 +105,7 @@ import Data.Id import Data.Metrics (Metrics) import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) +import Data.Qualified (Local, toLocalUnsafe) import Data.Text (pack, unpack) import Data.Time.Clock import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeOrError) @@ -525,6 +527,9 @@ withCachedBot t f = do viewFederationDomain :: MonadBotNet m => m Domain viewFederationDomain = liftBotNet . BotNet $ asks botNetDomain +qualifyLocal :: MonadBotNet m => a -> m (Local a) +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a + ------------------------------------------------------------------------------- -- Assertions diff --git a/libs/wire-api/src/Wire/API/Conversation/Member.hs b/libs/wire-api/src/Wire/API/Conversation/Member.hs index 7b1a570ff08..e2abc40d069 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Member.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Member.hs @@ -89,9 +89,8 @@ modelConversationMembers = Doc.defineModel "ConversationMembers" $ do -------------------------------------------------------------------------------- -- Members --- FUTUREWORK: Add a qualified Id here. data Member = Member - { memId :: UserId, + { memId :: Qualified UserId, memService :: Maybe ServiceRef, memOtrMutedStatus :: Maybe MutedStatus, memOtrMutedRef :: Maybe Text, @@ -109,7 +108,9 @@ instance ToSchema Member where schema = object "Member" $ Member - <$> memId .= field "id" schema + <$> memId .= field "qualified_id" schema + <* (qUnqualified . memId) + .= optional (field "id" (deprecatedSchema "qualified_id" schema)) <*> memService .= lax (field "service" (optWithDefault A.Null schema)) -- Remove ... <* const () .= optional (field "status" (c (0 :: Int))) diff --git a/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json b/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json index 67711be729a..8c5765489d6 100644 --- a/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json +++ b/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json @@ -23,6 +23,10 @@ "otr_archived_ref": "", "otr_muted_ref": "", "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, "service": { "id": "00000001-0000-0000-0000-000000000000", "provider": "00000000-0000-0000-0000-000000000000" diff --git a/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json b/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json index 97ecd589b74..050ea4b53ae 100644 --- a/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json +++ b/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json @@ -9,6 +9,10 @@ "otr_archived_ref": null, "otr_muted_ref": "", "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000000" + }, "service": { "id": "00000001-0000-0001-0000-000100000001", "provider": "00000001-0000-0001-0000-000000000001" diff --git a/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json b/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json index 326adbbcda0..ceccfb14fc5 100644 --- a/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json +++ b/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json @@ -18,6 +18,10 @@ "otr_archived_ref": null, "otr_muted_ref": "", "otr_muted_status": 0, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000000" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_Conversation_user_1.json b/libs/wire-api/test/golden/testObject_Conversation_user_1.json index 5ac0de117e1..22dcd63af64 100644 --- a/libs/wire-api/test/golden/testObject_Conversation_user_1.json +++ b/libs/wire-api/test/golden/testObject_Conversation_user_1.json @@ -16,6 +16,10 @@ "otr_archived_ref": "", "otr_muted_ref": null, "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_Conversation_user_2.json b/libs/wire-api/test/golden/testObject_Conversation_user_2.json index 6b605941104..7c2362da23f 100644 --- a/libs/wire-api/test/golden/testObject_Conversation_user_2.json +++ b/libs/wire-api/test/golden/testObject_Conversation_user_2.json @@ -43,6 +43,10 @@ "otr_archived_ref": null, "otr_muted_ref": null, "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json b/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json index f33bf1205ea..db6807e12db 100644 --- a/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json +++ b/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json @@ -28,6 +28,10 @@ "otr_archived_ref": "", "otr_muted_ref": null, "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, "service": null, "status": 0, "status_ref": "0.0", @@ -75,6 +79,10 @@ "otr_archived_ref": null, "otr_muted_ref": null, "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_Event_user_8.json b/libs/wire-api/test/golden/testObject_Event_user_8.json index bf7fab73317..ecfc1b3da8d 100644 --- a/libs/wire-api/test/golden/testObject_Event_user_8.json +++ b/libs/wire-api/test/golden/testObject_Event_user_8.json @@ -36,6 +36,10 @@ "otr_archived_ref": "", "otr_muted_ref": "", "otr_muted_status": 0, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0000-0000-000000000001" + }, "service": { "id": "00000001-0000-0000-0000-000000000001", "provider": "00000000-0000-0000-0000-000100000001" diff --git a/libs/wire-api/test/golden/testObject_Member_user_1.json b/libs/wire-api/test/golden/testObject_Member_user_1.json index 76d176b1bef..16fad764237 100644 --- a/libs/wire-api/test/golden/testObject_Member_user_1.json +++ b/libs/wire-api/test/golden/testObject_Member_user_1.json @@ -7,6 +7,10 @@ "otr_archived_ref": "𢖖", "otr_muted_ref": "ref", "otr_muted_status": -2, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000002-0000-0001-0000-000100000000" + }, "service": { "id": "00000000-0000-0000-0000-000000000001", "provider": "00000000-0000-0001-0000-000000000001" diff --git a/libs/wire-api/test/golden/testObject_Member_user_2.json b/libs/wire-api/test/golden/testObject_Member_user_2.json index e6f6fd61ce9..4415044d05e 100644 --- a/libs/wire-api/test/golden/testObject_Member_user_2.json +++ b/libs/wire-api/test/golden/testObject_Member_user_2.json @@ -7,6 +7,10 @@ "otr_archived_ref": null, "otr_muted_ref": null, "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000002" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs index c0e49460faa..2666cd20610 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs @@ -50,7 +50,7 @@ testObject_ConvMembers_user_1 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, memService = Just ( ServiceRef @@ -92,7 +92,7 @@ testObject_ConvMembers_user_2 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) domain, memService = Just ( ServiceRef diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs index 6c17eda72fc..e51e664e48b 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs @@ -27,6 +27,9 @@ import Imports (Bool (False, True), Maybe (Just, Nothing), fromJust) import Wire.API.Conversation import Wire.API.Conversation.Role (parseRoleName) +domain :: Domain +domain = Domain "golden.example.com" + testObject_ConversationList_20Conversation_user_1 :: ConversationList Conversation testObject_ConversationList_20Conversation_user_1 = ConversationList @@ -48,7 +51,7 @@ testObject_ConversationList_20Conversation_user_1 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) domain, memService = Nothing, memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = 0}), memOtrMutedRef = Just "", diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs index 5b819cdd477..688f856d43f 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs @@ -34,7 +34,7 @@ domain = Domain "golden.example.com" testObject_Conversation_user_1 :: Conversation testObject_Conversation_user_1 = Conversation - { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) domain, cnvMetadata = ConversationMetadata { cnvmType = One2OneConv, @@ -50,7 +50,7 @@ testObject_Conversation_user_1 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) domain, memService = Nothing, memOtrMutedStatus = Nothing, memOtrMutedRef = Nothing, @@ -67,7 +67,7 @@ testObject_Conversation_user_1 = testObject_Conversation_user_2 :: Conversation testObject_Conversation_user_2 = Conversation - { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) domain, cnvMetadata = ConversationMetadata { cnvmType = SelfConv, @@ -96,7 +96,7 @@ testObject_Conversation_user_2 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, memService = Nothing, memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = -1}), memOtrMutedRef = Nothing, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs index bf7223ebb75..93e7d7dbfe6 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs @@ -159,7 +159,7 @@ testObject_Event_user_8 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) (Domain "golden.example.com"), memService = Just ( ServiceRef diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs index 5621b211694..bbac8ae66a6 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs @@ -16,17 +16,22 @@ -- with this program. If not, see . module Test.Wire.API.Golden.Generated.Member_user where +import Data.Domain (Domain (..)) import Data.Id (Id (Id)) +import Data.Qualified (Qualified (..)) import qualified Data.UUID as UUID (fromString) import Imports (Bool (False, True), Maybe (Just, Nothing), fromJust) import Wire.API.Conversation (Member (..), MutedStatus (MutedStatus, fromMutedStatus)) import Wire.API.Conversation.Role (parseRoleName) import Wire.API.Provider.Service (ServiceRef (ServiceRef, _serviceRefId, _serviceRefProvider)) +domain :: Domain +domain = Domain "golden.example.com" + testObject_Member_user_1 :: Member testObject_Member_user_1 = Member - { memId = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000100000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000100000000"))) domain, memService = Just ( ServiceRef @@ -47,7 +52,7 @@ testObject_Member_user_1 = testObject_Member_user_2 :: Member testObject_Member_user_2 = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000002")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000002"))) domain, memService = Nothing, memOtrMutedStatus = Nothing, memOtrMutedRef = Nothing, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs index 534641eb826..1210c3687ae 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs @@ -12,16 +12,19 @@ import Imports import Wire.API.Conversation import Wire.API.Conversation.Role +domain :: Domain +domain = Domain "golden.example.com" + testObject_ConversationsResponse_1 :: ConversationsResponse testObject_ConversationsResponse_1 = ConversationsResponse { crFound = [conv1, conv2], crNotFound = - [ Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002"))) (Domain "golden.example.com"), + [ Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002"))) domain, Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-111111111112"))) (Domain "golden2.example.com") ], crFailed = - [ Qualified (Id (fromJust (UUID.fromString "00000018-4444-0020-0000-000e00000002"))) (Domain "golden.example.com"), + [ Qualified (Id (fromJust (UUID.fromString "00000018-4444-0020-0000-000e00000002"))) domain, Qualified (Id (fromJust (UUID.fromString "99999999-0000-0020-0000-111111111112"))) (Domain "golden3.example.com") ] } @@ -29,7 +32,7 @@ testObject_ConversationsResponse_1 = conv1 :: Conversation conv1 = Conversation - { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) domain, cnvMetadata = ConversationMetadata { cnvmType = One2OneConv, @@ -45,7 +48,7 @@ conv1 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) domain, memService = Nothing, memOtrMutedStatus = Nothing, memOtrMutedRef = Nothing, @@ -62,7 +65,7 @@ conv1 = conv2 :: Conversation conv2 = Conversation - { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) domain, cnvMetadata = ConversationMetadata { cnvmType = SelfConv, @@ -91,7 +94,7 @@ conv2 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, memService = Nothing, memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = -1}), memOtrMutedRef = Nothing, diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 535023c2796..fb3a09bbc0e 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -489,33 +489,29 @@ testDeleteService config db brig galley cannon = withTestService config db brig -- Create a conversation u1 <- createUser "Ernie" brig u2 <- createUser "Bert" brig - let uid1 = userId u1 - quid1 = userQualifiedId u1 - localDomain = qDomain quid1 - uid2 = userId u2 + let uid2 = userId u2 + Qualified uid1 localDomain = userQualifiedId u1 + luid1 = toLocalUnsafe localDomain uid1 postConnection brig uid1 uid2 !!! const 201 === statusCode putConnection brig uid2 uid1 Accepted !!! const 200 === statusCode cnv <- responseJsonError =<< (createConv galley uid1 [uid2] do deleteService brig pid sid defProviderPassword !!! const 202 === statusCode - _ <- waitFor (5 # Second) not (isMember galley buid1 cid) - _ <- waitFor (5 # Second) not (isMember galley buid2 cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid1 cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid2 cid) getBotConv galley bid1 cid !!! const 404 === statusCode getBotConv galley bid2 cid !!! const 404 === statusCode - wsAssertMemberLeave ws qcid qbuid1 [qbuid1] - wsAssertMemberLeave ws qcid qbuid2 [qbuid2] + wsAssertMemberLeave ws qcid (qUntagged lbuid1) [qUntagged lbuid1] + wsAssertMemberLeave ws qcid (qUntagged lbuid2) [qUntagged lbuid2] -- The service should not be available getService brig pid sid !!! const 404 === statusCode @@ -598,9 +594,9 @@ testAddRemoveBotTeam config db brig galley cannon = withTestService config db br testBotTeamOnlyConv :: Config -> DB.ClientState -> Brig -> Galley -> Cannon -> Http () testBotTeamOnlyConv config db brig galley cannon = withTestService config db brig defServiceApp $ \sref buf -> do (u1, u2, _h, _tid, cid, pid, sid) <- prepareBotUsersTeam brig galley sref - let (uid1, uid2) = (userId u1, userId u2) - quid1 = userQualifiedId u1 - localDomain = qDomain quid1 + let uid2 = userId u2 + Qualified uid1 localDomain = userQualifiedId u1 + luid1 = toLocalUnsafe localDomain uid1 qcid = Qualified cid localDomain -- Make the conversation team-only and check that the bot can't be added -- to the conversation @@ -611,21 +607,20 @@ testBotTeamOnlyConv config db brig galley cannon = withTestService config db bri -- Make the conversation allowed for guests and add the bot successfully setAccessRole uid1 cid NonActivatedAccessRole bid <- addBotConv localDomain brig cannon uid1 uid2 cid pid sid buf - let buid = botUserId bid - qbuid = Qualified buid localDomain + let lbuid = qualifyAs luid1 . botUserId $ bid -- Make the conversation team-only again and check that the bot has been removed WS.bracketR cannon uid1 $ \ws -> do setAccessRole uid1 cid TeamAccessRole - _ <- waitFor (5 # Second) not (isMember galley buid cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid cid) getBotConv galley bid cid !!! const 404 === statusCode svcAssertConvAccessUpdate buf - quid1 + (qUntagged luid1) (ConversationAccessData (Set.singleton InviteAccess) TeamAccessRole) qcid - svcAssertMemberLeave buf qbuid [qbuid] qcid - wsAssertMemberLeave ws qcid qbuid [qbuid] + svcAssertMemberLeave buf (qUntagged lbuid) [qUntagged lbuid] qcid + wsAssertMemberLeave ws qcid (qUntagged lbuid) [qUntagged lbuid] where setAccessRole uid cid role = updateConversationAccess galley uid cid [InviteAccess] role @@ -876,6 +871,7 @@ testWhitelistKickout localDomain config db brig galley cannon = do -- Create a team and a conversation (owner, tid) <- Team.createUserWithTeam brig let qowner = Qualified owner localDomain + lowner = toLocalUnsafe localDomain owner cid <- Team.createTeamConv galley tid owner [] Nothing let qcid = Qualified cid localDomain -- Create a service @@ -888,18 +884,17 @@ testWhitelistKickout localDomain config db brig galley cannon = do responseJsonError =<< (addBot brig owner pid sid cid do dewhitelistService brig owner tid pid sid - _ <- waitFor (2 # Second) not (isMember galley buid cid) + _ <- waitFor (2 # Second) not (isMember galley lbuid cid) getBotConv galley bid cid !!! const 404 === statusCode - wsAssertMemberLeave ws qcid qowner [qbuid] - svcAssertMemberLeave buf qowner [qbuid] qcid + wsAssertMemberLeave ws qcid qowner [qUntagged lbuid] + svcAssertMemberLeave buf qowner [qUntagged lbuid] qcid -- The bot should not get any further events liftIO $ timeout (2 # Second) (readChan buf) >>= \case @@ -1943,18 +1938,18 @@ testMessageBotUtil :: WS.Cannon -> Http () testMessageBotUtil quid uc cid pid sid sref buf brig galley cannon = do - let uid = qUnqualified quid - localDomain = qDomain quid + let Qualified uid localDomain = quid + luid = toLocalUnsafe localDomain uid qcid = Qualified cid localDomain -- Add bot to conversation _rs <- addBot brig uid pid sid cid do postBotMessage galley bid bc cid [(uid, uc, (toBase64Text "Hi User!"))] !!! const 201 === statusCode - wsAssertMessage ws qcid qbuid bc uc (toBase64Text "Hi User!") + wsAssertMessage ws qcid (qUntagged lbuid) bc uc (toBase64Text "Hi User!") -- The user replies postMessage galley uid uc cid [(buid, bc, (toBase64Text "Hi Bot"))] !!! const 201 === statusCode @@ -1981,10 +1976,10 @@ testMessageBotUtil quid uc cid pid sid sref buf brig galley cannon = do WS.bracketR cannon uid $ \ws -> do deleteService brig pid sid defProviderPassword !!! const 202 === statusCode - _ <- waitFor (5 # Second) not (isMember galley buid cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid cid) getBotConv galley bid cid !!! const 404 === statusCode - wsAssertMemberLeave ws qcid qbuid [qbuid] + wsAssertMemberLeave ws qcid (qUntagged lbuid) [qUntagged lbuid] prepareBotUsersTeam :: HasCallStack => diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index c23223a0bb4..5d6e47b80a0 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -640,16 +640,16 @@ listConvs galley zusr convs = do . zConn "conn" . json (ListConversations convs) -isMember :: Galley -> UserId -> ConvId -> (MonadIO m, MonadHttp m) => m Bool +isMember :: Galley -> Local UserId -> ConvId -> (MonadIO m, MonadHttp m) => m Bool isMember g usr cnv = do res <- get $ g - . paths ["i", "conversations", toByteString' cnv, "members", toByteString' usr] + . paths ["i", "conversations", toByteString' cnv, "members", toByteString' (tUnqualified usr)] . expect2xx case responseJsonMaybe res of Nothing -> return False - Just m -> return (usr == memId m) + Just m -> return (qUntagged usr == memId m) getStatus :: HasCallStack => Brig -> UserId -> (MonadIO m, MonadHttp m) => m AccountStatus getStatus brig u = diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 3870705d46f..9b873d0cebd 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -111,7 +111,7 @@ onConversationCreated domain rc = do (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrcConnected)) (rcTime qrcConnected) (EdConversation c) - pushConversationEvent Nothing event [Public.memId mem] [] + pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] getConversations :: Domain -> GetConversationsRequest -> Galley GetConversationsResponse getConversations domain (GetConversationsRequest uid cids) = do diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index c9da03d9c97..f118658f04a 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -30,7 +30,7 @@ import Control.Monad.Catch import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified -import Galley.API.Util (viewFederationDomain) +import Galley.API.Util (qualifyLocal) import Galley.App import qualified Galley.Data as Data import Galley.Data.Types (convId) @@ -48,8 +48,8 @@ import Wire.API.Federation.API.Galley -- Throws "bad-state" when the user is not part of the conversation. conversationView :: UserId -> Data.Conversation -> Galley Conversation conversationView uid conv = do - localDomain <- viewFederationDomain - let mbConv = conversationViewMaybe localDomain uid conv + luid <- qualifyLocal uid + let mbConv = conversationViewMaybe luid conv maybe memberNotFound pure mbConv where memberNotFound = do @@ -64,17 +64,17 @@ conversationView uid conv = do -- | View for a given user of a stored conversation. -- -- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Domain -> UserId -> Data.Conversation -> Maybe Conversation -conversationViewMaybe localDomain uid conv = do - let (selfs, lothers) = partition ((uid ==) . lmId) (Data.convLocalMembers conv) +conversationViewMaybe :: Local UserId -> Data.Conversation -> Maybe Conversation +conversationViewMaybe luid conv = do + let (selfs, lothers) = partition ((tUnqualified luid ==) . lmId) (Data.convLocalMembers conv) rothers = Data.convRemoteMembers conv - self <- localMemberToSelf <$> listToMaybe selfs + self <- localMemberToSelf luid <$> listToMaybe selfs let others = - map (localMemberToOther localDomain) lothers + map (localMemberToOther (tDomain luid)) lothers <> map remoteMemberToOther rothers pure $ Conversation - (Qualified (convId conv) localDomain) + (qUntagged . qualifyAs luid . convId $ conv) (Data.convMetadata conv) (ConvMembers self others) @@ -84,7 +84,7 @@ conversationViewMaybe localDomain uid conv = do -- discard the conversation altogether. This should only happen if the remote -- backend is misbehaving. remoteConversationView :: - UserId -> + Local UserId -> MemberStatus -> Remote RemoteConversation -> Maybe Conversation @@ -93,8 +93,9 @@ remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do others = rcmOthers mems self = localMemberToSelf + uid LocalMember - { lmId = uid, + { lmId = tUnqualified uid, lmService = Nothing, lmStatus = status, lmConvRoleName = rcmSelfRole mems @@ -130,10 +131,10 @@ conversationToRemote localDomain ruid conv = do -- | Convert a local conversation member (as stored in the DB) to a publicly -- facing 'Member' structure. -localMemberToSelf :: LocalMember -> Member -localMemberToSelf lm = +localMemberToSelf :: Local x -> LocalMember -> Member +localMemberToSelf loc lm = Member - { memId = lmId lm, + { memId = qUntagged . qualifyAs loc . lmId $ lm, memService = lmService lm, memOtrMutedStatus = msOtrMutedStatus st, memOtrMutedRef = msOtrMutedRef st, diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index e05ee412497..d98c99598de 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -161,13 +161,14 @@ getRemoteConversationsWithFailures :: Galley ([FailedGetConversation], [Public.Conversation]) getRemoteConversationsWithFailures zusr convs = do localDomain <- viewFederationDomain + lusr <- qualifyLocal zusr -- get self member statuses from the database statusMap <- Data.remoteConversationStatus zusr convs let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation remoteView rconv = Mapping.remoteConversationView - zusr + lusr ( Map.findWithDefault defMemberStatus (fmap FederatedGalley.rcnvId rconv) @@ -358,9 +359,10 @@ internalGetMemberH (cnv ::: usr) = do getLocalSelf :: UserId -> ConvId -> Galley (Maybe Public.Member) getLocalSelf usr cnv = do + lusr <- qualifyLocal usr alive <- Data.isConvAlive cnv if alive - then Mapping.localMemberToSelf <$$> Data.member cnv usr + then Mapping.localMemberToSelf lusr <$$> Data.member cnv usr else Nothing <$ Data.deleteConversation cnv getConversationMetaH :: ConvId -> Galley Response diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 3b5485c09f4..479c95f7f8f 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -735,7 +735,7 @@ fromNewRemoteConversation loc rc@NewRemoteConversation {..} = toMember :: OtherMember -> Public.Member toMember m = Public.Member - { memId = qUnqualified . omQualifiedId $ m, + { memId = omQualifiedId m, memService = omService m, memOtrMutedStatus = Nothing, memOtrMutedRef = Nothing, diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 31e12d7970c..f386381822b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -290,7 +290,7 @@ postConvOk = do rsp <- postConv alice [bob, jane] (Just nameMaxSize) [] Nothing Nothing viewFederationDomain bobId <- randomId convId <- randomId let remoteDomain = Domain "far-away.example.com" @@ -1995,7 +2001,7 @@ testGetQualifiedRemoteConv = do bobAsOtherMember = OtherMember bobQ Nothing roleNameWireAdmin aliceAsLocal = LocalMember aliceId defMemberStatus Nothing roleNameWireAdmin aliceAsOtherMember = localMemberToOther (qDomain aliceQ) aliceAsLocal - aliceAsSelfMember = localMemberToSelf aliceAsLocal + aliceAsSelfMember = localMemberToSelf loc aliceAsLocal connectWithRemoteUser aliceId bobQ registerRemoteConv remoteConvId bobId Nothing (Set.fromList [aliceAsOtherMember]) @@ -2069,6 +2075,7 @@ testBulkGetQualifiedConvs = do localDomain <- viewFederationDomain aliceQ <- randomQualifiedUser let alice = qUnqualified aliceQ + lAlice = toLocalUnsafe localDomain alice bobId <- randomId carlId <- randomId deeId <- randomId @@ -2134,8 +2141,8 @@ testBulkGetQualifiedConvs = do let expectedFound = sortOn cnvQualifiedId - $ maybeToList (remoteConversationView alice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) - <> maybeToList (remoteConversationView alice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) + $ maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) + <> maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) <> [localConv] actualFound = sortOn cnvQualifiedId $ crFound convs assertEqual "found conversations" expectedFound actualFound @@ -2242,14 +2249,14 @@ postMembersOk2 :: TestM () postMembersOk2 = do alice <- randomUser bob <- randomUser - chuck <- randomUser - connectUsers alice (list1 bob [chuck]) - connectUsers bob (singleton chuck) - conv <- decodeConvId <$> postConv alice [bob, chuck] Nothing [] Nothing Nothing - postMembers bob (singleton chuck) conv !!! do + chuck <- randomQualifiedUser + connectUsers alice (list1 bob [qUnqualified chuck]) + connectUsers bob (singleton . qUnqualified $ chuck) + conv <- decodeConvId <$> postConv alice [bob, qUnqualified chuck] Nothing [] Nothing Nothing + postMembers bob (singleton . qUnqualified $ chuck) conv !!! do const 204 === statusCode const Nothing === responseBody - chuck' <- responseJsonUnsafe <$> (getSelfMember chuck conv (getSelfMember (qUnqualified chuck) conv chuck') @@ -2787,7 +2794,7 @@ putMemberOk update = do -- Expected member state let memberBob = Member - { memId = bob, + { memId = qbob, memService = Nothing, memOtrMutedStatus = mupOtrMuteStatus update, memOtrMutedRef = mupOtrMuteRef update, @@ -2857,7 +2864,7 @@ putRemoteConvMemberOk update = do -- Expected member state let memberAlice = Member - { memId = alice, + { memId = qalice, memService = Nothing, memOtrMutedStatus = mupOtrMuteStatus update, memOtrMutedRef = mupOtrMuteRef update, diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 5a7941bf2fa..d541fd76958 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -174,7 +174,7 @@ onConvCreated = do WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") requestMembers liftIO $ do - let expectedSelf = alice + let expectedSelf = qAlice expectedOthers = [(qBob, roleNameWireAdmin), (qDee, roleNameWireMember)] expectedFrom = qBob -- since Charlie is not connected to Bob; expect a conversation with Alice&Bob only @@ -250,7 +250,7 @@ addUnconnectedUsersOnly = do -- Remote Bob creates a conversation with local Alice registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") requestMembers liftIO $ do - let expectedSelf = alice + let expectedSelf = qAlice expectedOthers = [(qBob, roleNameWireAdmin)] expectedFrom = qBob WS.assertMatch_ (5 # Second) wsA $ diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index ddaf4828f30..71d47cdf85f 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -74,11 +74,12 @@ messageTimerInit :: messageTimerInit mtimer = do -- Create a conversation with a timer [alice, bob, jane] <- randomUsers 3 + qAlice <- Qualified <$> pure alice <*> viewFederationDomain connectUsers alice (list1 bob [jane]) rsp <- postConv alice [bob, jane] Nothing [] Nothing mtimer pure alice <*> viewFederationDomain connectUsers alice (list1 bob [jane]) rsp <- postConv alice [bob, jane] Nothing [] Nothing Nothing pure alice <*> viewFederationDomain connectUsers alice (list1 bob [jane]) rsp <- postConv alice [bob, jane] Nothing [] Nothing Nothing pure alice <*> viewFederationDomain connectUsers alice (singleton bob) rsp <- postO2OConv alice bob Nothing pure alice <*> viewFederationDomain connectUsers alice (singleton bob) rsp <- postConv alice [bob] Nothing [] Nothing Nothing do let update = ConversationMessageTimerUpdate timer1sec diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index da7fb3861a7..615442b2c7e 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -93,7 +93,7 @@ handleConversationRoleAdmin = do let role = roleNameWireAdmin cid <- WS.bracketR3 c alice bob chuck $ \(wsA, wsB, wsC) -> do rsp <- postConvWithRole alice [bob, chuck] (Just "gossip") [] Nothing Nothing role - void $ assertConvWithRole rsp RegularConv alice alice [bob, chuck] (Just "gossip") Nothing role + void $ assertConvWithRole rsp RegularConv alice qalice [bob, chuck] (Just "gossip") Nothing role let cid = decodeConvId rsp qcid = Qualified cid localDomain -- Make sure everyone gets the correct event @@ -135,7 +135,7 @@ handleConversationRoleMember = do let role = roleNameWireMember cid <- WS.bracketR3 c alice bob chuck $ \(wsA, wsB, wsC) -> do rsp <- postConvWithRole alice [bob, chuck] (Just "gossip") [] Nothing Nothing role - void $ assertConvWithRole rsp RegularConv alice alice [bob, chuck] (Just "gossip") Nothing role + void $ assertConvWithRole rsp RegularConv alice qalice [bob, chuck] (Just "gossip") Nothing role let cid = decodeConvId rsp qcid = Qualified cid localDomain -- Make sure everyone gets the correct event diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 4529b88c4ff..8a15a7a255c 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -790,9 +790,10 @@ testAddTeamConvLegacy = do mem2 <- newTeamMember' p <$> Util.randomUser Util.connectUsers owner (list1 (mem1 ^. userId) [extern, mem2 ^. userId]) tid <- Util.createNonBindingTeam "foo" owner [mem2] - let allUserIds = [owner, extern, mem1 ^. userId, mem2 ^. userId] - WS.bracketRN c allUserIds $ \wss -> do - cid <- Util.createTeamConvLegacy owner tid allUserIds (Just "blaa") + allUserIds <- for [owner, extern, mem1 ^. userId, mem2 ^. userId] $ + \u -> Qualified <$> pure u <*> viewFederationDomain + WS.bracketRN c (qUnqualified <$> allUserIds) $ \wss -> do + cid <- Util.createTeamConvLegacy owner tid (qUnqualified <$> allUserIds) (Just "blaa") mapM_ (checkConvCreateEvent cid) wss -- All members become admin by default mapM_ (assertConvMemberWithRole roleNameWireAdmin cid) allUserIds @@ -802,7 +803,9 @@ testAddTeamConvWithRole :: TestM () testAddTeamConvWithRole = do c <- view tsCannon owner <- Util.randomUser + qOwner <- Qualified <$> pure owner <*> viewFederationDomain extern <- Util.randomUser + qExtern <- Qualified <$> pure extern <*> viewFederationDomain let p = Util.symmPermissions [CreateConversation, DoNotUseDeprecatedAddRemoveConvMember] mem1 <- newTeamMember' p <$> Util.randomUser mem2 <- newTeamMember' p <$> Util.randomUser @@ -813,13 +816,13 @@ testAddTeamConvWithRole = do cid2 <- Util.createTeamConvWithRole owner tid [extern] (Just "blaa") Nothing Nothing roleNameWireAdmin checkConvCreateEvent cid2 wsOwner checkConvCreateEvent cid2 wsExtern - mapM_ (assertConvMemberWithRole roleNameWireAdmin cid2) [owner, extern] + mapM_ (assertConvMemberWithRole roleNameWireAdmin cid2) [qOwner, qExtern] -- Regular conversation (using member role for participants): cid3 <- Util.createTeamConvWithRole owner tid [extern] (Just "blaa") Nothing Nothing roleNameWireMember checkConvCreateEvent cid3 wsOwner checkConvCreateEvent cid3 wsExtern - assertConvMemberWithRole roleNameWireAdmin cid3 owner - assertConvMemberWithRole roleNameWireMember cid3 extern + assertConvMemberWithRole roleNameWireAdmin cid3 qOwner + assertConvMemberWithRole roleNameWireMember cid3 qExtern -- mem2 is not a conversation member and no longer receives -- an event that a new team conversation has been created @@ -879,13 +882,18 @@ testAddTeamMemberToConv :: TestM () testAddTeamMemberToConv = do personalUser <- Util.randomUser ownerT1 <- Util.randomUser + qOwnerT1 <- Qualified <$> pure ownerT1 <*> viewFederationDomain let p = Util.symmPermissions [DoNotUseDeprecatedAddRemoveConvMember] mem1T1 <- newTeamMember' p <$> Util.randomUser + qMem1T1 <- Qualified <$> pure (mem1T1 ^. userId) <*> viewFederationDomain mem2T1 <- newTeamMember' p <$> Util.randomUser + qMem2T1 <- Qualified <$> pure (mem2T1 ^. userId) <*> viewFederationDomain mem3T1 <- newTeamMember' (Util.symmPermissions []) <$> Util.randomUser mem4T1 <- newTeamMember' (Util.symmPermissions []) <$> Util.randomUser ownerT2 <- Util.randomUser + qOwnerT2 <- Qualified <$> pure ownerT2 <*> viewFederationDomain mem1T2 <- newTeamMember' p <$> Util.randomUser + qMem1T2 <- Qualified <$> pure (mem1T2 ^. userId) <*> viewFederationDomain Util.connectUsers ownerT1 (list1 (mem1T1 ^. userId) [mem2T1 ^. userId, mem3T1 ^. userId, ownerT2, personalUser]) tidT1 <- Util.createNonBindingTeam "foo" ownerT1 [mem1T1, mem2T1, mem3T1] tidT2 <- Util.createBindingTeamInternal "foo" ownerT2 @@ -902,9 +910,9 @@ testAddTeamMemberToConv = do Util.assertNotConvMember (mem2T1 ^. userId) cidT1 -- OTOH, mem3T1 _can_ add another team member despite lacking the required team permission -- since conversation roles trump any team roles. Note that all users are admins by default - Util.assertConvMember ownerT1 cidT1 + Util.assertConvMember qOwnerT1 cidT1 Util.postMembers ownerT1 (list1 (mem2T1 ^. userId) []) cidT1 !!! const 200 === statusCode - Util.assertConvMember (mem2T1 ^. userId) cidT1 + Util.assertConvMember qMem2T1 cidT1 -- The following tests check the logic: users can add other users to a conversation -- iff: -- - *the adding user is connected to the users being added* @@ -913,24 +921,24 @@ testAddTeamMemberToConv = do -- Now we add someone from T2 that we are connected to Util.postMembers ownerT1 (list1 ownerT2 []) cidT1 !!! const 200 === statusCode - Util.assertConvMember ownerT2 cidT1 + Util.assertConvMember qOwnerT2 cidT1 -- And they can add their own team members Util.postMembers ownerT2 (list1 (mem1T2 ^. userId) []) cidT1 !!! const 200 === statusCode - Util.assertConvMember (mem1T2 ^. userId) cidT1 + Util.assertConvMember qMem1T2 cidT1 -- Still, they cannot add random members without a connection from T1, despite the conversation being "hosted" there Util.postMembers ownerT2 (list1 (mem4T1 ^. userId) []) cidT1 !!! const 403 === statusCode Util.assertNotConvMember (mem4T1 ^. userId) cidT1 -- Now let's look at convs hosted on team2 -- ownerT2 *is* connected to ownerT1 Util.postMembers ownerT2 (list1 ownerT1 []) cidT2 !!! const 200 === statusCode - Util.assertConvMember ownerT1 cidT2 + Util.assertConvMember qOwnerT1 cidT2 -- and mem1T2 is on the same team, but mem1T1 is *not* Util.postMembers ownerT2 (list1 (mem1T2 ^. userId) [mem1T1 ^. userId]) cidT2 !!! const 403 === statusCode Util.assertNotConvMember (mem1T1 ^. userId) cidT2 Util.assertNotConvMember (mem1T2 ^. userId) cidT2 -- mem1T2 is on the same team, so that is fine too Util.postMembers ownerT2 (list1 (mem1T2 ^. userId) []) cidT2 !!! const 200 === statusCode - Util.assertConvMember (mem1T2 ^. userId) cidT2 + Util.assertConvMember qMem1T2 cidT2 -- ownerT2 is *NOT* connected to mem3T1 and not on the same team, so should not be allowed to add Util.postMembers ownerT2 (list1 (mem3T1 ^. userId) []) cidT2 !!! const 403 === statusCode Util.assertNotConvMember (mem3T1 ^. userId) cidT2 @@ -938,19 +946,19 @@ testAddTeamMemberToConv = do -- Can add connected users Util.postMembers personalUser (list1 ownerT1 []) cidPersonal !!! const 200 === statusCode - Util.assertConvMember ownerT1 cidPersonal + Util.assertConvMember qOwnerT1 cidPersonal -- Can *not* add users that are *not* connected Util.postMembers personalUser (list1 ownerT2 []) cidPersonal !!! const 403 === statusCode Util.assertNotConvMember ownerT2 cidPersonal -- Users of the same team can add one another Util.postMembers ownerT1 (list1 (mem1T1 ^. userId) []) cidPersonal !!! const 200 === statusCode - Util.assertConvMember (mem1T1 ^. userId) cidPersonal + Util.assertConvMember qMem1T1 cidPersonal -- Users can not add across teams if *not* connected Util.postMembers (mem1T1 ^. userId) (list1 ownerT2 []) cidPersonal !!! const 403 === statusCode Util.assertNotConvMember ownerT2 cidPersonal -- Users *can* add across teams if *connected* Util.postMembers ownerT1 (list1 ownerT2 []) cidPersonal !!! const 200 === statusCode - Util.assertConvMember ownerT2 cidPersonal + Util.assertConvMember qOwnerT2 cidPersonal testUpdateTeamConv :: -- | Team role of the user who creates the conversation @@ -976,20 +984,24 @@ testDeleteTeam = do g <- view tsGalley c <- view tsCannon owner <- Util.randomUser + qOwner <- Qualified <$> pure owner <*> viewFederationDomain let p = Util.symmPermissions [DoNotUseDeprecatedAddRemoveConvMember] member <- newTeamMember' p <$> Util.randomUser + qMember <- Qualified <$> pure (member ^. userId) <*> viewFederationDomain extern <- Util.randomUser + qExtern <- Qualified <$> pure extern <*> viewFederationDomain + let members = [owner, member ^. userId] Util.connectUsers owner (list1 (member ^. userId) [extern]) tid <- Util.createNonBindingTeam "foo" owner [member] cid1 <- Util.createTeamConv owner tid [] (Just "blaa") Nothing Nothing cid2 <- Util.createTeamConv owner tid members (Just "blup") Nothing Nothing - Util.assertConvMember owner cid2 - Util.assertConvMember (member ^. userId) cid2 + Util.assertConvMember qOwner cid2 + Util.assertConvMember qMember cid2 Util.assertNotConvMember extern cid2 Util.postMembers owner (list1 extern []) cid1 !!! const 200 === statusCode - Util.assertConvMember owner cid1 - Util.assertConvMember extern cid1 + Util.assertConvMember qOwner cid1 + Util.assertConvMember qExtern cid1 Util.assertNotConvMember (member ^. userId) cid1 void . WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do delete (g . paths ["teams", toByteString' tid] . zUser owner . zConn "conn") @@ -1163,20 +1175,23 @@ testDeleteTeamConv = do localDomain <- viewFederationDomain c <- view tsCannon owner <- Util.randomUser + qOwner <- Qualified <$> pure owner <*> viewFederationDomain let p = Util.symmPermissions [DoNotUseDeprecatedDeleteConversation] member <- newTeamMember' p <$> Util.randomUser - let members = [owner, member ^. userId] + qMember <- Qualified <$> pure (member ^. userId) <*> viewFederationDomain + let members = [qOwner, qMember] extern <- Util.randomUser + qExtern <- Qualified <$> pure extern <*> viewFederationDomain Util.connectUsers owner (list1 (member ^. userId) [extern]) tid <- Util.createNonBindingTeam "foo" owner [member] cid1 <- Util.createTeamConv owner tid [] (Just "blaa") Nothing Nothing let access = ConversationAccessData (Set.fromList [InviteAccess, CodeAccess]) ActivatedAccessRole putAccessUpdate owner cid1 access !!! const 200 === statusCode code <- decodeConvCodeEvent <$> (postConvCode owner cid1 members) (Just "blup") Nothing Nothing Util.postMembers owner (list1 extern [member ^. userId]) cid1 !!! const 200 === statusCode - for_ [owner, member ^. userId, extern] $ \u -> Util.assertConvMember u cid1 - for_ [owner, member ^. userId] $ \u -> Util.assertConvMember u cid2 + for_ (qExtern : members) $ \u -> Util.assertConvMember u cid1 + for_ members $ flip Util.assertConvMember cid2 WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do deleteTeamConv tid cid2 (member ^. userId) !!! const 200 === statusCode diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 4ba95817758..01d7cf94509 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -941,7 +941,9 @@ data GroupConvAdmin testNoConsentRemoveFromGroupConv :: GroupConvAdmin -> HasCallStack => TestM () testNoConsentRemoveFromGroupConv whoIsAdmin = do (legalholder :: UserId, tid) <- createBindingTeam + qLegalHolder <- Qualified <$> pure legalholder <*> viewFederationDomain (peer :: UserId, teamPeer) <- createBindingTeam + qPeer <- Qualified <$> pure peer <*> viewFederationDomain galley <- view tsGalley let enableLHForLegalholder :: HasCallStack => TestM () @@ -963,41 +965,40 @@ testNoConsentRemoveFromGroupConv whoIsAdmin = do convId <- do let (inviter, tidInviter, invitee, inviteeRole) = case whoIsAdmin of - LegalholderIsAdmin -> (legalholder, tid, peer, roleNameWireMember) - PeerIsAdmin -> (peer, teamPeer, legalholder, roleNameWireMember) - BothAreAdmins -> (legalholder, tid, peer, roleNameWireAdmin) + LegalholderIsAdmin -> (qLegalHolder, tid, qPeer, roleNameWireMember) + PeerIsAdmin -> (qPeer, teamPeer, qLegalHolder, roleNameWireMember) + BothAreAdmins -> (qLegalHolder, tid, qPeer, roleNameWireAdmin) - convId <- createTeamConvWithRole inviter tidInviter [invitee] (Just "group chat with external peer") Nothing Nothing inviteeRole + convId <- createTeamConvWithRole (qUnqualified inviter) tidInviter [qUnqualified invitee] (Just "group chat with external peer") Nothing Nothing inviteeRole mapM_ (assertConvMemberWithRole roleNameWireAdmin convId) ([inviter] <> [invitee | whoIsAdmin == BothAreAdmins]) mapM_ (assertConvMemberWithRole roleNameWireMember convId) [invitee | whoIsAdmin /= BothAreAdmins] pure convId + qconvId <- Qualified <$> pure convId <*> viewFederationDomain checkConvCreateEvent convId legalholderWs checkConvCreateEvent convId peerWs - assertConvMember legalholder convId - assertConvMember peer convId + assertConvMember qLegalHolder convId + assertConvMember qPeer convId void enableLHForLegalholder - localdomain <- viewFederationDomain - case whoIsAdmin of LegalholderIsAdmin -> do - assertConvMember legalholder convId + assertConvMember qLegalHolder convId assertNotConvMember peer convId - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) legalholderWs - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) peerWs + checkConvMemberLeaveEvent qconvId qPeer legalholderWs + checkConvMemberLeaveEvent qconvId qPeer peerWs PeerIsAdmin -> do - assertConvMember peer convId + assertConvMember qPeer convId assertNotConvMember legalholder convId - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified legalholder localdomain) legalholderWs - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified legalholder localdomain) peerWs + checkConvMemberLeaveEvent qconvId qLegalHolder legalholderWs + checkConvMemberLeaveEvent qconvId qLegalHolder peerWs BothAreAdmins -> do - assertConvMember legalholder convId + assertConvMember qLegalHolder convId assertNotConvMember peer convId - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) legalholderWs - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) peerWs + checkConvMemberLeaveEvent qconvId qPeer legalholderWs + checkConvMemberLeaveEvent qconvId qPeer peerWs data GroupConvInvCase = InviteOnlyConsenters | InviteAlsoNonConsenters deriving (Show, Eq, Ord, Bounded, Enum) @@ -1006,8 +1007,11 @@ testGroupConvInvitationHandlesLHConflicts :: HasCallStack => GroupConvInvCase -> testGroupConvInvitationHandlesLHConflicts inviteCase = do -- team that is legalhold whitelisted (legalholder :: UserId, tid) <- createBindingTeam + qLegalHolder <- Qualified <$> pure legalholder <*> viewFederationDomain userWithConsent <- (^. userId) <$> addUserToTeam legalholder tid - userWithConsent2 <- (^. userId) <$> addUserToTeam legalholder tid + userWithConsent2 <- do + uid <- (^. userId) <$> addUserToTeam legalholder tid + Qualified <$> pure uid <*> viewFederationDomain ensureQueueEmpty putLHWhitelistTeam tid !!! const 200 === statusCode @@ -1037,10 +1041,10 @@ testGroupConvInvitationHandlesLHConflicts inviteCase = do case inviteCase of InviteOnlyConsenters -> do - API.Util.postMembers userWithConsent (List1.list1 legalholder [userWithConsent2]) convId + API.Util.postMembers userWithConsent (List1.list1 legalholder [qUnqualified userWithConsent2]) convId !!! const 200 === statusCode - assertConvMember legalholder convId + assertConvMember qLegalHolder convId assertConvMember userWithConsent2 convId assertNotConvMember peer convId InviteAlsoNonConsenters -> do diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index dbfe877d178..cd3b71c0e3e 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1266,16 +1266,16 @@ registerRemoteConv convId originUser name othMembers = do ------------------------------------------------------------------------------- -- Common Assertions -assertConvMemberWithRole :: HasCallStack => RoleName -> ConvId -> UserId -> TestM () +assertConvMemberWithRole :: HasCallStack => RoleName -> ConvId -> Qualified UserId -> TestM () assertConvMemberWithRole r c u = - getSelfMember u c !!! do + getSelfMember (qUnqualified u) c !!! do const 200 === statusCode const (Right u) === (fmap memId <$> responseJsonEither) const (Right r) === (fmap memConvRoleName <$> responseJsonEither) -assertConvMember :: HasCallStack => UserId -> ConvId -> TestM () +assertConvMember :: HasCallStack => Qualified UserId -> ConvId -> TestM () assertConvMember u c = - getSelfMember u c !!! do + getSelfMember (qUnqualified u) c !!! do const 200 === statusCode const (Right u) === (fmap memId <$> responseJsonEither) @@ -1304,7 +1304,7 @@ assertConv :: Response (Maybe Lazy.ByteString) -> ConvType -> UserId -> - UserId -> + Qualified UserId -> [UserId] -> Maybe Text -> Maybe Milliseconds -> @@ -1316,7 +1316,7 @@ assertConvWithRole :: Response (Maybe Lazy.ByteString) -> ConvType -> UserId -> - UserId -> + Qualified UserId -> [UserId] -> Maybe Text -> Maybe Milliseconds -> @@ -2331,7 +2331,14 @@ checkConvCreateEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do Conv.EdConversation x -> (qUnqualified . cnvQualifiedId) x @?= cid other -> assertFailure $ "Unexpected event data: " <> show other -wsAssertConvCreateWithRole :: HasCallStack => Qualified ConvId -> Qualified UserId -> UserId -> [(Qualified UserId, RoleName)] -> Notification -> IO () +wsAssertConvCreateWithRole :: + HasCallStack => + Qualified ConvId -> + Qualified UserId -> + Qualified UserId -> + [(Qualified UserId, RoleName)] -> + Notification -> + IO () wsAssertConvCreateWithRole conv eventFrom selfMember otherMembers n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index 940178095fe..ffda58da20e 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -42,31 +42,31 @@ tests = testGroup "ConversationMapping" [ testProperty "conversation view for a valid user is non-empty" $ - \(ConvWithLocalUser c uid) dom -> isJust (conversationViewMaybe dom uid c), + \(ConvWithLocalUser c luid) -> isJust (conversationViewMaybe luid c), testProperty "self user in conversation view is correct" $ - \(ConvWithLocalUser c uid) dom -> - fmap (memId . cmSelf . cnvMembers) (conversationViewMaybe dom uid c) - == Just uid, + \(ConvWithLocalUser c luid) -> + fmap (memId . cmSelf . cnvMembers) (conversationViewMaybe luid c) + == Just (qUntagged luid), testProperty "conversation view metadata is correct" $ - \(ConvWithLocalUser c uid) dom -> - fmap cnvMetadata (conversationViewMaybe dom uid c) + \(ConvWithLocalUser c luid) -> + fmap cnvMetadata (conversationViewMaybe luid c) == Just (Data.convMetadata c), testProperty "other members in conversation view do not contain self" $ - \(ConvWithLocalUser c uid) dom -> case conversationViewMaybe dom uid c of + \(ConvWithLocalUser c luid) -> case conversationViewMaybe luid c of Nothing -> False Just cnv -> not - ( Qualified uid dom + ( qUntagged luid `elem` (map omQualifiedId (cmOthers (cnvMembers cnv))) ), testProperty "conversation view contains all users" $ - \(ConvWithLocalUser c uid) dom -> - fmap (sort . cnvUids dom) (conversationViewMaybe dom uid c) - == Just (sort (convUids dom c)), + \(ConvWithLocalUser c luid) -> + fmap (sort . cnvUids) (conversationViewMaybe luid c) + == Just (sort (convUids (tDomain luid) c)), testProperty "conversation view for an invalid user is empty" $ - \(RandomConversation c) dom uid -> - not (elem uid (map lmId (Data.convLocalMembers c))) - ==> isNothing (conversationViewMaybe dom uid c), + \(RandomConversation c) luid -> + not (elem (tUnqualified luid) (map lmId (Data.convLocalMembers c))) + ==> isNothing (conversationViewMaybe luid c), testProperty "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (qUntagged ruid) /= dom @@ -91,10 +91,10 @@ tests = ) ] -cnvUids :: Domain -> Conversation -> [Qualified UserId] -cnvUids dom c = +cnvUids :: Conversation -> [Qualified UserId] +cnvUids c = let mems = cnvMembers c - in Qualified (memId (cmSelf mems)) dom : + in memId (cmSelf mems) : map omQualifiedId (cmOthers mems) convUids :: Domain -> Data.Conversation -> [Qualified UserId] @@ -136,14 +136,16 @@ newtype RandomConversation = RandomConversation instance Arbitrary RandomConversation where arbitrary = RandomConversation <$> genConversation -data ConvWithLocalUser = ConvWithLocalUser Data.Conversation UserId +data ConvWithLocalUser = ConvWithLocalUser Data.Conversation (Local UserId) deriving (Show) instance Arbitrary ConvWithLocalUser where arbitrary = do member <- genLocalMember - ConvWithLocalUser <$> genConv member <*> pure (lmId member) + ConvWithLocalUser <$> genConv member <*> genLocal (lmId member) where + genLocal :: x -> Gen (Local x) + genLocal v = flip toLocalUnsafe v <$> arbitrary genConv m = uniqueMembers m . unRandomConversation <$> arbitrary uniqueMembers :: LocalMember -> Data.Conversation -> Data.Conversation uniqueMembers m c = diff --git a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs index f0f383a491b..7a34d8280b9 100644 --- a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs +++ b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs @@ -81,7 +81,8 @@ prepareConv (a : bs) = do mapM_ (connectIfNeeded a) bs let bIds = map botId bs conv <- qUnqualified . cnvQualifiedId <$> runBotSession a (createConv bIds Nothing) - assertConvCreated conv a bs + lconv <- qualifyLocal conv + assertConvCreated lconv a bs return conv -- | Make sure that there is a connection between two bots. diff --git a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs index 529cdf29486..4fcd6d0acfb 100644 --- a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs +++ b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs @@ -89,7 +89,8 @@ mainBotNet n = do meetup <- runBotSession ally $ do let others = bill : carl : goons conv <- qUnqualified . cnvQualifiedId <$> createConv (map botId others) (Just "Meetup") - assertConvCreated conv ally others + lconv <- qualifyLocal conv + assertConvCreated lconv ally others return conv info $ msg "Bill updates his member state" localDomain <- viewFederationDomain From 48ff7da260463c57eeeabaf3b8379a3aed9b46ec Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 21 Oct 2021 09:53:53 +0200 Subject: [PATCH 40/88] Changelog script: skip empty sections (#1871) --- changelog.d/mk-changelog.sh | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/changelog.d/mk-changelog.sh b/changelog.d/mk-changelog.sh index da6998647d8..550e024738c 100755 --- a/changelog.d/mk-changelog.sh +++ b/changelog.d/mk-changelog.sh @@ -13,10 +13,14 @@ getPRNumber() { for d in "$DIR"/*; do if [[ ! -d "$d" ]]; then continue; fi + entries=("$d"/*[^~]) + + if [[ ${#entries[@]} -eq 0 ]]; then continue; fi + echo -n "## " sed '$ a\' "$d/.title" echo "" - for f in "$d"/*[^~]; do + for f in "${entries[@]}"; do pr=$(getPRNumber $f) sed -r ' # create a bullet point on the first line From a2c02fa7633979a4ada649eeb363107d1238b387 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Oct 2021 12:08:58 +0200 Subject: [PATCH 41/88] Replace shell.nix with a direnv + nixpkgs.buildEnv based setup (#1876) * Replace shell.nix with a direnv + nixpkgs.buildEnv based setup * Add instructions on how to use nix-hls.sh from emacs --- .envrc | 5 +++++ Makefile | 2 +- changelog.d/5-internal/direnv_buildEnv | 1 + shell.nix => direnv.nix | 21 ++++++++++++++++----- docs/developer/dependencies.md | 5 +++-- docs/developer/editor-setup.md | 10 ++++++++++ hack/bin/nix-hls.sh | 10 ++++++++++ 7 files changed, 46 insertions(+), 8 deletions(-) create mode 100644 .envrc create mode 100644 changelog.d/5-internal/direnv_buildEnv rename shell.nix => direnv.nix (86%) create mode 100755 hack/bin/nix-hls.sh diff --git a/.envrc b/.envrc new file mode 100644 index 00000000000..2da5bd84730 --- /dev/null +++ b/.envrc @@ -0,0 +1,5 @@ +env=$(nix-build --no-out-link "$PWD/direnv.nix") +PATH_add "${env}" + +# allow local .envrc overrides +[[ -f .envrc.local ]] && source_env .envrc.local diff --git a/Makefile b/Makefile index 465c03ca2d0..980fffa3204 100644 --- a/Makefile +++ b/Makefile @@ -234,7 +234,7 @@ libzauth: .PHONY: hie.yaml hie.yaml: stack-dev.yaml stack build implicit-hie - stack exec gen-hie | nix-shell --command 'yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml' + stack exec gen-hie | yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml .PHONY: stack-dev.yaml stack-dev.yaml: diff --git a/changelog.d/5-internal/direnv_buildEnv b/changelog.d/5-internal/direnv_buildEnv new file mode 100644 index 00000000000..8ee4394ab61 --- /dev/null +++ b/changelog.d/5-internal/direnv_buildEnv @@ -0,0 +1 @@ +Replace shell.nix with direnv + nixpkgs.buildEnv based setup \ No newline at end of file diff --git a/shell.nix b/direnv.nix similarity index 86% rename from shell.nix rename to direnv.nix index 334f8007c3d..c29ac40da57 100644 --- a/shell.nix +++ b/direnv.nix @@ -90,11 +90,21 @@ let binPath = "client/bin/kubectl"; }; + + kind = staticBinary { + pname = "kind"; + version = "0.11.0"; + + darwinAmd64Url = "https://github.com/kubernetes-sigs/kind/releases/download/v0.11.1/kind-darwin-amd64"; + darwinAmd64Sha256 = "432bef555a70e9360b44661c759658265b9eaaf7f75f1beec4c4d1e6bbf97ce3"; + + linuxAmd64Url = "https://github.com/kubernetes-sigs/kind/releases/download/v0.11.1/kind-linux-amd64"; + linuxAmd64Sha256 = "949f81b3c30ca03a3d4effdecda04f100fa3edc07a28b19400f72ede7c5f0491"; + }; }; -in pkgs.mkShell { - name = "shell"; - LOCALE_ARCHIVE = "${pkgs.glibcLocales}/lib/locale/locale-archive"; # works around https://github.com/tweag/ormolu/issues/38 - buildInputs = [ +in pkgs.buildEnv { + name = "wire-server-direnv"; + paths = [ pkgs.docker-compose pkgs.gnumake pkgs.haskell-language-server @@ -107,11 +117,12 @@ in pkgs.mkShell { # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf pkgs.buildah - pkgs.kind pinned.stack pinned.helm pinned.helmfile pinned.kubectl + pinned.kind ]; } + diff --git a/docs/developer/dependencies.md b/docs/developer/dependencies.md index 25a15e42055..3cd670834ed 100644 --- a/docs/developer/dependencies.md +++ b/docs/developer/dependencies.md @@ -174,11 +174,12 @@ docker login --username= * [Install docker](https://docker.com) * [Install docker-compose](https://docs.docker.com/compose/install/) -## Nix +## Nix + Direnv Using Stack's [Nix integration](https://docs.haskellstack.org/en/stable/nix_integration/), Stack will take care of installing any system dependencies automatically - including `cryptobox-c`. If new system dependencies are needed, add them to the `stack-deps.nix` file in the project root. -Just type `$ nix-shell` and you will automatically have `make`, `docker-compose` and `stack` in `PATH`. + +If you have `direnv` and `nix`, you will automatically have `make`, `docker-compose` and `stack` in `PATH` once you `cd` into the project root and `direnv allow`. You can then run all the builds, and the native dependencies will be automatically present. ## Telepresence diff --git a/docs/developer/editor-setup.md b/docs/developer/editor-setup.md index 99509513fe9..e21d59025b8 100644 --- a/docs/developer/editor-setup.md +++ b/docs/developer/editor-setup.md @@ -57,6 +57,16 @@ Install the [projectile][] package for Emacs and do `M-x projectile-add-known-pr ad-do-it))) ``` +### Haskell Language Server + +To use HLS bundled in direnv setup, here is a sample `.dir-locals.el` that can +be put in the root directory of the project: +```el +((haskell-mode . ((haskell-completion-backend . lsp) + (lsp-haskell-server-path . "/home/haskeller/code/wire-server/hack/bin/nix-hls.sh") + ))) +``` + ### Ormolu integration There are make targets `format`, `formatf`, `formatc` to re-format diff --git a/hack/bin/nix-hls.sh b/hack/bin/nix-hls.sh new file mode 100755 index 00000000000..488cc122e6e --- /dev/null +++ b/hack/bin/nix-hls.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +env=$(nix-build --no-out-link "$PWD/direnv.nix") +export PATH="$env/bin:$PATH" +haskell-language-server-wrapper "$@" From 4293d82b49a9dbbebd1405bfeb2430824c9f3dbd Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Oct 2021 12:16:52 +0200 Subject: [PATCH 42/88] Correctly update PATH in .envrc (#1877) --- .envrc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.envrc b/.envrc index 2da5bd84730..45436364165 100644 --- a/.envrc +++ b/.envrc @@ -1,5 +1,5 @@ env=$(nix-build --no-out-link "$PWD/direnv.nix") -PATH_add "${env}" +PATH_add "${env}/bin" # allow local .envrc overrides [[ -f .envrc.local ]] && source_env .envrc.local From 992796e8b8552f8651162855fdee7fe06c5f582f Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 21 Oct 2021 12:38:27 +0200 Subject: [PATCH 43/88] Introduce 'make flake-PATTERN' (#1875) Add a 'make flake-PATTERN' target to run a subset of tests multiple times to trigger a failure case in flaky tests. By default the test(s) will run up to 1000 times until a failure occurs, at which point it will stop. Scrolling up on the output will show you how many tests had to run to trigger a failure. example output: ``` make flake-sso-id echo 'set -ex' > /tmp/flake.sh chmod +x /tmp/flake.sh for i in $(seq 1000); do \ echo "echo $i" >> /tmp/flake.sh; \ echo '../../dist/brig-integration -s brig.integration.yaml -i ../integration.yaml -p "sso-id" ' >> /tmp/flake.sh; \ done INTEGRATION_USE_NGINZ=1 ../integration.sh /tmp/flake.sh Running tests using mocked AWS services [cannon] I, Listening on 127.0.0.1:8083 [cannon] I, Listening on 127.0.0.1:8183 [cargohold] I, Listening on 0.0.0.0:8084 [spar] I, logger=cassandra.spar, Known hosts: [datacenter1:rack1:127.0.0.1:9042] [federator] D, inotify initialized, inotify= [gundeck] I, Listening on 0.0.0.0:8086 [galley] I, Listening on 127.0.0.1:8085 [spar] I, Listening on 0.0.0.0:8088 [nginz] 127.0.0.1 - - [20/Oct/2021:16:33:50 +0200] "GET /i/status HTTP/1.1" 200 0 "-" "curl/7.71.1" "-" - 2 0.000 - - - - 3cabaf643c510db36a3c989301d73569 all services are up! ++ echo 1 1 ++ ../../dist/brig-integration -s brig.integration.yaml -i ../integration.yaml -p sso-id 2021-10-20T14:33:51Z, D, Connecting to 127.0.0.1:9042 2021-10-20T14:33:51Z, I, Known hosts: [datacenter1:rack1:127.0.0.1:9042] 2021-10-20T14:33:51Z, I, New control connection: datacenter1:rack1:127.0.0.1:9042# Brig API Integration user account put /i/users/:uid/sso-id: OK (0.82s) All 1 tests passed (0.83s) ++ echo 2 2 ++ ../../dist/brig-integration -s brig.integration.yaml -i ../integration.yaml -p sso-id 2021-10-20T14:33:53Z, D, Connecting to 127.0.0.1:9042 Brig API Integration user account put /i/users/:uid/sso-id: 2021-10-20T14:33:53Z, I, Known hosts: [datacenter1:rack1:127.0.0.1:9042] 2021-10-20T14:33:53Z, I, New control connection: datacenter1:rack1:127.0.0.1:9042# OK (0.85s) All 1 tests passed (0.85s) ++ echo 3 3 ++ ../../dist/brig-integration -s brig.integration.yaml -i ../integration.yaml -p sso-id 2021-10-20T14:33:55Z, D, Connecting to 127.0.0.1:9042 Brig API Integration user account put /i/users/:uid/sso-id: 2021-10-20T14:33:55Z, I, Known hosts: [datacenter1:rack1:127.0.0.1:9042] 2021-10-20T14:33:55Z, I, New control connection: datacenter1:rack1:127.0.0.1:9042# OK (0.77s) All 1 tests passed (0.77s) ++ echo 4 4 ++ ../../dist/brig-integration -s brig.integration.yaml -i ../integration.yaml -p sso-id 2021-10-20T14:33:56Z, D, Connecting to 127.0.0.1:9042 Brig API Integration user account put /i/users/:uid/sso-id: 2021-10-20T14:33:56Z, I, Known hosts: [datacenter1:rack1:127.0.0.1:9042] 2021-10-20T14:33:56Z, I, New control connection: datacenter1:rack1:127.0.0.1:9042# OK (0.79s) All 1 tests passed (0.79s) ++ echo 5 5 ++ ../../dist/brig-integration -s brig.integration.yaml -i ../integration.yaml -p sso-id ``` When a failure happens: ``` ++ echo 282 282 ++ ../../dist/brig-integration -s brig.integration.yaml -i ../integration.yaml -p sso-id 2021-10-20T14:41:25Z, D, Connecting to 127.0.0.1:9042 [brig] W, logger=cassandra.brig, Server warning: Read 0 live rows and 2102 tombstone cells for query SELECT * FROM brig_test.users_pending_activation WHERE LIMIT 10000 (see tombstone_warn_threshold) Brig API Integration user account put /i/users/:uid/sso-id: 2021-10-20T14:41:25Z, I, Known hosts: [datacenter1:rack1:127.0.0.1:9042] 2021-10-20T14:41:25Z, I, New control connection: datacenter1:rack1:127.0.0.1:9042# [brig] W, logger=cassandra.brig, Server warning: Read 0 live rows and 2104 tombstone cells for query SELECT * FROM brig_test.users_pending_activation WHERE LIMIT 10000 (see tombstone_warn_threshold) FAIL Exception: Assertions failed: 1: 202 =/= 403 2: updatePhone (PUT /self/phone): failed to update to Phone {fromPhone = "+046965171332989"} - might be a flaky test tracked in https://wearezeta.atlassian.net/browse/BE-526 Response was: Response {responseStatus = Status {statusCode = 403, statusMessage = "Forbidden"}, responseVersion = HTTP/1.1, responseHeaders = [("Transfer-Encoding","chunked"),("Date","Wed, 20 Oct 2021 14:41:27 GMT"),("Server","Warp/3.3.13"),("Content-Encoding","gzip"),("Content-Type","application/json")], responseBody = Just "{\"code\":403,\"message\":\"The given phone number has been blacklisted due to suspected abuse or a complaint.\",\"label\":\"blacklisted-phone\"}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} CallStack (from HasCallStack): error, called at src/Bilge/Assert.hs:89:5 in bilge-0.22.0-5tCtgpJGKRb38JsbN4shGd:Bilge.Assert $(FLAKE_FILE) + chmod +x $(FLAKE_FILE) + for i in $$(seq $(FLAKE_AMOUNT)); do \ + echo "echo $$i" >> $(FLAKE_FILE); \ + echo '$(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml -p "$*" $(WIRE_INTEGRATION_TEST_OPTIONS)' >> $(FLAKE_FILE); \ + done + INTEGRATION_USE_NGINZ=$(INTEGRATION_USE_NGINZ) ../integration.sh $(FLAKE_FILE) + .PHONY: integration integration: fast i From 6291a909219ce247745943636a2c201e0d13b8ac Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 21 Oct 2021 16:20:15 +0200 Subject: [PATCH 44/88] updatePhone deflake (#1874) * updatePhone deflake debugging information This is about https://wearezeta.atlassian.net/browse/BE-526 I think what's happening is that one test that tests the phone blocking adds a record into the brig.excluded_phones entry. Then, another, unrelated test, if unlucky enough to randomly generate a phone number contained under that prefix, fails in the PUT /self/phone call. * 1) update integration test output to give better information and link to a flaky test description * 2) change the code to (hopefully) avoid this flake to re-occur. The changes to integration tests will lead to the following output on failure: user account put /i/users/:uid/sso-id: Exception: Assertions failed: 1: 202 =/= 403 2: updatePhone (PUT /self/phone): failed to update to Phone {fromPhone = "+046965171332989"} - might be a flaky test tracked in https://wearezeta.atlassian.net/browse/BE-526 Response was: Response {responseStatus = Status {statusCode = 403, statusMessage = "Forbidden"}, responseVersion = HTTP/1.1, responseHeaders = [("Transfer-Encoding","chunked"),("Date","Wed, 20 Oct 2021 14:41:27 GMT"),("Server","Warp/3.3.13"),("Content-Encoding","gzip"),("Content-Type","application/json")], responseBody = Just "{\"code\":403,\"message\":\"The given phone number has been blacklisted due to suspected abuse or a complaint.\",\"label\":\"blacklisted-phone\"}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} CallStack (from HasCallStack): error, called at src/Bilge/Assert.hs:89:5 in bilge-0.22.0-5tCtgpJGKRb38JsbN4shGd:Bilge.Assert Brig -> Http () testCreateAccountPendingActivationKey (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ = pure () testCreateAccountPendingActivationKey _ brig = do diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 5d6e47b80a0..5cb0712b87f 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -727,12 +727,14 @@ randomPhone = liftIO $ do let phone = parsePhone . Text.pack $ "+0" ++ concat nrs return $ fromMaybe (error "Invalid random phone#") phone -updatePhone :: Brig -> UserId -> Phone -> Http () +updatePhone :: HasCallStack => Brig -> UserId -> Phone -> Http () updatePhone brig uid phn = do -- update phone let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn - put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) - !!! (const 202 === statusCode) + failMsg = "updatePhone (PUT /self/phone): failed to update to " <> show phn <> " - might be a flaky test tracked in https://wearezeta.atlassian.net/browse/BE-526" + put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) !!! do + const 202 === statusCode + assertTrue failMsg ((== 202) . statusCode) -- activate act <- getActivationCode brig (Right phn) case act of From d586d0debb41310c17d7c59205855d3071ed821d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 25 Oct 2021 09:40:01 +0200 Subject: [PATCH 45/88] Include conv creator is only once in notifications sent to remotes (#1879) To remove any confusion in the `on-conversation-created` federation API, rename "members" to "non_creator_members". As the creator is already specified in "orig_user_id". Also: - Add Golden tests for `NewRemoteConversation` - Add integration tests for creating conversation with remote users --- .../6-federation/ensure-one-creator-member | 1 + .../src/Wire/API/Federation/API/Galley.hs | 4 +- .../Wire/API/Federation/Golden/GoldenSpec.hs | 5 ++ .../Golden/NewRemoteConversation.hs | 67 ++++++++++++++++++ .../testObject_NewRemoteConversation1.json | 38 ++++++++++ .../testObject_NewRemoteConversation2.json | 12 ++++ .../wire-api-federation.cabal | 3 +- services/galley/src/Galley/API/Federation.hs | 6 +- services/galley/src/Galley/API/Util.hs | 4 +- services/galley/test/integration/API.hs | 70 ++++++++++++++++++- services/galley/test/integration/API/Util.hs | 50 ++++++++++++- 11 files changed, 250 insertions(+), 10 deletions(-) create mode 100644 changelog.d/6-federation/ensure-one-creator-member create mode 100644 libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs create mode 100644 libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json create mode 100644 libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json diff --git a/changelog.d/6-federation/ensure-one-creator-member b/changelog.d/6-federation/ensure-one-creator-member new file mode 100644 index 00000000000..471240b0977 --- /dev/null +++ b/changelog.d/6-federation/ensure-one-creator-member @@ -0,0 +1 @@ +Ensure that the conversation creator is included only once in notifications sent to remote users \ No newline at end of file diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 8da62aaba63..699ce838274 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -163,8 +163,8 @@ data NewRemoteConversation conv = NewRemoteConversation rcCnvAccessRole :: AccessRole, -- | The conversation name, rcCnvName :: Maybe Text, - -- | Members of the conversation - rcMembers :: Set OtherMember, + -- | Members of the conversation apart from the creator + rcNonCreatorMembers :: Set OtherMember, rcMessageTimer :: Maybe Milliseconds, rcReceiptMode :: Maybe ReceiptMode } diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index 8142d17ae17..5cac536c68e 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -25,6 +25,7 @@ import qualified Test.Wire.API.Federation.Golden.LeaveConversationResponse as Le import qualified Test.Wire.API.Federation.Golden.MessageSendResponse as MessageSendResponse import qualified Test.Wire.API.Federation.Golden.NewConnectionRequest as NewConnectionRequest import qualified Test.Wire.API.Federation.Golden.NewConnectionResponse as NewConnectionResponse +import qualified Test.Wire.API.Federation.Golden.NewRemoteConversation as NewRemoteConversation import Test.Wire.API.Federation.Golden.Runner (testObjects) spec :: Spec @@ -62,3 +63,7 @@ spec = (NewConnectionResponse.testObject_NewConnectionResponse3, "testObject_NewConnectionResponse3.json"), (NewConnectionResponse.testObject_NewConnectionResponse4, "testObject_NewConnectionResponse4.json") ] + testObjects + [ (NewRemoteConversation.testObject_NewRemoteConversation1, "testObject_NewRemoteConversation1.json"), + (NewRemoteConversation.testObject_NewRemoteConversation2, "testObject_NewRemoteConversation2.json") + ] diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs new file mode 100644 index 00000000000..9fcb503ea5c --- /dev/null +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs @@ -0,0 +1,67 @@ +module Test.Wire.API.Federation.Golden.NewRemoteConversation where + +import Data.Domain +import Data.Id +import Data.Misc +import Data.Qualified +import qualified Data.Set as Set +import qualified Data.UUID as UUID +import Imports +import Wire.API.Conversation +import Wire.API.Conversation.Role +import Wire.API.Federation.API.Galley +import Wire.API.Provider.Service + +testObject_NewRemoteConversation1 :: NewRemoteConversation ConvId +testObject_NewRemoteConversation1 = + NewRemoteConversation + { rcTime = read "1864-04-12 12:22:43.673 UTC", + rcOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), + rcCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), + rcCnvType = RegularConv, + rcCnvAccess = [InviteAccess, CodeAccess], + rcCnvAccessRole = ActivatedAccessRole, + rcCnvName = Just "gossip", + rcNonCreatorMembers = + Set.fromList + [ OtherMember + { omQualifiedId = + Qualified + (read "50e6fff1-ffbd-4235-bc73-19c093433beb") + (Domain "golden.example.com"), + omService = Nothing, + omConvRoleName = roleNameWireAdmin + }, + OtherMember + { omQualifiedId = + Qualified + (read "6801e49b-918c-4eef-baed-f18522152fca") + (Domain "golden.example.com"), + omService = + Just + ( ServiceRef + { _serviceRefId = read "abfe2452-ed22-4f94-b4d4-765b989d7dbb", + _serviceRefProvider = read "11b91f61-917e-489b-a268-60b881d08f06" + } + ), + omConvRoleName = roleNameWireMember + } + ], + rcMessageTimer = Just (Ms 1000), + rcReceiptMode = Just (ReceiptMode 42) + } + +testObject_NewRemoteConversation2 :: NewRemoteConversation ConvId +testObject_NewRemoteConversation2 = + NewRemoteConversation + { rcTime = read "1864-04-12 12:22:43.673 UTC", + rcOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), + rcCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), + rcCnvType = One2OneConv, + rcCnvAccess = [], + rcCnvAccessRole = ActivatedAccessRole, + rcCnvName = Nothing, + rcNonCreatorMembers = Set.fromList [], + rcMessageTimer = Nothing, + rcReceiptMode = Nothing + } diff --git a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json new file mode 100644 index 00000000000..f1716f8bb18 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json @@ -0,0 +1,38 @@ +{ + "orig_user_id": "eed9dea3-5468-45f8-b562-7ad5de2587d0", + "time": "1864-04-12T12:22:43.673Z", + "cnv_access": [ + "invite", + "code" + ], + "non_creator_members": [ + { + "status": 0, + "conversation_role": "wire_admin", + "qualified_id": { + "domain": "golden.example.com", + "id": "50e6fff1-ffbd-4235-bc73-19c093433beb" + }, + "id": "50e6fff1-ffbd-4235-bc73-19c093433beb" + }, + { + "status": 0, + "service": { + "id": "abfe2452-ed22-4f94-b4d4-765b989d7dbb", + "provider": "11b91f61-917e-489b-a268-60b881d08f06" + }, + "conversation_role": "wire_member", + "qualified_id": { + "domain": "golden.example.com", + "id": "6801e49b-918c-4eef-baed-f18522152fca" + }, + "id": "6801e49b-918c-4eef-baed-f18522152fca" + } + ], + "cnv_access_role": "activated", + "cnv_type": 0, + "receipt_mode": 42, + "message_timer": 1000, + "cnv_name": "gossip", + "cnv_id": "d13dbe58-d4e3-450f-9c0c-1e632f548740" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json new file mode 100644 index 00000000000..bb4bcfc7550 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json @@ -0,0 +1,12 @@ +{ + "orig_user_id": "eed9dea3-5468-45f8-b562-7ad5de2587d0", + "time": "1864-04-12T12:22:43.673Z", + "cnv_access": [], + "non_creator_members": [], + "cnv_access_role": "activated", + "cnv_type": 2, + "receipt_mode": null, + "message_timer": null, + "cnv_name": null, + "cnv_id": "d13dbe58-d4e3-450f-9c0c-1e632f548740" +} \ No newline at end of file diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index e8729651c85..7f35a001fbe 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 03f7245b036ccc38819ed5f5654dae8d96b7ec5917b2f898be3305193bc3faf5 +-- hash: 6b4b223086cf1ba879d202fe6b884009e44bff247db6de7a2501d599295b8457 name: wire-api-federation version: 0.1.0 @@ -84,6 +84,7 @@ test-suite spec Test.Wire.API.Federation.Golden.MessageSendResponse Test.Wire.API.Federation.Golden.NewConnectionRequest Test.Wire.API.Federation.Golden.NewConnectionResponse + Test.Wire.API.Federation.Golden.NewRemoteConversation Test.Wire.API.Federation.Golden.Runner Test.Wire.API.Federation.GRPC.TypesSpec Paths_wire_api_federation diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 9b873d0cebd..715c34145b6 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -83,7 +83,7 @@ onConversationCreated :: Domain -> NewRemoteConversation ConvId -> Galley () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () - let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (rcMembers rc))) + let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (rcNonCreatorMembers rc))) addedUserIds <- addLocalUsersToRemoteConv @@ -99,9 +99,9 @@ onConversationCreated domain rc = do (const True) . omQualifiedId ) - (rcMembers rc) + (rcNonCreatorMembers rc) -- Make sure to notify only about local users connected to the adder - let qrcConnected = qrc {rcMembers = connectedMembers} + let qrcConnected = qrc {rcNonCreatorMembers = connectedMembers} forM_ (fromNewRemoteConversation loc qrcConnected) $ \(mem, c) -> do let event = diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 479c95f7f8f..e0c3d332bb0 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -690,7 +690,7 @@ toNewRemoteConversation now localDomain Data.Conversation {..} = rcCnvAccess = convAccess, rcCnvAccessRole = convAccessRole, rcCnvName = convName, - rcMembers = toMembers convLocalMembers convRemoteMembers, + rcNonCreatorMembers = toMembers (filter (\lm -> lmId lm /= convCreator) convLocalMembers) convRemoteMembers, rcMessageTimer = convMessageTimer, rcReceiptMode = convReceiptMode } @@ -714,7 +714,7 @@ fromNewRemoteConversation :: NewRemoteConversation (Remote ConvId) -> [(Public.Member, Public.Conversation)] fromNewRemoteConversation loc rc@NewRemoteConversation {..} = - let membersView = fmap (second Set.toList) . setHoles $ rcMembers + let membersView = fmap (second Set.toList) . setHoles $ rcNonCreatorMembers creatorOther = OtherMember (qUntagged (rcRemoteOrigUserId rc)) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index f386381822b..c965710dd8e 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -125,6 +125,7 @@ tests s = [ test s "status" status, test s "metrics" metrics, test s "create conversation" postConvOk, + test s "create conversation with remote users" postConvWithRemoteUsersOk, test s "get empty conversations" getConvsOk, test s "get conversations by ids" getConvsOk2, test s "fail to get >500 conversations" getConvsFailMaxSize, @@ -305,6 +306,73 @@ postConvOk = do EdConversation c' -> assertConvEquals cnv c' _ -> assertFailure "Unexpected event data" +postConvWithRemoteUsersOk :: TestM () +postConvWithRemoteUsersOk = do + c <- view tsCannon + (alice, qAlice) <- randomUserTuple + (alex, qAlex) <- randomUserTuple + (amy, qAmy) <- randomUserTuple + connectUsers alice (list1 alex [amy]) + let cDomain = Domain "c.example.com" + dDomain = Domain "d.example.com" + qChad <- randomQualifiedId cDomain + qCharlie <- randomQualifiedId cDomain + qDee <- randomQualifiedId dDomain + mapM_ (connectWithRemoteUser alice) [qChad, qCharlie, qDee] + + -- Ensure name is within range, max size is 256 + postConvQualified alice defNewConv {newConvName = Just (T.replicate 257 "a"), newConvQualifiedUsers = [qAlex, qAmy, qChad, qCharlie, qDee]} + !!! const 400 === statusCode + + let nameMaxSize = T.replicate 256 "a" + WS.bracketR3 c alice alex amy $ \(wsAlice, wsAlex, wsAmy) -> do + (rsp, federatedRequests) <- + withTempMockFederator (const ()) $ + postConvQualified alice defNewConv {newConvName = Just nameMaxSize, newConvQualifiedUsers = [qAlex, qAmy, qChad, qCharlie, qDee]} + F.domain r == domainText cDomain) federatedRequests + cFedReqBody <- assertRight $ parseFedReqBody cFedReq + + dFedReq <- assertOne $ filter (\r -> F.domain r == domainText dDomain) federatedRequests + dFedReqBody <- assertRight $ parseFedReqBody dFedReq + + liftIO $ do + length federatedRequests @?= 2 + + FederatedGalley.rcOrigUserId cFedReqBody @?= alice + FederatedGalley.rcCnvId cFedReqBody @?= cid + FederatedGalley.rcCnvType cFedReqBody @?= RegularConv + FederatedGalley.rcCnvAccess cFedReqBody @?= [InviteAccess] + FederatedGalley.rcCnvAccessRole cFedReqBody @?= ActivatedAccessRole + FederatedGalley.rcCnvName cFedReqBody @?= Just nameMaxSize + FederatedGalley.rcNonCreatorMembers cFedReqBody @?= Set.fromList (toOtherMember <$> [qAlex, qAmy, qChad, qCharlie, qDee]) + FederatedGalley.rcMessageTimer cFedReqBody @?= Nothing + FederatedGalley.rcReceiptMode cFedReqBody @?= Nothing + + dFedReqBody @?= cFedReqBody + where + parseFedReqBody :: FromJSON a => F.FederatedRequest -> Either String a + parseFedReqBody fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + toOtherMember qid = OtherMember qid Nothing roleNameWireAdmin + convView cnv usr = responseJsonUnsafeWithMsg "conversation" <$> getConv usr cnv + checkWs qalice (cnv, ws) = WS.awaitMatch (5 # Second) ws $ \n -> do + ntfTransient n @?= False + let e = List1.head (WS.unpackPayload n) + evtConv e @?= cnvQualifiedId cnv + evtType e @?= ConvCreate + evtFrom e @?= qalice + case evtData e of + EdConversation c' -> assertConvEquals cnv c' + _ -> assertFailure "Unexpected event data" + -- | This test verifies whether a message actually gets sent all the way to -- cannon. postCryptoMessage1 :: TestM () @@ -3065,7 +3133,7 @@ removeUser = do FederatedGalley.rcCnvAccess = [], FederatedGalley.rcCnvAccessRole = PrivateAccessRole, FederatedGalley.rcCnvName = Just "gossip4", - FederatedGalley.rcMembers = Set.fromList $ createOtherMember <$> [dee, alice, bob], + FederatedGalley.rcNonCreatorMembers = Set.fromList $ createOtherMember <$> [alice, bob], FederatedGalley.rcMessageTimer = Nothing, FederatedGalley.rcReceiptMode = Nothing } diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index cd3b71c0e3e..04ac52e7ed7 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1257,7 +1257,7 @@ registerRemoteConv convId originUser name othMembers = do rcCnvAccess = [], rcCnvAccessRole = ActivatedAccessRole, rcCnvName = name, - rcMembers = othMembers, + rcNonCreatorMembers = othMembers, rcMessageTimer = Nothing, rcReceiptMode = Nothing } @@ -1347,6 +1347,54 @@ assertConvWithRole r t c s us n mt role = do _ -> return () return cId +assertConvQualified :: + HasCallStack => + Response (Maybe Lazy.ByteString) -> + ConvType -> + UserId -> + Qualified UserId -> + [Qualified UserId] -> + Maybe Text -> + Maybe Milliseconds -> + TestM ConvId +assertConvQualified r t c s us n mt = assertConvQualifiedWithRole r t c s us n mt roleNameWireAdmin + +assertConvQualifiedWithRole :: + HasCallStack => + Response (Maybe Lazy.ByteString) -> + ConvType -> + UserId -> + Qualified UserId -> + [Qualified UserId] -> + Maybe Text -> + Maybe Milliseconds -> + RoleName -> + TestM ConvId +assertConvQualifiedWithRole r t c s us n mt role = do + cId <- fromBS $ getHeader' "Location" r + let cnv = responseJsonMaybe @Conversation r + let _self = cmSelf . cnvMembers <$> cnv + let others = cmOthers . cnvMembers <$> cnv + liftIO $ do + assertEqual "id" (Just cId) (qUnqualified . cnvQualifiedId <$> cnv) + assertEqual "name" n (cnv >>= cnvName) + assertEqual "type" (Just t) (cnvType <$> cnv) + assertEqual "creator" (Just c) (cnvCreator <$> cnv) + assertEqual "message_timer" (Just mt) (cnvMessageTimer <$> cnv) + assertEqual "self" (Just s) (memId <$> _self) + assertEqual "others" (Just . Set.fromList $ us) (Set.fromList . map omQualifiedId . toList <$> others) + assertEqual "creator is always and admin" (Just roleNameWireAdmin) (memConvRoleName <$> _self) + assertBool "others role" (all (== role) $ maybe (error "Cannot be null") (map omConvRoleName . toList) others) + assertBool "otr muted ref not empty" (isNothing (memOtrMutedRef =<< _self)) + assertBool "otr archived not false" (Just False == (memOtrArchived <$> _self)) + assertBool "otr archived ref not empty" (isNothing (memOtrArchivedRef =<< _self)) + case t of + SelfConv -> assertEqual "access" (Just privateAccess) (cnvAccess <$> cnv) + ConnectConv -> assertEqual "access" (Just privateAccess) (cnvAccess <$> cnv) + One2OneConv -> assertEqual "access" (Just privateAccess) (cnvAccess <$> cnv) + _ -> return () + return cId + wsAssertOtr :: Qualified ConvId -> Qualified UserId -> ClientId -> ClientId -> Text -> Notification -> IO () wsAssertOtr = wsAssertOtr' "data" From 8eb2048e9cbb33363e39391109b29a35c808d6be Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 26 Oct 2021 13:52:34 +0200 Subject: [PATCH 46/88] Optimise remote user deletion (#1872) Creates two Federation RPCs: * In brig: on-user-deleted, notify about the connections in chunks of 1000 users. * In galley: on-user-deleted, notify about the conversations in chunks 1000 conversations When writing integration tests in brig, we can mock the federator for brig but not galley. As the two RPCs must be made from two separate places. So, we had to mock out galley to be able to test the brig functionality. The galley functionality is tested separately by calling the internal endpoint. Co-authored-by: Akshay Mankar Co-authored-by: Stefan Matting --- .../6-federation/optimize-user-deletion | 1 + libs/brig-types/src/Brig/Types/User/Event.hs | 37 ++--- libs/types-common/src/Data/Range.hs | 9 ++ .../src/Wire/API/Federation/API/Brig.hs | 23 ++- .../src/Wire/API/Federation/API/Common.hs | 35 ++++ .../src/Wire/API/Federation/API/Galley.hs | 21 ++- .../wire-api-federation.cabal | 3 +- services/brig/brig.cabal | 3 +- services/brig/package.yaml | 1 + services/brig/src/Brig/API/Federation.hs | 28 +++- services/brig/src/Brig/API/User.hs | 3 +- services/brig/src/Brig/Data/Connection.hs | 22 ++- services/brig/src/Brig/Federation/Client.hs | 12 ++ services/brig/src/Brig/IO/Intra.hs | 65 +++++++- .../brig/test/integration/API/Federation.hs | 43 ++++- .../brig/test/integration/API/User/Account.hs | 75 +++++++-- .../brig/test/integration/API/User/Util.hs | 12 ++ .../brig/test/integration/Federation/Util.hs | 5 - services/brig/test/integration/Main.hs | 2 +- services/brig/test/integration/Util.hs | 141 ++++++++++++++++- services/galley/src/Galley/API/Federation.hs | 34 +++- services/galley/src/Galley/API/Internal.hs | 32 +++- services/galley/src/Galley/API/Update.hs | 3 + services/galley/test/integration/API.hs | 148 +++++++++++------ .../galley/test/integration/API/Federation.hs | 149 +++++++++++++++++- services/galley/test/integration/API/Util.hs | 10 ++ 26 files changed, 784 insertions(+), 133 deletions(-) create mode 100644 changelog.d/6-federation/optimize-user-deletion create mode 100644 libs/wire-api-federation/src/Wire/API/Federation/API/Common.hs diff --git a/changelog.d/6-federation/optimize-user-deletion b/changelog.d/6-federation/optimize-user-deletion new file mode 100644 index 00000000000..a160e66fc0b --- /dev/null +++ b/changelog.d/6-federation/optimize-user-deletion @@ -0,0 +1 @@ +When a user gets deleted, notify remotes about conversations and connections in chunks of 1000 \ No newline at end of file diff --git a/libs/brig-types/src/Brig/Types/User/Event.hs b/libs/brig-types/src/Brig/Types/User/Event.hs index efe7c991f88..382eae7af51 100644 --- a/libs/brig-types/src/Brig/Types/User/Event.hs +++ b/libs/brig-types/src/Brig/Types/User/Event.hs @@ -23,7 +23,7 @@ import Brig.Types import Data.ByteString.Conversion import Data.Handle (Handle) import Data.Id -import Data.Qualified (Qualified (Qualified)) +import Data.Qualified import Imports import System.Logger.Class @@ -44,7 +44,7 @@ data UserEvent -- has been restored. UserResumed !UserId | -- | The user account has been deleted. - UserDeleted !UserId + UserDeleted !(Qualified UserId) | UserUpdated !UserUpdatedData | UserIdentityUpdated !UserIdentityUpdatedData | UserIdentityRemoved !UserIdentityRemovedData @@ -162,19 +162,6 @@ emptyUserUpdatedData u = connEventUserId :: ConnectionEvent -> UserId connEventUserId ConnectionUpdated {..} = ucFrom ucConn -userEventUserId :: UserEvent -> UserId -userEventUserId (UserCreated u) = userId u -userEventUserId (UserActivated u) = userId u -userEventUserId (UserSuspended u) = u -userEventUserId (UserResumed u) = u -userEventUserId (UserDeleted u) = u -userEventUserId (UserUpdated u) = eupId u -userEventUserId (UserIdentityUpdated u) = eiuId u -userEventUserId (UserIdentityRemoved u) = eirId u -userEventUserId (UserLegalHoldDisabled uid) = uid -userEventUserId (UserLegalHoldEnabled uid) = uid -userEventUserId (LegalHoldClientRequested dat) = lhcTargetUser dat - propEventUserId :: PropertyEvent -> UserId propEventUserId (PropertySet u _ _) = u propEventUserId (PropertyDeleted u _) = u @@ -198,16 +185,16 @@ instance ToBytes Event where bytes (ClientEvent e) = bytes e instance ToBytes UserEvent where - bytes e@UserCreated {} = val "user.new: " +++ toByteString (userEventUserId e) - bytes e@UserActivated {} = val "user.activate: " +++ toByteString (userEventUserId e) - bytes e@UserUpdated {} = val "user.update: " +++ toByteString (userEventUserId e) - bytes e@UserIdentityUpdated {} = val "user.update: " +++ toByteString (userEventUserId e) - bytes e@UserIdentityRemoved {} = val "user.identity-remove: " +++ toByteString (userEventUserId e) - bytes e@UserSuspended {} = val "user.suspend: " +++ toByteString (userEventUserId e) - bytes e@UserResumed {} = val "user.resume: " +++ toByteString (userEventUserId e) - bytes e@UserDeleted {} = val "user.delete: " +++ toByteString (userEventUserId e) - bytes e@UserLegalHoldDisabled {} = val "user.legalhold-disable: " +++ toByteString (userEventUserId e) - bytes e@UserLegalHoldEnabled {} = val "user.legalhold-enable: " +++ toByteString (userEventUserId e) + bytes (UserCreated u) = val "user.new: " +++ toByteString (userId u) + bytes (UserActivated u) = val "user.activate: " +++ toByteString (userId u) + bytes (UserUpdated u) = val "user.update: " +++ toByteString (eupId u) + bytes (UserIdentityUpdated u) = val "user.update: " +++ toByteString (eiuId u) + bytes (UserIdentityRemoved u) = val "user.identity-remove: " +++ toByteString (eirId u) + bytes (UserSuspended u) = val "user.suspend: " +++ toByteString u + bytes (UserResumed u) = val "user.resume: " +++ toByteString u + bytes (UserDeleted u) = val "user.delete: " +++ toByteString (qUnqualified u) +++ val "@" +++ toByteString (qDomain u) + bytes (UserLegalHoldDisabled u) = val "user.legalhold-disable: " +++ toByteString u + bytes (UserLegalHoldEnabled u) = val "user.legalhold-enable: " +++ toByteString u bytes (LegalHoldClientRequested payload) = val "user.legalhold-request: " +++ show payload instance ToBytes ConnectionEvent where diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index 832746ccc13..d244a6fa656 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -30,6 +30,7 @@ module Data.Range checked, checkedEither, checkedEitherMsg, + rangedChunks, errorMsg, unsafeRange, fromRange, @@ -286,6 +287,14 @@ checkedEither x = do Nothing -> Left (errorMsg (fromSing sn) (fromSing sm) "") Just r -> Right r +rangedChunks :: forall a n. (Within [a] 1 n, KnownNat n) => [a] -> [Range 1 n [a]] +rangedChunks xs = + let (headPart, tailPart) = splitAt (fromIntegral (natVal (Proxy @n))) xs + in -- Since n >= 1, headPart being empty can only be when 'xs' was empty. + case headPart of + [] -> [] + _ -> Range headPart : rangedChunks tailPart + unsafeRange :: (Show a, Within a n m) => a -> Range n m a unsafeRange x = fromMaybe (msg sing sing) (checked x) where diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index 9599b40e4c0..c41324c4111 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -18,15 +18,17 @@ module Wire.API.Federation.API.Brig where import Control.Monad.Except (MonadError (..)) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson import Data.Handle (Handle) import Data.Id +import Data.Range import Imports import Servant.API import Servant.API.Generic import Servant.Client.Generic (AsClientT, genericClient) import Test.QuickCheck (Arbitrary) import Wire.API.Arbitrary (GenericUniform (..)) +import Wire.API.Federation.API.Common import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import Wire.API.Federation.Domain (OriginDomainHeader) import qualified Wire.API.Federation.GRPC.Types as Proto @@ -100,7 +102,14 @@ data Api routes = Api :> "send-connection-action" :> OriginDomainHeader :> ReqBody '[JSON] NewConnectionRequest - :> Post '[JSON] NewConnectionResponse + :> Post '[JSON] NewConnectionResponse, + onUserDeleted :: + routes + :- "federation" + :> "on-user-deleted" + :> OriginDomainHeader + :> ReqBody '[JSON] UserDeletedNotification + :> Post '[JSON] EmptyResponse } deriving (Generic) @@ -151,5 +160,15 @@ data NewConnectionResponse deriving (Arbitrary) via (GenericUniform NewConnectionResponse) deriving (FromJSON, ToJSON) via (CustomEncoded NewConnectionResponse) +data UserDeletedNotification = UserDeletedNotification + { -- | This is qualified implicitly by the origin domain + udnUser :: UserId, + -- | These are qualified implicitly by the target domain + udnConnections :: Range 1 1000 [UserId] + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserDeletedNotification) + deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedNotification) + clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Brig m)) clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Common.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Common.hs new file mode 100644 index 00000000000..0df3432e3f6 --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Common.hs @@ -0,0 +1,35 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Federation.API.Common where + +import Data.Aeson +import Imports +import Test.QuickCheck +import Wire.API.Arbitrary + +-- | This is equivalent to '()', but JSONifies to an empty object instead of an +-- empty array. +data EmptyResponse = EmptyResponse + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform EmptyResponse) + +instance FromJSON EmptyResponse where + parseJSON = withObject "EmptyResponse" . const $ pure EmptyResponse + +instance ToJSON EmptyResponse where + toJSON EmptyResponse = object [] diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 699ce838274..ff9841544d0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -23,6 +23,7 @@ import Data.Id (ClientId, ConvId, UserId) import Data.Json.Util (Base64ByteString) import Data.Misc (Milliseconds) import Data.Qualified +import Data.Range import Data.Time.Clock (UTCTime) import Imports import Servant.API (JSON, Post, ReqBody, Summary, (:>)) @@ -39,6 +40,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember) import Wire.API.Conversation.Role (RoleName) +import Wire.API.Federation.API.Common import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import Wire.API.Federation.Domain (OriginDomainHeader) import qualified Wire.API.Federation.GRPC.Types as Proto @@ -102,7 +104,14 @@ data Api routes = Api :> "send-message" :> OriginDomainHeader :> ReqBody '[JSON] MessageSendRequest - :> Post '[JSON] MessageSendResponse + :> Post '[JSON] MessageSendResponse, + onUserDeleted :: + routes + :- "federation" + :> "on-user-deleted" + :> OriginDomainHeader + :> ReqBody '[JSON] UserDeletedNotification + :> Post '[JSON] EmptyResponse } deriving (Generic) @@ -253,5 +262,15 @@ newtype LeaveConversationResponse = LeaveConversationResponse (ToJSON, FromJSON) via (Either (CustomEncoded RemoveFromConversationError) ()) +data UserDeletedNotification = UserDeletedNotification + { -- | This is qualified implicitly by the origin domain + udnUser :: UserId, + -- | These are qualified implicitly by the target domain + udnConversations :: Range 1 1000 [ConvId] + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserDeletedNotification) + deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedNotification) + clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Galley m)) clientRoutes = genericClient diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index 7f35a001fbe..a48cc3d7743 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6b4b223086cf1ba879d202fe6b884009e44bff247db6de7a2501d599295b8457 +-- hash: 502683f56cc0fbb11b75807669858c1d4fdf146afa8a016fa18daec9f6a72e7a name: wire-api-federation version: 0.1.0 @@ -23,6 +23,7 @@ extra-source-files: library exposed-modules: Wire.API.Federation.API.Brig + Wire.API.Federation.API.Common Wire.API.Federation.API.Galley Wire.API.Federation.Client Wire.API.Federation.Domain diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 5ff67e3f5c0..0b10a5456a0 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: 33acd5be229059e16903857f1923a9afcf55f285461298721a15d8d8c5b88a12 +-- hash: 3f6cdbdd5b65f096b8f3e838b1009c4a1a0dd5e295304d123a4ad90ebcdf2057 name: brig version: 1.35.0 @@ -341,6 +341,7 @@ executable brig-integration , lens-aeson , metrics-wai , mime >=0.4 + , mtl , mu-grpc-server , mu-rpc , network diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 3adddffd60d..0fb6928ca17 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -221,6 +221,7 @@ executables: - metrics-wai - mime >=0.4 - MonadRandom >= 0.5 + - mtl - mu-grpc-server - mu-rpc - network diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 2e9ea4ac12b..496b7e5caf1 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -27,21 +27,30 @@ import qualified Brig.API.User as API import Brig.App (qualifyLocal) import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data -import Brig.Types (PrekeyBundle) +import Brig.IO.Intra (notify) +import Brig.Types (PrekeyBundle, Relation (Accepted)) +import Brig.Types.User.Event import Brig.User.API.Handle import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, UserId) +import Data.List.NonEmpty (nonEmpty) +import Data.List1 import Data.Qualified +import Data.Range +import qualified Gundeck.Types.Push as Push import Imports import Network.Wai.Utilities.Error ((!>>)) import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) +import UnliftIO.Async (pooledForConcurrentlyN_) import Wire.API.Federation.API.Brig hiding (Api (..)) import qualified Wire.API.Federation.API.Brig as Federated import qualified Wire.API.Federation.API.Brig as FederationAPIBrig +import Wire.API.Federation.API.Common import Wire.API.Message (UserClients) +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import Wire.API.User (UserProfile) import Wire.API.User.Client (PubClient, UserClientPrekeyMap) @@ -60,7 +69,8 @@ federationSitemap = Federated.claimMultiPrekeyBundle = claimMultiPrekeyBundle, Federated.searchUsers = searchUsers, Federated.getUserClients = getUserClients, - Federated.sendConnectionAction = sendConnectionAction + Federated.sendConnectionAction = sendConnectionAction, + Federated.onUserDeleted = onUserDeleted } sendConnectionAction :: Domain -> NewConnectionRequest -> Handler NewConnectionResponse @@ -112,3 +122,17 @@ searchUsers (SearchRequest searchTerm) = do getUserClients :: GetUserClients -> Handler (UserMap (Set PubClient)) getUserClients (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError + +onUserDeleted :: Domain -> UserDeletedNotification -> Handler EmptyResponse +onUserDeleted origDomain udn = lift $ do + let deletedUser = toRemoteUnsafe origDomain (udnUser udn) + connections = udnConnections udn + event = pure . UserEvent $ UserDeleted (qUntagged deletedUser) + acceptedLocals <- + map csv2From + . filter (\x -> csv2Status x == Accepted) + <$> Data.lookupRemoteConnectionStatuses (fromRange connections) (fmap pure deletedUser) + pooledForConcurrentlyN_ 16 (nonEmpty acceptedLocals) $ \(List1 -> recipients) -> + notify event (tUnqualified deletedUser) Push.RouteDirect Nothing (pure recipients) + Data.deleteRemoteConnections deletedUser connections + pure EmptyResponse diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index cf8e9247013..950b3184d5b 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1054,7 +1054,8 @@ deleteAccount account@(accountUser -> user) = do Data.insertAccount tombstone Nothing Nothing False Intra.rmUser uid (userAssets user) Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) - Intra.onUserEvent uid Nothing (UserDeleted uid) + luid <- qualifyLocal uid + Intra.onUserEvent uid Nothing (UserDeleted (qUntagged luid)) -- Note: Connections can only be deleted afterwards, since -- they need to be notified. Data.deleteConnections uid diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index cc1d9f0543d..79d69990561 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -35,8 +33,10 @@ module Brig.Data.Connection lookupLocalConnectionStatuses, lookupRemoteConnectionStatuses, lookupAllStatuses, + lookupRemoteConnectedUsersC, countConnections, deleteConnections, + deleteRemoteConnections, remoteConnectionInsert, remoteConnectionSelect, remoteConnectionSelectFrom, @@ -55,7 +55,7 @@ import Brig.Types import Cassandra import Control.Monad.Morph import Control.Monad.Trans.Maybe -import Data.Conduit (runConduit, (.|)) +import Data.Conduit (ConduitT, runConduit, (.|)) import qualified Data.Conduit.List as C import Data.Domain (Domain) import Data.Id @@ -64,7 +64,7 @@ import Data.Qualified import Data.Range import Data.Time (getCurrentTime) import Imports hiding (local) -import UnliftIO.Async (pooledMapConcurrentlyN, pooledMapConcurrentlyN_) +import UnliftIO.Async (pooledForConcurrentlyN_, pooledMapConcurrentlyN, pooledMapConcurrentlyN_) import Wire.API.Connection import Wire.API.Routes.Internal.Brig.Connection @@ -242,6 +242,11 @@ lookupAllStatuses lfroms = do map (\(d, u, r) -> toConnectionStatusV2 from d u r) <$> retry x1 (query remoteRelationsSelectAll (params Quorum (Identity from))) +lookupRemoteConnectedUsersC :: forall m. (MonadClient m) => UserId -> Int32 -> ConduitT () [Remote UserId] m () +lookupRemoteConnectedUsersC u maxResults = + paginateC remoteConnectionsSelectUsers (paramsP Quorum (Identity u) maxResults) x1 + .| C.map (map (uncurry toRemoteUnsafe)) + -- | See 'lookupContactListWithRelation'. lookupContactList :: UserId -> AppIO [UserId] lookupContactList u = @@ -278,9 +283,15 @@ deleteConnections u = do paginateC contactsSelect (paramsP Quorum (Identity u) 100) x1 .| C.mapM_ (pooledMapConcurrentlyN_ 16 delete) retry x1 . write connectionClear $ params Quorum (Identity u) + retry x1 . write remoteConnectionClear $ params Quorum (Identity u) where delete (other, _status) = write connectionDelete $ params Quorum (other, u) +deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> AppIO () +deleteRemoteConnections (qUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = + pooledForConcurrentlyN_ 16 locals $ \u -> + write remoteConnectionDelete $ params Quorum (u, remoteDomain, remoteUser) + -- Queries connectionInsert :: PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () @@ -355,6 +366,9 @@ remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?" +remoteConnectionsSelectUsers :: PrepQuery R (Identity UserId) (Domain, UserId) +remoteConnectionsSelectUsers = "SELECT right_domain, right_user FROM connection_remote WHERE left = ?" + -- Conversions toLocalUserConnection :: diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index a6a33b550fd..3eb23f66622 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -31,6 +31,7 @@ import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) import Data.Qualified +import Data.Range (Range) import qualified Data.Text as T import Imports import qualified System.Logger.Class as Log @@ -94,3 +95,14 @@ sendConnectionAction self (qUntagged -> other) action = do let req = NewConnectionRequest (tUnqualified self) (qUnqualified other) action Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (tDomain self) req + +notifyUserDeleted :: + Local UserId -> + Remote (Range 1 1000 [UserId]) -> + FederationAppIO () +notifyUserDeleted self remotes = do + let remoteConnections = tUnqualified remotes + let fedRPC = + FederatedBrig.onUserDeleted clientRoutes (tDomain self) $ + UserDeletedNotification (tUnqualified self) remoteConnections + void $ executeFederated (tDomain remotes) fedRPC diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 271c72b7f80..ff5617bff15 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -60,6 +60,9 @@ module Brig.IO.Intra -- * Legalhold guardLegalhold, + + -- * Low Level API for Notifications + notify, ) where @@ -70,21 +73,26 @@ import Brig.API.Error (internalServerError) import Brig.API.Types import Brig.App import Brig.Data.Connection (lookupContactList) +import qualified Brig.Data.Connection as Data +import Brig.Federation.Client (notifyUserDeleted) import qualified Brig.IO.Journal as Journal import Brig.RPC import Brig.Types import Brig.Types.User.Event import qualified Brig.User.Search.Index as Search +import Conduit (runConduit, (.|)) import Control.Error (ExceptT) import Control.Lens (view, (.~), (?~), (^.)) import Control.Monad.Catch (MonadThrow (throwM)) -import Control.Monad.Trans.Except (throwE) +import Control.Monad.Trans.Except (runExceptT, throwE) import Control.Retry import Data.Aeson hiding (json) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) +import qualified Data.Conduit.List as C import qualified Data.Currency as Currency +import Data.Domain import qualified Data.HashMap.Strict as M import Data.Id import Data.Json.Util (UTCTimeMillis, (#)) @@ -106,7 +114,8 @@ 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.Federation.Client +import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) import Wire.API.Message (UserClients) import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) @@ -234,11 +243,52 @@ dispatchNotifications orig conn e = case e of UserDeleted {} -> do -- n.b. Synchronously fetch the contact list on the current thread. -- If done asynchronously, the connections may already have been deleted. - recipients <- list1 orig <$> lookupContactList orig - notify event orig Push.RouteDirect conn (pure recipients) + notifyUserDeletionLocals orig conn event + notifyUserDeletionRemotes orig where event = singleton $ UserEvent e +notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> AppIO () +notifyUserDeletionLocals deleted conn event = do + recipients <- list1 deleted <$> lookupContactList deleted + notify event deleted Push.RouteDirect conn (pure recipients) + +notifyUserDeletionRemotes :: UserId -> AppIO () +notifyUserDeletionRemotes deleted = do + runConduit $ + Data.lookupRemoteConnectedUsersC deleted 1000 + .| C.mapM_ fanoutNotifications + where + fanoutNotifications :: [Remote UserId] -> AppIO () + fanoutNotifications = mapM_ notifyBackend . bucketRemote + + notifyBackend :: Remote [UserId] -> AppIO () + notifyBackend uids = do + let rangedMaybeUids = checked @_ @1 @1000 <$> uids + case tUnqualified rangedMaybeUids of + Nothing -> + -- The user IDs cannot be more than 1000, so we can assume the range + -- check will only fail because there are 0 User Ids. + pure () + Just rangedUids -> do + luidDeleted <- qualifyLocal deleted + eitherFErr <- runExceptT (notifyUserDeleted luidDeleted (qualifyAs uids rangedUids)) + case eitherFErr of + Left fErr -> do + logFederationError (tDomain uids) fErr + -- FUTUTREWORK: Do something better here? + -- FUTUREWORK: Write test that this happens + throwM $ federationErrorToWai fErr + Right () -> pure () + + logFederationError :: Domain -> FederationError -> AppT IO () + logFederationError domain fErr = + Log.err $ + Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) + . Log.field "user_id" (show deleted) + . Log.field "domain" (domainText domain) + . Log.field "error" (show fErr) + -- | Push events to other users. push :: -- | The events to push. @@ -312,7 +362,7 @@ rawPush (toList -> events) usrs orig route conn = do -- | (Asynchronously) notifies other users of events. notify :: List1 Event -> - -- | Origin user. + -- | Origin user, TODO: Delete UserId -> -- | Push routing strategy. Push.Route -> @@ -442,11 +492,12 @@ toPushFormat (UserEvent (UserResumed i)) = [ "type" .= ("user.resume" :: Text), "id" .= i ] -toPushFormat (UserEvent (UserDeleted i)) = +toPushFormat (UserEvent (UserDeleted qid)) = Just $ M.fromList [ "type" .= ("user.delete" :: Text), - "id" .= i + "id" .= qUnqualified qid, + "qualified_id" .= qid ] toPushFormat (UserEvent (UserLegalHoldDisabled i)) = Just $ diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index 8825e3240df..72e7edf3720 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -14,12 +14,15 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module API.Federation where import API.Search.Util (refreshIndex) +import API.User.Util import Bilge hiding (head) import Bilge.Assert +import qualified Brig.Options as Opt import Brig.Types import Control.Arrow (Arrow (first), (&&&)) import Data.Aeson (encode) @@ -27,24 +30,27 @@ import Data.Handle (Handle (..)) import Data.Id import qualified Data.Map as Map import Data.Qualified +import Data.Range import qualified Data.Set as Set +import Data.Timeout import qualified Data.UUID.V4 as UUIDv4 import Federation.Util (generateClientPrekeys) import Imports import Test.QuickCheck (arbitrary) import Test.QuickCheck.Gen (generate) import Test.Tasty +import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit (assertEqual, assertFailure) import Util -import Wire.API.Federation.API.Brig (GetUserClients (..), SearchRequest (SearchRequest)) +import Wire.API.Federation.API.Brig (GetUserClients (..), SearchRequest (SearchRequest), UserDeletedNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig import Wire.API.Message (UserClients (..)) import Wire.API.User.Client (mkUserClientPrekeyMap) import Wire.API.UserMap (UserMap (UserMap)) -- Note: POST /federation/send-connection-action is implicitly tested in API.User.Connection -tests :: Manager -> Brig -> FedBrigClient -> IO TestTree -tests m brig fedBrigClient = +tests :: Manager -> Opt.Opts -> Brig -> Cannon -> FedBrigClient -> IO TestTree +tests m opts brig cannon fedBrigClient = return $ testGroup "federation" @@ -60,7 +66,8 @@ tests m brig fedBrigClient = test m "POST /federation/claim-prekey-bundle : 200" (testClaimPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/claim-multi-prekey-bundle : 200" (testClaimMultiPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/get-user-clients : 200" (testGetUserClients brig fedBrigClient), - test m "POST /federation/get-user-clients : Not Found" (testGetUserClientsNotFound fedBrigClient) + test m "POST /federation/get-user-clients : Not Found" (testGetUserClientsNotFound fedBrigClient), + test m "POST /federation/on-user-deleted : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) ] testSearchSuccess :: Brig -> FedBrigClient -> Http () @@ -211,3 +218,31 @@ testGetUserClientsNotFound fedBrigClient = do "client set for user should match" (Just (Set.fromList [])) (fmap (Set.map pubClientId) . Map.lookup absentUserId $ userClients) + +testRemoteUserGetsDeleted :: Opt.Opts -> Brig -> Cannon -> FedBrigClient -> Http () +testRemoteUserGetsDeleted opts brig cannon fedBrigClient = do + connectedUser <- userId <$> randomUser brig + pendingUser <- userId <$> randomUser brig + blockedUser <- userId <$> randomUser brig + unconnectedUser <- userId <$> randomUser brig + remoteUser <- fakeRemoteUser + + sendConnectionAction brig opts connectedUser remoteUser (Just FedBrig.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient pendingUser remoteUser FedBrig.RemoteConnect Nothing Pending + sendConnectionAction brig opts blockedUser remoteUser (Just FedBrig.RemoteConnect) Accepted + putConnectionQualified brig blockedUser remoteUser Blocked !!! statusCode === const 200 + + let localUsers = [connectedUser, pendingUser, blockedUser, unconnectedUser] + void . WS.bracketRN cannon localUsers $ \[cc, pc, bc, uc] -> do + _ <- + FedBrig.onUserDeleted + fedBrigClient + (qDomain remoteUser) + (UserDeletedNotification (qUnqualified remoteUser) (unsafeRange localUsers)) + + WS.assertMatchN_ (5 # Second) [cc] $ matchDeleteUserNotification remoteUser + WS.assertNoEvent (1 # Second) [pc, bc, uc] + + for_ localUsers $ \u -> + getConnectionQualified brig u remoteUser !!! do + const 404 === statusCode diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 15b9804140c..1e71e967e2e 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - +{-# LANGUAGE NumericUnderscores #-} -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,6 +15,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module API.User.Account ( tests, @@ -45,13 +45,16 @@ import qualified Data.Aeson.Lens as AesonL import qualified Data.ByteString as C8 import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion +import Data.Domain (Domain (..), domainText) import Data.Id hiding (client) import Data.Json.Util (fromUTCTimeMillis) import Data.List1 (singleton) import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) import Data.Qualified +import Data.Range (Range (fromRange)) import qualified Data.Set as Set +import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time (UTCTime, getCurrentTime) @@ -63,6 +66,8 @@ import qualified Data.Vector as Vec import Galley.Types.Teams (noPermissions) import Gundeck.Types.Notification import Imports hiding (head) +import qualified Network.HTTP.Types as Http +import qualified Network.Wai as Wai import qualified Network.Wai.Utilities.Error as Error import Test.Tasty hiding (Timeout) import Test.Tasty.Cannon hiding (Cannon) @@ -72,6 +77,11 @@ import UnliftIO (mapConcurrently_) import Util as Util import Util.AWS as Util import Web.Cookie (parseSetCookie) +import Wire.API.Federation.API.Brig (UserDeletedNotification (..)) +import qualified Wire.API.Federation.API.Brig as FedBrig +import Wire.API.Federation.API.Common (EmptyResponse (EmptyResponse)) +import Wire.API.Federation.GRPC.Types (OutwardResponse (OutwardResponseBody)) +import qualified Wire.API.Federation.GRPC.Types as F import Wire.API.User (ListUsersQuery (..)) import Wire.API.User.Identity (mkSampleUref, mkSimpleSampleUref) @@ -125,6 +135,7 @@ tests _ at opts p b c ch g aws = test' aws p "delete/anonymous" $ testDeleteAnonUser b, test' aws p "delete /i/users/:uid - 202" $ testDeleteInternal b c aws, test' aws p "delete with profile pic" $ testDeleteWithProfilePic b ch, + test' aws p "delete with connected remote users" $ testDeleteWithRemotes opts b, test' aws p "put /i/users/:uid/sso-id" $ testUpdateSSOId b g, testGroup "temporary customer extensions" @@ -1110,7 +1121,7 @@ testDeleteUserByPassword brig cannon aws = do !!! const 200 === statusCode n1 <- countCookies brig uid1 defCookieLabel liftIO $ Just 1 @=? n1 - setHandleAndDeleteUser brig cannon u [] aws $ + setHandleAndDeleteUser brig cannon u [uid2, uid3] aws $ \uid -> deleteUser uid (Just defPassword) brig !!! const 200 === statusCode -- Activating the new email address now should not work act <- getActivationCode brig (Left eml) @@ -1182,9 +1193,6 @@ testDeleteInternal brig cannon aws = do setHandleAndDeleteUser brig cannon u [] aws $ \uid -> delete (brig . paths ["/i/users", toByteString' uid]) !!! const 202 === statusCode --- Check that user deletion is also triggered --- liftIO $ Util.assertUserJournalQueue "user deletion testDeleteInternal2: " aws (userDeleteJournaled $ userId u) - testDeleteWithProfilePic :: Brig -> CargoHold -> Http () testDeleteWithProfilePic brig cargohold = do uid <- userId <$> createAnonUser "anon" brig @@ -1201,6 +1209,54 @@ testDeleteWithProfilePic brig cargohold = do -- Check that the asset gets deleted downloadAsset cargohold uid (toByteString' (ast ^. CHV3.assetKey)) !!! const 404 === statusCode +testDeleteWithRemotes :: Opt.Opts -> Brig -> Http () +testDeleteWithRemotes opts brig = do + localUser <- randomUser brig + + let remote1Domain = Domain "remote1.example.com" + remote2Domain = Domain "remote2.example.com" + remote1UserConnected <- Qualified <$> randomId <*> pure remote1Domain + remote1UserPending <- Qualified <$> randomId <*> pure remote1Domain + remote2UserBlocked <- Qualified <$> randomId <*> pure remote2Domain + + sendConnectionAction brig opts (userId localUser) remote1UserConnected (Just FedBrig.RemoteConnect) Accepted + sendConnectionAction brig opts (userId localUser) remote1UserPending Nothing Sent + sendConnectionAction brig opts (userId localUser) remote2UserBlocked (Just FedBrig.RemoteConnect) Accepted + void $ putConnectionQualified brig (userId localUser) remote2UserBlocked Blocked + + let fedMockResponse = OutwardResponseBody (cs $ Aeson.encode EmptyResponse) + let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response + galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = + case (requestMethod, requestPath) of + (_methodDelete, ["i", "user"]) -> do + let response = Wai.responseLBS Http.status200 [(Http.hContentType, "application/json")] (cs $ Aeson.encode EmptyResponse) + pure response + _ -> error "not mocked" + + (_, rpcCalls, _galleyCalls) <- liftIO $ + withMockedFederatorAndGalley opts (Domain "example.com") fedMockResponse galleyHandler $ do + deleteUser (userId localUser) (Just defPassword) brig !!! do + const 200 === statusCode + + liftIO $ do + remote1Call <- assertOne $ filter (\c -> F.domain c == domainText remote1Domain) rpcCalls + remote1Udn <- assertRight $ parseFedRequest remote1Call + udnUser remote1Udn @?= userId localUser + sort (fromRange (udnConnections remote1Udn)) + @?= sort (map qUnqualified [remote1UserConnected, remote1UserPending]) + + remote2Call <- assertOne $ filter (\c -> F.domain c == domainText remote2Domain) rpcCalls + remote2Udn <- assertRight $ parseFedRequest remote2Call + udnUser remote2Udn @?= userId localUser + fromRange (udnConnections remote2Udn) @?= [qUnqualified remote2UserBlocked] + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a + parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + testUpdateSSOId :: Brig -> Galley -> Http () testUpdateSSOId brig galley = do noSuchUserId <- Id <$> liftIO UUID.nextRandom @@ -1353,12 +1409,7 @@ setHandleAndDeleteUser brig cannon u others aws execDelete = do -- Delete the user WS.bracketRN cannon (uid : others) $ \wss -> do execDelete uid - void . liftIO . WS.assertMatchN (5 # Second) wss $ \n -> do - let j = Object $ List1.head (ntfPayload n) - let etype = j ^? key "type" . _String - let euser = j ^? key "id" . _String - etype @?= Just "user.delete" - euser @?= Just (UUID.toText (toUUID uid)) + void . liftIO . WS.assertMatchN (5 # Second) wss $ matchDeleteUserNotification quid liftIO $ Util.assertUserJournalQueue "user deletion, setHandleAndDeleteUser: " aws (userDeleteJournaled uid) -- Cookies are gone n2 <- countCookies brig uid defCookieLabel diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index c72a8181287..6ee884a3dc0 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -40,6 +40,7 @@ import qualified Data.ByteString.Lazy as LB import Data.Domain (Domain, domainText) import Data.Handle (Handle (Handle)) import Data.Id hiding (client) +import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) import Data.Qualified import Data.Range (unsafeRange) @@ -47,6 +48,7 @@ import Data.String.Conversions (cs) import qualified Data.Text.Ascii as Ascii import qualified Data.Vector as Vec import Federation.Util (withTempMockFederator) +import Gundeck.Types (Notification (..)) import Imports import Test.Tasty.HUnit import Util @@ -450,3 +452,13 @@ deleteLegalHoldDevice brig uid = brig . paths ["i", "clients", "legalhold", toByteString' uid] . contentJson + +matchDeleteUserNotification :: Qualified UserId -> Notification -> Assertion +matchDeleteUserNotification quid n = do + let j = Object $ List1.head (ntfPayload n) + let etype = j ^? key "type" . _String + let eUnqualifiedId = maybeFromJSON =<< j ^? key "id" + let eQualifiedId = maybeFromJSON =<< j ^? key "qualified_id" + etype @?= Just "user.delete" + eUnqualifiedId @?= Just (qUnqualified quid) + eQualifiedId @?= Just quid diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index 9566c994d19..67611a79df4 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -106,11 +106,6 @@ generateClientPrekeys brig prekeys = do clients <- traverse (responseJsonError <=< addClient brig (qUnqualified quser)) nclients pure (quser, zipWith mkClientPrekey prekeys clients) -assertRight :: (MonadIO m, Show a, HasCallStack) => Either a b -> m b -assertRight = \case - Left e -> liftIO $ assertFailure $ "Expected Right, got Left: " <> show e - Right x -> pure x - assertRightT :: (MonadIO m, Show a, HasCallStack) => ExceptT a m b -> m b assertRightT = assertRight <=< runExceptT diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index d0423fe8ced..9380b84a4f8 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -139,7 +139,7 @@ runTests iConf brigOpts otherArgs = do browseTeam <- TeamUserSearch.tests brigOpts mg g b userPendingActivation <- UserPendingActivation.tests brigOpts mg db b g s federationEnd2End <- Federation.End2end.spec brigOpts mg b g c f brigTwo galleyTwo - federationEndpoints <- API.Federation.tests mg b fedBrigClient + federationEndpoints <- API.Federation.tests mg brigOpts b c fedBrigClient includeFederationTests <- (== Just "1") <$> Blank.getEnv "INTEGRATION_FEDERATION_TESTS" internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g withArgs otherArgs . defaultMain $ diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 5cb0712b87f..b6ad08f42d3 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,8 +14,10 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - -- for SES notifications +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Util where @@ -27,6 +27,7 @@ import qualified Brig.AWS as AWS import Brig.AWS.Types import Brig.App (applog, sftEnv) import Brig.Calling as Calling +import qualified Brig.Options as Opt import qualified Brig.Options as Opts import qualified Brig.Run as Run import Brig.Types.Activation @@ -38,6 +39,10 @@ import Brig.Types.User.Auth import qualified Brig.ZAuth as ZAuth import Control.Lens ((^.), (^?), (^?!)) import Control.Monad.Catch (MonadCatch, MonadMask) +import qualified Control.Monad.Catch as Catch +import Control.Monad.State.Class (MonadState) +import qualified Control.Monad.State.Class as MonadState +import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Control.Retry import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _Integral, _JSON, _String) @@ -64,19 +69,28 @@ import Galley.Types.Conversations.One2One (one2OneConvId) import qualified Galley.Types.Teams as Team import Gundeck.Types.Notification import Imports +import Network.HTTP.Types (Method) +import Network.Wai (Application) +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Test (Session) import qualified Network.Wai.Test as WaiTest import Servant.Client.Generic (AsClientT) import System.Random (randomIO, randomRIO) +import qualified System.Timeout as System import Test.Tasty (TestName, TestTree) import Test.Tasty.Cannon import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import qualified UnliftIO.Async as Async import Util.AWS +import Util.Options (Endpoint (Endpoint)) import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.Federation.API.Brig as FedBrig import qualified Wire.API.Federation.API.Galley as FedGalley +import Wire.API.Federation.GRPC.Types (OutwardResponse) +import qualified Wire.API.Federation.Mock as Mock import Wire.API.Routes.MultiTablePaging type Brig = Request -> Request @@ -337,7 +351,7 @@ postUserRegister' :: (MonadIO m, MonadCatch m, MonadHttp m) => Object -> Brig -> postUserRegister' payload brig = do post (brig . path "/register" . contentJson . body (RequestBodyLBS $ encode payload)) -deleteUser :: UserId -> Maybe PlainTextPassword -> Brig -> Http ResponseLBS +deleteUser :: (Functor m, MonadIO m, MonadCatch m, MonadHttp m, HasCallStack) => UserId -> Maybe PlainTextPassword -> Brig -> m ResponseLBS deleteUser u p brig = delete $ brig @@ -924,3 +938,122 @@ aFewTimes assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs + +-------------------------------------------------------------------------------- + +newtype MockT m a = MockT {unMock :: ReaderT (IORef MockState) m a} + deriving newtype (Functor, Applicative, Monad, MonadReader (IORef MockState), MonadIO) + +instance MonadIO m => MonadState MockState (MockT m) where + get = readIORef =<< ask + put x = do + ref <- ask + writeIORef ref x + +data ReceivedRequest = ReceivedRequest Method [Text] LByteString + +data MockState = MockState + { receivedRequests :: [ReceivedRequest], + serverThread :: Async.Async (), + serverPort :: Integer, + mockHandler :: ReceivedRequest -> MockT IO Wai.Response + } + +mkMockApp :: IORef MockState -> Application +mkMockApp ref request mkResponse = do + let action = do + req <- liftIO $ getReceivedRequest request + handler <- mockHandler <$> liftIO (readIORef ref) + response <- handler req + MonadState.modify (\ms -> ms {receivedRequests = receivedRequests ms <> [req]}) + pure response + runMockT ref action >>= mkResponse + +getReceivedRequest :: Wai.Request -> IO ReceivedRequest +getReceivedRequest r = + ReceivedRequest (Wai.requestMethod r) (Wai.pathInfo r) <$> Wai.strictRequestBody r + +runMockT :: IORef MockState -> MockT m a -> m a +runMockT ref mock = runReaderT (unMock mock) ref + +startMockService :: MonadIO m => IORef MockState -> ExceptT String m () +startMockService ref = ExceptT . liftIO $ do + (sPort, sock) <- Warp.openFreePort + serverStarted <- newEmptyMVar + let settings = + Warp.defaultSettings + & Warp.setPort sPort + & Warp.setGracefulCloseTimeout2 0 -- Defaults to 2 seconds, causes server stop to take very long + & Warp.setBeforeMainLoop (putMVar serverStarted ()) + let app = mkMockApp ref + serviceThread <- Async.async $ Warp.runSettingsSocket settings sock app + serverStartedSignal <- System.timeout 10_000_000 (takeMVar serverStarted) + case serverStartedSignal of + Nothing -> do + liftIO $ Async.cancel serviceThread + pure . Left $ "Failed to start the mock server within 10 seconds on port: " <> show sPort + _ -> do + liftIO . modifyIORef ref $ \s -> s {serverThread = serviceThread, serverPort = toInteger sPort} + pure (Right ()) + +initState :: MockState +initState = MockState [] (error "server not started") (error "server not started") (error "No mock response provided") + +stopMockedService :: MonadIO m => IORef MockState -> m () +stopMockedService ref = + liftIO $ Async.cancel . serverThread <=< readIORef $ ref + +withTempMockedService :: + (MonadIO m, MonadMask m) => + MockState -> + (ReceivedRequest -> MockT IO Wai.Response) -> + (MockState -> ExceptT String m a) -> + ExceptT String m (a, [ReceivedRequest]) +withTempMockedService state handler action = do + ref <- newIORef state + startMockService ref + ( do + liftIO . modifyIORef ref $ \s -> s {mockHandler = handler} + st <- liftIO $ readIORef ref + actualResponse <- action st + st' <- liftIO $ readIORef ref + pure (actualResponse, receivedRequests st') + ) + `Catch.finally` stopMockedService ref + +assertRight :: (MonadIO m, Show a, HasCallStack) => Either a b -> m b +assertRight = \case + Left e -> liftIO $ assertFailure $ "Expected Right, got Left: " <> show e + Right x -> pure x + +withMockedGalley :: (MonadIO m, MonadMask m) => Opt.Opts -> (ReceivedRequest -> MockT IO Wai.Response) -> Session a -> m (a, [ReceivedRequest]) +withMockedGalley opts handler action = + assertRight <=< runExceptT $ + withTempMockedService initState handler $ \st -> lift $ do + let opts' = + opts + { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort st)) + } + withSettingsOverrides opts' action + +withMockedFederatorAndGalley :: + Opt.Opts -> + Domain -> + OutwardResponse -> + (ReceivedRequest -> MockT IO Wai.Response) -> + Session a -> + IO (a, Mock.ReceivedRequests, [ReceivedRequest]) +withMockedFederatorAndGalley opts domain fedResp galleyHandler action = do + result <- assertRight <=< runExceptT $ + withTempMockedService initState galleyHandler $ \galleyMockState -> + Mock.withTempMockFederator (Mock.initState domain) (const (pure fedResp)) $ \fedMockState -> do + let opts' = + opts + { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)), + Opt.federatorInternal = Just (Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort fedMockState))) + } + withSettingsOverrides opts' action + pure (combineResults result) + where + combineResults :: ((a, Mock.ReceivedRequests), [ReceivedRequest]) -> (a, Mock.ReceivedRequests, [ReceivedRequest]) + combineResults ((a, mrr), rr) = (a, mrr, rr) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 715c34145b6..f802f256e31 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -29,11 +29,13 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) import Data.Qualified +import Data.Range import qualified Data.Set as Set import qualified Data.Text.Lazy as LT import Galley.API.Error (invalidPayload) import qualified Galley.API.Mapping as Mapping import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtrMessage, sendLocalMessages) +import Galley.API.Update (notifyConversationMetadataUpdate) import qualified Galley.API.Update as API import Galley.API.Util import Galley.App (Galley) @@ -45,11 +47,13 @@ import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) import qualified System.Logger.Class as Log +import UnliftIO.Async (pooledForConcurrentlyN_) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation +import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley ( ConversationUpdate (..), GetConversationsRequest (..), @@ -60,6 +64,7 @@ import Wire.API.Federation.API.Galley MessageSendResponse (..), NewRemoteConversation (..), RemoteMessage (..), + UserDeletedNotification, ) import qualified Wire.API.Federation.API.Galley as FederationAPIGalley import Wire.API.Routes.Internal.Brig.Connection @@ -76,7 +81,8 @@ federationSitemap = FederationAPIGalley.onConversationUpdated = onConversationUpdated, FederationAPIGalley.leaveConversation = leaveConversation, FederationAPIGalley.onMessageSent = onMessageSent, - FederationAPIGalley.sendMessage = sendMessage + FederationAPIGalley.sendMessage = sendMessage, + FederationAPIGalley.onUserDeleted = onUserDeleted } onConversationCreated :: Domain -> NewRemoteConversation ConvId -> Galley () @@ -271,3 +277,29 @@ sendMessage originDomain msr = do MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (msrConvId msr) msg where err = throwM . invalidPayload . LT.pack + +onUserDeleted :: Domain -> UserDeletedNotification -> Galley EmptyResponse +onUserDeleted origDomain udn = do + let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udnUser udn) + untaggedDeletedUser = qUntagged deletedUser + convIds = FederationAPIGalley.udnConversations udn + pooledForConcurrentlyN_ 16 (fromRange convIds) $ \c -> do + lc <- qualifyLocal c + mconv <- Data.conversation c + Data.removeRemoteMembersFromLocalConv c (pure deletedUser) + for_ mconv $ \conv -> do + when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ + case Data.convType conv of + -- No need for a notification on One2One conv as the user is being + -- deleted and that notification should suffice. + Public.One2OneConv -> pure () + -- No need for a notification on Connect Conv as there should be no + -- other user in the conv. + Public.ConnectConv -> pure () + -- The self conv cannot be on a remote backend. + Public.SelfConv -> pure () + Public.RegularConv -> do + let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) + botsAndMembers = convBotsAndMembers conv + void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action + pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 925e5456f23..546f09154f2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -29,12 +29,14 @@ import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) import Control.Monad.Catch (MonadCatch) +import Control.Monad.Trans.Except (runExceptT) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) import Data.Qualified import Data.Range import Data.String.Conversions (cs) +import qualified Data.Text as T import Data.Time import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients @@ -76,8 +78,12 @@ import Servant.API.Generic import Servant.Server import Servant.Server.Generic (genericServerT) import System.Logger.Class hiding (Path, name) +import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.Federation.API.Galley (UserDeletedNotification (UserDeletedNotification)) +import qualified Wire.API.Federation.API.Galley as FedGalley +import Wire.API.Federation.Client (executeFederated) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) import Wire.API.Routes.Public (ZOptConn, ZUser) @@ -474,7 +480,7 @@ rmUser user conn = do goConvPages lusr range page = do let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs - leaveRemoteConversations lusr remoteConvs + for_ (rangedChunks remoteConvs) (leaveRemoteConversations lusr) when (mtpHasMore page) $ do let nextState = mtpPagingState page usr = tUnqualified lusr @@ -487,6 +493,7 @@ rmUser user conn = do uncheckedDeleteTeamMember user conn tid user mems leaveTeams =<< Cql.liftClient (Cql.nextPage tids) + -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity leaveLocalConversations :: [ConvId] -> Galley () leaveLocalConversations ids = do localDomain <- viewFederationDomain @@ -515,10 +522,25 @@ rmUser user conn = do (maybeList1 (catMaybes pp)) Intra.push - leaveRemoteConversations :: Foldable t => Local UserId -> t (Remote ConvId) -> Galley () - leaveRemoteConversations lusr cids = - for_ cids $ \cid -> - Update.removeMemberFromRemoteConv cid lusr Nothing (qUntagged lusr) + leaveRemoteConversations :: Local UserId -> Range 1 1000 [Remote ConvId] -> Galley () + leaveRemoteConversations lusr cids = do + for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do + let userDelete = UserDeletedNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) + let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete + res <- runExceptT (executeFederated (tDomain remoteConvs) rpc) + case res of + -- FUTUREWORK: Add a retry mechanism if there are federation errrors. + -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 + Left federationError -> do + Log.err $ + Log.msg $ + T.unwords + [ "Federation error while notifying remote backends of a user deletion (Galley).", + "user_id: " <> (cs . show) lusr, + "details: " <> (cs . show) federationError + ] + pure () + Right _ -> pure () deleteLoop :: Galley () deleteLoop = do diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index ac0f1a5c3b5..5c3579c9100 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -50,6 +50,9 @@ module Galley.API.Update removeMemberFromLocalConv, removeMemberFromRemoteConv, + -- * Notifications + notifyConversationMetadataUpdate, + -- * Talking postProteusMessage, postOtrMessageUnqualified, diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index c965710dd8e..7f1c7207f82 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -61,7 +61,6 @@ import qualified Data.Text.Ascii as Ascii import Data.Time.Clock (getCurrentTime) import Database.CQL.IO import Galley.API.Mapping -import Galley.API.One2One (one2OneConvId) import qualified Galley.Data as Data import Galley.Options (Opts, optFederator) import Galley.Types hiding (LocalMember (..)) @@ -224,7 +223,8 @@ tests s = test s "convert code to team-access conversation" postConvertTeamConv, test s "local and remote guests are removed when access changes" testAccessUpdateGuestRemoved, test s "cannot join private conversation" postJoinConvFail, - test s "remove user" removeUser, + test s "remove user with only local convs" removeUserNoFederation, + test s "remove user with local and remote convs" removeUser, test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests ] @@ -240,7 +240,8 @@ emptyFederatedBrig = FederatedBrig.claimMultiPrekeyBundle = \_ -> e "claimMultiPrekeyBundle", FederatedBrig.searchUsers = \_ -> e "searchUsers", FederatedBrig.getUserClients = \_ -> e "getUserClients", - FederatedBrig.sendConnectionAction = \_ _ -> e "sendConnectionAction" + FederatedBrig.sendConnectionAction = \_ _ -> e "sendConnectionAction", + FederatedBrig.onUserDeleted = \_ _ -> e "onUserDeleted" } emptyFederatedGalley :: FederatedGalley.Api (AsServerT Handler) @@ -253,7 +254,8 @@ emptyFederatedGalley = FederatedGalley.onConversationUpdated = \_ _ -> e "onConversationUpdated", FederatedGalley.leaveConversation = \_ _ -> e "leaveConversation", FederatedGalley.onMessageSent = \_ _ -> e "onMessageSent", - FederatedGalley.sendMessage = \_ _ -> e "sendMessage" + FederatedGalley.sendMessage = \_ _ -> e "sendMessage", + FederatedGalley.onUserDeleted = \_ _ -> e "onUserDeleted" } ------------------------------------------------------------------------------- @@ -3103,55 +3105,22 @@ postTypingIndicators = do ) !!! const 400 === statusCode -removeUser :: TestM () -removeUser = do +removeUserNoFederation :: TestM () +removeUserNoFederation = do c <- view tsCannon - let remoteDomain = Domain "far-away.example.com" [alice, bob, carl] <- replicateM 3 randomQualifiedUser - dee <- (`Qualified` remoteDomain) <$> randomId let [alice', bob', carl'] = qUnqualified <$> [alice, bob, carl] connectUsers alice' (list1 bob' [carl']) - connectWithRemoteUser alice' dee - connectWithRemoteUser bob' dee conv1 <- decodeConvId <$> postConv alice' [bob'] (Just "gossip") [] Nothing Nothing conv2 <- decodeConvId <$> postConv alice' [bob', carl'] (Just "gossip2") [] Nothing Nothing conv3 <- decodeConvId <$> postConv alice' [carl'] (Just "gossip3") [] Nothing Nothing - conv4 <- randomId -- a remote conversation at 'remoteDomain' that Alice, Bob and Dee will be in let qconv1 = Qualified conv1 (qDomain bob) qconv2 = Qualified conv2 (qDomain bob) - now <- liftIO getCurrentTime - fedGalleyClient <- view tsFedGalleyClient - let nc = - FederatedGalley.NewRemoteConversation - { FederatedGalley.rcTime = now, - FederatedGalley.rcOrigUserId = qUnqualified dee, - FederatedGalley.rcCnvId = conv4, - FederatedGalley.rcCnvType = RegularConv, - FederatedGalley.rcCnvAccess = [], - FederatedGalley.rcCnvAccessRole = PrivateAccessRole, - FederatedGalley.rcCnvName = Just "gossip4", - FederatedGalley.rcNonCreatorMembers = Set.fromList $ createOtherMember <$> [alice, bob], - FederatedGalley.rcMessageTimer = Nothing, - FederatedGalley.rcReceiptMode = Nothing - } - FederatedGalley.onConversationCreated fedGalleyClient remoteDomain nc - WS.bracketR3 c alice' bob' carl' $ \(wsA, wsB, wsC) -> do - (_, fedRequests) <- - withTempMockFederator (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ - deleteUser bob' !!! const 200 === statusCode - - req <- assertOne fedRequests - liftIO $ do - F.domain req @?= domainText remoteDomain - fmap F.component (F.request req) @?= Just F.Galley - fmap F.path (F.request req) @?= Just "/federation/leave-conversation" - Just (Right lc) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request req) - FederatedGalley.lcConvId lc @?= conv4 - FederatedGalley.lcLeaver lc @?= qUnqualified bob + deleteUser bob' !!! const 200 === statusCode void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB] $ @@ -3170,6 +3139,94 @@ removeUser = do (mems2 >>= other carl) @?= Just (OtherMember carl Nothing roleNameWireAdmin) (mems3 >>= other bob) @?= Nothing (mems3 >>= other carl) @?= Just (OtherMember carl Nothing roleNameWireAdmin) + +removeUser :: TestM () +removeUser = do + c <- view tsCannon + [alice, alexDel, amy] <- replicateM 3 randomQualifiedUser + let [alice', alexDel', amy'] = qUnqualified <$> [alice, alexDel, amy] + let bDomain = Domain "b.example.com" + bart <- randomQualifiedId bDomain + let cDomain = Domain "c.example.com" + carl <- randomQualifiedId cDomain + + connectUsers alice' (list1 alexDel' [amy']) + connectWithRemoteUser alice' bart + connectWithRemoteUser alexDel' bart + connectWithRemoteUser alice' carl + connectWithRemoteUser alexDel' carl + + convA1 <- decodeConvId <$> postConv alice' [alexDel'] (Just "gossip") [] Nothing Nothing + convA2 <- decodeConvId <$> postConv alice' [alexDel', amy'] (Just "gossip2") [] Nothing Nothing + convA3 <- decodeConvId <$> postConv alice' [amy'] (Just "gossip3") [] Nothing Nothing + convA4 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, bart, carl]} + convB1 <- randomId -- a remote conversation at 'bDomain' that Alice, AlexDel and Bart will be in + convB2 <- randomId -- a remote conversation at 'bDomain' that AlexDel and Bart will be in + convC1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Carl will be in + let qconvA1 = Qualified convA1 (qDomain alexDel) + qconvA2 = Qualified convA2 (qDomain alexDel) + + now <- liftIO getCurrentTime + fedGalleyClient <- view tsFedGalleyClient + let nc cid creator quids = + FederatedGalley.NewRemoteConversation + { FederatedGalley.rcTime = now, + FederatedGalley.rcOrigUserId = qUnqualified creator, + FederatedGalley.rcCnvId = cid, + FederatedGalley.rcCnvType = RegularConv, + FederatedGalley.rcCnvAccess = [], + FederatedGalley.rcCnvAccessRole = PrivateAccessRole, + FederatedGalley.rcCnvName = Just "gossip4", + FederatedGalley.rcNonCreatorMembers = Set.fromList $ createOtherMember <$> quids, + FederatedGalley.rcMessageTimer = Nothing, + FederatedGalley.rcReceiptMode = Nothing + } + FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] + FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB2 bart [alexDel] + FederatedGalley.onConversationCreated fedGalleyClient cDomain $ nc convC1 carl [alexDel] + + WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do + (_, fedRequests) <- + withTempMockFederator (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ + deleteUser alexDel' !!! const 200 === statusCode + + -- FUTUTREWORK: There should be 4 requests, one to each domain for telling + -- them that alex left the conversation hosted locally. Add assertions for + -- that and implement it. + liftIO $ do + assertEqual ("expect exactly 2 federated requests in : " <> show fedRequests) 2 (length fedRequests) + bReq <- assertOne $ filter (\req -> F.domain req == domainText bDomain) fedRequests + cReq <- assertOne $ filter (\req -> F.domain req == domainText cDomain) fedRequests + liftIO $ do + fmap F.component (F.request bReq) @?= Just F.Galley + fmap F.path (F.request bReq) @?= Just "/federation/on-user-deleted" + Just (Right udnB) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request bReq) + sort (fromRange (FederatedGalley.udnConversations udnB)) @?= sort [convB1, convB2] + FederatedGalley.udnUser udnB @?= qUnqualified alexDel + + fmap F.component (F.request bReq) @?= Just F.Galley + fmap F.path (F.request cReq) @?= Just "/federation/on-user-deleted" + Just (Right udnC) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cReq) + sort (fromRange (FederatedGalley.udnConversations udnC)) @?= sort [convC1] + FederatedGalley.udnUser udnC @?= qUnqualified alexDel + + WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ + wsAssertMembersLeave qconvA1 alexDel [alexDel] + WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel, wsAmy] $ + wsAssertMembersLeave qconvA2 alexDel [alexDel] + -- Check memberships + mems1 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA1 + mems2 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA2 + mems3 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA3 + mems4 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA4 + let findOther u = find ((== u) . omQualifiedId) . cmOthers + liftIO $ do + findOther alexDel mems1 @?= Nothing + findOther alexDel mems2 @?= Nothing + findOther amy mems2 @?= Just (OtherMember amy Nothing roleNameWireAdmin) + findOther alexDel mems3 @?= Nothing + findOther amy mems3 @?= Just (OtherMember amy Nothing roleNameWireAdmin) + findOther alexDel mems4 @?= Nothing where createOtherMember :: Qualified UserId -> OtherMember createOtherMember quid = @@ -3189,7 +3246,7 @@ testAllOne2OneConversationRequests = do testOne2OneConversationRequest :: Bool -> Actor -> DesiredMembership -> TestM () testOne2OneConversationRequest shouldBeLocal actor desired = do alice <- qTagUnsafe <$> randomQualifiedUser - (bob, expectedConvId) <- generateRemoteAndConvId alice + (bob, expectedConvId) <- generateRemoteAndConvId shouldBeLocal alice db <- view tsCass convId <- do @@ -3220,12 +3277,3 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do _ -> pure [] when (actor == LocalActor) $ liftIO $ isJust (find (qUntagged alice ==) mems) @?= (desired == Included) - where - generateRemoteAndConvId :: Local UserId -> TestM (Remote UserId, Qualified ConvId) - generateRemoteAndConvId lUserId = do - other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") - let convId = one2OneConvId (qUntagged lUserId) other - isLocal = tDomain lUserId == qDomain convId - if shouldBeLocal == isLocal - then pure (qTagUnsafe other, convId) - else generateRemoteAndConvId lUserId diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index d541fd76958..82ef1ea967a 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -22,7 +22,7 @@ import API.Util import Bilge import Bilge.Assert import Control.Lens hiding ((#)) -import Data.Aeson (ToJSON (..)) +import Data.Aeson (FromJSON, ToJSON (..), eitherDecode) import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS @@ -34,12 +34,15 @@ import Data.List1 import qualified Data.List1 as List1 import qualified Data.Map as Map import qualified Data.ProtoLens as Protolens -import Data.Qualified (Qualified (..)) +import Data.Qualified +import Data.Range import qualified Data.Set as Set +import Data.String.Conversions import Data.Time.Clock import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) import Galley.Types +import Galley.Types.Conversations.Intra import Gundeck.Types.Notification import Imports import Test.QuickCheck (arbitrary, generate) @@ -51,6 +54,7 @@ import TestSetup import Wire.API.Conversation.Action (ConversationAction (..)) import Wire.API.Conversation.Member (Member (..)) import Wire.API.Conversation.Role +import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley (GetConversationsRequest (..), GetConversationsResponse (..), RemoteConvMembers (..), RemoteConversation (..)) import qualified Wire.API.Federation.API.Galley as FedGalley import qualified Wire.API.Federation.GRPC.Types as F @@ -78,7 +82,8 @@ tests s = test s "POST /federation/on-conversation-updated : Notify local users about a deleted conversation" notifyDeletedConversation, test s "POST /federation/leave-conversation : Success" leaveConversationSuccess, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, - test s "POST /federation/send-message : Post a message sent from another backend" sendMessage + test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, + test s "POST /federation/on-user-deleted : Remove deleted remote user from local conversations" onUserDeleted ] getConversationsAllFound :: TestM () @@ -108,7 +113,7 @@ getConversationsAllFound = do -- get conversations fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponse cs <- + GetConversationsResponse convs <- FedGalley.getConversations fedGalleyClient (qDomain aliceQ) @@ -117,7 +122,7 @@ getConversationsAllFound = do (map (qUnqualified . cnvQualifiedId) [cnv2]) ) - let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) cs + let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) convs liftIO $ do assertEqual @@ -147,12 +152,12 @@ getConversationsNotPartOf = do fedGalleyClient <- view tsFedGalleyClient localDomain <- viewFederationDomain rando <- Id <$> liftIO nextRandom - GetConversationsResponse cs <- + GetConversationsResponse convs <- FedGalley.getConversations fedGalleyClient localDomain (GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1]) - liftIO $ assertEqual "conversation list not empty" [] cs + liftIO $ assertEqual "conversation list not empty" [] convs onConvCreated :: TestM () onConvCreated = do @@ -848,3 +853,133 @@ sendMessage = do FedGalley.rmSender rm @?= bob Map.keysSet (userClientMap (FedGalley.rmRecipients rm)) @?= Set.singleton chadId + +onUserDeleted :: TestM () +onUserDeleted = do + cannon <- view tsCannon + let eveDomain = Domain "eve.example.com" + + alice <- qTagUnsafe <$> randomQualifiedUser + (bob, ooConvId) <- generateRemoteAndConvId True alice + let bobDomain = tDomain bob + charlie <- randomQualifiedUser + dee <- randomQualifiedId bobDomain + eve <- randomQualifiedId eveDomain + + connectWithRemoteUser (tUnqualified alice) (qUntagged bob) + connectUsers (tUnqualified alice) (pure (qUnqualified charlie)) + connectWithRemoteUser (tUnqualified alice) dee + connectWithRemoteUser (tUnqualified alice) eve + + -- create 1-1 conversation between alice and bob + iUpsertOne2OneConversation + UpsertOne2OneConversationRequest + { uooLocalUser = alice, + uooRemoteUser = bob, + uooActor = LocalActor, + uooActorDesiredMembership = Included, + uooConvId = Nothing + } + !!! const 200 === statusCode + iUpsertOne2OneConversation + UpsertOne2OneConversationRequest + { uooLocalUser = alice, + uooRemoteUser = bob, + uooActor = RemoteActor, + uooActorDesiredMembership = Included, + uooConvId = Just ooConvId + } + !!! const 200 === statusCode + + -- create group conversation with everybody + groupConvId <- + decodeQualifiedConvId + <$> ( postConvWithRemoteUsers + (tUnqualified alice) + defNewConv {newConvQualifiedUsers = [qUntagged bob, charlie, dee, eve]} + ( postConvQualified (tUnqualified alice) defNewConv {newConvQualifiedUsers = [charlie]} + do + (resp, rpcCalls) <- withTempMockFederator (const ()) $ do + let udn = + FedGalley.UserDeletedNotification + { FedGalley.udnUser = tUnqualified bob, + FedGalley.udnConversations = + unsafeRange + [ qUnqualified ooConvId, + qUnqualified groupConvId, + extraConvId, + qUnqualified noBobConvId + ] + } + g <- viewGalley + responseJsonError + =<< post + ( g + . paths ["federation", "on-user-deleted"] + . content "application/json" + . header "Wire-Origin-Domain" (toByteString' (tDomain bob)) + . json udn + ) + F.domain c == domainText bobDomain) rpcCalls + bobDomainRPCReq <- assertRight $ parseFedRequest bobDomainRPC + FedGalley.cuOrigUserId bobDomainRPCReq @?= qUntagged bob + FedGalley.cuConvId bobDomainRPCReq @?= qUnqualified groupConvId + sort (FedGalley.cuAlreadyPresentUsers bobDomainRPCReq) @?= sort [tUnqualified bob, qUnqualified dee] + FedGalley.cuAction bobDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) + + -- Assertions about RPC to Eve's domain + eveDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText eveDomain) rpcCalls + eveDomainRPCReq <- assertRight $ parseFedRequest eveDomainRPC + FedGalley.cuOrigUserId eveDomainRPCReq @?= qUntagged bob + FedGalley.cuConvId eveDomainRPCReq @?= qUnqualified groupConvId + FedGalley.cuAlreadyPresentUsers eveDomainRPCReq @?= [qUnqualified eve] + FedGalley.cuAction eveDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a + parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 04ac52e7ed7..212834e6032 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -72,6 +72,7 @@ import qualified Galley.Run as Run import Galley.Types import qualified Galley.Types as Conv import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..)) +import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.Conversations.Roles hiding (DeleteConversation) import Galley.Types.Teams hiding (Event, EventType (..), self) import qualified Galley.Types.Teams as Team @@ -2469,3 +2470,12 @@ iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> TestM Response iUpsertOne2OneConversation req = do galley <- view tsGalley post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req) + +generateRemoteAndConvId :: Bool -> Local UserId -> TestM (Remote UserId, Qualified ConvId) +generateRemoteAndConvId shouldBeLocal lUserId = do + other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + let convId = one2OneConvId (qUntagged lUserId) other + isLocal = tDomain lUserId == qDomain convId + if shouldBeLocal == isLocal + then pure (qTagUnsafe other, convId) + else generateRemoteAndConvId shouldBeLocal lUserId From e9d8d995b6486e125455119a87f44707c376ad1f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 26 Oct 2021 17:08:14 +0200 Subject: [PATCH 47/88] Set federator's default log level to Info (#1882) --- changelog.d/6-federation/federator-log-level | 1 + charts/federator/values.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/6-federation/federator-log-level diff --git a/changelog.d/6-federation/federator-log-level b/changelog.d/6-federation/federator-log-level new file mode 100644 index 00000000000..63cd4052e1e --- /dev/null +++ b/changelog.d/6-federation/federator-log-level @@ -0,0 +1 @@ +Make federator's default log level Info \ No newline at end of file diff --git a/charts/federator/values.yaml b/charts/federator/values.yaml index 3184c8983c9..9e0439e596a 100644 --- a/charts/federator/values.yaml +++ b/charts/federator/values.yaml @@ -23,7 +23,7 @@ resources: memory: "512Mi" cpu: "500m" config: - logLevel: Debug + logLevel: Info logFormat: JSON optSettings: # Defaults to using system CA store in the federator image for making From 327914634df7d19f81adc43f31a1a8d65555ef55 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 27 Oct 2021 01:11:55 +0200 Subject: [PATCH 48/88] Rename the two federation/on-user-deleted endpoints (#1883) * Update Federation API conventions doc in prep for on-user-deleted * brig/galley: Rename the two federation/on-user-deleted endpoints This is to ensure that they do not overlap. This will hopefully make it easier to merge brig and galley. * Extract type level vars for UserDeleteNotificationMax{Conns,Convs} --- .../6-federation/optimize-user-deletion | 2 +- docs/developer/federation-api-conventions.md | 26 +++++++++++++------ .../src/Wire/API/Federation/API/Brig.hs | 15 ++++++----- .../src/Wire/API/Federation/API/Galley.hs | 15 ++++++----- services/brig/src/Brig/API/Federation.hs | 8 +++--- services/brig/src/Brig/Federation/Client.hs | 2 +- services/brig/src/Brig/IO/Intra.hs | 8 +++--- .../brig/test/integration/API/Federation.hs | 6 ++--- .../brig/test/integration/API/User/Account.hs | 10 +++---- services/galley/src/Galley/API/Federation.hs | 10 +++---- services/galley/src/Galley/API/Internal.hs | 6 ++--- services/galley/test/integration/API.hs | 16 ++++++------ .../galley/test/integration/API/Federation.hs | 14 +++++----- 13 files changed, 78 insertions(+), 60 deletions(-) diff --git a/changelog.d/6-federation/optimize-user-deletion b/changelog.d/6-federation/optimize-user-deletion index a160e66fc0b..e5e083c6023 100644 --- a/changelog.d/6-federation/optimize-user-deletion +++ b/changelog.d/6-federation/optimize-user-deletion @@ -1 +1 @@ -When a user gets deleted, notify remotes about conversations and connections in chunks of 1000 \ No newline at end of file +When a user gets deleted, notify remotes about conversations and connections in chunks of 1000 (#1872, #1883) \ No newline at end of file diff --git a/docs/developer/federation-api-conventions.md b/docs/developer/federation-api-conventions.md index 6971d4b042e..5703ffe3af5 100644 --- a/docs/developer/federation-api-conventions.md +++ b/docs/developer/federation-api-conventions.md @@ -3,12 +3,14 @@ # Federation API Conventions - All endpoints must start with `/federation/` -- All endpoints must have exactly one path segment after federation, so - `/federation/foo` is valid `/fedeartion/foo/bar` is not. The path segments - must be in kebab-case. The name of the field in this record must be the - same name in camelCase. +- All path segments must be in kebab-case. The name the field in the record must + be the same name in camelCase. +- There can be either one or two path segments after `/federation/`, so + `/federation/foo` is valid, `/fedeartion/foo/bar` is valid, but + `/federation/foo/bar/baz` is not. - All endpoints must be `POST`. -- No query query params, all information that needs to go must go in body. +- No query query params or captured path params, all information that needs to + go must go in body. - All responses must be `200 OK`, domain specific failures (e.g. the conversation doesn't exist) must be indicated as a Sum type. Unhandled failures can be 5xx, an endpoint not being implemented will of course @@ -16,9 +18,11 @@ - Accept only json, respond with only json. Maybe we can think of changing this in future. But as of now, the federator hardcodes application/json as the content type of the body. -- Name of the last path segment must be either `-` or - `on--`, e.g. `get-conversations` or - `on-conversation-created`. +- Ensure that paths don't collide between brig and galley federation API, this + will be very helpful when we merge brig and galley. +- Name of the first path segment after `/federation/` must be either + `-` or `on--`, e.g. + `get-conversations` or `on-conversation-created`. How to decide which one to use: - If the request is supposed to ask for information/change from another @@ -29,3 +33,9 @@ this request has authority on, like a conversation got created, or a message is sent, then use the second format like `on-conversation-created` or `on-message-sent` +- Path segment number 3 (so `/federation/not-this/but-this-one`), must only be + used in exceptional circumstances, like when there needs to be the same path + in brig and galley, e.g. `on-user-deleted`. In this case use the third segment + to express the difference. For `on-user-deleted` we came up with + `on-user-deleted/connections`for brig and `on-user-deleted/conversations` for + galley. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index c41324c4111..ba8bf3f1a9a 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -107,8 +107,9 @@ data Api routes = Api routes :- "federation" :> "on-user-deleted" + :> "connections" :> OriginDomainHeader - :> ReqBody '[JSON] UserDeletedNotification + :> ReqBody '[JSON] UserDeletedConnectionsNotification :> Post '[JSON] EmptyResponse } deriving (Generic) @@ -160,15 +161,17 @@ data NewConnectionResponse deriving (Arbitrary) via (GenericUniform NewConnectionResponse) deriving (FromJSON, ToJSON) via (CustomEncoded NewConnectionResponse) -data UserDeletedNotification = UserDeletedNotification +type UserDeletedNotificationMaxConnections = 1000 + +data UserDeletedConnectionsNotification = UserDeletedConnectionsNotification { -- | This is qualified implicitly by the origin domain - udnUser :: UserId, + udcnUser :: UserId, -- | These are qualified implicitly by the target domain - udnConnections :: Range 1 1000 [UserId] + udcnConnections :: Range 1 UserDeletedNotificationMaxConnections [UserId] } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform UserDeletedNotification) - deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedNotification) + deriving (Arbitrary) via (GenericUniform UserDeletedConnectionsNotification) + deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedConnectionsNotification) clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Brig m)) clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index ff9841544d0..6e258cc242c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -109,8 +109,9 @@ data Api routes = Api routes :- "federation" :> "on-user-deleted" + :> "conversations" :> OriginDomainHeader - :> ReqBody '[JSON] UserDeletedNotification + :> ReqBody '[JSON] UserDeletedConversationsNotification :> Post '[JSON] EmptyResponse } deriving (Generic) @@ -262,15 +263,17 @@ newtype LeaveConversationResponse = LeaveConversationResponse (ToJSON, FromJSON) via (Either (CustomEncoded RemoveFromConversationError) ()) -data UserDeletedNotification = UserDeletedNotification +type UserDeletedNotificationMaxConvs = 1000 + +data UserDeletedConversationsNotification = UserDeletedConversationsNotification { -- | This is qualified implicitly by the origin domain - udnUser :: UserId, + udcnUser :: UserId, -- | These are qualified implicitly by the target domain - udnConversations :: Range 1 1000 [ConvId] + udcnConversations :: Range 1 UserDeletedNotificationMaxConvs [ConvId] } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform UserDeletedNotification) - deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedNotification) + deriving (Arbitrary) via (GenericUniform UserDeletedConversationsNotification) + deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedConversationsNotification) clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Galley m)) clientRoutes = genericClient diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 496b7e5caf1..9ae84c6eeec 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -123,10 +123,10 @@ searchUsers (SearchRequest searchTerm) = do getUserClients :: GetUserClients -> Handler (UserMap (Set PubClient)) getUserClients (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError -onUserDeleted :: Domain -> UserDeletedNotification -> Handler EmptyResponse -onUserDeleted origDomain udn = lift $ do - let deletedUser = toRemoteUnsafe origDomain (udnUser udn) - connections = udnConnections udn +onUserDeleted :: Domain -> UserDeletedConnectionsNotification -> Handler EmptyResponse +onUserDeleted origDomain udcn = lift $ do + let deletedUser = toRemoteUnsafe origDomain (udcnUser udcn) + connections = udcnConnections udcn event = pure . UserEvent $ UserDeleted (qUntagged deletedUser) acceptedLocals <- map csv2From diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 3eb23f66622..951d67b4d43 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -104,5 +104,5 @@ notifyUserDeleted self remotes = do let remoteConnections = tUnqualified remotes let fedRPC = FederatedBrig.onUserDeleted clientRoutes (tDomain self) $ - UserDeletedNotification (tUnqualified self) remoteConnections + UserDeletedConnectionsNotification (tUnqualified self) remoteConnections void $ executeFederated (tDomain remotes) fedRPC diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index ff5617bff15..6ceed1c77fa 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -98,9 +98,11 @@ import Data.Id import Data.Json.Util (UTCTimeMillis, (#)) import Data.List.Split (chunksOf) import Data.List1 (List1, list1, singleton) +import Data.Proxy import Data.Qualified import Data.Range import qualified Data.Set as Set +import GHC.TypeLits import Galley.Types (Connect (..), Conversation) import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest, UpsertOne2OneConversationResponse) import qualified Galley.Types.Teams as Team @@ -114,6 +116,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.API.Brig import Wire.API.Federation.Client import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) import Wire.API.Message (UserClients) @@ -256,7 +259,7 @@ notifyUserDeletionLocals deleted conn event = do notifyUserDeletionRemotes :: UserId -> AppIO () notifyUserDeletionRemotes deleted = do runConduit $ - Data.lookupRemoteConnectedUsersC deleted 1000 + Data.lookupRemoteConnectedUsersC deleted (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) .| C.mapM_ fanoutNotifications where fanoutNotifications :: [Remote UserId] -> AppIO () @@ -264,8 +267,7 @@ notifyUserDeletionRemotes deleted = do notifyBackend :: Remote [UserId] -> AppIO () notifyBackend uids = do - let rangedMaybeUids = checked @_ @1 @1000 <$> uids - case tUnqualified rangedMaybeUids of + case tUnqualified (checked <$> uids) of Nothing -> -- The user IDs cannot be more than 1000, so we can assume the range -- check will only fail because there are 0 User Ids. diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index 72e7edf3720..7f8960d7e63 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -42,7 +42,7 @@ import Test.Tasty import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit (assertEqual, assertFailure) import Util -import Wire.API.Federation.API.Brig (GetUserClients (..), SearchRequest (SearchRequest), UserDeletedNotification (..)) +import Wire.API.Federation.API.Brig (GetUserClients (..), SearchRequest (SearchRequest), UserDeletedConnectionsNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig import Wire.API.Message (UserClients (..)) import Wire.API.User.Client (mkUserClientPrekeyMap) @@ -67,7 +67,7 @@ tests m opts brig cannon fedBrigClient = test m "POST /federation/claim-multi-prekey-bundle : 200" (testClaimMultiPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/get-user-clients : 200" (testGetUserClients brig fedBrigClient), test m "POST /federation/get-user-clients : Not Found" (testGetUserClientsNotFound fedBrigClient), - test m "POST /federation/on-user-deleted : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) + test m "POST /federation/on-user-deleted/connections : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) ] testSearchSuccess :: Brig -> FedBrigClient -> Http () @@ -238,7 +238,7 @@ testRemoteUserGetsDeleted opts brig cannon fedBrigClient = do FedBrig.onUserDeleted fedBrigClient (qDomain remoteUser) - (UserDeletedNotification (qUnqualified remoteUser) (unsafeRange localUsers)) + (UserDeletedConnectionsNotification (qUnqualified remoteUser) (unsafeRange localUsers)) WS.assertMatchN_ (5 # Second) [cc] $ matchDeleteUserNotification remoteUser WS.assertNoEvent (1 # Second) [pc, bc, uc] diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 1e71e967e2e..fcc529fd2da 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -77,7 +77,7 @@ import UnliftIO (mapConcurrently_) import Util as Util import Util.AWS as Util import Web.Cookie (parseSetCookie) -import Wire.API.Federation.API.Brig (UserDeletedNotification (..)) +import Wire.API.Federation.API.Brig (UserDeletedConnectionsNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig import Wire.API.Federation.API.Common (EmptyResponse (EmptyResponse)) import Wire.API.Federation.GRPC.Types (OutwardResponse (OutwardResponseBody)) @@ -1241,14 +1241,14 @@ testDeleteWithRemotes opts brig = do liftIO $ do remote1Call <- assertOne $ filter (\c -> F.domain c == domainText remote1Domain) rpcCalls remote1Udn <- assertRight $ parseFedRequest remote1Call - udnUser remote1Udn @?= userId localUser - sort (fromRange (udnConnections remote1Udn)) + udcnUser remote1Udn @?= userId localUser + sort (fromRange (udcnConnections remote1Udn)) @?= sort (map qUnqualified [remote1UserConnected, remote1UserPending]) remote2Call <- assertOne $ filter (\c -> F.domain c == domainText remote2Domain) rpcCalls remote2Udn <- assertRight $ parseFedRequest remote2Call - udnUser remote2Udn @?= userId localUser - fromRange (udnConnections remote2Udn) @?= [qUnqualified remote2UserBlocked] + udcnUser remote2Udn @?= userId localUser + fromRange (udcnConnections remote2Udn) @?= [qUnqualified remote2UserBlocked] where parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a parseFedRequest fr = diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index f802f256e31..b26697a00bb 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -64,7 +64,7 @@ import Wire.API.Federation.API.Galley MessageSendResponse (..), NewRemoteConversation (..), RemoteMessage (..), - UserDeletedNotification, + UserDeletedConversationsNotification, ) import qualified Wire.API.Federation.API.Galley as FederationAPIGalley import Wire.API.Routes.Internal.Brig.Connection @@ -278,11 +278,11 @@ sendMessage originDomain msr = do where err = throwM . invalidPayload . LT.pack -onUserDeleted :: Domain -> UserDeletedNotification -> Galley EmptyResponse -onUserDeleted origDomain udn = do - let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udnUser udn) +onUserDeleted :: Domain -> UserDeletedConversationsNotification -> Galley EmptyResponse +onUserDeleted origDomain udcn = do + let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser - convIds = FederationAPIGalley.udnConversations udn + convIds = FederationAPIGalley.udcnConversations udcn pooledForConcurrentlyN_ 16 (fromRange convIds) $ \c -> do lc <- qualifyLocal c mconv <- Data.conversation c diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 546f09154f2..400f7d775ab 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -81,7 +81,7 @@ import System.Logger.Class hiding (Path, name) import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.ErrorDescription (MissingLegalholdConsent) -import Wire.API.Federation.API.Galley (UserDeletedNotification (UserDeletedNotification)) +import Wire.API.Federation.API.Galley (UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Federation.Client (executeFederated) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) @@ -522,10 +522,10 @@ rmUser user conn = do (maybeList1 (catMaybes pp)) Intra.push - leaveRemoteConversations :: Local UserId -> Range 1 1000 [Remote ConvId] -> Galley () + leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley () leaveRemoteConversations lusr cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do - let userDelete = UserDeletedNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) + let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete res <- runExceptT (executeFederated (tDomain remoteConvs) rpc) case res of diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7f1c7207f82..cd61c67eb42 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -3199,16 +3199,16 @@ removeUser = do cReq <- assertOne $ filter (\req -> F.domain req == domainText cDomain) fedRequests liftIO $ do fmap F.component (F.request bReq) @?= Just F.Galley - fmap F.path (F.request bReq) @?= Just "/federation/on-user-deleted" - Just (Right udnB) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request bReq) - sort (fromRange (FederatedGalley.udnConversations udnB)) @?= sort [convB1, convB2] - FederatedGalley.udnUser udnB @?= qUnqualified alexDel + fmap F.path (F.request bReq) @?= Just "/federation/on-user-deleted/conversations" + Just (Right udcnB) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request bReq) + sort (fromRange (FederatedGalley.udcnConversations udcnB)) @?= sort [convB1, convB2] + FederatedGalley.udcnUser udcnB @?= qUnqualified alexDel fmap F.component (F.request bReq) @?= Just F.Galley - fmap F.path (F.request cReq) @?= Just "/federation/on-user-deleted" - Just (Right udnC) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cReq) - sort (fromRange (FederatedGalley.udnConversations udnC)) @?= sort [convC1] - FederatedGalley.udnUser udnC @?= qUnqualified alexDel + fmap F.path (F.request cReq) @?= Just "/federation/on-user-deleted/conversations" + Just (Right udcnC) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cReq) + sort (fromRange (FederatedGalley.udcnConversations udcnC)) @?= sort [convC1] + FederatedGalley.udcnUser udcnC @?= qUnqualified alexDel WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ wsAssertMembersLeave qconvA1 alexDel [alexDel] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 82ef1ea967a..2665106b2d8 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -83,7 +83,7 @@ tests s = test s "POST /federation/leave-conversation : Success" leaveConversationSuccess, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, - test s "POST /federation/on-user-deleted : Remove deleted remote user from local conversations" onUserDeleted + test s "POST /federation/on-user-deleted/conversations : Remove deleted remote user from local conversations" onUserDeleted ] getConversationsAllFound :: TestM () @@ -912,10 +912,10 @@ onUserDeleted = do WS.bracketR2 cannon (tUnqualified alice) (qUnqualified charlie) $ \(wsAlice, wsCharlie) -> do (resp, rpcCalls) <- withTempMockFederator (const ()) $ do - let udn = - FedGalley.UserDeletedNotification - { FedGalley.udnUser = tUnqualified bob, - FedGalley.udnConversations = + let udcn = + FedGalley.UserDeletedConversationsNotification + { FedGalley.udcnUser = tUnqualified bob, + FedGalley.udcnConversations = unsafeRange [ qUnqualified ooConvId, qUnqualified groupConvId, @@ -927,10 +927,10 @@ onUserDeleted = do responseJsonError =<< post ( g - . paths ["federation", "on-user-deleted"] + . paths ["federation", "on-user-deleted", "conversations"] . content "application/json" . header "Wire-Origin-Domain" (toByteString' (tDomain bob)) - . json udn + . json udcn ) Date: Wed, 27 Oct 2021 09:24:55 +0200 Subject: [PATCH 49/88] Galley polysemy (1/5) - Introduce Sem and "access" effects (#1881) * Add type variable to Galley monad This is step 0 in the process of converting galley to effects. We introduce a phantom type variable `r` in the `Galley` monad, which will later be used for the effect row. * Use API instead of DB access in 1-1 conv test * Monomorphise Data functions * Avoid MonadUnliftIO in Bilge.RPC * Remove unneeded MonadLogger constraint * Introduce fine-grained placeholder effects This commit introduces several placeholder effects, mostly having to do with making HTTP requests. All the existing uses of `MonadUnliftIO` are now either gone, or hidden behind of of these effects, and that made it possible to get rid of the `MonadUnliftIO` instance for `Galley`. Also, the `Galley0` type synomym now refers to `Galley` without any effects, so `runGalley` and related functions now take a `Galley GalleyEffects` instead. `Galley0` still has a `MonadUnliftIO` instance, so it can be used as a temporary crutch to get access to async primitives. Those need to be run in `Galley0`, and finally lifted to a general `Galley r` monad. Eventually, the `Galley0` actions will simply be replaced by effect actions, and the code actually using `MonadUnliftIO` will be relegated to interpreters. * Remove MonadMask instance of Galley This also introduces a `SparAccess` effect and adds a few more `BrigAccess` and `BotAccess` constraints. * Remove MonadCatch instance of Galley * Turn Galley into a Sem newtype The underlying `Sem` monad in `Galley` is an arbitrary effect stack that contains at least the effects which replicate the functionality of the original `Galley` monad. All the functionality has been reimplemented in terms of `Sem`, so the existing code does not need to be changed at all. --- changelog.d/5-internal/galley-polysemy | 1 + libs/bilge/src/Bilge/RPC.hs | 7 +- .../src/Network/Wai/Utilities/Server.hs | 2 +- services/galley/galley.cabal | 12 +- services/galley/package.yaml | 3 +- services/galley/src/Galley/API.hs | 4 +- services/galley/src/Galley/API/Clients.hs | 9 +- services/galley/src/Galley/API/Create.hs | 82 +++- .../galley/src/Galley/API/CustomBackend.hs | 8 +- services/galley/src/Galley/API/Federation.hs | 93 +++-- services/galley/src/Galley/API/Internal.hs | 47 ++- services/galley/src/Galley/API/LegalHold.hs | 131 ++++-- .../src/Galley/API/LegalHold/Conflicts.hs | 22 +- services/galley/src/Galley/API/Mapping.hs | 2 +- services/galley/src/Galley/API/Message.hs | 70 ++-- services/galley/src/Galley/API/One2One.hs | 6 +- services/galley/src/Galley/API/Public.hs | 8 +- services/galley/src/Galley/API/Query.hs | 75 ++-- services/galley/src/Galley/API/Teams.hs | 294 +++++++++---- .../galley/src/Galley/API/Teams/Features.hs | 136 +++--- .../src/Galley/API/Teams/Notifications.hs | 6 +- services/galley/src/Galley/API/Update.hs | 393 +++++++++++++----- services/galley/src/Galley/API/Util.hs | 145 ++++--- services/galley/src/Galley/App.hs | 162 ++++++-- services/galley/src/Galley/Data.hs | 323 +++++++------- services/galley/src/Galley/Data/Services.hs | 2 +- .../src/Galley/Data/TeamNotifications.hs | 12 +- services/galley/src/Galley/Effects.hs | 109 +++++ .../src/Galley/Effects/FireAndForget.hs | 48 +++ services/galley/src/Galley/External.hs | 36 +- .../src/Galley/External/LegalHoldService.hs | 31 +- services/galley/src/Galley/Intra/Client.hs | 48 ++- services/galley/src/Galley/Intra/Journal.hs | 18 +- services/galley/src/Galley/Intra/Push.hs | 49 +-- services/galley/src/Galley/Intra/Spar.hs | 5 +- services/galley/src/Galley/Intra/Team.hs | 5 +- services/galley/src/Galley/Intra/User.hs | 69 +-- services/galley/src/Galley/Intra/Util.hs | 23 +- services/galley/src/Galley/Run.hs | 4 +- services/galley/src/Galley/Validation.hs | 8 +- services/galley/test/integration/API.hs | 50 ++- .../test/integration/API/Teams/LegalHold.hs | 2 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 2 +- services/galley/test/integration/API/Util.hs | 2 +- 44 files changed, 1727 insertions(+), 837 deletions(-) create mode 100644 changelog.d/5-internal/galley-polysemy create mode 100644 services/galley/src/Galley/Effects.hs create mode 100644 services/galley/src/Galley/Effects/FireAndForget.hs diff --git a/changelog.d/5-internal/galley-polysemy b/changelog.d/5-internal/galley-polysemy new file mode 100644 index 00000000000..528c615de11 --- /dev/null +++ b/changelog.d/5-internal/galley-polysemy @@ -0,0 +1 @@ +Turn `Galley` into a polysemy monad stack. diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index 50d8a6507b4..04cb232ec31 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -33,7 +33,7 @@ import Bilge.IO import Bilge.Request import Bilge.Response import Control.Error hiding (err) -import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow (..), try) import Control.Monad.Except import Data.Aeson (FromJSON, eitherDecode') import Data.CaseInsensitive (original) @@ -41,7 +41,6 @@ import Data.Text.Lazy (pack) import Imports hiding (log) import qualified Network.HTTP.Client as HTTP import System.Logger.Class -import UnliftIO.Exception (try) class HasRequestId m where getRequestId :: m RequestId @@ -69,7 +68,7 @@ instance Show RPCException where . showString "}" rpc :: - (MonadUnliftIO m, MonadHttp m, HasRequestId m, MonadLogger m, MonadThrow m) => + (MonadIO m, MonadCatch m, MonadHttp m, HasRequestId m) => LText -> (Request -> Request) -> m (Response (Maybe LByteString)) @@ -81,7 +80,7 @@ rpc sys = rpc' sys empty -- Note: 'syncIO' is wrapped around the IO action performing the request -- and any exceptions caught are re-thrown in an 'RPCException'. rpc' :: - (MonadUnliftIO m, MonadHttp m, HasRequestId m, MonadThrow m) => + (MonadIO m, MonadCatch m, MonadHttp m, HasRequestId m) => -- | A label for the remote system in case of 'RPCException's. LText -> Request -> diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index e2181ca099a..8986d39e897 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -170,7 +170,7 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes) messageStr (Just t) = char7 ':' <> char7 ' ' <> byteString t messageStr Nothing = mempty -route :: (MonadCatch m, MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived +route :: MonadIO m => Tree (App m) -> Request -> Continue IO -> m ResponseReceived route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (liftIO . k) where noEndpoint = Wai.mkError status404 "no-endpoint" "The requested endpoint does not exist" diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 0c6dbd6d86c..81c99088c3a 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 1daf2eec8d6d9666168a442a3c2856c2d453361e3bbffcc4a17c55d8bbf914f4 +-- hash: 8bf007e90cc28a7b92252e0fccfb998d850e30df040205e1bc7316b9008a0c9f name: galley version: 0.83.0 @@ -55,6 +55,8 @@ library Galley.Data.TeamFeatures Galley.Data.TeamNotifications Galley.Data.Types + Galley.Effects + Galley.Effects.FireAndForget Galley.External Galley.External.LegalHoldService Galley.Intra.Client @@ -121,6 +123,7 @@ library , mtl >=2.2 , optparse-applicative >=0.10 , pem + , polysemy , proto-lens >=0.2 , protobuf >=0.2 , raw-strings-qq >=1.0 @@ -146,7 +149,7 @@ library , time >=1.4 , tinylog >=0.10 , tls >=1.3.10 - , transformers >=0.3 + , transformers , types-common >=0.16 , types-common-journal >=0.1 , unliftio >=0.2 @@ -186,6 +189,7 @@ executable galley , servant-client , ssl-util , tagged + , transformers , types-common , wire-api , wire-api-federation @@ -283,6 +287,7 @@ executable galley-integration , time , tinylog , tls >=1.3.8 + , transformers , types-common , types-common-journal , unliftio @@ -334,6 +339,7 @@ executable galley-migrate-data , text , time , tinylog + , transformers , types-common , unliftio , wire-api @@ -400,6 +406,7 @@ executable galley-schema , tagged , text , tinylog + , transformers , wire-api , wire-api-federation if flag(static) @@ -444,6 +451,7 @@ test-suite galley-types-tests , tasty-hspec , tasty-hunit , tasty-quickcheck + , transformers , types-common , wai , wai-predicates diff --git a/services/galley/package.yaml b/services/galley/package.yaml index ead7824b388..03a557c84e7 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -22,6 +22,7 @@ dependencies: - tagged - servant-client - saml2-web-sso >=0.18 +- transformers library: source-dirs: src @@ -64,6 +65,7 @@ library: - mtl >=2.2 - optparse-applicative >=0.10 - pem + - polysemy - protobuf >=0.2 - proto-lens >=0.2 - QuickCheck >=2.14 @@ -85,7 +87,6 @@ library: - time >=1.4 - tinylog >=0.10 - tls >=1.3.10 - - transformers >=0.3 - types-common >=0.16 - types-common-journal >=0.1 - unliftio >=0.2 diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 6e964ad9826..122c06859f1 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -24,10 +24,10 @@ where import qualified Data.Swagger.Build.Api as Doc import qualified Galley.API.Internal as Internal import qualified Galley.API.Public as Public -import Galley.App (Galley) +import Galley.App (Galley, GalleyEffects) import Network.Wai.Routing (Routes) -sitemap :: Routes Doc.ApiBuilder Galley () +sitemap :: Routes Doc.ApiBuilder (Galley GalleyEffects) () sitemap = do Public.sitemap Public.apiDocs diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 526c7530517..e9c90bf5a29 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -26,6 +26,7 @@ import Control.Lens (view) import Data.Id import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Client as Intra import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) @@ -34,11 +35,11 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities -getClientsH :: UserId -> Galley Response +getClientsH :: Member BrigAccess r => UserId -> Galley r Response getClientsH usr = do json <$> getClients usr -getClients :: UserId -> Galley [ClientId] +getClients :: Member BrigAccess r => UserId -> Galley r [ClientId] getClients usr = do isInternal <- view $ options . optSettings . setIntraListing clts <- @@ -47,12 +48,12 @@ getClients usr = do else Data.lookupClients [usr] return $ clientIds usr clts -addClientH :: UserId ::: ClientId -> Galley Response +addClientH :: UserId ::: ClientId -> Galley r Response addClientH (usr ::: clt) = do Data.updateClient True usr clt return empty -rmClientH :: UserId ::: ClientId -> Galley Response +rmClientH :: UserId ::: ClientId -> Galley r Response rmClientH (usr ::: clt) = do Data.updateClient False usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index a23e127b57e..182deff3267 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -40,6 +40,7 @@ import Galley.API.One2One import Galley.API.Util import Galley.App import qualified Galley.Data as Data +import Galley.Effects import Galley.Intra.Push import Galley.Types import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notTeamMember) @@ -64,10 +65,11 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm -- -- See Note [managed conversations]. createGroupConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => UserId -> ConnId -> Public.NewConvUnmanaged -> - Galley ConversationResponse + Galley r ConversationResponse createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = case newConvTeam body of Nothing -> createRegularGroupConv user conn wrapped @@ -75,18 +77,29 @@ createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. -internalCreateManagedConversationH :: UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley Response +internalCreateManagedConversationH :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest NewConvManaged -> + Galley r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do newConv <- fromJsonBody req handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv -internalCreateManagedConversation :: UserId -> ConnId -> NewConvManaged -> Galley ConversationResponse +internalCreateManagedConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvManaged -> + Galley r ConversationResponse internalCreateManagedConversation zusr zcon (NewConvManaged body) = do case newConvTeam body of Nothing -> throwM internalError Just tinfo -> createTeamGroupConv zusr zcon tinfo body -ensureNoLegalholdConflicts :: [Remote UserId] -> [UserId] -> Galley () +ensureNoLegalholdConflicts :: + [Remote UserId] -> + [UserId] -> + Galley r () ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ @@ -94,7 +107,12 @@ ensureNoLegalholdConflicts remotes locals = do throwErrorDescriptionType @MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. -createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createRegularGroupConv :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvUnmanaged -> + Galley r ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) @@ -118,7 +136,13 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Only supports unmanaged conversations. -createTeamGroupConv :: UserId -> ConnId -> Public.ConvTeamInfo -> Public.NewConv -> Galley ConversationResponse +createTeamGroupConv :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.ConvTeamInfo -> + Public.NewConv -> + Galley r ConversationResponse createTeamGroupConv zusr zcon tinfo body = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) @@ -166,7 +190,7 @@ createTeamGroupConv zusr zcon tinfo body = do ---------------------------------------------------------------------------- -- Other kinds of conversations -createSelfConversation :: UserId -> Galley ConversationResponse +createSelfConversation :: UserId -> Galley r ConversationResponse createSelfConversation zusr = do lusr <- qualifyLocal zusr c <- Data.conversation (Id . toUUID $ zusr) @@ -176,7 +200,12 @@ createSelfConversation zusr = do c <- Data.createSelfConversation lusr Nothing conversationCreated zusr c -createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createOne2OneConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvUnmanaged -> + Galley r ConversationResponse createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do lusr <- qualifyLocal zusr let allUsers = newConvMembers lusr j @@ -216,12 +245,13 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do Nothing -> throwM teamNotFound createLegacyOne2OneConversationUnchecked :: + Members '[FederatorAccess, GundeckAccess] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Local UserId -> - Galley ConversationResponse + Galley r ConversationResponse createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other mc <- Data.conversation (tUnqualified lcnv) @@ -234,12 +264,13 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: + Members '[FederatorAccess, GundeckAccess] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley ConversationResponse + Galley r ConversationResponse createOne2OneConversationUnchecked self zcon name mtid other = do let create = foldQualified @@ -249,13 +280,14 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: + Members '[FederatorAccess, GundeckAccess] r => Local ConvId -> Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley ConversationResponse + Galley r ConversationResponse createOne2OneConversationLocally lcnv self zcon name mtid other = do mc <- Data.conversation (tUnqualified lcnv) case mc of @@ -272,15 +304,16 @@ createOne2OneConversationRemotely :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley ConversationResponse + Galley r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = throwM federationNotImplemented createConnectConversation :: + Members '[FederatorAccess, GundeckAccess] r => UserId -> Maybe ConnId -> Connect -> - Galley ConversationResponse + Galley r ConversationResponse createConnectConversation usr conn j = do lusr <- qualifyLocal usr foldQualified @@ -293,16 +326,17 @@ createConnectConversationWithRemote :: Local UserId -> Maybe ConnId -> Remote UserId -> - Galley ConversationResponse + Galley r ConversationResponse createConnectConversationWithRemote _ _ _ = throwM federationNotImplemented createLegacyConnectConversation :: + Members '[FederatorAccess, GundeckAccess] r => Local UserId -> Maybe ConnId -> Local UserId -> Connect -> - Galley ConversationResponse + Galley r ConversationResponse createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) n <- rangeCheckedMaybe (cName j) @@ -367,10 +401,10 @@ createLegacyConnectConversation lusr conn lrecipient j = do ------------------------------------------------------------------------------- -- Helpers -conversationCreated :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationCreated :: UserId -> Data.Conversation -> Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv -conversationExisted :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationExisted :: UserId -> Data.Conversation -> Galley r ConversationResponse conversationExisted usr cnv = Existed <$> conversationView usr cnv handleConversationResponse :: ConversationResponse -> Response @@ -378,7 +412,13 @@ handleConversationResponse = \case Created cnv -> json cnv & setStatus status201 . location (qUnqualified . cnvQualifiedId $ cnv) Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) -notifyCreatedConversation :: Maybe UTCTime -> UserId -> Maybe ConnId -> Data.Conversation -> Galley () +notifyCreatedConversation :: + Members '[FederatorAccess, GundeckAccess] r => + Maybe UTCTime -> + UserId -> + Maybe ConnId -> + Data.Conversation -> + Galley r () notifyCreatedConversation dtime usr conn c = do localDomain <- viewFederationDomain now <- maybe (liftIO getCurrentTime) pure dtime @@ -404,12 +444,12 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -localOne2OneConvId :: Local UserId -> Local UserId -> Galley (Local ConvId) +localOne2OneConvId :: Local UserId -> Local UserId -> Galley r (Local ConvId) localOne2OneConvId self other = do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) pure . qualifyAs self $ Data.localOne2OneConvId x y -toUUIDs :: UserId -> UserId -> Galley (U.UUID U.V4, U.UUID U.V4) +toUUIDs :: UserId -> UserId -> Galley r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 b' <- U.fromUUID (toUUID b) & ifNothing invalidUUID4 @@ -428,6 +468,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: [a] -> Galley a +ensureOne :: [a] -> Galley r a ensureOne [x] = pure x ensureOne _ = throwM (invalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index ab75da493ab..fa98803c799 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -38,11 +38,11 @@ import qualified Wire.API.CustomBackend as Public -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +getCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Domain -> Galley Public.CustomBackend +getCustomBackendByDomain :: Domain -> Galley r Public.CustomBackend getCustomBackendByDomain domain = Data.getCustomBackend domain >>= \case Nothing -> throwM (customBackendNotFound domain) @@ -50,14 +50,14 @@ getCustomBackendByDomain domain = -- INTERNAL ------------------------------------------------------------------- -internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley Response +internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley r Response internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req -- simple enough to not need a separate function Data.setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response internalDeleteCustomBackendByDomainH (domain ::: _) = do Data.deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index b26697a00bb..5889cb12a1a 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -38,8 +38,9 @@ import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtr import Galley.API.Update (notifyConversationMetadataUpdate) import qualified Galley.API.Update as API import Galley.API.Util -import Galley.App (Galley) +import Galley.App import qualified Galley.Data as Data +import Galley.Effects import Galley.Intra.User (getConnections) import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) import Imports @@ -47,7 +48,6 @@ import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) import qualified System.Logger.Class as Log -import UnliftIO.Async (pooledForConcurrentlyN_) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) @@ -72,7 +72,7 @@ import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..) import Wire.API.ServantProto (FromProto (..)) import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) Galley +federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) (Galley GalleyEffects) federationSitemap = genericServerT $ FederationAPIGalley.Api @@ -85,7 +85,11 @@ federationSitemap = FederationAPIGalley.onUserDeleted = onUserDeleted } -onConversationCreated :: Domain -> NewRemoteConversation ConvId -> Galley () +onConversationCreated :: + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Domain -> + NewRemoteConversation ConvId -> + Galley r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () @@ -119,7 +123,10 @@ onConversationCreated domain rc = do (EdConversation c) pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] -getConversations :: Domain -> GetConversationsRequest -> Galley GetConversationsResponse +getConversations :: + Domain -> + GetConversationsRequest -> + Galley r GetConversationsResponse getConversations domain (GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain @@ -132,7 +139,11 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai -- | Update the local database with information on conversation members joining -- or leaving. Finally, push out notifications to local users. -onConversationUpdated :: Domain -> ConversationUpdate -> Galley () +onConversationUpdated :: + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Domain -> + ConversationUpdate -> + Galley r () onConversationUpdated requestingDomain cu = do localDomain <- viewFederationDomain loc <- qualifyLocal () @@ -191,7 +202,12 @@ onConversationUpdated requestingDomain cu = do -- FUTUREWORK: support bots? pushConversationEvent Nothing event targets [] -addLocalUsersToRemoteConv :: Remote ConvId -> Qualified UserId -> [UserId] -> Galley (Set UserId) +addLocalUsersToRemoteConv :: + Member BrigAccess r => + Remote ConvId -> + Qualified UserId -> + [UserId] -> + Galley r (Set UserId) addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do connStatus <- getConnections localUsers (Just [qAdder]) (Just Accepted) let localUserIdsSet = Set.fromList localUsers @@ -214,9 +230,10 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => Domain -> LeaveConversationRequest -> - Galley LeaveConversationResponse + Galley r LeaveConversationResponse leaveConversation requestingDomain lc = do let leaver = Qualified (lcLeaver lc) requestingDomain lcnv <- qualifyLocal (lcConvId lc) @@ -233,7 +250,11 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients -onMessageSent :: Domain -> RemoteMessage ConvId -> Galley () +onMessageSent :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Domain -> + RemoteMessage ConvId -> + Galley r () onMessageSent domain rmUnqualified = do let rm = fmap (toRemoteUnsafe domain) rmUnqualified convId = qUntagged $ rmConversation rm @@ -260,7 +281,7 @@ onMessageSent domain rmUnqualified = do void $ sendLocalMessages (rmTime rm) (rmSender rm) (rmSenderClient rm) Nothing convId localMembers msgMetadata msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 - mkLocalMember :: UserId -> Galley LocalMember + mkLocalMember :: UserId -> Galley r LocalMember mkLocalMember m = pure $ LocalMember @@ -270,7 +291,11 @@ onMessageSent domain rmUnqualified = do lmConvRoleName = Public.roleNameWireMember } -sendMessage :: Domain -> MessageSendRequest -> Galley MessageSendResponse +sendMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Domain -> + MessageSendRequest -> + Galley r MessageSendResponse sendMessage originDomain msr = do let sender = Qualified (msrSender msr) originDomain msg <- either err pure (fromProto (fromBase64ByteString (msrRawMessage msr))) @@ -278,28 +303,34 @@ sendMessage originDomain msr = do where err = throwM . invalidPayload . LT.pack -onUserDeleted :: Domain -> UserDeletedConversationsNotification -> Galley EmptyResponse +onUserDeleted :: + Members '[FederatorAccess, FireAndForget, ExternalAccess, GundeckAccess] r => + Domain -> + UserDeletedConversationsNotification -> + Galley r EmptyResponse onUserDeleted origDomain udcn = do let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser convIds = FederationAPIGalley.udcnConversations udcn - pooledForConcurrentlyN_ 16 (fromRange convIds) $ \c -> do - lc <- qualifyLocal c - mconv <- Data.conversation c - Data.removeRemoteMembersFromLocalConv c (pure deletedUser) - for_ mconv $ \conv -> do - when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ - case Data.convType conv of - -- No need for a notification on One2One conv as the user is being - -- deleted and that notification should suffice. - Public.One2OneConv -> pure () - -- No need for a notification on Connect Conv as there should be no - -- other user in the conv. - Public.ConnectConv -> pure () - -- The self conv cannot be on a remote backend. - Public.SelfConv -> pure () - Public.RegularConv -> do - let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) - botsAndMembers = convBotsAndMembers conv - void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action + + spawnMany $ + fromRange convIds <&> \c -> do + lc <- qualifyLocal c + mconv <- Data.conversation c + Data.removeRemoteMembersFromLocalConv c (pure deletedUser) + for_ mconv $ \conv -> do + when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ + case Data.convType conv of + -- No need for a notification on One2One conv as the user is being + -- deleted and that notification should suffice. + Public.One2OneConv -> pure () + -- No need for a notification on Connect Conv as there should be no + -- other user in the conv. + Public.ConnectConv -> pure () + -- The self conv cannot be on a remote backend. + Public.SelfConv -> pure () + Public.RegularConv -> do + let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) + botsAndMembers = convBotsAndMembers conv + void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 400f7d775ab..5cc940a4579 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -28,8 +28,7 @@ where import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Except (runExceptT) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) @@ -55,6 +54,7 @@ import qualified Galley.API.Update as Update import Galley.API.Util (JSON, isMember, qualifyLocal, viewFederationDomain) import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Push as Intra import qualified Galley.Queue as Q import Galley.Types @@ -252,7 +252,7 @@ type IFeatureStatusDeprecatedPut featureName = :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) -servantSitemap :: ServerT ServantAPI Galley +servantSitemap :: ServerT ServantAPI (Galley GalleyEffects) servantSitemap = genericServerT $ InternalApi @@ -287,23 +287,23 @@ servantSitemap = } iGetTeamFeature :: - forall a. + forall a r. Public.KnownTeamFeatureName a => - (Features.GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: - forall a. + forall a r. Public.KnownTeamFeatureName a => - (TeamId -> Public.TeamFeatureStatus a -> Galley (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth -sitemap :: Routes a Galley () +sitemap :: Routes a (Galley GalleyEffects) () sitemap = do -- Conversation API (internal) ---------------------------------------- @@ -465,7 +465,12 @@ sitemap = do get "/i/legalhold/whitelisted-teams/:tid" (continue getTeamLegalholdWhitelistedH) $ capture "tid" -rmUser :: UserId -> Maybe ConnId -> Galley () +rmUser :: + forall r. + Members '[BrigAccess, ExternalAccess, FederatorAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + Galley r () rmUser user conn = do let n = toRange (Proxy @100) :: Range 1 100 Int32 nRange1000 = rcast n :: Range 1 1000 Int32 @@ -476,7 +481,7 @@ rmUser user conn = do goConvPages lusr nRange1000 allConvIds Data.eraseClients user where - goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley () + goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley r () goConvPages lusr range page = do let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs @@ -494,7 +499,7 @@ rmUser user conn = do leaveTeams =<< Cql.liftClient (Cql.nextPage tids) -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity - leaveLocalConversations :: [ConvId] -> Galley () + leaveLocalConversations :: [ConvId] -> Galley r () leaveLocalConversations ids = do localDomain <- viewFederationDomain cc <- Data.localConversations ids @@ -522,7 +527,7 @@ rmUser user conn = do (maybeList1 (catMaybes pp)) Intra.push - leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley () + leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () leaveRemoteConversations lusr cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) @@ -542,12 +547,13 @@ rmUser user conn = do pure () Right _ -> pure () -deleteLoop :: Galley () -deleteLoop = do +deleteLoop :: Galley r () +deleteLoop = liftGalley0 $ do q <- view deleteQueue safeForever "deleteLoop" $ do i@(TeamItem tid usr con) <- Q.pop q - Teams.uncheckedDeleteTeam usr con tid `catchAny` someError q i + interpretGalleyToGalley0 (Teams.uncheckedDeleteTeam usr con tid) + `catchAny` someError q i where someError q i x = do err $ "error" .= show x ~~ msg (val "failed to delete") @@ -556,14 +562,17 @@ deleteLoop = do err (msg (val "delete queue is full, dropping item") ~~ "item" .= show i) liftIO $ threadDelay 1000000 -safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () +safeForever :: String -> Galley0 () -> Galley0 () safeForever funName action = forever $ action `catchAny` \exc -> do err $ "error" .= show exc ~~ msg (val $ cs funName <> " failed") threadDelay 60000000 -- pause to keep worst-case noise in logs manageable -guardLegalholdPolicyConflictsH :: (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley Response +guardLegalholdPolicyConflictsH :: + Member BrigAccess r => + (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> + Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index bd40fa575f6..48d9eed39a9 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -56,6 +56,7 @@ import qualified Galley.Data as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import qualified Galley.Data.LegalHold as LegalHoldData import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import qualified Galley.External.LegalHoldService as LHService import qualified Galley.Intra.Client as Client import Galley.Intra.User (getConnectionsUnqualified, putConnectionInternal) @@ -69,7 +70,6 @@ import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus, _3) import Network.Wai.Utilities as Wai import qualified System.Logger.Class as Log -import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Routes.Internal.Brig.Connection @@ -77,10 +77,10 @@ import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public -assertLegalHoldEnabledForTeam :: TeamId -> Galley () +assertLegalHoldEnabledForTeam :: TeamId -> Galley r () assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ throwM legalHoldNotEnabled -isLegalHoldEnabledForTeam :: TeamId -> Galley Bool +isLegalHoldEnabledForTeam :: TeamId -> Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do @@ -94,12 +94,12 @@ isLegalHoldEnabledForTeam tid = do FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> isTeamLegalholdWhitelisted tid -createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley Response +createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do newService <- fromJsonBody req setStatus status201 . json <$> createSettings zusr tid newService -createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley Public.ViewLegalHoldService +createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley r Public.ViewLegalHoldService createSettings zusr tid newService = do assertLegalHoldEnabledForTeam tid zusrMembership <- Data.teamMember tid zusr @@ -116,11 +116,11 @@ createSettings zusr tid newService = do LegalHoldData.createSettings service pure . viewLegalHoldService $ service -getSettingsH :: UserId ::: TeamId ::: JSON -> Galley Response +getSettingsH :: UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid -getSettings :: UserId -> TeamId -> Galley Public.ViewLegalHoldService +getSettings :: UserId -> TeamId -> Galley r Public.ViewLegalHoldService getSettings zusr tid = do zusrMembership <- Data.teamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership @@ -131,13 +131,21 @@ getSettings zusr tid = do (True, Nothing) -> Public.ViewLegalHoldServiceNotConfigured (True, Just result) -> viewLegalHoldService result -removeSettingsH :: UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> Galley Response +removeSettingsH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> + Galley r Response removeSettingsH (zusr ::: tid ::: req ::: _) = do removeSettingsRequest <- fromJsonBody req removeSettings zusr tid removeSettingsRequest pure noContent -removeSettings :: UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> Galley () +removeSettings :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + Public.RemoveLegalHoldSettingsRequest -> + Galley r () removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting assertLegalHoldEnabledForTeam tid @@ -150,7 +158,7 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Galley () + assertNotWhitelisting :: Galley r () assertNotWhitelisting = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure () @@ -160,23 +168,24 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => TeamId -> - Galley () + Galley r () removeSettings' tid = do -- Loop through team members and run this action. Data.withTeamMembersWithChunks tid action LegalHoldData.removeSettings tid where - action :: [TeamMember] -> Galley () + action :: [TeamMember] -> Galley r () action membs = do let zothers = map (view userId) membs let lhMembers = filter ((== UserLegalHoldEnabled) . view legalHoldStatus) membs Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "LegalHold.removeSettings'") - -- I picked this number by fair dice roll, feel free to change it :P - pooledMapConcurrentlyN_ 8 removeLHForUser lhMembers - removeLHForUser :: TeamMember -> Galley () + spawnMany (map removeLHForUser lhMembers) + removeLHForUser :: TeamMember -> Galley r () removeLHForUser member = do let uid = member ^. Team.userId Client.removeLegalHoldClientFromUser uid @@ -185,11 +194,11 @@ removeSettings' tid = do -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid -getUserStatus :: TeamId -> UserId -> Galley Public.UserLegalHoldStatusResponse +getUserStatus :: TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do mTeamMember <- Data.teamMember tid uid teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember @@ -201,7 +210,7 @@ getUserStatus tid uid = do UserLegalHoldEnabled -> makeResponseDetails pure $ UserLegalHoldStatusResponse status mlk lcid where - makeResponseDetails :: Galley (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails :: Galley r (Maybe LastPrekey, Maybe ClientId) makeResponseDetails = do mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid lastKey <- case mLastKey of @@ -218,7 +227,10 @@ getUserStatus tid uid = do -- | Change 'UserLegalHoldStatus' from no consent to disabled. FUTUREWORK: -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). -grantConsentH :: UserId ::: TeamId ::: JSON -> Galley Response +grantConsentH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: JSON -> + Galley r Response grantConsentH (zusr ::: tid ::: _) = do grantConsent zusr tid >>= \case GrantConsentSuccess -> pure $ empty & setStatus status201 @@ -228,7 +240,11 @@ data GrantConsentResult = GrantConsentSuccess | GrantConsentAlreadyGranted -grantConsent :: UserId -> TeamId -> Galley GrantConsentResult +grantConsent :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + Galley r GrantConsentResult grantConsent zusr tid = do userLHStatus <- fmap (view legalHoldStatus) <$> Data.teamMember tid zusr case userLHStatus of @@ -241,7 +257,10 @@ grantConsent zusr tid = do Just UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted -- | Request to provision a device on the legal hold service for a user -requestDeviceH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +requestDeviceH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: UserId ::: JSON -> + Galley r Response requestDeviceH (zusr ::: tid ::: uid ::: _) = do requestDevice zusr tid uid <&> \case RequestDeviceSuccess -> empty & setStatus status201 @@ -251,7 +270,13 @@ data RequestDeviceResult = RequestDeviceSuccess | RequestDeviceAlreadyPending -requestDevice :: UserId -> TeamId -> UserId -> Galley RequestDeviceResult +requestDevice :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + Galley r RequestDeviceResult requestDevice zusr tid uid = do assertLegalHoldEnabledForTeam tid Log.debug $ @@ -273,7 +298,7 @@ requestDevice zusr tid uid = do -- This will still work if the LH service creates two new device on two consecutive calls -- to `/init`, but there may be race conditions, eg. when updating and enabling a pending -- device at (almost) the same time. - provisionLHDevice :: UserLegalHoldStatus -> Galley () + provisionLHDevice :: UserLegalHoldStatus -> Galley r () provisionLHDevice userLHStatus = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added @@ -281,7 +306,7 @@ requestDevice zusr tid uid = do changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending Client.notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' - requestDeviceFromService :: Galley (LastPrekey, [Prekey]) + requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) requestDeviceFromService = do LegalHoldData.dropPendingPrekeys uid lhDevice <- LHService.requestNewDevice tid uid @@ -294,14 +319,22 @@ requestDevice zusr tid uid = do -- it gets interupted. There's really no reason to delete them anyways -- since they are replaced if needed when registering new LH devices. approveDeviceH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> - Galley Response + Galley r Response approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do approve <- fromJsonBody req approveDevice zusr tid uid connId approve pure empty -approveDevice :: UserId -> TeamId -> UserId -> ConnId -> Public.ApproveLegalHoldForUserRequest -> Galley () +approveDevice :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + ConnId -> + Public.ApproveLegalHoldForUserRequest -> + Galley r () approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPassword) = do assertLegalHoldEnabledForTeam tid Log.debug $ @@ -330,7 +363,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: UserLegalHoldStatus -> Galley () + assertUserLHPending :: UserLegalHoldStatus -> Galley r () assertUserLHPending userLHStatus = do case userLHStatus of UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled @@ -339,8 +372,9 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo UserLegalHoldNoConsent -> throwM userLegalHoldNotPending disableForUserH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> - Galley Response + Galley r Response disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do disable <- fromJsonBody req disableForUser zusr tid uid disable <&> \case @@ -351,7 +385,14 @@ data DisableLegalHoldForUserResponse = DisableLegalHoldSuccess | DisableLegalHoldWasNotEnabled -disableForUser :: UserId -> TeamId -> UserId -> Public.DisableLegalHoldForUserRequest -> Galley DisableLegalHoldForUserResponse +disableForUser :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + Public.DisableLegalHoldForUserRequest -> + Galley r DisableLegalHoldForUserResponse disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = do Log.debug $ Log.field "targets" (toByteString uid) @@ -364,7 +405,7 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = then pure DisableLegalHoldWasNotEnabled else disableLH userLHStatus $> DisableLegalHoldSuccess where - disableLH :: UserLegalHoldStatus -> Galley () + disableLH :: UserLegalHoldStatus -> Galley r () disableLH userLHStatus = do ensureReAuthorised zusr mPassword Client.removeLegalHoldClientFromUser uid @@ -377,7 +418,13 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- | Allow no-consent => consent without further changes. If LH device is requested, enabled, -- or disabled, make sure the affected connections are screened for policy conflict (anybody -- with no-consent), and put those connections in the appropriate blocked state. -changeLegalholdStatus :: TeamId -> UserId -> UserLegalHoldStatus -> UserLegalHoldStatus -> Galley () +changeLegalholdStatus :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + TeamId -> + UserId -> + UserLegalHoldStatus -> + UserLegalHoldStatus -> + Galley r () changeLegalholdStatus tid uid old new = do case old of UserLegalHoldEnabled -> case new of @@ -413,7 +460,7 @@ changeLegalholdStatus tid uid old new = do illegal = throwM userLegalHoldIllegalOperation -- FUTUREWORK: make this async? -blockNonConsentingConnections :: UserId -> Galley () +blockNonConsentingConnections :: forall r. Member BrigAccess r => UserId -> Galley r () blockNonConsentingConnections uid = do conns <- getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do @@ -425,7 +472,7 @@ blockNonConsentingConnections uid = do Log.warn $ Log.msg @String msgs throwM legalHoldCouldNotBlockConnections where - findConflicts :: [ConnectionStatus] -> Galley [[UserId]] + findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] findConflicts conns = do let (FutureWork @'Public.LegalholdPlusFederationNotImplemented -> _remoteUids, localUids) = (undefined, csTo <$> conns) -- FUTUREWORK: Handle remoteUsers here when federation is implemented @@ -433,25 +480,25 @@ blockNonConsentingConnections uid = do teamsOfUsers <- Data.usersTeams others filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others - blockConflicts :: UserId -> [UserId] -> Galley [String] + blockConflicts :: UserId -> [UserId] -> Galley r [String] blockConflicts _ [] = pure [] blockConflicts userLegalhold othersToBlock@(_ : _) = do status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -setTeamLegalholdWhitelisted :: TeamId -> Galley () +setTeamLegalholdWhitelisted :: TeamId -> Galley r () setTeamLegalholdWhitelisted tid = do LegalHoldData.setTeamLegalholdWhitelisted tid -setTeamLegalholdWhitelistedH :: TeamId -> Galley Response +setTeamLegalholdWhitelistedH :: TeamId -> Galley r Response setTeamLegalholdWhitelistedH tid = do empty <$ setTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelisted :: TeamId -> Galley () +unsetTeamLegalholdWhitelisted :: TeamId -> Galley r () unsetTeamLegalholdWhitelisted tid = do LegalHoldData.unsetTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelistedH :: TeamId -> Galley Response +unsetTeamLegalholdWhitelistedH :: TeamId -> Galley r Response unsetTeamLegalholdWhitelistedH tid = do () <- error @@ -460,7 +507,7 @@ unsetTeamLegalholdWhitelistedH tid = do \before you enable the end-point." setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid -getTeamLegalholdWhitelistedH :: TeamId -> Galley Response +getTeamLegalholdWhitelistedH :: TeamId -> Galley r Response getTeamLegalholdWhitelistedH tid = do lhEnabled <- isTeamLegalholdWhitelisted tid pure $ @@ -482,7 +529,11 @@ getTeamLegalholdWhitelistedH tid = do -- which may cause wrong behavior. In order to guarantee correct behavior, the first argument -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. -handleGroupConvPolicyConflicts :: UserId -> UserLegalHoldStatus -> Galley () +handleGroupConvPolicyConflicts :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + UserLegalHoldStatus -> + Galley r () handleGroupConvPolicyConflicts uid hypotheticalLHStatus = void $ iterateConversations uid (toRange (Proxy @500)) $ \convs -> do diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 89e774d8379..42bebf1fe3b 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -30,6 +30,7 @@ import qualified Data.Set as Set import Galley.API.Util import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Client as Intra import Galley.Intra.User (getUser) import Galley.Options @@ -42,7 +43,11 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts -guardQualifiedLegalholdPolicyConflicts :: LegalholdProtectee -> QualifiedUserClients -> Galley (Either LegalholdConflicts ()) +guardQualifiedLegalholdPolicyConflicts :: + Member BrigAccess r => + LegalholdProtectee -> + QualifiedUserClients -> + Galley r (Either LegalholdConflicts ()) guardQualifiedLegalholdPolicyConflicts protectee qclients = do localDomain <- viewFederationDomain guardLegalholdPolicyConflicts protectee @@ -57,7 +62,11 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do -- -- This is a fallback safeguard that shouldn't get triggered if backend and clients work as -- intended. -guardLegalholdPolicyConflicts :: LegalholdProtectee -> UserClients -> Galley (Either LegalholdConflicts ()) +guardLegalholdPolicyConflicts :: + Member BrigAccess r => + LegalholdProtectee -> + UserClients -> + Galley r (Either LegalholdConflicts ()) guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClients = pure . pure $ () guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure . pure $ () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do @@ -67,7 +76,12 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do FeatureLegalHoldDisabledByDefault -> guardLegalholdPolicyConflictsUid self otherClients FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> guardLegalholdPolicyConflictsUid self otherClients -guardLegalholdPolicyConflictsUid :: UserId -> UserClients -> Galley (Either LegalholdConflicts ()) +guardLegalholdPolicyConflictsUid :: + forall r. + Member BrigAccess r => + UserId -> + UserClients -> + Galley r (Either LegalholdConflicts ()) guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do let otherCids :: [ClientId] otherCids = Set.toList . Set.unions . Map.elems . userClients $ otherClients @@ -111,7 +125,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do . Client.fromClientCapabilityList . Client.clientCapabilities - checkConsentMissing :: Galley Bool + checkConsentMissing :: Galley r Bool checkConsentMissing = do -- (we could also get the profile from brig. would make the code slightly more -- concise, but not really help with the rpc back-and-forth, so, like, why?) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index f118658f04a..9ee604c32b2 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -46,7 +46,7 @@ import Wire.API.Federation.API.Galley -- | View for a given user of a stored conversation. -- -- Throws "bad-state" when the user is not part of the conversation. -conversationView :: UserId -> Data.Conversation -> Galley Conversation +conversationView :: UserId -> Data.Conversation -> Galley r Conversation conversationView uid conv = do luid <- qualifyLocal uid let mbConv = conversationViewMaybe luid conv diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 1df97be4f34..5f03241147f 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -23,24 +23,19 @@ import Data.Set.Lens import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util - ( runFederatedBrig, - runFederatedGalley, - viewFederationDomain, - ) import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push -import Galley.Intra.User import Galley.Options (optSettings, setIntraListing) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) -import Imports +import Imports hiding (forkIO) import qualified System.Logger.Class as Log -import UnliftIO.Async import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley @@ -179,24 +174,25 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = mkQualifiedMismatch reportedMissing redundant deleted ) -getRemoteClients :: [RemoteMember] -> Galley (Map (Domain, UserId) (Set ClientId)) -getRemoteClients remoteMembers = do - fmap mconcat -- concatenating maps is correct here, because their sets of keys are disjoint - . pooledMapConcurrentlyN 8 getRemoteClientsFromDomain - . bucketRemote - . map rmId - $ remoteMembers +getRemoteClients :: + Member FederatorAccess r => + [RemoteMember] -> + Galley r (Map (Domain, UserId) (Set ClientId)) +getRemoteClients remoteMembers = + -- concatenating maps is correct here, because their sets of keys are disjoint + mconcat . map tUnqualified + <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain where - getRemoteClientsFromDomain :: Remote [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) - getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = do - let rpc = FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) - Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> runFederatedBrig domain rpc + getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = + Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap + <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) postRemoteOtrMessage :: + Member FederatorAccess r => Qualified UserId -> Qualified ConvId -> LByteString -> - Galley (PostOtrResponse MessageSendingStatus) + Galley r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest @@ -207,9 +203,16 @@ postRemoteOtrMessage sender conv rawMsg = do rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr FederatedGalley.msResponse <$> runFederatedGalley (qDomain conv) rpc -postQualifiedOtrMessage :: UserType -> Qualified UserId -> Maybe ConnId -> ConvId -> QualifiedNewOtrMessage -> Galley (PostOtrResponse MessageSendingStatus) +postQualifiedOtrMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserType -> + Qualified UserId -> + Maybe ConnId -> + ConvId -> + QualifiedNewOtrMessage -> + Galley r (PostOtrResponse MessageSendingStatus) postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do - alive <- Data.isConvAlive convId + alive <- lift $ Data.isConvAlive convId localDomain <- viewFederationDomain now <- liftIO getCurrentTime let nowMillis = toUTCTimeMillis now @@ -222,7 +225,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- conversation members localMembers <- lift $ Data.members convId - remoteMembers <- Data.lookupRemoteMembers convId + remoteMembers <- lift $ Data.lookupRemoteMembers convId let localMemberIds = lmId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -297,6 +300,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- | Send both local and remote messages, return the set of clients for which -- sending has failed. sendMessages :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => UTCTime -> Qualified UserId -> ClientId -> @@ -305,7 +309,7 @@ sendMessages :: Map UserId LocalMember -> MessageMetadata -> Map (Domain, UserId, ClientId) ByteString -> - Galley QualifiedUserClients + Galley r QualifiedUserClients sendMessages now sender senderClient mconn conv localMemberMap metadata messages = do localDomain <- viewFederationDomain let messageMap = byDomain $ fmap toBase64Text messages @@ -323,6 +327,7 @@ sendMessages now sender senderClient mconn conv localMemberMap metadata messages mempty sendLocalMessages :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => UTCTime -> Qualified UserId -> ClientId -> @@ -331,7 +336,7 @@ sendLocalMessages :: Map UserId LocalMember -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley (Set (UserId, ClientId)) + Galley r (Set (UserId, ClientId)) sendLocalMessages now sender senderClient mconn conv localMemberMap metadata localMessages = do localDomain <- viewFederationDomain let events = @@ -356,7 +361,7 @@ sendRemoteMessages :: ConvId -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley (Set (UserId, ClientId)) + Galley r (Set (UserId, ClientId)) sendRemoteMessages domain now sender senderClient conv metadata messages = handle <=< runExceptT $ do let rcpts = foldr @@ -381,7 +386,7 @@ sendRemoteMessages domain now sender senderClient conv metadata messages = handl let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes originDomain rm executeFederated domain rpc where - handle :: Either FederationError a -> Galley (Set (UserId, ClientId)) + handle :: Either FederationError a -> Galley r (Set (UserId, ClientId)) handle (Right _) = pure mempty handle (Left e) = do Log.warn $ @@ -419,20 +424,23 @@ newUserPush p = MessagePush {userPushes = pure p, botPushes = mempty} newBotPush :: BotMember -> Event -> MessagePush newBotPush b e = MessagePush {userPushes = mempty, botPushes = pure (b, e)} -runMessagePush :: Qualified ConvId -> MessagePush -> Galley () +runMessagePush :: + forall r. + Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Qualified ConvId -> + MessagePush -> + Galley r () runMessagePush cnv mp = do pushSome (userPushes mp) pushToBots (botPushes mp) where - pushToBots :: [(BotMember, Event)] -> Galley () + pushToBots :: [(BotMember, Event)] -> Galley r () pushToBots pushes = do localDomain <- viewFederationDomain if localDomain /= qDomain cnv then unless (null pushes) $ do Log.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show cnv) - else void . forkIO $ do - gone <- External.deliver pushes - mapM_ (deleteBot (qUnqualified cnv) . botMemId) gone + else External.deliverAndDeleteAsync (qUnqualified cnv) pushes newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event newMessageEvent convId sender senderClient dat time receiverClient cipherText = diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index d9be593d5f0..d9978a18b2d 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -31,11 +31,11 @@ import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.UserList (UserList (..)) import Imports -iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley UpsertOne2OneConversationResponse +iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley r UpsertOne2OneConversationResponse iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId - let dolocal :: Local ConvId -> Galley () + let dolocal :: Local ConvId -> Galley r () dolocal lconvId = do mbConv <- Data.conversation (tUnqualified lconvId) case mbConv of @@ -60,7 +60,7 @@ iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do unless (null (Data.convLocalMembers conv)) $ Data.acceptConnect (tUnqualified lconvId) (RemoteActor, Excluded) -> Data.removeRemoteMembersFromLocalConv (tUnqualified lconvId) (pure uooRemoteUser) - doremote :: Remote ConvId -> Galley () + doremote :: Remote ConvId -> Galley r () doremote rconvId = case (uooActor, uooActorDesiredMembership) of (LocalActor, Included) -> do diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index a5422585473..900e4b052ff 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -72,7 +72,7 @@ import qualified Wire.API.Team.SearchVisibility as Public import qualified Wire.API.User as Public (UserIdList, modelUserIdList) import Wire.Swagger (int32Between) -servantSitemap :: ServerT GalleyAPI.ServantAPI Galley +servantSitemap :: ServerT GalleyAPI.ServantAPI (Galley GalleyEffects) servantSitemap = genericServerT $ GalleyAPI.Api @@ -174,7 +174,7 @@ servantSitemap = GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal } -sitemap :: Routes ApiBuilder Galley () +sitemap :: Routes ApiBuilder (Galley GalleyEffects) () sitemap = do -- Team API ----------------------------------------------------------- @@ -731,7 +731,7 @@ sitemap = do errorResponse (Error.errorDescriptionTypeToWai @Error.UnknownClient) errorResponse Error.broadcastLimitExceeded -apiDocs :: Routes ApiBuilder Galley () +apiDocs :: Routes ApiBuilder (Galley r) () apiDocs = get "/conversations/api-docs" (continue docs) $ accept "application" "json" @@ -739,7 +739,7 @@ apiDocs = type JSON = Media "application" "json" -docs :: JSON ::: ByteString -> Galley Response +docs :: JSON ::: ByteString -> Galley r Response docs (_ ::: url) = do let models = Public.Swagger.models let apidoc = encode $ mkSwaggerApi (decodeLatin1 url) models sitemap diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index d98c99598de..0666e32b506 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -53,6 +53,7 @@ import Galley.API.Util import Galley.App import qualified Galley.Data as Data import qualified Galley.Data.Types as Data +import Galley.Effects import Galley.Types import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles @@ -75,11 +76,11 @@ import Wire.API.Federation.Error import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public -getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley Response +getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv -getBotConversation :: BotId -> ConvId -> Galley Public.BotConvView +getBotConversation :: BotId -> ConvId -> Galley r Public.BotConvView getBotConversation zbot zcnv = do (c, _) <- getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) (botUserId zbot) zcnv domain <- viewFederationDomain @@ -93,12 +94,12 @@ getBotConversation zbot zcnv = do | otherwise = Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) -getUnqualifiedConversation :: UserId -> ConvId -> Galley Public.Conversation +getUnqualifiedConversation :: UserId -> ConvId -> Galley r Public.Conversation getUnqualifiedConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv Mapping.conversationView zusr c -getConversation :: UserId -> Qualified ConvId -> Galley Public.Conversation +getConversation :: UserId -> Qualified ConvId -> Galley r Public.Conversation getConversation zusr cnv = do lusr <- qualifyLocal zusr foldQualified @@ -107,7 +108,7 @@ getConversation zusr cnv = do getRemoteConversation cnv where - getRemoteConversation :: Remote ConvId -> Galley Public.Conversation + getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] case conversations of @@ -115,7 +116,7 @@ getConversation zusr cnv = do [conv] -> pure conv _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") -getRemoteConversations :: UserId -> [Remote ConvId] -> Galley [Public.Conversation] +getRemoteConversations :: UserId -> [Remote ConvId] -> Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error @@ -158,7 +159,7 @@ partitionGetConversationFailures = bimap concat concat . partitionEithers . map getRemoteConversationsWithFailures :: UserId -> [Remote ConvId] -> - Galley ([FailedGetConversation], [Public.Conversation]) + Galley r ([FailedGetConversation], [Public.Conversation]) getRemoteConversationsWithFailures zusr convs = do localDomain <- viewFederationDomain lusr <- qualifyLocal zusr @@ -181,7 +182,8 @@ getRemoteConversationsWithFailures zusr convs = do | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends - fmap (bimap (localFailures <>) concat . partitionEithers) + liftGalley0 + . fmap (bimap (localFailures <>) concat . partitionEithers) . pooledForConcurrentlyN 8 (bucketRemote locallyFound) $ \someConvs -> do let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) @@ -192,8 +194,8 @@ getRemoteConversationsWithFailures zusr convs = do where handleFailures :: [Remote ConvId] -> - ExceptT FederationError Galley a -> - Galley (Either FailedGetConversation a) + ExceptT FederationError Galley0 a -> + Galley0 (Either FailedGetConversation a) handleFailures rconvs action = runExceptT . withExceptT (failedGetConversationRemotely rconvs) . catchE action @@ -203,14 +205,14 @@ getRemoteConversationsWithFailures zusr convs = do . Logger.field "error" (show e) throwE e -getConversationRoles :: UserId -> ConvId -> Galley Public.ConversationRolesList +getConversationRoles :: UserId -> ConvId -> Galley r Public.ConversationRolesList getConversationRoles zusr cnv = do void $ getConversationAndCheckMembership zusr cnv -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley r (Public.ConversationList ConvId) conversationIdsPageFromUnqualified zusr start msize = do let size = fromMaybe (toRange (Proxy @1000)) msize ids <- Data.conversationIdsFrom zusr start size @@ -227,7 +229,7 @@ conversationIdsPageFromUnqualified zusr start msize = do -- -- - After local conversations, remote conversations are listed ordered -- - lexicographically by their domain and then by their id. -conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley Public.ConvIdsPage +conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley r Public.ConvIdsPage conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localDomain <- viewFederationDomain case gmtprState of @@ -237,7 +239,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley Public.ConvIdsPage + localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley r Public.ConvIdsPage localsAndRemotes localDomain pagingState size = do localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) <$> Data.localConversationIdsPageFrom zusr pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) @@ -247,7 +249,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do remotePage <- remotesOnly Nothing remainingSize pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} - remotesOnly :: Maybe C.PagingState -> Int32 -> Galley Public.ConvIdsPage + remotesOnly :: Maybe C.PagingState -> Int32 -> Galley r Public.ConvIdsPage remotesOnly pagingState size = pageToConvIdPage Public.PagingRemotes <$> Data.remoteConversationIdsPageFrom zusr pagingState size @@ -259,12 +261,22 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do mtpPagingState = Public.ConversationPagingState table (LBS.toStrict . C.unPagingState <$> pwsState) } -getConversations :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Public.Conversation) +getConversations :: + UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + Galley r (Public.ConversationList Public.Conversation) getConversations user mids mstart msize = do ConversationList cs more <- getConversationsInternal user mids mstart msize flip ConversationList more <$> mapM (Mapping.conversationView user) cs -getConversationsInternal :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Data.Conversation) +getConversationsInternal :: + UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + Galley r (Public.ConversationList Data.Conversation) getConversationsInternal user mids mstart msize = do (more, ids) <- getIds mids let localConvIds = ids @@ -291,7 +303,10 @@ getConversationsInternal user mids mstart msize = do | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True -listConversations :: UserId -> Public.ListConversations -> Galley Public.ConversationsResponse +listConversations :: + UserId -> + Public.ListConversations -> + Galley r Public.ConversationsResponse listConversations user (Public.ListConversations ids) = do luser <- qualifyLocal user @@ -328,7 +343,7 @@ listConversations user (Public.ListConversations ids) = do crFailed = failedConvsRemotely } where - removeDeleted :: Data.Conversation -> Galley Bool + removeDeleted :: Data.Conversation -> Galley r Bool removeDeleted c | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True @@ -338,10 +353,13 @@ listConversations user (Public.ListConversations ids) = do let notFounds = xs \\ founds pure (founds, notFounds) -iterateConversations :: forall a. UserId -> Range 1 500 Int32 -> ([Data.Conversation] -> Galley a) -> Galley [a] +iterateConversations :: + UserId -> + Range 1 500 Int32 -> + ([Data.Conversation] -> Galley r a) -> + Galley r [a] iterateConversations uid pageSize handleConvs = go Nothing where - go :: Maybe ConvId -> Galley [a] go mbConv = do convResult <- getConversationsInternal uid Nothing mbConv (Just pageSize) resultHead <- handleConvs (convList convResult) @@ -353,11 +371,11 @@ iterateConversations uid pageSize handleConvs = go Nothing _ -> pure [] pure $ resultHead : resultTail -internalGetMemberH :: ConvId ::: UserId -> Galley Response +internalGetMemberH :: ConvId ::: UserId -> Galley r Response internalGetMemberH (cnv ::: usr) = do json <$> getLocalSelf usr cnv -getLocalSelf :: UserId -> ConvId -> Galley (Maybe Public.Member) +getLocalSelf :: UserId -> ConvId -> Galley r (Maybe Public.Member) getLocalSelf usr cnv = do lusr <- qualifyLocal usr alive <- Data.isConvAlive cnv @@ -365,13 +383,13 @@ getLocalSelf usr cnv = do then Mapping.localMemberToSelf lusr <$$> Data.member cnv usr else Nothing <$ Data.deleteConversation cnv -getConversationMetaH :: ConvId -> Galley Response +getConversationMetaH :: ConvId -> Galley r Response getConversationMetaH cnv = do getConversationMeta cnv <&> \case Nothing -> setStatus status404 empty Just meta -> json meta -getConversationMeta :: ConvId -> Galley (Maybe ConversationMetadata) +getConversationMeta :: ConvId -> Galley r (Maybe ConversationMetadata) getConversationMeta cnv = do alive <- Data.isConvAlive cnv localDomain <- viewFederationDomain @@ -381,7 +399,12 @@ getConversationMeta cnv = do Data.deleteConversation cnv pure Nothing -getConversationByReusableCode :: UserId -> Key -> Value -> Galley ConversationCoverView +getConversationByReusableCode :: + Member BrigAccess r => + UserId -> + Key -> + Value -> + Galley r ConversationCoverView getConversationByReusableCode zusr key value = do c <- verifyReusableCode (ConversationCode key value Nothing) conv <- ensureConversationAccess zusr (Data.codeConversation c) CodeAccess diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index dd1c93e023f..b2d8f0681da 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -90,6 +90,7 @@ import qualified Galley.Data.LegalHold as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push @@ -105,14 +106,14 @@ import Galley.Types.Conversations.Roles as Roles import Galley.Types.Teams hiding (newTeam) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus) import Network.Wai.Utilities import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log -import UnliftIO (mapConcurrently) +import UnliftIO.Async (mapConcurrently) import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription (ConvNotFound, NotATeamMember, operationDenied) import qualified Wire.API.Notification as Public @@ -128,35 +129,35 @@ import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) -getTeamH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamH :: UserId ::: TeamId ::: JSON -> Galley r Response getTeamH (zusr ::: tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid -getTeamInternalH :: TeamId ::: JSON -> Galley Response +getTeamInternalH :: TeamId ::: JSON -> Galley r Response getTeamInternalH (tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< getTeamInternal tid -getTeamInternal :: TeamId -> Galley (Maybe TeamData) +getTeamInternal :: TeamId -> Galley r (Maybe TeamData) getTeamInternal = Data.team -getTeamNameInternalH :: TeamId ::: JSON -> Galley Response +getTeamNameInternalH :: TeamId ::: JSON -> Galley r Response getTeamNameInternalH (tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< getTeamNameInternal tid -getTeamNameInternal :: TeamId -> Galley (Maybe TeamName) +getTeamNameInternal :: TeamId -> Galley r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . Data.teamName -getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley Response +getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley r Response getManyTeamsH (zusr ::: range ::: size ::: _) = json <$> getManyTeams zusr range size -getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley Public.TeamList +getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley r Public.TeamList getManyTeams zusr range size = withTeamIds zusr range size $ \more ids -> do teams <- mapM (lookupTeam zusr) ids pure (Public.newTeamList (catMaybes teams) more) -lookupTeam :: UserId -> TeamId -> Galley (Maybe Public.Team) +lookupTeam :: UserId -> TeamId -> Galley r (Maybe Public.Team) lookupTeam zusr tid = do tm <- Data.teamMember tid zusr if isJust tm @@ -168,13 +169,21 @@ lookupTeam zusr tid = do pure (tdTeam <$> t) else pure Nothing -createNonBindingTeamH :: UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley Response +createNonBindingTeamH :: + Members '[GundeckAccess, BrigAccess] r => + UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> + Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createNonBindingTeam zusr zcon newTeam pure (empty & setStatus status201 . location newTeamId) -createNonBindingTeam :: UserId -> ConnId -> Public.NonBindingNewTeam -> Galley TeamId +createNonBindingTeam :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.NonBindingNewTeam -> + Galley r TeamId createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus let others = @@ -191,26 +200,34 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do finishCreateTeam team owner others (Just zcon) pure (team ^. teamId) -createBindingTeamH :: UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley Response +createBindingTeamH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> + Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createBindingTeam zusr tid newTeam pure (empty & setStatus status201 . location newTeamId) -createBindingTeam :: UserId -> TeamId -> BindingNewTeam -> Galley TeamId +createBindingTeam :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + TeamId -> + BindingNewTeam -> + Galley r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus team <- Data.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing pure tid -updateTeamStatusH :: TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley Response +updateTeamStatusH :: Member BrigAccess r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response updateTeamStatusH (tid ::: req ::: _) = do teamStatusUpdate <- fromJsonBody req updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: TeamId -> TeamStatusUpdate -> Galley () +updateTeamStatus :: Member BrigAccess r => TeamId -> TeamStatusUpdate -> Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do oldStatus <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) valid <- validateTransition (oldStatus, newStatus) @@ -231,7 +248,7 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime journal _ _ = throwM invalidTeamStatusUpdate - validateTransition :: (TeamStatus, TeamStatus) -> Galley Bool + validateTransition :: (TeamStatus, TeamStatus) -> Galley r Bool validateTransition = \case (PendingActive, Active) -> return True (Active, Active) -> return False @@ -240,13 +257,22 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (Suspended, Suspended) -> return False (_, _) -> throwM invalidTeamStatusUpdate -updateTeamH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley Response +updateTeamH :: + Member GundeckAccess r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> + Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do updateData <- fromJsonBody req updateTeam zusr zcon tid updateData pure empty -updateTeam :: UserId -> ConnId -> TeamId -> Public.TeamUpdateData -> Galley () +updateTeam :: + Member GundeckAccess r => + UserId -> + ConnId -> + TeamId -> + Public.TeamUpdateData -> + Galley r () updateTeam zusr zcon tid updateData = do zusrMembership <- Data.teamMember tid zusr -- let zothers = map (view userId) membs @@ -261,14 +287,23 @@ updateTeam zusr zcon tid updateData = do let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon -deleteTeamH :: UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley Response +deleteTeamH :: + Member BrigAccess r => + UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> + Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeam zusr zcon tid mBody pure (empty & setStatus status202) -- | 'TeamDeleteData' is only required for binding teams -deleteTeam :: UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley () +deleteTeam :: + Member BrigAccess r => + UserId -> + ConnId -> + TeamId -> + Maybe Public.TeamDeleteData -> + Galley r () deleteTeam zusr zcon tid mBody = do team <- Data.team tid >>= ifNothing teamNotFound case tdStatus team of @@ -287,7 +322,7 @@ deleteTeam zusr zcon tid mBody = do ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: TeamId -> Galley () +internalDeleteBindingTeamWithOneMember :: TeamId -> Galley r () internalDeleteBindingTeamWithOneMember tid = do team <- Data.team tid unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ @@ -298,7 +333,13 @@ internalDeleteBindingTeamWithOneMember tid = do _ -> throwM notAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. -uncheckedDeleteTeam :: UserId -> Maybe ConnId -> TeamId -> Galley () +uncheckedDeleteTeam :: + forall r. + Members '[BrigAccess, ExternalAccess, GundeckAccess, SparAccess] r => + UserId -> + Maybe ConnId -> + TeamId -> + Galley r () uncheckedDeleteTeam zusr zcon tid = do team <- Data.team tid when (isJust team) $ do @@ -314,7 +355,7 @@ uncheckedDeleteTeam zusr zcon tid = do (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue - void . forkIO $ void $ External.deliver be + External.deliverAsync be -- TODO: we don't delete bots here, but we should do that, since -- every bot user can only be in a single conversation. Just -- deleting conversations from the database is not enough. @@ -324,7 +365,7 @@ uncheckedDeleteTeam zusr zcon tid = do Data.unsetTeamLegalholdWhitelisted tid Data.deleteTeam tid where - pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley () + pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () pushDeleteEvents membs e ue = do o <- view $ options . optSettings let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) membs) @@ -347,7 +388,7 @@ uncheckedDeleteTeam zusr zcon tid = do [TeamMember] -> TeamConversation -> ([Push], [(BotMember, Conv.Event)]) -> - Galley ([Push], [(BotMember, Conv.Event)]) + Galley r ([Push], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do localDomain <- viewFederationDomain let qconvId = Qualified (c ^. conversationId) localDomain @@ -364,7 +405,7 @@ uncheckedDeleteTeam zusr zcon tid = do let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) -getTeamConversationRoles :: UserId -> TeamId -> Galley Public.ConversationRolesList +getTeamConversationRoles :: UserId -> TeamId -> Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do mem <- Data.teamMember tid zusr case mem of @@ -374,12 +415,12 @@ getTeamConversationRoles zusr tid = do -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley Response +getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do (memberList, withPerms) <- getTeamMembers zusr tid maxResults pure . json $ teamMemberListJson withPerms memberList -getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley (Public.TeamMemberList, Public.TeamMember -> Bool) +getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) getTeamMembers zusr tid maxResults = do Data.teamMember tid zusr >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember @@ -388,7 +429,10 @@ getTeamMembers zusr tid maxResults = do let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) -getTeamMembersCSVH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamMembersCSVH :: + Member BrigAccess r => + UserId ::: TeamId ::: JSON -> + Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do Data.teamMember tid zusr >>= \case Nothing -> throwM accessDenied @@ -459,7 +503,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do tExportUserId = U.userId user } - lookupInviterHandle :: [TeamMember] -> Galley (UserId -> Maybe Handle.Handle) + lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Galley r (UserId -> Maybe Handle.Handle) lookupInviterHandle members = do let inviterIds :: [UserId] inviterIds = nub $ catMaybes $ fmap fst . view invitation <$> members @@ -491,14 +535,14 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId (UserScimExternalId _) -> Nothing -bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley Response +bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do UserIdList uids <- fromJsonBody body (memberList, withPerms) <- bulkGetTeamMembers zusr tid maxResults uids pure . json $ teamMemberListJson withPerms memberList -- | like 'getTeamMembers', but with an explicit list of users we are to return. -bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley (TeamMemberList, TeamMember -> Bool) +bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley r (TeamMemberList, TeamMember -> Bool) bulkGetTeamMembers zusr tid maxResults uids = do unless (length uids <= fromIntegral (fromRange maxResults)) $ throwM bulkGetMemberLimitExceeded @@ -510,12 +554,12 @@ bulkGetTeamMembers zusr tid maxResults uids = do hasMore = ListComplete pure (newTeamMemberList mems hasMore, withPerms) -getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do (member, withPerms) <- getTeamMember zusr tid uid pure . json $ teamMemberJson withPerms member -getTeamMember :: UserId -> TeamId -> UserId -> Galley (Public.TeamMember, Public.TeamMember -> Bool) +getTeamMember :: UserId -> TeamId -> UserId -> Galley r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do zusrMembership <- Data.teamMember tid zusr case zusrMembership of @@ -526,33 +570,45 @@ getTeamMember zusr tid uid = do Nothing -> throwM teamMemberNotFound Just member -> pure (member, withPerms) -internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley Response +internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do internalDeleteBindingTeamWithOneMember tid pure (empty & setStatus status202) -uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley Response +uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid -uncheckedGetTeamMember :: TeamId -> UserId -> Galley TeamMember +uncheckedGetTeamMember :: TeamId -> UserId -> Galley r TeamMember uncheckedGetTeamMember tid uid = do Data.teamMember tid uid >>= ifNothing teamMemberNotFound -uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley Response +uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley r Response uncheckedGetTeamMembersH (tid ::: maxResults ::: _) = do json <$> uncheckedGetTeamMembers tid maxResults -uncheckedGetTeamMembers :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley TeamMemberList +uncheckedGetTeamMembers :: + TeamId -> + Range 1 HardTruncationLimit Int32 -> + Galley r TeamMemberList uncheckedGetTeamMembers tid maxResults = Data.teamMembersWithLimit tid maxResults -addTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley Response +addTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> + Galley r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do nmem <- fromJsonBody req addTeamMember zusr zcon tid nmem pure empty -addTeamMember :: UserId -> ConnId -> TeamId -> Public.NewTeamMember -> Galley () +addTeamMember :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + Public.NewTeamMember -> + Galley r () addTeamMember zusr zcon tid nmem = do let uid = nmem ^. ntmNewTeamMember . userId Log.debug $ @@ -573,13 +629,20 @@ addTeamMember zusr zcon tid nmem = do void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList -- This function is "unchecked" because there is no need to check for user binding (invite only). -uncheckedAddTeamMemberH :: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response +uncheckedAddTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + TeamId ::: JsonRequest NewTeamMember ::: JSON -> + Galley r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do nmem <- fromJsonBody req uncheckedAddTeamMember tid nmem return empty -uncheckedAddTeamMember :: TeamId -> NewTeamMember -> Galley () +uncheckedAddTeamMember :: + Members '[BrigAccess, GundeckAccess] r => + TeamId -> + NewTeamMember -> + Galley r () uncheckedAddTeamMember tid nmem = do mems <- Data.teamMembersForFanout tid (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid @@ -588,14 +651,24 @@ uncheckedAddTeamMember tid nmem = do billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds -updateTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley Response +updateTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> + Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated targetMember <- view ntmNewTeamMember <$> fromJsonBody req updateTeamMember zusr zcon tid targetMember pure empty -updateTeamMember :: UserId -> ConnId -> TeamId -> TeamMember -> Galley () +updateTeamMember :: + forall r. + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + TeamMember -> + Galley r () updateTeamMember zusr zcon tid targetMember = do let targetId = targetMember ^. userId targetPermissions = targetMember ^. permissions @@ -637,14 +710,14 @@ updateTeamMember zusr zcon tid targetMember = do permissionsRole (previousMember ^. permissions) == Just RoleOwner && permissionsRole targetPermissions /= Just RoleOwner - updateJournal :: Team -> TeamMemberList -> Galley () + updateJournal :: Team -> TeamMemberList -> Galley r () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do (TeamSize size) <- BrigTeam.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds - updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley () + updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley r () updatePeers targetId targetPermissions updatedMembers = do -- inform members of the team about the change -- some (privileged) users will be informed about which change was applied @@ -658,7 +731,10 @@ updateTeamMember zusr zcon tid targetMember = do let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients for_ pushPriv $ \p -> push1 $ p & pushConn .~ Just zcon -deleteTeamMemberH :: UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> Galley Response +deleteTeamMemberH :: + Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> + Galley r Response deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeamMember zusr zcon tid remove mBody >>= \case @@ -670,7 +746,14 @@ data TeamMemberDeleteResult | TeamMemberDeleteCompleted -- | 'TeamMemberDeleteData' is only required for binding teams -deleteTeamMember :: UserId -> ConnId -> TeamId -> UserId -> Maybe Public.TeamMemberDeleteData -> Galley TeamMemberDeleteResult +deleteTeamMember :: + Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + UserId -> + Maybe Public.TeamMemberDeleteData -> + Galley r TeamMemberDeleteResult deleteTeamMember zusr zcon tid remove mBody = do Log.debug $ Log.field "targets" (toByteString remove) @@ -705,7 +788,15 @@ deleteTeamMember zusr zcon tid remove mBody = do pure TeamMemberDeleteCompleted -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. -uncheckedDeleteTeamMember :: UserId -> Maybe ConnId -> TeamId -> UserId -> TeamMemberList -> Galley () +uncheckedDeleteTeamMember :: + forall r. + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + UserId -> + Maybe ConnId -> + TeamId -> + UserId -> + TeamMemberList -> + Galley r () uncheckedDeleteTeamMember zusr zcon tid remove mems = do now <- liftIO getCurrentTime pushMemberLeaveEvent now @@ -713,13 +804,13 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do removeFromConvsAndPushConvLeaveEvent now where -- notify all team members. - pushMemberLeaveEvent :: UTCTime -> Galley () + pushMemberLeaveEvent :: UTCTime -> Galley r () pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData ?~ EdMemberLeave remove let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) push1 $ newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. - removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley () + removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley r () removeFromConvsAndPushConvLeaveEvent now = do -- This may not make sense if that list has been truncated. In such cases, we still want to -- remove the user from conversations but never send out any events. We assume that clients @@ -735,7 +826,7 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do -- If the list was truncated, then the tmids list is incomplete so we simply drop these events unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc - pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley () + pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley r () pushEvent exceptTo edata now dc = do localDomain <- viewFederationDomain let qconvId = Qualified (Data.convId dc) localDomain @@ -745,35 +836,41 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do let y = Conv.Event Conv.MemberLeave qconvId qusr now edata for_ (newPushLocal (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> push1 $ p & pushConn .~ zcon - void . forkIO $ void $ External.deliver (bots `zip` repeat y) + External.deliverAsync (bots `zip` repeat y) -getTeamConversations :: UserId -> TeamId -> Galley Public.TeamConversationList +getTeamConversations :: UserId -> TeamId -> Galley r Public.TeamConversationList getTeamConversations zusr tid = do tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) Public.newTeamConversationList <$> Data.teamConversations tid -getTeamConversation :: UserId -> TeamId -> ConvId -> Galley Public.TeamConversation +getTeamConversation :: UserId -> TeamId -> ConvId -> Galley r Public.TeamConversation getTeamConversation zusr tid cid = do tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) Data.teamConversation tid cid >>= maybe (throwErrorDescriptionType @ConvNotFound) pure -deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley () +deleteTeamConversation :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + ConvId -> + Galley r () deleteTeamConversation zusr zcon _tid cid = do lusr <- qualifyLocal zusr lconv <- qualifyLocal cid void $ API.deleteLocalConversation lusr zcon lconv -getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley Response +getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do zusrMembership <- Data.teamMember tid uid void $ permissionCheck ViewTeamSearchVisibility zusrMembership json <$> getSearchVisibilityInternal tid -setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley Response +setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do zusrMembership <- Data.teamMember tid uid void $ permissionCheck ChangeTeamSearchVisibility zusrMembership @@ -796,8 +893,8 @@ withTeamIds :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - (Bool -> [TeamId] -> Galley a) -> - Galley a + (Bool -> [TeamId] -> Galley r a) -> + Galley r a withTeamIds usr range size k = case range of Nothing -> do r <- Data.teamIdsFrom usr Nothing (rcast size) @@ -810,18 +907,17 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: [UserId] -> Galley () +ensureUnboundUsers :: [UserId] -> Galley r () ensureUnboundUsers uids = do - e <- ask -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. - ts <- liftIO $ mapConcurrently (evalGalley e . Data.oneUserTeam) uids + ts <- liftGalley0 $ mapConcurrently Data.oneUserTeam uids let teams = toList $ fromList (catMaybes ts) - binds <- liftIO $ mapConcurrently (evalGalley e . Data.teamBinding) teams + binds <- liftGalley0 $ mapConcurrently Data.teamBinding teams when (any ((==) (Just Binding)) binds) $ throwM userBindingExists -ensureNonBindingTeam :: TeamId -> Galley () +ensureNonBindingTeam :: TeamId -> Galley r () ensureNonBindingTeam tid = do team <- Data.team tid >>= ifNothing teamNotFound when ((tdTeam team) ^. teamBinding == Binding) $ @@ -829,7 +925,7 @@ ensureNonBindingTeam tid = do -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Permissions -> TeamMember -> Galley () +ensureNotElevated :: Permissions -> TeamMember -> Galley r () ensureNotElevated targetPermissions member = unless ( (targetPermissions ^. self) @@ -837,7 +933,7 @@ ensureNotElevated targetPermissions member = ) $ throwM invalidPermissions -ensureNotTooLarge :: TeamId -> Galley TeamSize +ensureNotTooLarge :: Member BrigAccess r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options (TeamSize size) <- BrigTeam.getSize tid @@ -854,19 +950,19 @@ ensureNotTooLarge tid = do -- size unlimited, because we make the assumption that these teams won't turn -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. -ensureNotTooLargeForLegalHold :: TeamId -> Int -> Galley () +ensureNotTooLargeForLegalHold :: Member BrigAccess r => TeamId -> Int -> Galley r () ensureNotTooLargeForLegalHold tid teamSize = do whenM (isLegalHoldEnabledForTeam tid) $ do unlessM (teamSizeBelowLimit teamSize) $ do throwM tooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: TeamId -> Galley () +ensureNotTooLargeToActivateLegalHold :: Member BrigAccess r => TeamId -> Galley r () ensureNotTooLargeToActivateLegalHold tid = do (TeamSize teamSize) <- BrigTeam.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do throwM cannotEnableLegalHoldServiceLargeTeam -teamSizeBelowLimit :: Int -> Galley Bool +teamSizeBelowLimit :: Int -> Galley r Bool teamSizeBelowLimit teamSize = do limit <- fromIntegral . fromRange <$> fanoutLimit let withinLimit = teamSize <= limit @@ -877,7 +973,14 @@ teamSizeBelowLimit teamSize = do -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' pure True -addTeamMemberInternal :: TeamId -> Maybe UserId -> Maybe ConnId -> NewTeamMember -> TeamMemberList -> Galley TeamSize +addTeamMemberInternal :: + Members '[BrigAccess, GundeckAccess] r => + TeamId -> + Maybe UserId -> + Maybe ConnId -> + NewTeamMember -> + TeamMemberList -> + Galley r TeamSize addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memList = do Log.debug $ Log.field "targets" (toByteString (new ^. userId)) @@ -908,20 +1011,21 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi -- less warped. This is a work-around because we cannot send events to all of a large team. -- See haddocks of module "Galley.API.TeamNotifications" for details. getTeamNotificationsH :: + Member BrigAccess r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 ::: JSON -> - Galley Response + Galley r Response getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do since <- parseSince json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Galley (Maybe Public.NotificationId) + parseSince :: Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: ByteString -> Galley Public.NotificationId + parseUUID :: ByteString -> Galley r Public.NotificationId parseUUID raw = maybe (throwM invalidTeamNotificationId) @@ -931,7 +1035,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID :: UUID.UUID -> Maybe UUID.UUID isV1UUID u = if UUID.version u == 1 then Just u else Nothing -finishCreateTeam :: Team -> TeamMember -> [TeamMember] -> Maybe ConnId -> Galley () +finishCreateTeam :: + Member GundeckAccess r => + Team -> + TeamMember -> + [TeamMember] -> + Maybe ConnId -> + Galley r () finishCreateTeam team owner others zcon = do let zusr = owner ^. userId for_ (owner : others) $ @@ -941,7 +1051,7 @@ finishCreateTeam team owner others zcon = do let r = membersToRecipients Nothing others push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b +withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound binding <- Data.teamBinding tid >>= ifNothing teamNotFound @@ -949,31 +1059,31 @@ withBindingTeam zusr callback = do Binding -> callback tid NonBinding -> throwM nonBindingTeam -getBindingTeamIdH :: UserId -> Galley Response +getBindingTeamIdH :: UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: UserId -> Galley TeamId +getBindingTeamId :: UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: UserId -> Galley Response +getBindingTeamMembersH :: UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: UserId -> Galley TeamMemberList +getBindingTeamMembers :: UserId -> Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> Data.teamMembersForFanout tid -canUserJoinTeamH :: TeamId -> Galley Response +canUserJoinTeamH :: Member BrigAccess r => TeamId -> Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold -canUserJoinTeam :: TeamId -> Galley () +canUserJoinTeam :: Member BrigAccess r => TeamId -> Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) -getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do @@ -986,38 +1096,38 @@ getTeamSearchVisibilityAvailableInternal tid = do <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) -getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley Response +getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley r Response getSearchVisibilityInternalH (tid ::: _) = json <$> getSearchVisibilityInternal tid -getSearchVisibilityInternal :: TeamId -> Galley TeamSearchVisibilityView +getSearchVisibilityInternal :: TeamId -> Galley r TeamSearchVisibilityView getSearchVisibilityInternal = fmap TeamSearchVisibilityView . SearchVisibilityData.getSearchVisibility -setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley Response +setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do setSearchVisibilityInternal tid =<< fromJsonBody req pure noContent -setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley () +setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ throwM teamSearchVisibilityNotEnabled SearchVisibilityData.setSearchVisibility tid searchVisibility -userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley Response +userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty False -> throwM accessDenied -userIsTeamOwner :: TeamId -> UserId -> Galley Bool +userIsTeamOwner :: TeamId -> UserId -> Galley r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion -queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley () +queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley r () queueTeamDeletion tid zusr zcon = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr zcon) diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index f0a25d91ebd..b34917162d3 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -60,6 +60,7 @@ import Galley.App import qualified Galley.Data as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush, push1) import Galley.Options import Galley.Types.Teams hiding (newTeam) @@ -83,12 +84,12 @@ data DoAuth = DoAuth UserId | DontDoAuth -- | For team-settings, to administrate team feature configuration. Here we have an admin uid -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do @@ -100,13 +101,13 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (TeamId -> Public.TeamFeatureStatus a -> Galley (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do @@ -118,11 +119,11 @@ setFeatureStatus setter doauth tid status = do -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do mbTeam <- Data.oneUserTeam zusr case mbTeam of @@ -133,17 +134,17 @@ getFeatureConfig getter zusr = do assertTeamExists tid getter (Right tid) -getAllFeatureConfigs :: UserId -> Galley AllFeatureConfigs +getAllFeatureConfigs :: UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do mbTeam <- Data.oneUserTeam zusr zusrMembership <- maybe (pure Nothing) (flip Data.teamMember zusr) mbTeam let getStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> - Galley (Text, Aeson.Value) + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + Galley r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership @@ -164,11 +165,11 @@ getAllFeatureConfigs zusr = do getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal ] -getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley Response +getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid -getAllFeatures :: UserId -> TeamId -> Galley Aeson.Value +getAllFeatures :: UserId -> TeamId -> Galley r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -184,34 +185,38 @@ getAllFeatures uid tid = do ] where getStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> - Galley (Text, Aeson.Value) + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + Galley r (Text, Aeson.Value) getStatus getter = do status <- getFeatureStatus @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a pure $ (cs (toByteString' feature) Aeson..= status) getFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => - Galley Public.TeamFeatureStatusValue -> + Galley r Public.TeamFeatureStatusValue -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName). - (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => - (Public.TeamFeatureStatusValue -> TeamId -> Galley ()) -> + forall (a :: Public.TeamFeatureName) r. + ( Public.KnownTeamFeatureName a, + Public.FeatureHasNoConfig a, + TeamFeatures.HasStatusCol a, + Member GundeckAccess r + ) => + (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status @@ -223,24 +228,28 @@ setFeatureStatusNoConfig applyState tid status = do -- the feature flag, so that we get more type safety. type GetFeatureInternalParam = Either (Maybe UserId) TeamId -getSSOStatusInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +getSSOStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @'Public.TeamFeatureSSO getDef) where - getDef :: Galley Public.TeamFeatureStatusValue + getDef :: Galley r Public.TeamFeatureStatusValue getDef = view (options . optSettings . setFeatureFlags . flagSSO) <&> \case FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled -setSSOStatusInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +setSSOStatusInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case Public.TeamFeatureDisabled -> const (throwM disableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) -getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -251,12 +260,16 @@ getTeamSearchVisibilityAvailableInternal = FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled -setTeamSearchVisibilityAvailableInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +setTeamSearchVisibilityAvailableInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) -getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -267,10 +280,14 @@ getValidateSAMLEmailsInternal = -- Use getFeatureStatusWithDefault getDef = pure Public.TeamFeatureDisabled -setValidateSAMLEmailsInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +setValidateSAMLEmailsInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () -getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -281,10 +298,14 @@ getDigitalSignaturesInternal = -- Use getFeatureStatusWithDefault getDef = pure Public.TeamFeatureDisabled -setDigitalSignaturesInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +setDigitalSignaturesInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () -getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -292,7 +313,11 @@ getLegalholdStatusInternal (Right tid) = do True -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureEnabled False -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled -setLegalholdStatusInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +setLegalholdStatusInternal :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do do -- this extra do is to encapsulate the assertions running before the actual operation. @@ -314,42 +339,46 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do ensureNotTooLargeToActivateLegalHold tid TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status -getFileSharingInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +getFileSharingInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: - forall (a :: TeamFeatureName). + forall (a :: TeamFeatureName) r. (KnownTeamFeatureName a, TeamFeatures.HasStatusCol a, FeatureHasNoConfig a) => Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @a getDef) where - getDef :: Galley Public.TeamFeatureStatusValue + getDef :: Galley r Public.TeamFeatureStatusValue getDef = view (options . optSettings . setFeatureFlags . lens') <&> Public.tfwoStatus . view unDefaults -setFileSharingInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +setFileSharingInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () -getAppLockInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +getAppLockInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- view (options . optSettings . setFeatureFlags . flagAppLockDefaults) status <- join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) pure $ fromMaybe defaultStatus status -setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throwM inactivityTimeoutTooLow TeamFeatures.setApplockFeatureStatus tid status -getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) +getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do globalConfig <- view (options . optSettings . setFeatureFlags . flagClassifiedDomains) let config = globalConfig @@ -358,7 +387,9 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureStatusWithConfig Public.TeamFeatureDisabled (Public.TeamFeatureClassifiedDomainsConfig []) Public.TeamFeatureEnabled -> config -getConferenceCallingInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) +getConferenceCallingInternal :: + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do @@ -366,10 +397,14 @@ getConferenceCallingInternal (Left Nothing) = do getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) -setConferenceCallingInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) +setConferenceCallingInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () -pushFeatureConfigEvent :: TeamId -> Event.Event -> Galley () +pushFeatureConfigEvent :: Member GundeckAccess r => TeamId -> Event.Event -> Galley r () pushFeatureConfigEvent tid event = do memList <- Data.teamMembersForFanout tid when ((memList ^. teamMemberListType) == ListTruncated) $ do @@ -385,7 +420,10 @@ pushFeatureConfigEvent tid event = do -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) -getFeatureConfigViaAccount :: flag ~ 'Public.TeamFeatureConferenceCalling => UserId -> Galley (Public.TeamFeatureStatus flag) +getFeatureConfigViaAccount :: + (flag ~ 'Public.TeamFeatureConferenceCalling) => + UserId -> + Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do mgr <- asks (^. manager) brigep <- asks (^. brig) @@ -393,7 +431,7 @@ getFeatureConfigViaAccount uid = do where handleResp :: Either Client.ClientError Public.TeamFeatureStatusNoConfig -> - Galley Public.TeamFeatureStatusNoConfig + Galley r Public.TeamFeatureStatusNoConfig handleResp (Right cfg) = pure cfg handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 7b6128a4414..08edac5eb25 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -51,6 +51,7 @@ import qualified Data.UUID.V1 as UUID import Galley.API.Error import Galley.App import qualified Galley.Data.TeamNotifications as DataTeamQueue +import Galley.Effects import Galley.Intra.User as Intra import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification @@ -59,10 +60,11 @@ import Network.HTTP.Types import Network.Wai.Utilities getTeamNotifications :: + Member BrigAccess r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> - Galley QueuedNotificationList + Galley r QueuedNotificationList getTeamNotifications zusr since size = do tid :: TeamId <- do mtid <- (userTeam . accountUser =<<) <$> Intra.getUser zusr @@ -75,7 +77,7 @@ getTeamNotifications zusr since size = do (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: TeamId -> Event -> Galley () +pushTeamEvent :: TeamId -> Event -> Galley r () pushTeamEvent tid evt = do nid <- mkNotificationId DataTeamQueue.add tid nid (List1.singleton $ toJSONObject evt) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 5c3579c9100..dee504abe4f 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -95,6 +95,7 @@ import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push @@ -109,12 +110,11 @@ import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList import Galley.Validation import Gundeck.Types.Push.V2 (RecipientClients (..)) -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) import Network.Wai.Utilities -import UnliftIO (pooledForConcurrentlyN) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import qualified Wire.API.Conversation.Code as Public @@ -138,21 +138,21 @@ import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client -acceptConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +acceptConvH :: Member GundeckAccess r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response acceptConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> acceptConv usr conn cnv -acceptConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +acceptConv :: Member GundeckAccess r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation acceptConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) conv' <- acceptOne2One usr conv conn conversationView usr conv' -blockConvH :: UserId ::: ConvId -> Galley Response +blockConvH :: UserId ::: ConvId -> Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv -blockConv :: UserId -> ConvId -> Galley () +blockConv :: UserId -> ConvId -> Galley r () blockConv zusr cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ @@ -161,11 +161,19 @@ blockConv zusr cnv = do let mems = Data.convLocalMembers conv when (zusr `isMember` mems) $ Data.removeMember zusr cnv -unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +unblockConvH :: + Member GundeckAccess r => + UserId ::: Maybe ConnId ::: ConvId -> + Galley r Response unblockConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> unblockConv usr conn cnv -unblockConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +unblockConv :: + Member GundeckAccess r => + UserId -> + Maybe ConnId -> + ConvId -> + Galley r Conversation unblockConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ @@ -182,11 +190,12 @@ handleUpdateResult = \case Unchanged -> empty & setStatus status204 updateConversationAccess :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationAccess usr con qcnv update = do lusr <- qualifyLocal usr let doUpdate = @@ -197,22 +206,24 @@ updateConversationAccess usr con qcnv update = do doUpdate qcnv lusr con update updateConversationAccessUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationAccessUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationAccess lcnv lusr con target = getUpdateResult . updateLocalConversation lcnv (qUntagged lusr) (Just con) @@ -224,14 +235,16 @@ updateRemoteConversationAccess :: Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented performAccessUpdateAction :: + forall r. + Members '[BrigAccess, BotAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => Qualified UserId -> Data.Conversation -> ConversationAccessData -> - MaybeT Galley () + MaybeT (Galley r) () performAccessUpdateAction qusr conv target = do lcnv <- qualifyLocal (Data.convId conv) guard $ Data.convAccessData conv /= target @@ -252,7 +265,7 @@ performAccessUpdateAction qusr conv target = do -- Update Cassandra lift $ Data.updateConversationAccess (tUnqualified lcnv) target - lift . void . forkIO $ do + lift . fireAndForget $ do -- Remove bots traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) @@ -265,7 +278,7 @@ performAccessUpdateAction qusr conv target = do void . runMaybeT $ performAction qusr conv action notifyConversationMetadataUpdate qusr Nothing lcnv current' action where - filterActivated :: BotsAndMembers -> Galley BotsAndMembers + filterActivated :: BotsAndMembers -> Galley r BotsAndMembers filterActivated bm | ( Data.convAccessRole conv > ActivatedAccessRole && cupAccessRole target <= ActivatedAccessRole @@ -275,7 +288,7 @@ performAccessUpdateAction qusr conv target = do pure $ bm {bmLocals = Set.fromList activated} | otherwise = pure bm - filterTeammates :: BotsAndMembers -> Galley BotsAndMembers + filterTeammates :: BotsAndMembers -> Galley r BotsAndMembers filterTeammates bm = do -- In a team-only conversation we also want to remove bots and guests case (cupAccessRole target, Data.convTeam conv) of @@ -291,11 +304,12 @@ performAccessUpdateAction qusr conv target = do _ -> pure bm updateConversationReceiptMode :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationReceiptMode usr zcon qcnv update = do lusr <- qualifyLocal usr let doUpdate = @@ -306,22 +320,24 @@ updateConversationReceiptMode usr zcon qcnv update = do doUpdate qcnv lusr zcon update updateConversationReceiptModeUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationReceiptModeUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) $ @@ -332,26 +348,28 @@ updateRemoteConversationReceiptMode :: Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateRemoteConversationReceiptMode _ _ _ _ = throwM federationNotImplemented updateConversationMessageTimerUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationMessageTimerUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationMessageTimer usr zcon qcnv update = do lusr <- qualifyLocal usr foldQualified @@ -362,32 +380,44 @@ updateConversationMessageTimer usr zcon qcnv update = do update updateLocalConversationMessageTimer :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMessageTimerUpdate update deleteLocalConversation :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) deleteLocalConversation lusr con lcnv = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete +type UpdateConversationActions = + '[ BotAccess, + BrigAccess, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess + ] + -- | Update a local conversation, and notify all local and remote members. updateLocalConversation :: + Members UpdateConversationActions r => Local ConvId -> Qualified UserId -> Maybe ConnId -> ConversationAction -> - MaybeT Galley Event + MaybeT (Galley r) Event updateLocalConversation lcnv qusr con action = do -- retrieve conversation (conv, self) <- @@ -418,10 +448,11 @@ getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT -- | Perform a conversation action, and return extra notification targets and -- an updated action. performAction :: + Members UpdateConversationActions r => Qualified UserId -> Data.Conversation -> ConversationAction -> - MaybeT Galley (BotsAndMembers, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) performAction qusr conv action = case action of ConversationActionAddMembers members role -> performAddMemberAction qusr conv members role @@ -456,7 +487,10 @@ performAction qusr conv action = case action of Just tid -> Data.removeTeamConv tid cid pure (mempty, action) -addCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +addCodeH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId -> + Galley r Response addCodeH (usr ::: zcon ::: cnv) = addCode usr zcon cnv <&> \case CodeAdded event -> json event & setStatus status201 @@ -466,7 +500,13 @@ data AddCodeResult = CodeAdded Public.Event | CodeAlreadyExisted Public.ConversationCode -addCode :: UserId -> ConnId -> ConvId -> Galley AddCodeResult +addCode :: + forall r. + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r AddCodeResult addCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -490,16 +530,24 @@ addCode usr zcon cnv = do conversationCode <- createCode code pure $ CodeAlreadyExisted conversationCode where - createCode :: Code -> Galley ConversationCode + createCode :: Code -> Galley r ConversationCode createCode code = do urlPrefix <- view $ options . optSettings . setConversationCodeURI return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix -rmCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +rmCodeH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId -> + Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv -rmCode :: UserId -> ConnId -> ConvId -> Galley Public.Event +rmCode :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r Public.Event rmCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -515,11 +563,11 @@ rmCode usr zcon cnv = do pushConversationEvent (Just zcon) event (map lmId users) bots pure event -getCodeH :: UserId ::: ConvId -> Galley Response +getCodeH :: UserId ::: ConvId -> Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv -getCode :: UserId -> ConvId -> Galley Public.ConversationCode +getCode :: UserId -> ConvId -> Galley r Public.ConversationCode getCode usr cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv CodeAccess @@ -530,40 +578,62 @@ getCode usr cnv = do >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) returnCode c -returnCode :: Code -> Galley Public.ConversationCode +returnCode :: Code -> Galley r Public.ConversationCode returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley Response +checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode pure empty -checkReusableCode :: Public.ConversationCode -> Galley () +checkReusableCode :: Public.ConversationCode -> Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode -joinConversationByReusableCodeH :: UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> Galley Response +joinConversationByReusableCodeH :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> + Galley r Response joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do convCode <- fromJsonBody req handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode -joinConversationByReusableCode :: UserId -> ConnId -> Public.ConversationCode -> Galley (UpdateResult Event) +joinConversationByReusableCode :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.ConversationCode -> + Galley r (UpdateResult Event) joinConversationByReusableCode zusr zcon convCode = do c <- verifyReusableCode convCode joinConversation zusr zcon (codeConversation c) CodeAccess -joinConversationByIdH :: UserId ::: ConnId ::: ConvId ::: JSON -> Galley Response +joinConversationByIdH :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId ::: JSON -> + Galley r Response joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = handleUpdateResult <$> joinConversationById zusr zcon cnv -joinConversationById :: UserId -> ConnId -> ConvId -> Galley (UpdateResult Event) +joinConversationById :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r (UpdateResult Event) joinConversationById zusr zcon cnv = joinConversation zusr zcon cnv LinkAccess -joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley (UpdateResult Event) +joinConversation :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Access -> + Galley r (UpdateResult Event) joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv @@ -592,7 +662,7 @@ addMembersToLocalConversation :: Local ConvId -> UserList UserId -> RoleName -> - MaybeT Galley (BotsAndMembers, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) addMembersToLocalConversation lcnv users role = do (lmems, rmems) <- lift $ Data.addMembers lcnv (fmap (,role) users) neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users @@ -600,11 +670,13 @@ addMembersToLocalConversation lcnv users role = do pure (bmFromMembers lmems rmems, action) performAddMemberAction :: + forall r. + Members UpdateConversationActions r => Qualified UserId -> Data.Conversation -> NonEmpty (Qualified UserId) -> RoleName -> - MaybeT Galley (BotsAndMembers, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) performAddMemberAction qusr conv invited role = do lcnv <- lift $ qualifyLocal (Data.convId conv) let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited @@ -619,7 +691,7 @@ performAddMemberAction qusr conv invited role = do where userIsMember u = (^. userId . to (== u)) - checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley () + checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () checkLocals lcnv (Just tid) newUsers = do tms <- Data.teamMembersLimited tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers @@ -632,7 +704,7 @@ performAddMemberAction qusr conv invited role = do ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) ensureConnectedOrSameTeam qusr newUsers - checkRemotes :: [Remote UserId] -> Galley () + checkRemotes :: [Remote UserId] -> Galley r () checkRemotes remotes = do -- if federator is not configured, we fail early, so we avoid adding -- remote members to the database @@ -649,7 +721,7 @@ performAddMemberAction qusr conv invited role = do qusr remotes - checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley () + checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley r () checkLHPolicyConflictsLocal lcnv newUsers = do let convUsers = Data.convLocalMembers conv @@ -682,16 +754,27 @@ performAddMemberAction qusr conv invited role = do ConversationActionRemoveMembers (pure qvictim) else throwErrorDescriptionType @MissingLegalholdConsent - checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () + checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley r () checkLHPolicyConflictsRemote _remotes = pure () addMembersUnqualified :: - UserId -> ConnId -> ConvId -> Public.Invite -> Galley (UpdateResult Event) + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.Invite -> + Galley r (UpdateResult Event) addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do qusers <- traverse (fmap qUntagged . qualifyLocal) (toNonEmpty users) addMembers zusr zcon cnv (Public.InviteQualified qusers role) -addMembers :: UserId -> ConnId -> ConvId -> Public.InviteQualified -> Galley (UpdateResult Event) +addMembers :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.InviteQualified -> + Galley r (UpdateResult Event) addMembers zusr zcon cnv (Public.InviteQualified users role) = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv @@ -699,7 +782,13 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ ConversationActionAddMembers users role -updateSelfMember :: UserId -> ConnId -> Qualified ConvId -> Public.MemberUpdate -> Galley () +updateSelfMember :: + Members '[GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + Qualified ConvId -> + Public.MemberUpdate -> + Galley r () updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr @@ -727,18 +816,25 @@ updateSelfMember zusr zcon qcnv update = do misConvRoleName = Nothing } -updateUnqualifiedSelfMember :: UserId -> ConnId -> ConvId -> Public.MemberUpdate -> Galley () +updateUnqualifiedSelfMember :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.MemberUpdate -> + Galley r () updateUnqualifiedSelfMember zusr zcon cnv update = do lcnv <- qualifyLocal cnv updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberUnqualified zusr zcon cnv victim update = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv @@ -746,24 +842,26 @@ updateOtherMemberUnqualified zusr zcon cnv victim update = do updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMember zusr zcon qcnv qvictim update = do lusr <- qualifyLocal zusr let doUpdate = foldQualified lusr updateOtherMemberLocalConv updateOtherMemberRemoteConv doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do when (qUntagged lusr == qvictim) $ throwM invalidTargetUserOp @@ -776,31 +874,39 @@ updateOtherMemberRemoteConv :: ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberRemoteConv _ _ _ _ _ = throwM federationNotImplemented -removeMemberUnqualified :: UserId -> ConnId -> ConvId -> UserId -> Galley RemoveFromConversationResponse +removeMemberUnqualified :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + UserId -> + Galley r RemoveFromConversationResponse removeMemberUnqualified zusr con cnv victim = do lcnv <- qualifyLocal cnv lvictim <- qualifyLocal victim removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberQualified zusr con qcnv victim = do lusr <- qualifyLocal zusr foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: + Member FederatorAccess r => Remote ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim | qUntagged lusr == victim = do @@ -820,7 +926,7 @@ removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim performRemoveMemberAction :: Data.Conversation -> [Qualified UserId] -> - MaybeT Galley () + MaybeT (Galley r) () performRemoveMemberAction conv victims = do loc <- qualifyLocal () let presentVictims = filter (isConvMember loc conv) victims @@ -832,11 +938,12 @@ performRemoveMemberAction conv victims = do -- | Remove a member from a local conversation. removeMemberFromLocalConv :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberFromLocalConv lcnv lusr con victim = -- FUTUREWORK: actually return errors as part of the response instead of throwing fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) @@ -854,24 +961,39 @@ data OtrResult | OtrUnknownClient !Public.UnknownClient | OtrConversationNotFound !Public.ConvNotFound -handleOtrResult :: OtrResult -> Galley Response +handleOtrResult :: OtrResult -> Galley r Response handleOtrResult = \case OtrSent m -> pure $ json m & setStatus status201 OtrMissingRecipients m -> pure $ json m & setStatus status412 OtrUnknownClient _ -> throwErrorDescriptionType @UnknownClient OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound -postBotMessageH :: BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> Galley Response +postBotMessageH :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> + Galley r Response postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postBotMessage zbot zcnv val' message -postBotMessage :: BotId -> ConvId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley OtrResult +postBotMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + BotId -> + ConvId -> + Public.OtrFilterMissing -> + Public.NewOtrMessage -> + Galley r OtrResult postBotMessage zbot zcnv val message = postNewOtrMessage Bot (botUserId zbot) Nothing zcnv val message -postProteusMessage :: UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> Galley (Public.PostOtrResponse Public.MessageSendingStatus) +postProteusMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + Qualified ConvId -> + RawProto Public.QualifiedNewOtrMessage -> + Galley r (Public.PostOtrResponse Public.MessageSendingStatus) postProteusMessage zusr zcon conv msg = do localDomain <- viewFederationDomain let sender = Qualified zusr localDomain @@ -879,7 +1001,15 @@ postProteusMessage zusr zcon conv msg = do then postRemoteOtrMessage sender conv (rpRaw msg) else postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) -postOtrMessageUnqualified :: UserId -> ConnId -> ConvId -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.NewOtrMessage -> Galley (Public.PostOtrResponse Public.ClientMismatch) +postOtrMessageUnqualified :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + ConvId -> + Maybe Public.IgnoreMissing -> + Maybe Public.ReportMissing -> + Public.NewOtrMessage -> + Galley r (Public.PostOtrResponse Public.ClientMismatch) postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do localDomain <- viewFederationDomain let sender = Qualified zusr localDomain @@ -906,19 +1036,31 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do unqualify localDomain <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage -postProtoOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley Response +postProtoOtrBroadcastH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> + Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do message <- Public.protoToNewOtrMessage <$> fromProtoBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postOtrBroadcast zusr zcon val' message -postOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley Response +postOtrBroadcastH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> + Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postOtrBroadcast zusr zcon val' message -postOtrBroadcast :: UserId -> ConnId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley OtrResult +postOtrBroadcast :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.OtrFilterMissing -> + Public.NewOtrMessage -> + Galley r OtrResult postOtrBroadcast zusr zcon = postNewOtrBroadcast zusr (Just zcon) -- internal OTR helpers @@ -932,7 +1074,13 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep Just uids -> OtrReportMissing $ Set.fromList uids -- | bots are not supported on broadcast -postNewOtrBroadcast :: UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postNewOtrBroadcast :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + OtrFilterMissing -> + NewOtrMessage -> + Galley r OtrResult postNewOtrBroadcast usr con val msg = do localDomain <- viewFederationDomain let qusr = Qualified usr localDomain @@ -943,7 +1091,15 @@ postNewOtrBroadcast usr con val msg = do let (_, toUsers) = foldr (newMessage qusr con Nothing msg now) ([], []) rs pushSome (catMaybes toUsers) -postNewOtrMessage :: UserType -> UserId -> Maybe ConnId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postNewOtrMessage :: + Members '[BotAccess, BrigAccess, ExternalAccess, GundeckAccess] r => + UserType -> + UserId -> + Maybe ConnId -> + ConvId -> + OtrFilterMissing -> + NewOtrMessage -> + Galley r OtrResult postNewOtrMessage utype usr con cnv val msg = do localDomain <- viewFederationDomain let qusr = Qualified usr localDomain @@ -954,9 +1110,7 @@ postNewOtrMessage utype usr con cnv val msg = do withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> do let (toBots, toUsers) = foldr (newMessage qusr con (Just qcnv) msg now) ([], []) rs pushSome (catMaybes toUsers) - void . forkIO $ do - gone <- External.deliver toBots - mapM_ (deleteBot cnv . botMemId) gone + External.deliverAndDeleteAsync cnv toBots newMessage :: Qualified UserId -> @@ -994,11 +1148,12 @@ newMessage qusr con qcnv msg now (m, c, t) ~(toBots, toUsers) = in (toBots, p : toUsers) updateConversationName :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateConversationName zusr zcon qcnv convRename = do lusr <- qualifyLocal zusr foldQualified @@ -1009,22 +1164,24 @@ updateConversationName zusr zcon qcnv convRename = do convRename updateUnqualifiedConversationName :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateUnqualifiedConversationName zusr zcon cnv rename = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do alive <- Data.isConvAlive (tUnqualified lcnv) if alive @@ -1032,49 +1189,54 @@ updateLocalConversationName lusr zcon lcnv convRename = do else Nothing <$ Data.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionRename rename notifyConversationMetadataUpdate :: + Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => Qualified UserId -> Maybe ConnId -> Local ConvId -> BotsAndMembers -> ConversationAction -> - Galley Event + Galley r Event notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do localDomain <- viewFederationDomain now <- liftIO getCurrentTime let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = bucketRemote (toList (bmRemotes targets)) - void . pooledForConcurrentlyN 8 rusersByDomain $ \(qUntagged -> Qualified uids domain) -> do - let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action - rpc = - FederatedGalley.onConversationUpdated - FederatedGalley.clientRoutes - localDomain - req - runFederatedGalley domain rpc + runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ + FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action -- notify local participants and bots pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e -isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley Response +isTypingH :: + Member GundeckAccess r => + UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> + Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do typingData <- fromJsonBody req isTyping zusr zcon cnv typingData pure empty -isTyping :: UserId -> ConnId -> ConvId -> Public.TypingData -> Galley () +isTyping :: + Member GundeckAccess r => + UserId -> + ConnId -> + ConvId -> + Public.TypingData -> + Galley r () isTyping zusr zcon cnv typingData = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -1091,22 +1253,30 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: JsonRequest Service -> Galley Response +addServiceH :: JsonRequest Service -> Galley r Response addServiceH req = do Data.insertService =<< fromJsonBody req return empty -rmServiceH :: JsonRequest ServiceRef -> Galley Response +rmServiceH :: JsonRequest ServiceRef -> Galley r Response rmServiceH req = do Data.deleteService =<< fromJsonBody req return empty -addBotH :: UserId ::: ConnId ::: JsonRequest AddBot -> Galley Response +addBotH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest AddBot -> + Galley r Response addBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req json <$> addBot zusr zcon bot -addBot :: UserId -> ConnId -> AddBot -> Galley Event +addBot :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + AddBot -> + Galley r Event addBot zusr zcon b = do lusr <- qualifyLocal zusr c <- Data.conversation (b ^. addBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) @@ -1118,7 +1288,7 @@ addBot zusr zcon b = do (e, bm) <- Data.addBotMember (qUntagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon - void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e) + External.deliverAsync ((bm : bots) `zip` repeat e) pure e where regularConvChecks lusr c = do @@ -1136,12 +1306,20 @@ addBot zusr zcon b = do when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged -rmBotH :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response +rmBotH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> + Galley r Response rmBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req handleUpdateResult <$> rmBot zusr zcon bot -rmBot :: UserId -> Maybe ConnId -> RemoveBot -> Galley (UpdateResult Event) +rmBot :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + RemoveBot -> + Galley r (UpdateResult Event) rmBot zusr zcon b = do c <- Data.conversation (b ^. rmBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) localDomain <- viewFederationDomain @@ -1160,20 +1338,20 @@ rmBot zusr zcon b = do push1 $ p & pushConn .~ zcon Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) Data.eraseClients (botUserId (b ^. rmBotId)) - void . forkIO $ void $ External.deliver (bots `zip` repeat e) + External.deliverAsync (bots `zip` repeat e) pure $ Updated e ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley () +ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley r () ensureMemberLimit old new = do o <- view options let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) when (length old + length new > maxSize) $ throwM tooManyMembers -ensureConvMember :: [LocalMember] -> UserId -> Galley () +ensureConvMember :: [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = unless (usr `isMember` users) $ throwErrorDescriptionType @ConvNotFound @@ -1194,13 +1372,14 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: + Member BrigAccess r => UserId -> ClientId -> OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early @@ -1238,6 +1417,7 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ pure (mems ^. teamMembers) withValidOtrRecipients :: + Member BrigAccess r => UserType -> UserId -> ClientId -> @@ -1245,8 +1425,8 @@ withValidOtrRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult withValidOtrRecipients utype usr clt cnv rcps val now go = do alive <- Data.isConvAlive cnv if not alive @@ -1264,6 +1444,7 @@ withValidOtrRecipients utype usr clt cnv rcps val now go = do handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: + Member BrigAccess r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1281,8 +1462,8 @@ handleOtrResponse :: -- | The current timestamp. UTCTime -> -- | Callback if OtrRecipients are valid - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of ValidOtrRecipients m r -> go r >> pure (OtrSent m) MissingOtrRecipients m -> do @@ -1375,7 +1556,7 @@ checkOtrRecipients usr sid prs vms vcs val now OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss -- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b +withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound binding <- Data.teamBinding tid >>= ifNothing teamNotFound diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index e0c3d332bb0..bbcf15950d7 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -44,6 +44,7 @@ import qualified Galley.Data as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes +import Galley.Effects import qualified Galley.External as External import Galley.Intra.Push import Galley.Intra.User @@ -53,12 +54,12 @@ import Galley.Types.Conversations.Members (localMemberToOther, remoteMemberToOth import Galley.Types.Conversations.Roles import Galley.Types.Teams hiding (Event, MemberJoin, self) import Galley.Types.UserList -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) import Network.Wai.Utilities -import UnliftIO.Async +import UnliftIO.Async (concurrently, pooledForConcurrentlyN) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription @@ -71,7 +72,7 @@ import qualified Wire.API.User as User type JSON = Media "application" "json" -ensureAccessRole :: AccessRole -> [(UserId, Maybe TeamMember)] -> Galley () +ensureAccessRole :: Member BrigAccess r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () ensureAccessRole role users = case role of PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied TeamAccessRole -> @@ -88,7 +89,7 @@ ensureAccessRole role users = case role of -- -- Team members are always considered connected, so we only check 'ensureConnected' -- for non-team-members of the _given_ user -ensureConnectedOrSameTeam :: Qualified UserId -> [UserId] -> Galley () +ensureConnectedOrSameTeam :: Member BrigAccess r => Qualified UserId -> [UserId] -> Galley r () ensureConnectedOrSameTeam _ [] = pure () ensureConnectedOrSameTeam (Qualified u domain) uids = do -- FUTUREWORK(federation, #1262): handle remote users (can't be part of the same team, just check connections) @@ -106,28 +107,28 @@ ensureConnectedOrSameTeam (Qualified u domain) uids = do -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: Local UserId -> UserList UserId -> Galley () +ensureConnected :: Member BrigAccess r => Local UserId -> UserList UserId -> Galley r () ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: UserId -> [UserId] -> Galley () +ensureConnectedToLocals :: Member BrigAccess r => UserId -> [UserId] -> Galley r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do +ensureConnectedToLocals u uids = liftGalley0 $ do (connsFrom, connsTo) <- - getConnectionsUnqualified [u] (Just uids) (Just Accepted) - `concurrently` getConnectionsUnqualified uids (Just [u]) (Just Accepted) + getConnectionsUnqualified0 [u] (Just uids) (Just Accepted) + `concurrently` getConnectionsUnqualified0 uids (Just [u]) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ throwErrorDescriptionType @NotConnected -ensureConnectedToRemotes :: Local UserId -> [Remote UserId] -> Galley () +ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () ensureConnectedToRemotes _ [] = pure () ensureConnectedToRemotes u remotes = do acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ throwErrorDescriptionType @NotConnected -ensureReAuthorised :: UserId -> Maybe PlainTextPassword -> Galley () +ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () ensureReAuthorised u secret = do reAuthed <- reAuthUser u (ReAuthUser secret) unless reAuthed $ @@ -136,7 +137,7 @@ ensureReAuthorised u secret = do -- | Given a member in a conversation, check if the given action -- is permitted. If the user does not have the given permission, throw -- 'operationDenied'. -ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley () +ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley r () ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of Just True -> pure () Just False -> throwErrorDescription (actionDenied action) @@ -150,7 +151,7 @@ ensureConversationActionAllowed :: ConversationAction -> Data.Conversation -> mem -> - Galley () + Galley r () ensureConversationActionAllowed action conv self = do loc <- qualifyLocal () let tag = conversationActionTag (convMemberId loc self) action @@ -199,7 +200,7 @@ ensureConversationActionAllowed action conv self = do throwErrorDescriptionType @InvalidTargetAccess _ -> pure () -ensureGroupConvThrowing :: Data.Conversation -> Galley () +ensureGroupConvThrowing :: Data.Conversation -> Galley r () ensureGroupConvThrowing conv = case Data.convType conv of SelfConv -> throwM invalidSelfOp One2OneConv -> throwM invalidOne2OneOp @@ -210,7 +211,7 @@ ensureGroupConvThrowing conv = case Data.convType conv of -- own. This is used to ensure users cannot "elevate" allowed actions -- This function needs to be review when custom roles are introduced since only -- custom roles can cause `roleNameToActions` to return a Nothing -ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley () +ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley r () ensureConvRoleNotElevated origMember targetRole = do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> @@ -222,7 +223,7 @@ ensureConvRoleNotElevated origMember targetRole = do -- | If a team member is not given throw 'notATeamMember'; if the given team -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. -permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley TeamMember +permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley r TeamMember permissionCheck p = \case Just m -> do if m `hasPermission` p @@ -230,14 +231,14 @@ permissionCheck p = \case else throwErrorDescription (operationDenied p) Nothing -> throwErrorDescriptionType @NotATeamMember -assertTeamExists :: TeamId -> Galley () +assertTeamExists :: TeamId -> Galley r () assertTeamExists tid = do teamExists <- isJust <$> Data.team tid if teamExists then pure () else throwM teamNotFound -assertOnTeam :: UserId -> TeamId -> Galley () +assertOnTeam :: UserId -> TeamId -> Galley r () assertOnTeam uid tid = do Data.teamMember tid uid >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember @@ -245,7 +246,7 @@ assertOnTeam uid tid = do -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). -permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley () +permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley r () permissionCheckTeamConv zusr cnv perm = Data.conversation cnv >>= \case Just cnv' -> case Data.convTeam cnv' of @@ -254,7 +255,12 @@ permissionCheckTeamConv zusr cnv perm = Nothing -> throwErrorDescriptionType @ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. -acceptOne2One :: UserId -> Data.Conversation -> Maybe ConnId -> Galley Data.Conversation +acceptOne2One :: + Member GundeckAccess r => + UserId -> + Data.Conversation -> + Maybe ConnId -> + Galley r Data.Conversation acceptOne2One usr conv conn = do lusr <- qualifyLocal usr lcid <- qualifyLocal cid @@ -460,12 +466,12 @@ getSelfMemberFromLocals :: ExceptT ConvNotFound m LocalMember getSelfMemberFromLocals = getLocalMember (mkErrorDescription :: ConvNotFound) --- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley monad. +-- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. getSelfMemberFromLocalsLegacy :: Foldable t => UserId -> t LocalMember -> - Galley LocalMember + Galley r LocalMember getSelfMemberFromLocalsLegacy usr lmems = eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromLocals usr lmems @@ -475,7 +481,7 @@ ensureOtherMember :: Local a -> Qualified UserId -> Data.Conversation -> - Galley (Either LocalMember RemoteMember) + Galley r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) @@ -488,7 +494,7 @@ getSelfMemberFromRemotes :: ExceptT ConvNotFound m RemoteMember getSelfMemberFromRemotes = getRemoteMember (mkErrorDescription :: ConvNotFound) -getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley RemoteMember +getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley r RemoteMember getSelfMemberFromRemotesLegacy usr rmems = eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromRemotes usr rmems @@ -538,7 +544,10 @@ getMember :: ExceptT e m mem getMember p ex u = hoistEither . note ex . find ((u ==) . p) -getConversationAndCheckMembership :: UserId -> ConvId -> Galley Data.Conversation +getConversationAndCheckMembership :: + UserId -> + ConvId -> + Galley r Data.Conversation getConversationAndCheckMembership uid cnv = do (conv, _) <- getConversationAndMemberWithError @@ -552,7 +561,7 @@ getConversationAndMemberWithError :: Error -> uid -> ConvId -> - Galley (Data.Conversation, mem) + Galley r (Data.Conversation, mem) getConversationAndMemberWithError ex usr convId = do c <- Data.conversation convId >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) when (DataTypes.isConvDeleted c) $ do @@ -582,14 +591,20 @@ canDeleteMember deleter deletee getRole mem = fromMaybe RoleMember $ permissionsRole $ mem ^. permissions -- | Send an event to local users and bots -pushConversationEvent :: Foldable f => Maybe ConnId -> Event -> f UserId -> f BotMember -> Galley () +pushConversationEvent :: + (Members '[GundeckAccess, ExternalAccess] r, Foldable f) => + Maybe ConnId -> + Event -> + f UserId -> + f BotMember -> + Galley r () pushConversationEvent conn e users bots = do localDomain <- viewFederationDomain for_ (newConversationEventPush localDomain e (toList users)) $ \p -> push1 $ p & set pushConn conn - void . forkIO $ void $ External.deliver (toList bots `zip` repeat e) + External.deliverAsync (toList bots `zip` repeat e) -verifyReusableCode :: ConversationCode -> Galley DataTypes.Code +verifyReusableCode :: ConversationCode -> Galley r DataTypes.Code verifyReusableCode convCode = do c <- Data.lookupCode (conversationKey convCode) DataTypes.ReusableCode @@ -598,7 +613,7 @@ verifyReusableCode convCode = do throwM (errorDescriptionTypeToWai @CodeNotFound) return c -ensureConversationAccess :: UserId -> ConvId -> Access -> Galley Data.Conversation +ensureConversationAccess :: Member BrigAccess r => UserId -> ConvId -> Access -> Galley r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv access @@ -606,7 +621,7 @@ ensureConversationAccess zusr cnv access = do ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv -ensureAccess :: Data.Conversation -> Access -> Galley () +ensureAccess :: Data.Conversation -> Access -> Galley r () ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ throwErrorDescriptionType @ConvAccessDenied @@ -620,12 +635,15 @@ viewFederationDomain = view (options . optSettings . setFederationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a -checkRemoteUsersExist :: (Functor f, Foldable f) => f (Remote UserId) -> Galley () +checkRemoteUsersExist :: + (Member FederatorAccess r, Functor f, Foldable f) => + f (Remote UserId) -> + Galley r () checkRemoteUsersExist = -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain traverse_ checkRemotesFor . bucketRemote -checkRemotesFor :: Remote [UserId] -> Galley () +checkRemotesFor :: Member FederatorAccess r => Remote [UserId] -> Galley r () checkRemotesFor (qUntagged -> Qualified uids domain) = do let rpc = FederatedBrig.getUsersByIds FederatedBrig.clientRoutes uids users <- runFederatedBrig domain rpc @@ -636,33 +654,55 @@ checkRemotesFor (qUntagged -> Qualified uids domain) = do unless (Set.fromList uids == Set.fromList uids') $ throwM unknownRemoteUser -type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley) a +type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley0) a -runFederatedGalley :: Domain -> FederatedGalleyRPC 'Galley a -> Galley a -runFederatedGalley = runFederated @'Galley - -runFederatedBrig :: Domain -> FederatedGalleyRPC 'Brig a -> Galley a -runFederatedBrig = runFederated @'Brig - -runFederated :: forall (c :: Component) a. Domain -> FederatorClient c (ExceptT FederationClientFailure Galley) a -> Galley a -runFederated remoteDomain rpc = do +runFederated0 :: + forall (c :: Component) a. + Domain -> + FederatedGalleyRPC c a -> + Galley0 a +runFederated0 remoteDomain rpc = do runExceptT (executeFederated remoteDomain rpc) >>= either (throwM . federationErrorToWai) pure +runFederatedGalley :: + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC 'Galley a -> + Galley r a +runFederatedGalley = runFederated + +runFederatedBrig :: + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC 'Brig a -> + Galley r a +runFederatedBrig = runFederated + +runFederated :: + forall (c :: Component) r a. + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC c a -> + Galley r a +runFederated remoteDomain = liftGalley0 . runFederated0 remoteDomain + runFederatedConcurrently :: + Member FederatorAccess r => (Foldable f, Functor f) => f (Remote a) -> (Remote [a] -> FederatedGalleyRPC c b) -> - Galley [Remote b] -runFederatedConcurrently xs rpc = + Galley r [Remote b] +runFederatedConcurrently xs rpc = liftGalley0 $ pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> - qualifyAs r <$> runFederated (tDomain r) (rpc r) + qualifyAs r <$> runFederated0 (tDomain r) (rpc r) runFederatedConcurrently_ :: + Member FederatorAccess r => (Foldable f, Functor f) => f (Remote a) -> (Remote [a] -> FederatedGalleyRPC c ()) -> - Galley () + Galley r () runFederatedConcurrently_ xs = void . runFederatedConcurrently xs -- | Convert an internal conversation representation 'Data.Conversation' to @@ -767,12 +807,13 @@ fromNewRemoteConversation loc rc@NewRemoteConversation {..} = -- | Notify remote users of being added to a new conversation registerRemoteConversationMemberships :: + Member FederatorAccess r => -- | The time stamp when the conversation was created UTCTime -> -- | The domain of the user that created the conversation Domain -> Data.Conversation -> - Galley () + Galley r () registerRemoteConversationMemberships now localDomain c = do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c @@ -799,13 +840,13 @@ consentGiven = \case UserLegalHoldEnabled -> ConsentGiven UserLegalHoldNoConsent -> ConsentNotGiven -checkConsent :: Map UserId TeamId -> UserId -> Galley ConsentGiven +checkConsent :: Map UserId TeamId -> UserId -> Galley r ConsentGiven checkConsent teamsOfUsers other = do consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other -- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user -- doesn't belong to a team. -getLHStatus :: Maybe TeamId -> UserId -> Galley UserLegalHoldStatus +getLHStatus :: Maybe TeamId -> UserId -> Galley r UserLegalHoldStatus getLHStatus teamOfUser other = do case teamOfUser of Nothing -> pure defUserLegalHoldStatus @@ -813,7 +854,7 @@ getLHStatus teamOfUser other = do mMember <- Data.teamMember team other pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember -anyLegalholdActivated :: [UserId] -> Galley Bool +anyLegalholdActivated :: [UserId] -> Galley r Bool anyLegalholdActivated uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -825,7 +866,7 @@ anyLegalholdActivated uids = do teamsOfUsers <- Data.usersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage -allLegalholdConsentGiven :: [UserId] -> Galley Bool +allLegalholdConsentGiven :: [UserId] -> Galley r Bool allLegalholdConsentGiven uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -842,7 +883,7 @@ allLegalholdConsentGiven uids = do allM isTeamLegalholdWhitelisted teamsPage -- | Add to every uid the legalhold status -getLHStatusForUsers :: [UserId] -> Galley [(UserId, UserLegalHoldStatus)] +getLHStatusForUsers :: [UserId] -> Galley r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 3d938a8241d..10ba4724994 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -38,6 +38,8 @@ module Galley.App -- * Galley monad Galley, + GalleyEffects, + Galley0, runGalley, evalGalley, ask, @@ -52,6 +54,13 @@ module Galley.App initExtEnv, fanoutLimit, currentFanoutLimit, + + -- * MonadUnliftIO / Sem compatibility + fireAndForget, + spawnMany, + liftGalley0, + liftSem, + interpretGalleyToGalley0, ) where @@ -61,8 +70,9 @@ import Cassandra hiding (Set) import qualified Cassandra as C import qualified Cassandra.Settings as C import Control.Error +import qualified Control.Exception import Control.Lens hiding ((.=)) -import Control.Monad.Catch hiding (tryJust) +import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') @@ -80,26 +90,32 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Galley.API.Error import qualified Galley.Aws as Aws +import Galley.Effects +import qualified Galley.Effects.FireAndForget as E import Galley.Options import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams -import Imports +import Imports hiding (forkIO) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Types (hContentType) import Network.HTTP.Types.Status (statusCode, statusMessage) import Network.Wai -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) import qualified Network.Wai.Utilities as WaiError import qualified Network.Wai.Utilities.Server as Server import OpenSSL.EVP.Digest (getDigestByName) import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl +import Polysemy +import Polysemy.Internal (Append) +import qualified Polysemy.Reader as P import qualified Servant import Ssl.Util import System.Logger.Class hiding (Error, info) import qualified System.Logger.Extended as Logger +import qualified UnliftIO.Exception as UnliftIO import Util.Options import Wire.API.Federation.Client (HasFederatorConfig (..)) @@ -131,26 +147,48 @@ makeLenses ''Env makeLenses ''ExtEnv -newtype Galley a = Galley - { unGalley :: ReaderT Env Client a - } - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadThrow, - MonadCatch, - MonadMask, - MonadReader Env, - MonadClient - ) +-- MTL-style effects derived from the old implementation of the Galley monad. +-- They will disappear as we introduce more high-level effects into Galley. +type GalleyEffects0 = '[P.Reader ClientState, P.Reader Env, Embed IO, Final IO] + +type GalleyEffects = Append GalleyEffects1 GalleyEffects0 + +type Galley0 = Galley GalleyEffects0 + +newtype Galley r a = Galley {unGalley :: Members GalleyEffects0 r => Sem r a} + +instance Functor (Galley r) where + fmap f (Galley x) = Galley (fmap f x) + +instance Applicative (Galley r) where + pure x = Galley (pure x) + (<*>) = ap -instance HasFederatorConfig Galley where +instance Monad (Galley r) where + return = pure + Galley m >>= f = Galley (m >>= unGalley . f) + +instance MonadIO (Galley r) where + liftIO action = Galley (liftIO action) + +instance MonadThrow (Galley r) where + throwM e = Galley (embed @IO (throwM e)) + +instance MonadReader Env (Galley r) where + ask = Galley $ P.ask @Env + local f m = Galley $ P.local f (unGalley m) + +instance MonadClient (Galley r) where + liftClient m = Galley $ do + cs <- P.ask @ClientState + embed @IO $ runClient cs m + localState f m = Galley $ P.local f (unGalley m) + +instance HasFederatorConfig (Galley r) where federatorEndpoint = view federator federationDomain = view (options . optSettings . setFederationDomain) -fanoutLimit :: Galley (Range 1 Teams.HardTruncationLimit Int32) +fanoutLimit :: Galley r (Range 1 Teams.HardTruncationLimit Int32) fanoutLimit = view options >>= return . currentFanoutLimit currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 @@ -182,23 +220,17 @@ validateOptions l o = do when (settings ^. setMaxTeamSize < optFanoutLimit) $ error "setMaxTeamSize cannot be < setTruncationLimit" -instance MonadUnliftIO Galley where - askUnliftIO = - Galley . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unGalley)) - -instance MonadLogger Galley where +instance MonadLogger (Galley r) where log l m = do e <- ask Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) -instance MonadHttp Galley where +instance MonadHttp (Galley r) where handleRequestWithCont req handler = do httpManager <- view manager liftIO $ withResponse req httpManager handler -instance HasRequestId Galley where +instance HasRequestId (Galley r) where getRequestId = view reqId createEnv :: Metrics -> Opts -> IO Env @@ -271,13 +303,20 @@ initExtEnv = do let pinset = map toByteString' fprs in verifyRsaFingerprint sha pinset -runGalley :: Env -> Request -> Galley a -> IO a +runGalley :: Env -> Request -> Galley GalleyEffects a -> IO a runGalley e r m = let e' = reqId .~ lookupReqId r $ e in evalGalley e' m -evalGalley :: Env -> Galley a -> IO a -evalGalley e m = runClient (e ^. cstate) (runReaderT (unGalley m) e) +evalGalley0 :: Env -> Sem GalleyEffects0 a -> IO a +evalGalley0 e = + runFinal @IO + . embedToFinal @IO + . P.runReader e + . P.runReader (e ^. cstate) + +evalGalley :: Env -> Galley GalleyEffects a -> IO a +evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders @@ -286,33 +325,33 @@ reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -fromJsonBody :: FromJSON a => JsonRequest a -> Galley a +fromJsonBody :: FromJSON a => JsonRequest a -> Galley r a fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} -fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley (Maybe a) +fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley r (Maybe a) fromOptionalJsonBody r = exceptT (throwM . invalidPayload) return (parseOptionalBody r) {-# INLINE fromOptionalJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> Galley a +fromProtoBody :: Proto.Decode a => Request -> Galley r a fromProtoBody r = do b <- readBody r either (throwM . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: Error -> Maybe a -> Galley a +ifNothing :: WaiError.Error -> Maybe a -> Galley r a ifNothing e = maybe (throwM e) return {-# INLINE ifNothing #-} -toServantHandler :: Env -> Galley a -> Servant.Handler a +toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do - eith <- liftIO $ try (evalGalley env galley) + eith <- liftIO $ Control.Exception.try (evalGalley env galley) case eith of Left werr -> handleWaiErrors (view applog env) (unRequestId (view reqId env)) werr Right result -> pure result where - handleWaiErrors :: Logger -> ByteString -> Error -> Servant.Handler a + handleWaiErrors :: Logger -> ByteString -> WaiError.Error -> Servant.Handler a handleWaiErrors logger reqId' werr = do Server.logError' logger (Just reqId') werr Servant.throwError $ @@ -320,3 +359,50 @@ toServantHandler env galley = do mkCode = statusCode . WaiError.code mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . WaiError.code + +---------------------------------------------------------------------------------- +---- temporary MonadUnliftIO support code for the polysemy refactoring + +fireAndForget :: Member FireAndForget r => Galley r () -> Galley r () +fireAndForget (Galley m) = Galley $ E.fireAndForget m + +spawnMany :: Member FireAndForget r => [Galley r ()] -> Galley r () +spawnMany ms = Galley $ E.spawnMany (map unGalley ms) + +instance MonadUnliftIO Galley0 where + askUnliftIO = Galley $ do + env <- P.ask @Env + pure $ UnliftIO $ evalGalley0 env . unGalley + +instance MonadMask Galley0 where + mask = UnliftIO.mask + uninterruptibleMask = UnliftIO.uninterruptibleMask + generalBracket acquire release useB = Galley $ do + env <- P.ask @Env + embed @IO $ + generalBracket + (evalGalley0 env (unGalley acquire)) + (\resource exitCase -> evalGalley0 env (unGalley (release resource exitCase))) + (\resource -> evalGalley0 env (unGalley (useB resource))) + +instance MonadCatch Galley0 where + catch = UnliftIO.catch + +liftGalley0 :: Galley0 a -> Galley r a +liftGalley0 (Galley m) = Galley $ subsume_ m + +liftSem :: Sem r a -> Galley r a +liftSem m = Galley m + +interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a +interpretGalleyToGalley0 = + Galley + . interpretFireAndForget + . interpretIntra + . interpretBot + . interpretFederator + . interpretExternal + . interpretSpar + . interpretGundeck + . interpretBrig + . unGalley diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 04353e202e9..4d2e02de642 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -111,6 +111,7 @@ module Galley.Data -- * Clients eraseClients, lookupClients, + lookupClients', updateClient, -- * Utilities @@ -129,7 +130,7 @@ import Cassandra.Util import Control.Arrow (second) import Control.Exception (ErrorCall (ErrorCall)) import Control.Lens hiding ((<|)) -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch (throwM) import Control.Monad.Extra (ifM) import Data.ByteString.Conversion hiding (parser) import Data.Domain (Domain) @@ -170,10 +171,8 @@ import Galley.Types.Teams.Intra import Galley.Types.UserList import Galley.Validation import Imports hiding (Set, max) -import System.Logger.Class (MonadLogger) import qualified System.Logger.Class as Log -import UnliftIO (async, mapConcurrently, wait) -import UnliftIO.Async (pooledMapConcurrentlyN) +import qualified UnliftIO import Wire.API.Team.Member -- We use this newtype to highlight the fact that the 'Page' wrapped in here @@ -210,7 +209,7 @@ schemaVersion :: Int32 schemaVersion = 53 -- | Insert a conversation code -insertCode :: MonadClient m => Code -> m () +insertCode :: Code -> Galley r () insertCode c = do let k = codeKey c let v = codeValue c @@ -220,16 +219,16 @@ insertCode c = do retry x5 (write Cql.insertCode (params Quorum (k, v, cnv, s, t))) -- | Lookup a conversation by code. -lookupCode :: MonadClient m => Key -> Scope -> m (Maybe Code) +lookupCode :: Key -> Scope -> Galley r (Maybe Code) lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params Quorum (k, s))) -- | Delete a code associated with the given conversation key -deleteCode :: MonadClient m => Key -> Scope -> m () +deleteCode :: Key -> Scope -> Galley r () deleteCode k s = retry x5 $ write Cql.deleteCode (params Quorum (k, s)) -- Teams -------------------------------------------------------------------- -team :: MonadClient m => TeamId -> m (Maybe TeamData) +team :: TeamId -> Galley r (Maybe TeamData) team tid = fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params Quorum (Identity tid))) where @@ -238,16 +237,16 @@ team tid = status = if d then PendingDelete else fromMaybe Active s in TeamData t status (writeTimeToUTC <$> st) -teamName :: MonadClient m => TeamId -> m (Maybe Text) +teamName :: TeamId -> Galley r (Maybe Text) teamName tid = fmap runIdentity <$> retry x1 (query1 Cql.selectTeamName (params Quorum (Identity tid))) -teamIdsOf :: MonadClient m => UserId -> Range 1 32 (List TeamId) -> m [TeamId] +teamIdsOf :: UserId -> Range 1 32 (List TeamId) -> Galley r [TeamId] teamIdsOf usr (fromList . fromRange -> tids) = map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params Quorum (usr, tids))) -teamIdsFrom :: MonadClient m => UserId -> Maybe TeamId -> Range 1 100 Int32 -> m (ResultSet TeamId) +teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (ResultSet TeamId) teamIdsFrom usr range (fromRange -> max) = mkResultSet . fmap runIdentity . strip <$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) @@ -255,32 +254,32 @@ teamIdsFrom usr range (fromRange -> max) = where strip p = p {result = take (fromIntegral max) (result p)} -teamIdsForPagination :: MonadClient m => UserId -> Maybe TeamId -> Range 1 100 Int32 -> m (Page TeamId) +teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (Page TeamId) teamIdsForPagination usr range (fromRange -> max) = fmap runIdentity <$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) max) Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) max) -teamConversation :: MonadClient m => TeamId -> ConvId -> m (Maybe TeamConversation) +teamConversation :: TeamId -> ConvId -> Galley r (Maybe TeamConversation) teamConversation t c = fmap (newTeamConversation c . runIdentity) <$> retry x1 (query1 Cql.selectTeamConv (params Quorum (t, c))) -teamConversations :: MonadClient m => TeamId -> m [TeamConversation] +teamConversations :: TeamId -> Galley r [TeamConversation] teamConversations t = map (uncurry newTeamConversation) <$> retry x1 (query Cql.selectTeamConvs (params Quorum (Identity t))) -teamConversationsForPagination :: MonadClient m => TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> m (Page TeamConversation) +teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page TeamConversation) teamConversationsForPagination tid start (fromRange -> max) = fmap (uncurry newTeamConversation) <$> case start of Just c -> paginate Cql.selectTeamConvsFrom (paramsP Quorum (tid, c) max) Nothing -> paginate Cql.selectTeamConvs (paramsP Quorum (Identity tid) max) -teamMembersForFanout :: TeamId -> Galley TeamMemberList +teamMembersForFanout :: TeamId -> Galley r TeamMemberList teamMembersForFanout t = fanoutLimit >>= teamMembersWithLimit t -teamMembersWithLimit :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> Range 1 HardTruncationLimit Int32 -> m TeamMemberList +teamMembersWithLimit :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley r TeamMemberList teamMembersWithLimit t (fromRange -> limit) = do -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP Quorum (Identity t) (limit + 1))) @@ -293,7 +292,7 @@ teamMembersWithLimit t (fromRange -> limit) = do -- This function has a bit of a difficult type to work with because we don't have a pure function of type -- (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> TeamMember so we -- cannot fmap over the ResultSet. We don't want to mess around with the Result size nextPage either otherwise -teamMembersForPagination :: MonadClient m => TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> m (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) +teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) teamMembersForPagination tid start (fromRange -> max) = case start of Just u -> paginate Cql.selectTeamMembersFrom (paramsP Quorum (tid, u) max) @@ -301,7 +300,7 @@ teamMembersForPagination tid start (fromRange -> max) = -- NOTE: Use this function with care... should only be required when deleting a team! -- Maybe should be left explicitly for the caller? -teamMembersCollectedWithPagination :: TeamId -> Galley [TeamMember] +teamMembersCollectedWithPagination :: TeamId -> Galley r [TeamMember] teamMembersCollectedWithPagination tid = do mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) collectTeamMembersPaginated [] mems @@ -315,38 +314,43 @@ teamMembersCollectedWithPagination tid = do -- Lookup only specific team members: this is particularly useful for large teams when -- needed to look up only a small subset of members (typically 2, user to perform the action -- and the target user) -teamMembersLimited :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> [UserId] -> m [TeamMember] +teamMembersLimited :: TeamId -> [UserId] -> Galley r [TeamMember] teamMembersLimited t u = mapM (newTeamMember' t) =<< retry x1 (query Cql.selectTeamMembers' (params Quorum (t, u))) -teamMember :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> UserId -> m (Maybe TeamMember) +teamMember :: TeamId -> UserId -> Galley r (Maybe TeamMember) teamMember t u = newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params Quorum (t, u))) where newTeamMember'' :: UserId -> Maybe (Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> - m (Maybe TeamMember) + Galley r (Maybe TeamMember) newTeamMember'' _ Nothing = pure Nothing newTeamMember'' uid (Just (perms, minvu, minvt, mulhStatus)) = Just <$> newTeamMember' t (uid, perms, minvu, minvt, mulhStatus) -userTeams :: MonadClient m => UserId -> m [TeamId] +userTeams :: UserId -> Galley r [TeamId] userTeams u = map runIdentity <$> retry x1 (query Cql.selectUserTeams (params Quorum (Identity u))) -usersTeams :: (MonadUnliftIO m, MonadClient m) => [UserId] -> m (Map UserId TeamId) -usersTeams uids = do - pairs :: [(UserId, TeamId)] <- catMaybes <$> pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeam uid) uids +usersTeams :: [UserId] -> Galley r (Map UserId TeamId) +usersTeams uids = liftClient $ do + pairs :: [(UserId, TeamId)] <- + catMaybes + <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeamC uid) uids pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs -oneUserTeam :: MonadClient m => UserId -> m (Maybe TeamId) -oneUserTeam u = +oneUserTeam :: UserId -> Galley r (Maybe TeamId) +oneUserTeam = liftClient . oneUserTeamC + +oneUserTeamC :: UserId -> Client (Maybe TeamId) +oneUserTeamC u = fmap runIdentity <$> retry x1 (query1 Cql.selectOneUserTeam (params Quorum (Identity u))) -teamCreationTime :: MonadClient m => TeamId -> m (Maybe TeamCreationTime) +teamCreationTime :: TeamId -> Galley r (Maybe TeamCreationTime) teamCreationTime t = checkCreation . fmap runIdentity <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params Quorum (Identity t))) @@ -354,20 +358,19 @@ teamCreationTime t = checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts checkCreation _ = Nothing -teamBinding :: MonadClient m => TeamId -> m (Maybe TeamBinding) +teamBinding :: TeamId -> Galley r (Maybe TeamBinding) teamBinding t = fmap (fromMaybe NonBinding . runIdentity) <$> retry x1 (query1 Cql.selectTeamBinding (params Quorum (Identity t))) createTeam :: - MonadClient m => Maybe TeamId -> UserId -> Range 1 256 Text -> Range 1 256 Text -> Maybe (Range 1 256 Text) -> TeamBinding -> - m Team + Galley r Team createTeam t uid (fromRange -> n) (fromRange -> i) k b = do tid <- maybe (Id <$> liftIO nextRandom) return t retry x5 $ write Cql.insertTeam (params Quorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) @@ -376,7 +379,7 @@ createTeam t uid (fromRange -> n) (fromRange -> i) k b = do initialStatus Binding = PendingActive -- Team becomes Active after User account activation initialStatus NonBinding = Active -deleteTeam :: forall m. (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> m () +deleteTeam :: TeamId -> Galley r () deleteTeam tid = do -- TODO: delete service_whitelist records that mention this team retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) @@ -386,7 +389,7 @@ deleteTeam tid = do removeConvs cnvs retry x5 $ write Cql.deleteTeam (params Quorum (Deleted, tid)) where - removeConvs :: Page TeamConversation -> m () + removeConvs :: Page TeamConversation -> Galley r () removeConvs cnvs = do for_ (result cnvs) $ removeTeamConv tid . view conversationId unless (null $ result cnvs) $ @@ -400,13 +403,13 @@ deleteTeam tid = do Maybe UTCTimeMillis, Maybe UserLegalHoldStatus ) -> - m () + Galley r () removeTeamMembers mems = do mapM_ (removeTeamMember tid . view _1) (result mems) unless (null $ result mems) $ removeTeamMembers =<< liftClient (nextPage mems) -addTeamMember :: MonadClient m => TeamId -> TeamMember -> m () +addTeamMember :: TeamId -> TeamMember -> Galley r () addTeamMember t m = retry x5 . batch $ do setType BatchLogged @@ -424,14 +427,13 @@ addTeamMember t m = addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) updateTeamMember :: - MonadClient m => -- | Old permissions, used for maintaining 'billing_team_member' table Permissions -> TeamId -> UserId -> -- | New permissions Permissions -> - m () + Galley r () updateTeamMember oldPerms tid uid newPerms = do retry x5 . batch $ do setType BatchLogged @@ -448,7 +450,7 @@ updateTeamMember oldPerms tid uid newPerms = do acquiredPerms = newPerms `permDiff` oldPerms lostPerms = oldPerms `permDiff` newPerms -removeTeamMember :: MonadClient m => TeamId -> UserId -> m () +removeTeamMember :: TeamId -> UserId -> Galley r () removeTeamMember t m = retry x5 . batch $ do setType BatchLogged @@ -457,12 +459,12 @@ removeTeamMember t m = addPrepQuery Cql.deleteUserTeam (m, t) addPrepQuery Cql.deleteBillingTeamMember (t, m) -listBillingTeamMembers :: MonadClient m => TeamId -> m [UserId] +listBillingTeamMembers :: TeamId -> Galley r [UserId] listBillingTeamMembers tid = fmap runIdentity <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) -removeTeamConv :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> ConvId -> m () +removeTeamConv :: TeamId -> ConvId -> Galley r () removeTeamConv tid cid = do retry x5 . batch $ do setType BatchLogged @@ -471,10 +473,10 @@ removeTeamConv tid cid = do addPrepQuery Cql.deleteTeamConv (tid, cid) deleteConversation cid -updateTeamStatus :: MonadClient m => TeamId -> TeamStatus -> m () +updateTeamStatus :: TeamId -> TeamStatus -> Galley r () updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) -updateTeam :: MonadClient m => TeamId -> TeamUpdateData -> m () +updateTeam :: TeamId -> TeamUpdateData -> Galley r () updateTeam tid u = retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -487,7 +489,7 @@ updateTeam tid u = retry x5 . batch $ do -- Conversations ------------------------------------------------------------ -isConvAlive :: MonadClient m => ConvId -> m Bool +isConvAlive :: ConvId -> Galley r Bool isConvAlive cid = do result <- retry x1 (query1 Cql.isConvDeleted (params Quorum (Identity cid))) case runIdentity <$> result of @@ -496,38 +498,39 @@ isConvAlive cid = do Just (Just True) -> pure False Just (Just False) -> pure True -conversation :: - (MonadUnliftIO m, MonadClient m, Log.MonadLogger m, MonadThrow m) => - ConvId -> - m (Maybe Conversation) -conversation conv = do - cdata <- async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) - remoteMems <- async $ lookupRemoteMembers conv - mbConv <- toConv conv <$> members conv <*> wait remoteMems <*> wait cdata +conversation :: ConvId -> Galley r (Maybe Conversation) +conversation conv = liftClient $ do + cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) + remoteMems <- UnliftIO.async $ lookupRemoteMembersC conv + mbConv <- + toConv conv + <$> membersC conv + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait cdata return mbConv >>= conversationGC {- "Garbage collect" the conversation, i.e. the conversation may be marked as deleted, in which case we delete it and return Nothing -} conversationGC :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => Maybe Conversation -> - m (Maybe Conversation) + Client (Maybe Conversation) conversationGC conv = case join (convDeleted <$> conv) of (Just True) -> do - sequence_ $ deleteConversation . convId <$> conv + sequence_ $ deleteConversationC . convId <$> conv return Nothing _ -> return conv -localConversations :: - (MonadLogger m, MonadUnliftIO m, MonadClient m) => - [ConvId] -> - m [Conversation] +localConversations :: [ConvId] -> Galley r [Conversation] localConversations [] = return [] localConversations ids = do - convs <- async fetchConvs - mems <- async $ memberLists ids - remoteMems <- async $ remoteMemberLists ids - cs <- zipWith4 toConv ids <$> wait mems <*> wait remoteMems <*> wait convs + cs <- liftClient $ do + convs <- UnliftIO.async fetchConvs + mems <- UnliftIO.async $ memberLists ids + remoteMems <- UnliftIO.async $ remoteMemberLists ids + zipWith4 toConv ids + <$> UnliftIO.wait mems + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait convs foldrM flatten [] (zip ids cs) where fetchConvs = do @@ -551,7 +554,7 @@ toConv cid mms remoteMems conv = where f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm -conversationMeta :: MonadClient m => Domain -> ConvId -> m (Maybe ConversationMetadata) +conversationMeta :: Domain -> ConvId -> Galley r (Maybe ConversationMetadata) conversationMeta _localDomain conv = fmap toConvMeta <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) @@ -569,11 +572,10 @@ conversationMeta _localDomain conv = -- | Deprecated, use 'localConversationIdsPageFrom' conversationIdsFrom :: - (MonadClient m) => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> - m (ResultSet ConvId) + Galley r (ResultSet ConvId) conversationIdsFrom usr start (fromRange -> max) = mkResultSet . strip . fmap runIdentity <$> case start of Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) @@ -582,19 +584,18 @@ conversationIdsFrom usr start (fromRange -> max) = strip p = p {result = take (fromIntegral max) (result p)} localConversationIdsPageFrom :: - (MonadClient m) => UserId -> Maybe PagingState -> Range 1 1000 Int32 -> - m (PageWithState ConvId) + Galley r (PageWithState ConvId) localConversationIdsPageFrom usr pagingState (fromRange -> max) = fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) -remoteConversationIdsPageFrom :: (MonadClient m) => UserId -> Maybe PagingState -> Int32 -> m (PageWithState (Qualified ConvId)) +remoteConversationIdsPageFrom :: UserId -> Maybe PagingState -> Int32 -> Galley r (PageWithState (Qualified ConvId)) remoteConversationIdsPageFrom usr pagingState max = uncurry (flip Qualified) <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) -localConversationIdRowsForPagination :: MonadClient m => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> m (Page ConvId) +localConversationIdRowsForPagination :: UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Galley r (Page ConvId) localConversationIdRowsForPagination usr start (fromRange -> max) = runIdentity <$$> case start of @@ -603,24 +604,24 @@ localConversationIdRowsForPagination usr start (fromRange -> max) = -- | Takes a list of conversation ids and returns those found for the given -- user. -localConversationIdsOf :: forall m. (MonadClient m, MonadUnliftIO m) => UserId -> [ConvId] -> m [ConvId] +localConversationIdsOf :: UserId -> [ConvId] -> Galley r [ConvId] localConversationIdsOf usr cids = do runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) -- | Takes a list of remote conversation ids and fetches member status flags -- for the given user remoteConversationStatus :: - (MonadClient m, MonadUnliftIO m) => UserId -> [Remote ConvId] -> - m (Map (Remote ConvId) MemberStatus) + Galley r (Map (Remote ConvId) MemberStatus) remoteConversationStatus uid = - fmap mconcat - . pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) + liftClient + . fmap mconcat + . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomainC uid) . bucketRemote -remoteConversationStatusOnDomain :: MonadClient m => UserId -> Remote [ConvId] -> m (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomain uid rconvs = +remoteConversationStatusOnDomainC :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomainC uid rconvs = Map.fromList . map toPair <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) where @@ -629,12 +630,11 @@ remoteConversationStatusOnDomain uid rconvs = toMemberStatus (omus, omur, oar, oarr, hid, hidr) ) -conversationsRemote :: (MonadClient m) => UserId -> m [Remote ConvId] +conversationsRemote :: UserId -> Galley r [Remote ConvId] conversationsRemote usr = do uncurry toRemoteUnsafe <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) createConversation :: - MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> [Access] -> @@ -645,7 +645,7 @@ createConversation :: Maybe Milliseconds -> Maybe ReceiptMode -> RoleName -> - m Conversation + Galley r Conversation createConversation lusr name acc role others tinfo mtimer recpt othersConversationRole = do conv <- Id <$> liftIO nextRandom let lconv = qualifyAs lusr conv @@ -662,7 +662,7 @@ createConversation lusr name acc role others tinfo mtimer recpt othersConversati (lmems, rmems) <- addMembers lconv (ulAddLocal (tUnqualified lusr, roleNameWireAdmin) newUsers) pure $ newConv conv RegularConv usr lmems rmems acc role name (cnvTeamId <$> tinfo) mtimer recpt -createSelfConversation :: MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> m Conversation +createSelfConversation :: Local UserId -> Maybe (Range 1 256 Text) -> Galley r Conversation createSelfConversation lusr name = do let usr = tUnqualified lusr conv = selfConv usr @@ -673,12 +673,11 @@ createSelfConversation lusr name = do pure $ newConv conv SelfConv usr lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing createConnectConversation :: - MonadClient m => Local x -> U.UUID U.V4 -> U.UUID U.V4 -> Maybe (Range 1 256 Text) -> - m Conversation + Galley r Conversation createConnectConversation loc a b name = do let conv = localOne2OneConvId a b lconv = qualifyAs loc conv @@ -691,11 +690,10 @@ createConnectConversation loc a b name = do pure $ newConv conv ConnectConv a' lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing createConnectConversationWithRemote :: - MonadClient m => Local ConvId -> Local UserId -> UserList UserId -> - m () + Galley r () createConnectConversationWithRemote lconvId creator m = do retry x5 $ write Cql.insertConv (params Quorum (tUnqualified lconvId, ConnectConv, tUnqualified creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) @@ -704,13 +702,12 @@ createConnectConversationWithRemote lconvId creator m = do void $ addMembers lconvId m createLegacyOne2OneConversation :: - MonadClient m => Local x -> U.UUID U.V4 -> U.UUID U.V4 -> Maybe (Range 1 256 Text) -> Maybe TeamId -> - m Conversation + Galley r Conversation createLegacyOne2OneConversation loc a b name ti = do let conv = localOne2OneConvId a b lconv = qualifyAs loc conv @@ -724,13 +721,12 @@ createLegacyOne2OneConversation loc a b name ti = do ti createOne2OneConversation :: - MonadClient m => Local ConvId -> Local UserId -> Qualified UserId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> - m Conversation + Galley r Conversation createOne2OneConversation lconv self other name mtid = do retry x5 $ case mtid of Nothing -> write Cql.insertConv (params Quorum (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) @@ -742,38 +738,41 @@ createOne2OneConversation lconv self other name mtid = do (lmems, rmems) <- addMembers lconv (toUserList self [qUntagged self, other]) pure $ newConv (tUnqualified lconv) One2OneConv (tUnqualified self) lmems rmems [PrivateAccess] privateRole name mtid Nothing Nothing -updateConversation :: MonadClient m => ConvId -> Range 1 256 Text -> m () +updateConversation :: ConvId -> Range 1 256 Text -> Galley r () updateConversation cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) -updateConversationAccess :: MonadClient m => ConvId -> ConversationAccessData -> m () +updateConversationAccess :: ConvId -> ConversationAccessData -> Galley r () updateConversationAccess cid (ConversationAccessData acc role) = retry x5 $ write Cql.updateConvAccess (params Quorum (Set (toList acc), role, cid)) -updateConversationReceiptMode :: MonadClient m => ConvId -> ReceiptMode -> m () +updateConversationReceiptMode :: ConvId -> ReceiptMode -> Galley r () updateConversationReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params Quorum (receiptMode, cid)) -lookupReceiptMode :: MonadClient m => ConvId -> m (Maybe ReceiptMode) +lookupReceiptMode :: ConvId -> Galley r (Maybe ReceiptMode) lookupReceiptMode cid = join . fmap runIdentity <$> retry x1 (query1 Cql.selectReceiptMode (params Quorum (Identity cid))) -updateConversationMessageTimer :: MonadClient m => ConvId -> Maybe Milliseconds -> m () +updateConversationMessageTimer :: ConvId -> Maybe Milliseconds -> Galley r () updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) -deleteConversation :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m () -deleteConversation cid = do +deleteConversation :: ConvId -> Galley r () +deleteConversation = liftClient . deleteConversationC + +deleteConversationC :: ConvId -> Client () +deleteConversationC cid = do retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) - localMembers <- members cid + localMembers <- membersC cid for_ (nonEmpty localMembers) $ \ms -> - removeLocalMembersFromLocalConv cid (lmId <$> ms) + removeLocalMembersFromLocalConvC cid (lmId <$> ms) - remoteMembers <- lookupRemoteMembers cid + remoteMembers <- lookupRemoteMembersC cid for_ (nonEmpty remoteMembers) $ \ms -> - removeRemoteMembersFromLocalConv cid (rmId <$> ms) + removeRemoteMembersFromLocalConvC cid (rmId <$> ms) retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) -acceptConnect :: MonadClient m => ConvId -> m () +acceptConnect :: ConvId -> Galley r () acceptConnect cid = retry x5 $ write Cql.updateConvType (params Quorum (One2OneConv, cid)) -- | We deduce the conversation ID by adding the 4 components of the V4 UUID @@ -863,18 +862,14 @@ privateOnly = Set [PrivateAccess] -- Conversation Members ----------------------------------------------------- member :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> UserId -> - m (Maybe LocalMember) + Galley r (Maybe LocalMember) member cnv usr = (toMember =<<) <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) -remoteMemberLists :: - (MonadClient m) => - [ConvId] -> - m [[RemoteMember]] +remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] remoteMemberLists convs = do mems <- retry x1 $ query Cql.selectRemoteMembers (params Quorum (Identity convs)) let convMembers = foldr (insert . mkMem) Map.empty mems @@ -888,10 +883,7 @@ remoteMemberLists convs = do toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) -memberLists :: - (MonadClient m, MonadThrow m) => - [ConvId] -> - m [[LocalMember]] +memberLists :: [ConvId] -> Client [[LocalMember]] memberLists convs = do mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems @@ -904,14 +896,20 @@ memberLists convs = do mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) -members :: (MonadClient m, MonadThrow m) => ConvId -> m [LocalMember] -members conv = join <$> memberLists [conv] +members :: ConvId -> Galley r [LocalMember] +members = liftClient . membersC + +membersC :: ConvId -> Client [LocalMember] +membersC = fmap concat . liftClient . memberLists . pure -lookupRemoteMembers :: (MonadClient m) => ConvId -> m [RemoteMember] -lookupRemoteMembers conv = join <$> remoteMemberLists [conv] +lookupRemoteMembers :: ConvId -> Galley r [RemoteMember] +lookupRemoteMembers = liftClient . lookupRemoteMembersC + +lookupRemoteMembersC :: ConvId -> Client [RemoteMember] +lookupRemoteMembersC conv = join <$> remoteMemberLists [conv] -- | Add a member to a local conversation, as an admin. -addMember :: MonadClient m => Local ConvId -> Local UserId -> m [LocalMember] +addMember :: Local ConvId -> Local UserId -> Galley r [LocalMember] addMember c u = fst <$> addMembers c (UserList [tUnqualified u] []) class ToUserRole a where @@ -932,12 +930,7 @@ toQualifiedUserRole = requalify . fmap toUserRole -- Conversation is local, so we can add any member to it (including remote ones). -- When the role is not specified, it defaults to admin. -- Please make sure the conversation doesn't exceed the maximum size! -addMembers :: - forall m a. - (MonadClient m, ToUserRole a) => - Local ConvId -> - UserList a -> - m ([LocalMember], [RemoteMember]) +addMembers :: ToUserRole a => Local ConvId -> UserList a -> Galley r ([LocalMember], [RemoteMember]) addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do -- batch statement with 500 users are known to be above the batch size limit -- and throw "Batch too large" errors. Therefor we chunk requests and insert @@ -973,7 +966,7 @@ addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = -- | Set local users as belonging to a remote conversation. This is invoked by a -- remote galley when users from the current backend are added to conversations -- on the remote end. -addLocalMembersToRemoteConv :: MonadClient m => Remote ConvId -> [UserId] -> m () +addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Galley r () addLocalMembersToRemoteConv _ [] = pure () addLocalMembersToRemoteConv rconv users = do -- FUTUREWORK: consider using pooledMapConcurrentlyN @@ -987,20 +980,18 @@ addLocalMembersToRemoteConv rconv users = do (u, tDomain rconv, tUnqualified rconv) updateSelfMember :: - MonadClient m => Local x -> Qualified ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMember loc = foldQualified loc updateSelfMemberLocalConv updateSelfMemberRemoteConv updateSelfMemberLocalConv :: - MonadClient m => Local ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMemberLocalConv lcid luid mup = do retry x5 . batch $ do setType BatchUnLogged @@ -1019,11 +1010,10 @@ updateSelfMemberLocalConv lcid luid mup = do (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) updateSelfMemberRemoteConv :: - MonadClient m => Remote ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do retry x5 . batch $ do setType BatchUnLogged @@ -1042,20 +1032,18 @@ updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do (h, mupHiddenRef mup, domain, cid, tUnqualified luid) updateOtherMember :: - MonadClient m => Local x -> Qualified ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMember loc = foldQualified loc updateOtherMemberLocalConv updateOtherMemberRemoteConv updateOtherMemberLocalConv :: - MonadClient m => Local ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMemberLocalConv lcid quid omu = do let addQuery r @@ -1074,34 +1062,36 @@ updateOtherMemberLocalConv lcid quid omu = -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-887 updateOtherMemberRemoteConv :: - MonadClient m => Remote ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMemberRemoteConv _ _ _ = pure () -- | Select only the members of a remote conversation from a list of users. -- Return the filtered list and a boolean indicating whether the all the input -- users are members. -filterRemoteConvMembers :: (MonadUnliftIO m, MonadClient m) => [UserId] -> Qualified ConvId -> m ([UserId], Bool) +filterRemoteConvMembers :: + [UserId] -> + Qualified ConvId -> + Galley r ([UserId], Bool) filterRemoteConvMembers users (Qualified conv dom) = - fmap Data.Monoid.getAll - . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) - <$> pooledMapConcurrentlyN 8 filterMember users + liftClient $ + fmap Data.Monoid.getAll + . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) + <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users where - filterMember :: MonadClient m => UserId -> m [UserId] + filterMember :: UserId -> Client [UserId] filterMember user = fmap (map runIdentity) . retry x1 $ query Cql.selectRemoteConvMembers (params Quorum (user, dom, conv)) -removeLocalMembersFromLocalConv :: - MonadClient m => - ConvId -> - NonEmpty UserId -> - m () -removeLocalMembersFromLocalConv cnv victims = do +removeLocalMembersFromLocalConv :: ConvId -> NonEmpty UserId -> Galley r () +removeLocalMembersFromLocalConv cnv = liftClient . removeLocalMembersFromLocalConvC cnv + +removeLocalMembersFromLocalConvC :: ConvId -> NonEmpty UserId -> Client () +removeLocalMembersFromLocalConvC cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1109,12 +1099,11 @@ removeLocalMembersFromLocalConv cnv victims = do addPrepQuery Cql.removeMember (cnv, victim) addPrepQuery Cql.deleteUserConv (victim, cnv) -removeRemoteMembersFromLocalConv :: - MonadClient m => - ConvId -> - NonEmpty (Remote UserId) -> - m () -removeRemoteMembersFromLocalConv cnv victims = do +removeRemoteMembersFromLocalConv :: ConvId -> NonEmpty (Remote UserId) -> Galley r () +removeRemoteMembersFromLocalConv cnv = liftClient . removeRemoteMembersFromLocalConvC cnv + +removeRemoteMembersFromLocalConvC :: ConvId -> NonEmpty (Remote UserId) -> Client () +removeRemoteMembersFromLocalConvC cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1122,12 +1111,11 @@ removeRemoteMembersFromLocalConv cnv victims = do addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) removeLocalMembersFromRemoteConv :: - MonadClient m => -- | The conversation to remove members from Remote ConvId -> -- | Members to remove local to this backend [UserId] -> - m () + Galley r () removeLocalMembersFromRemoteConv _ [] = pure () removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = retry x5 . batch $ do @@ -1135,7 +1123,7 @@ removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victim setConsistency Quorum for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) -removeMember :: MonadClient m => UserId -> ConvId -> m () +removeMember :: UserId -> ConvId -> Galley r () removeMember usr cnv = retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1213,25 +1201,26 @@ toMember _ = Nothing -- Clients ------------------------------------------------------------------ -updateClient :: MonadClient m => Bool -> UserId -> ClientId -> m () +updateClient :: Bool -> UserId -> ClientId -> Galley r () updateClient add usr cls = do let q = if add then Cql.addMemberClient else Cql.rmMemberClient retry x5 $ write (q cls) (params Quorum (Identity usr)) -- Do, at most, 16 parallel lookups of up to 128 users each -lookupClients :: - (MonadClient m, MonadUnliftIO m) => - [UserId] -> - m Clients -lookupClients users = +lookupClients :: [UserId] -> Galley r Clients +lookupClients = liftClient . lookupClients' + +-- This is only used by tests +lookupClients' :: [UserId] -> Client Clients +lookupClients' users = Clients.fromList . concat . concat - <$> forM (chunksOf 2048 users) (mapConcurrently getClients . chunksOf 128) + <$> forM (chunksOf 2048 users) (UnliftIO.mapConcurrently getClients . chunksOf 128) where getClients us = map (second fromSet) <$> retry x1 (query Cql.selectClients (params Quorum (Identity us))) -eraseClients :: MonadClient m => UserId -> m () +eraseClients :: UserId -> Galley r () eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user))) -- Internal utilities @@ -1242,11 +1231,11 @@ eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user) -- -- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the -- other is 'Just', which can only be caused by inconsistent database content. -newTeamMember' :: (MonadIO m, MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> m TeamMember +newTeamMember' :: TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> Galley r TeamMember newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do mk minvu minvt >>= maybeGrant where - maybeGrant :: (MonadClient m, MonadReader Env m) => TeamMember -> m TeamMember + maybeGrant :: TeamMember -> Galley r TeamMember maybeGrant m = ifM (isTeamLegalholdWhitelisted tid) @@ -1271,8 +1260,8 @@ newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus - -- which are looked up based on: withTeamMembersWithChunks :: TeamId -> - ([TeamMember] -> Galley ()) -> - Galley () + ([TeamMember] -> Galley r ()) -> + Galley r () withTeamMembersWithChunks tid action = do mems <- teamMembersForPagination tid Nothing (unsafeRange hardTruncationLimit) handleMembers mems diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index 3d4f01108ed..f47bf123648 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -67,7 +67,7 @@ botMemId = BotId . lmId . fromBotMember botMemService :: BotMember -> ServiceRef botMemService = fromJust . lmService . fromBotMember -addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley (Event, BotMember) +addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley r (Event, BotMember) addBotMember qorig s bot cnv now = do retry x5 . batch $ do setType BatchLogged diff --git a/services/galley/src/Galley/Data/TeamNotifications.hs b/services/galley/src/Galley/Data/TeamNotifications.hs index 1922c1580ab..d5c7689538f 100644 --- a/services/galley/src/Galley/Data/TeamNotifications.hs +++ b/services/galley/src/Galley/Data/TeamNotifications.hs @@ -37,6 +37,7 @@ import Data.List1 (List1) import Data.Range (Range, fromRange) import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) import qualified Data.Sequence as Seq +import Galley.App import Gundeck.Types.Notification import Imports @@ -51,11 +52,10 @@ data ResultPage = ResultPage -- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned add :: - (MonadClient m, MonadUnliftIO m) => TeamId -> NotificationId -> List1 JSON.Object -> - m () + Galley r () add tid nid (Blob . JSON.encode -> payload) = write cqlInsert (params Quorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 where @@ -69,7 +69,7 @@ add tid nid (Blob . JSON.encode -> payload) = notificationTTLSeconds :: Int32 notificationTTLSeconds = 24192200 -fetch :: forall m. MonadClient m => TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> m ResultPage +fetch :: TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r ResultPage fetch tid since (fromRange -> size) = do -- We always need to look for one more than requested in order to correctly -- report whether there are more results. @@ -90,7 +90,11 @@ fetch tid since (fromRange -> size) = do EmptyL -> ResultPage Seq.empty False (x :< xs) -> ResultPage (x <| xs) more where - collect :: Seq QueuedNotification -> Int -> Page (TimeUuid, Blob) -> m (Seq QueuedNotification, Bool) + collect :: + Seq QueuedNotification -> + Int -> + Page (TimeUuid, Blob) -> + Galley r (Seq QueuedNotification, Bool) collect acc num page = let ns = splitAt num $ foldr toNotif [] (result page) nseq = Seq.fromList (fst ns) diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs new file mode 100644 index 00000000000..78aceb69541 --- /dev/null +++ b/services/galley/src/Galley/Effects.hs @@ -0,0 +1,109 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects + ( -- * Effects needed in Galley + GalleyEffects1, + + -- * Internal services + Intra, + interpretIntra, + + -- * Brig + BrigAccess, + interpretBrig, + + -- * Federator + FederatorAccess, + interpretFederator, + + -- * Spar + SparAccess, + interpretSpar, + + -- * Gundeck + GundeckAccess, + interpretGundeck, + + -- * External services + ExternalAccess, + interpretExternal, + + -- * Bot API + BotAccess, + interpretBot, + + -- * Fire-and-forget async + FireAndForget, + interpretFireAndForget, + + -- * Polysemy re-exports + Member, + Members, + ) +where + +import Galley.Effects.FireAndForget +import Imports +import Polysemy + +data Intra m a + +interpretIntra :: Sem (Intra ': r) a -> Sem r a +interpretIntra = interpret $ \case + +data BrigAccess m a + +interpretBrig :: Sem (BrigAccess ': r) a -> Sem r a +interpretBrig = interpret $ \case + +data GundeckAccess m a + +interpretGundeck :: Sem (GundeckAccess ': r) a -> Sem r a +interpretGundeck = interpret $ \case + +data ExternalAccess m a + +interpretExternal :: Sem (ExternalAccess ': r) a -> Sem r a +interpretExternal = interpret $ \case + +data FederatorAccess m a + +interpretFederator :: Sem (FederatorAccess ': r) a -> Sem r a +interpretFederator = interpret $ \case + +data SparAccess m a + +interpretSpar :: Sem (SparAccess ': r) a -> Sem r a +interpretSpar = interpret $ \case + +data BotAccess m a + +interpretBot :: Sem (BotAccess ': r) a -> Sem r a +interpretBot = interpret $ \case + +-- All the possible high-level effects. +type GalleyEffects1 = + '[ BrigAccess, + GundeckAccess, + SparAccess, + ExternalAccess, + FederatorAccess, + BotAccess, + Intra, + FireAndForget + ] diff --git a/services/galley/src/Galley/Effects/FireAndForget.hs b/services/galley/src/Galley/Effects/FireAndForget.hs new file mode 100644 index 00000000000..4b614862a35 --- /dev/null +++ b/services/galley/src/Galley/Effects/FireAndForget.hs @@ -0,0 +1,48 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.FireAndForget + ( FireAndForget, + fireAndForget, + spawnMany, + interpretFireAndForget, + ) +where + +import Imports +import Polysemy +import Polysemy.Final +import UnliftIO.Async (pooledMapConcurrentlyN_) + +data FireAndForget m a where + FireAndForgetOne :: m () -> FireAndForget m () + SpawnMany :: [m ()] -> FireAndForget m () + +makeSem ''FireAndForget + +fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () +fireAndForget = fireAndForgetOne + +interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a +interpretFireAndForget = interpretFinal @IO $ \case + FireAndForgetOne action -> do + action' <- runS action + liftS $ void . forkIO . void $ action' + SpawnMany actions -> do + actions' <- traverse runS actions + -- I picked this number by fair dice roll, feel free to change it :P + liftS $ pooledMapConcurrentlyN_ 8 void actions' diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index 4b8b7994a82..eb2024ee2d7 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -17,6 +17,8 @@ module Galley.External ( deliver, + deliverAndDeleteAsync, + deliverAsync, ) where @@ -25,10 +27,13 @@ import Bilge.Retry (httpHandlers) import Control.Lens import Control.Retry import Data.ByteString.Conversion.To +import Data.Id import Data.Misc import Galley.App import Galley.Data.Services (BotMember, botMemId, botMemService) import qualified Galley.Data.Services as Data +import Galley.Effects +import Galley.Intra.User import Galley.Types (Event) import Galley.Types.Bot import Imports @@ -41,22 +46,41 @@ import System.Logger.Message (field, msg, val, (~~)) import URI.ByteString import UnliftIO (Async, async, waitCatch) +-- | Like deliver, but ignore orphaned bots and return immediately. +-- +-- FUTUREWORK: Check if this can be removed. +deliverAsync :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r () +deliverAsync = liftGalley0 . void . forkIO . void . deliver0 + +-- | Like deliver, but remove orphaned bots and return immediately. +deliverAndDeleteAsync :: + Members '[ExternalAccess, BotAccess] r => + ConvId -> + [(BotMember, Event)] -> + Galley r () +deliverAndDeleteAsync cnv pushes = liftGalley0 . void . forkIO $ do + gone <- liftGalley0 $ deliver0 pushes + mapM_ (deleteBot0 cnv . botMemId) gone + -- | Deliver events to external (bot) services. -- -- Returns those bots which are found to be orphaned by the external -- service, e.g. when the service tells us that it no longer knows about the -- bot. -deliver :: [(BotMember, Event)] -> Galley [BotMember] -deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) +deliver :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r [BotMember] +deliver = liftGalley0 . deliver0 + +deliver0 :: [(BotMember, Event)] -> Galley0 [BotMember] +deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, Event) -> Galley Bool + exec :: (BotMember, Event) -> Galley0 Bool exec (b, e) = Data.lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e return True - eval :: [BotMember] -> (BotMember, Async Bool) -> Galley [BotMember] + eval :: [BotMember] -> (BotMember, Async Bool) -> Galley r [BotMember] eval gone (b, a) = do let s = botMemService b r <- waitCatch a @@ -95,7 +119,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: Service -> BotMember -> Event -> Galley () +deliver1 :: Service -> BotMember -> Event -> Galley0 () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) @@ -125,7 +149,7 @@ urlPort (HttpsUrl u) = do p <- a ^. authorityPortL return (fromIntegral (p ^. portNumberL)) -sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley () +sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley r () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 67d2f6bd9ac..133b4cf4134 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -67,7 +67,7 @@ import URI.ByteString (uriPath) -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. -checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley () +checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder if @@ -83,7 +83,7 @@ checkLegalHoldServiceStatus fpr url = do . Bilge.expect2xx -- | @POST /initiate@. -requestNewDevice :: TeamId -> UserId -> Galley NewLegalHoldClient +requestNewDevice :: TeamId -> UserId -> Galley r NewLegalHoldClient requestNewDevice tid uid = do resp <- makeLegalHoldServiceRequest tid reqParams case eitherDecode (responseBody resp) of @@ -107,7 +107,7 @@ confirmLegalHold :: UserId -> -- | TODO: Replace with 'LegalHold' token type OpaqueAuthToken -> - Galley () + Galley r () confirmLegalHold clientId tid uid legalHoldAuthToken = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -123,7 +123,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do removeLegalHold :: TeamId -> UserId -> - Galley () + Galley r () removeLegalHold tid uid = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -140,7 +140,7 @@ removeLegalHold tid uid = do -- | Lookup legal hold service settings for a team and make a request to the service. Pins -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. -makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do maybeLHSettings <- LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of @@ -157,7 +157,7 @@ makeLegalHoldServiceRequest tid reqBuilder = do reqBuilder . Bilge.header "Authorization" ("Bearer " <> toByteString' token) -makeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeVerifiedRequest fpr url reqBuilder = do (mgr, verifyFingerprints) <- view (extEnv . extGetManager) makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder @@ -166,23 +166,24 @@ makeVerifiedRequest fpr url reqBuilder = do -- We should really _only_ use it in `checkLegalHoldServiceStatus` for the time being because -- this is where we check for signatures, etc. If we reuse the manager, we are likely to reuse -- an existing connection which will _not_ cause the new public key to be verified. -makeVerifiedRequestFreshManager :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeVerifiedRequestFreshManager :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeVerifiedRequestFreshManager fpr url reqBuilder = do ExtEnv (mgr, verifyFingerprints) <- liftIO initExtEnv makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder -- | Check that the given fingerprint is valid and make the request over ssl. -- If the team has a device registered use 'makeLegalHoldServiceRequest' instead. -makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do let verified = verifyFingerprints [fpr] - extHandleAll errHandler $ do - recovering x3 httpHandlers $ - const $ - liftIO $ - withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ - \req -> - Http.httpLbs req mgr + liftGalley0 $ + extHandleAll errHandler $ do + recovering x3 httpHandlers $ + const $ + liftIO $ + withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ + \req -> + Http.httpLbs req mgr where reqBuilderMods = maybe id Bilge.host (Bilge.extHost url) diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index b45043dac89..f0a941d0a39 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -39,6 +39,7 @@ import qualified Data.Set as Set import Data.Text.Encoding import Galley.API.Error import Galley.App +import Galley.Effects import Galley.External.LegalHoldService import Galley.Intra.Util import Imports @@ -49,11 +50,11 @@ import qualified System.Logger.Class as Logger import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull) -- | Calls 'Brig.API.internalListClientsH'. -lookupClients :: [UserId] -> Galley UserClients +lookupClients :: Member BrigAccess r => [UserId] -> Galley r UserClients lookupClients uids = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort . path "/i/clients" . json (UserSet $ Set.fromList uids) @@ -62,11 +63,14 @@ lookupClients uids = do return $ filterClients (not . Set.null) clients -- | Calls 'Brig.API.internalListClientsFullH'. -lookupClientsFull :: [UserId] -> Galley UserClientsFull +lookupClientsFull :: + Member BrigAccess r => + [UserId] -> + Galley r UserClientsFull lookupClientsFull uids = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort . path "/i/clients/full" . json (UserSet $ Set.fromList uids) @@ -75,10 +79,15 @@ lookupClientsFull uids = do return $ filterClientsFull (not . Set.null) clients -- | Calls 'Brig.API.legalHoldClientRequestedH'. -notifyClientsAboutLegalHoldRequest :: UserId -> UserId -> LastPrekey -> Galley () +notifyClientsAboutLegalHoldRequest :: + Member BrigAccess r => + UserId -> + UserId -> + LastPrekey -> + Galley r () notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do (brigHost, brigPort) <- brigReq - void . call "brig" $ + void . callBrig $ method POST . host brigHost . port brigPort @@ -87,11 +96,15 @@ notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do . expect2xx -- | Calls 'Brig.User.API.Auth.legalHoldLoginH'. -getLegalHoldAuthToken :: UserId -> Maybe PlainTextPassword -> Galley OpaqueAuthToken +getLegalHoldAuthToken :: + Member BrigAccess r => + UserId -> + Maybe PlainTextPassword -> + Galley r OpaqueAuthToken getLegalHoldAuthToken uid pw = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort @@ -106,7 +119,13 @@ getLegalHoldAuthToken uid pw = do Just c -> pure . OpaqueAuthToken . decodeUtf8 $ c -- | Calls 'Brig.API.addClientInternalH'. -addLegalHoldClientToUser :: UserId -> ConnId -> [Prekey] -> LastPrekey -> Galley ClientId +addLegalHoldClientToUser :: + Member BrigAccess r => + UserId -> + ConnId -> + [Prekey] -> + LastPrekey -> + Galley r ClientId addLegalHoldClientToUser uid connId prekeys lastPrekey' = do clientId <$> brigAddClient uid connId lhClient where @@ -123,10 +142,13 @@ addLegalHoldClientToUser uid connId prekeys lastPrekey' = do Nothing -- | Calls 'Brig.API.removeLegalHoldClientH'. -removeLegalHoldClientFromUser :: UserId -> Galley () +removeLegalHoldClientFromUser :: + Member BrigAccess r => + UserId -> + Galley r () removeLegalHoldClientFromUser targetUid = do (brigHost, brigPort) <- brigReq - void . call "brig" $ + void . callBrig $ method DELETE . host brigHost . port brigPort @@ -135,11 +157,11 @@ removeLegalHoldClientFromUser targetUid = do . expect2xx -- | Calls 'Brig.API.addClientInternalH'. -brigAddClient :: UserId -> ConnId -> NewClient -> Galley Client +brigAddClient :: Member BrigAccess r => UserId -> ConnId -> NewClient -> Galley r Client brigAddClient uid connId client = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index 234db9ebbac..4cb9e07a3d7 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -49,22 +49,22 @@ import qualified System.Logger.Class as Log -- Team journal operations to SQS are a no-op when the service -- is started without journaling arguments -teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley () +teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley r () teamActivate tid teamSize cur time = do billingUserIds <- getBillingUserIds tid Nothing journalEvent TeamEvent'TEAM_ACTIVATE tid (Just $ evData teamSize billingUserIds cur) time -teamUpdate :: TeamId -> Natural -> [UserId] -> Galley () +teamUpdate :: TeamId -> Natural -> [UserId] -> Galley r () teamUpdate tid teamSize billingUserIds = journalEvent TeamEvent'TEAM_UPDATE tid (Just $ evData teamSize billingUserIds Nothing) Nothing -teamDelete :: TeamId -> Galley () +teamDelete :: TeamId -> Galley r () teamDelete tid = journalEvent TeamEvent'TEAM_DELETE tid Nothing Nothing -teamSuspend :: TeamId -> Galley () +teamSuspend :: TeamId -> Galley r () teamSuspend tid = journalEvent TeamEvent'TEAM_SUSPEND tid Nothing Nothing -journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley () +journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley r () journalEvent typ tid dat tim = view aEnv >>= \mEnv -> for_ mEnv $ \e -> do -- writetime is in microseconds in cassandra 3.11 @@ -90,7 +90,7 @@ evData memberCount billingUserIds cur = -- FUTUREWORK: Remove this function and always get billing users ids using -- 'Data.listBillingTeamMembers'. This is required only until data is backfilled in the -- 'billing_team_user' table. -getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley [UserId] +getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley r [UserId] getBillingUserIds tid maybeMemberList = do enableIndexedBillingTeamMembers <- view (options . Opts.optSettings . Opts.setEnableIndexedBillingTeamMembers . to (fromMaybe False)) case maybeMemberList of @@ -100,14 +100,14 @@ getBillingUserIds tid maybeMemberList = do else handleList enableIndexedBillingTeamMembers =<< Data.teamMembersForFanout tid Just list -> handleList enableIndexedBillingTeamMembers list where - fetchFromDB :: Galley [UserId] + fetchFromDB :: Galley r [UserId] fetchFromDB = Data.listBillingTeamMembers tid - filterFromMembers :: TeamMemberList -> Galley [UserId] + filterFromMembers :: TeamMemberList -> Galley r [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - handleList :: Bool -> TeamMemberList -> Galley [UserId] + handleList :: Bool -> TeamMemberList -> Galley r [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of ListTruncated -> diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs index 04c2e48b3e1..15f67076140 100644 --- a/services/galley/src/Galley/Intra/Push.hs +++ b/services/galley/src/Galley/Intra/Push.hs @@ -71,16 +71,18 @@ import qualified Data.Set as Set import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.App +import Galley.Effects import Galley.Options import Galley.Types import qualified Galley.Types.Teams as Teams import Gundeck.Types.Push.V2 (RecipientClients (..)) import qualified Gundeck.Types.Push.V2 as Gundeck -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types.Method import Safe (headDef, tailDef) import System.Logger.Class hiding (new) -import UnliftIO (mapConcurrently) +import UnliftIO.Async (mapConcurrently) +import UnliftIO.Concurrent (forkIO) import Util.Options import qualified Wire.API.Event.FeatureConfig as FeatureConfig @@ -158,14 +160,14 @@ newConversationEventPush localDomain e users = -- | Asynchronously send a single push, chunking it into multiple -- requests if there are more than 128 recipients. -push1 :: Push -> Galley () +push1 :: Member GundeckAccess r => Push -> Galley r () push1 p = push (list1 p []) -pushSome :: [Push] -> Galley () +pushSome :: Member GundeckAccess r => [Push] -> Galley r () pushSome [] = return () pushSome (x : xs) = push (list1 x xs) -push :: List1 Push -> Galley () +push :: Member GundeckAccess r => List1 Push -> Galley r () push ps = do let (localPushes, remotePushes) = foldMap (bimap toList toList . splitPush) (toList ps) traverse_ (pushLocal . List1) (nonEmpty localPushes) @@ -185,13 +187,14 @@ push ps = do -- | Asynchronously send multiple pushes, aggregating them into as -- few requests as possible, such that no single request targets -- more than 128 recipients. -pushLocal :: List1 (PushTo UserId) -> Galley () +pushLocal :: Member GundeckAccess r => List1 (PushTo UserId) -> Galley r () pushLocal ps = do limit <- fanoutLimit + opts <- view options -- Do not fan out for very large teams - let (async, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) - forM_ (pushes async) $ gundeckReq >=> callAsync "gundeck" - void $ mapConcurrently (gundeckReq >=> call "gundeck") (pushes sync) + let (asyncs, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) + forM_ (pushes asyncs) $ callAsync "gundeck" . gundeckReq opts + void . liftGalley0 $ mapConcurrently (call0 "gundeck" . gundeckReq opts) (pushes sync) return () where pushes = fst . foldr chunk ([], 0) @@ -226,7 +229,7 @@ pushLocal ps = do ) -- instead of IdMapping, we could also just take qualified IDs -pushRemote :: List1 (PushTo UserId) -> Galley () +pushRemote :: List1 (PushTo UserId) -> Galley r () pushRemote _ps = do -- FUTUREWORK(federation, #1261): send these to the other backends pure () @@ -234,27 +237,25 @@ pushRemote _ps = do ----------------------------------------------------------------------------- -- Helpers -gundeckReq :: [Gundeck.Push] -> Galley (Request -> Request) -gundeckReq ps = do - o <- view options - return $ - host (encodeUtf8 $ o ^. optGundeck . epHost) - . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) - . method POST - . path "/i/push/v2" - . json ps - . expect2xx +gundeckReq :: Opts -> [Gundeck.Push] -> Request -> Request +gundeckReq o ps = + host (encodeUtf8 $ o ^. optGundeck . epHost) + . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) + . method POST + . path "/i/push/v2" + . json ps + . expect2xx -callAsync :: LT.Text -> (Request -> Request) -> Galley () -callAsync n r = void . forkIO $ void (call n r) `catches` handlers +callAsync :: Member GundeckAccess r => LT.Text -> (Request -> Request) -> Galley r () +callAsync n r = liftGalley0 . void . forkIO $ void (call0 n r) `catches` handlers where handlers = [ Handler $ \(x :: RPCException) -> err (rpcExceptionMsg x), Handler $ \(x :: SomeException) -> err $ "remote" .= n ~~ msg (show x) ] -call :: LT.Text -> (Request -> Request) -> Galley (Response (Maybe LByteString)) -call n r = recovering x3 rpcHandlers (const (rpc n r)) +call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LByteString)) +call0 n r = recovering x3 rpcHandlers (const (rpc n r)) x3 :: RetryPolicy x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index 08ec54af70e..c10f3109d38 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -24,16 +24,17 @@ import Bilge import Data.ByteString.Conversion import Data.Id import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method -- | Notify Spar that a team is being deleted. -deleteTeam :: TeamId -> Galley () +deleteTeam :: Member SparAccess r => TeamId -> Galley r () deleteTeam tid = do (h, p) <- sparReq _ <- - call "spar" $ + callSpar $ method DELETE . host h . port p . paths ["i", "teams", toByteString' tid] . expect2xx diff --git a/services/galley/src/Galley/Intra/Team.hs b/services/galley/src/Galley/Intra/Team.hs index dbf56e2d6b2..50cdcdd345f 100644 --- a/services/galley/src/Galley/Intra/Team.hs +++ b/services/galley/src/Galley/Intra/Team.hs @@ -23,17 +23,18 @@ import Brig.Types.Team import Data.ByteString.Conversion import Data.Id import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error -getSize :: TeamId -> Galley TeamSize +getSize :: Member BrigAccess r => TeamId -> Galley r TeamSize getSize tid = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/teams", toByteString' tid, "size"] . expect2xx diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 29a077222a6..faea13c43ea 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -17,6 +17,7 @@ module Galley.Intra.User ( getConnections, + getConnectionsUnqualified0, getConnectionsUnqualified, putConnectionInternal, deleteBot, @@ -28,6 +29,9 @@ module Galley.Intra.User getContactList, chunkify, getRichInfoMultiUser, + + -- * Internal + deleteBot0, ) where @@ -43,6 +47,7 @@ import Data.ByteString.Conversion import Data.Id import Data.Qualified import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Client (HttpExceptionContent (..)) @@ -59,11 +64,24 @@ import Wire.API.User.RichInfo (RichInfo) -- -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatusUnqualified'. -getConnectionsUnqualified :: [UserId] -> Maybe [UserId] -> Maybe Relation -> Galley [ConnectionStatus] -getConnectionsUnqualified uFrom uTo rlt = do +getConnectionsUnqualified :: + Member BrigAccess r => + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + Galley r [ConnectionStatus] +getConnectionsUnqualified uFrom uTo rlt = + liftGalley0 $ getConnectionsUnqualified0 uFrom uTo rlt + +getConnectionsUnqualified0 :: + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + Galley0 [ConnectionStatus] +getConnectionsUnqualified0 uFrom uTo rlt = do (h, p) <- brigReq r <- - call "brig" $ + call0 "brig" $ method POST . host h . port p . path "/i/users/connections-status" . maybe id rfilter rlt @@ -79,34 +97,33 @@ getConnectionsUnqualified uFrom uTo rlt = do -- -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatus'. -getConnections :: [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley [ConnectionStatusV2] +getConnections :: Member BrigAccess r => [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley r [ConnectionStatusV2] getConnections [] _ _ = pure [] getConnections uFrom uTo rlt = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host h . port p . path "/i/users/connections-status/v2" . json (ConnectionsStatusRequestV2 uFrom uTo rlt) . expect2xx parseResponse (mkError status502 "server-error") r -putConnectionInternal :: UpdateConnectionsInternal -> Galley Status +putConnectionInternal :: Member BrigAccess r => UpdateConnectionsInternal -> Galley r Status putConnectionInternal updateConn = do (h, p) <- brigReq response <- - call "brig" $ + callBrig $ method PUT . host h . port p . paths ["/i/connections/connection-update"] . json updateConn pure $ responseStatus response --- | Calls 'Brig.Provider.API.botGetSelfH'. -deleteBot :: ConvId -> BotId -> Galley () -deleteBot cid bot = do +deleteBot0 :: ConvId -> BotId -> Galley0 () +deleteBot0 cid bot = do (h, p) <- brigReq void $ - call "brig" $ + call0 "brig" $ method DELETE . host h . port p . path "/bot/self" . header "Z-Type" "bot" @@ -114,15 +131,19 @@ deleteBot cid bot = do . header "Z-Conversation" (toByteString' cid) . expect2xx +-- | Calls 'Brig.Provider.API.botGetSelfH'. +deleteBot :: Member BotAccess r => ConvId -> BotId -> Galley r () +deleteBot cid bot = liftGalley0 $ deleteBot0 cid bot + -- | Calls 'Brig.User.API.Auth.reAuthUserH'. -reAuthUser :: UserId -> ReAuthUser -> Galley Bool +reAuthUser :: Member BrigAccess r => UserId -> ReAuthUser -> Galley r Bool reAuthUser uid auth = do (h, p) <- brigReq let req = method GET . host h . port p . paths ["/i/users", toByteString' uid, "reauthenticate"] . json auth - st <- statusCode . responseStatus <$> call "brig" (check [status200, status403] . req) + st <- statusCode . responseStatus <$> callBrig (check [status200, status403] . req) return $ st == 200 check :: [Status] -> Request -> Request @@ -135,12 +156,12 @@ check allowed r = } -- | Calls 'Brig.API.listActivatedAccountsH'. -lookupActivatedUsers :: [UserId] -> Galley [User] +lookupActivatedUsers :: Member BrigAccess r => [UserId] -> Galley r [User] lookupActivatedUsers = chunkify $ \uids -> do (h, p) <- brigReq let users = BSC.intercalate "," $ toByteString' <$> uids r <- - call "brig" $ + callBrig $ method GET . host h . port p . path "/i/users" . queryItem "ids" users @@ -162,15 +183,15 @@ chunkify doChunk keys = mconcat <$> (doChunk `mapM` chunks keys) chunks uids = case splitAt maxSize uids of (h, t) -> h : chunks t -- | Calls 'Brig.API.listActivatedAccountsH'. -getUser :: UserId -> Galley (Maybe UserAccount) +getUser :: Member BrigAccess r => UserId -> Galley r (Maybe UserAccount) getUser uid = listToMaybe <$> getUsers [uid] -- | Calls 'Brig.API.listActivatedAccountsH'. -getUsers :: [UserId] -> Galley [UserAccount] +getUsers :: Member BrigAccess r => [UserId] -> Galley r [UserAccount] getUsers = chunkify $ \uids -> do (h, p) <- brigReq resp <- - call "brig" $ + callBrig $ method GET . host h . port p . path "/i/users" . queryItem "ids" (BSC.intercalate "," (toByteString' <$> uids)) @@ -178,32 +199,32 @@ getUsers = chunkify $ \uids -> do pure . fromMaybe [] . responseJsonMaybe $ resp -- | Calls 'Brig.API.deleteUserNoVerifyH'. -deleteUser :: UserId -> Galley () +deleteUser :: Member BrigAccess r => UserId -> Galley r () deleteUser uid = do (h, p) <- brigReq void $ - call "brig" $ + callBrig $ method DELETE . host h . port p . paths ["/i/users", toByteString' uid] . expect2xx -- | Calls 'Brig.API.getContactListH'. -getContactList :: UserId -> Galley [UserId] +getContactList :: Member BrigAccess r => UserId -> Galley r [UserId] getContactList uid = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/users", toByteString' uid, "contacts"] . expect2xx cUsers <$> parseResponse (mkError status502 "server-error") r -- | Calls 'Brig.API.Internal.getRichInfoMultiH' -getRichInfoMultiUser :: [UserId] -> Galley [(UserId, RichInfo)] +getRichInfoMultiUser :: Member BrigAccess r => [UserId] -> Galley r [(UserId, RichInfo)] getRichInfoMultiUser = chunkify $ \uids -> do (h, p) <- brigReq resp <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/users/rich-info"] . queryItem "ids" (toByteString' (List uids)) diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 9416c8d68f3..a9dc8ff8820 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -18,7 +18,10 @@ module Galley.Intra.Util ( brigReq, sparReq, - call, + call0, + callBrig, + callSpar, + callBot, x1, ) where @@ -33,17 +36,18 @@ import Data.Misc (portNumber) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.App +import Galley.Effects import Galley.Options import Imports import Util.Options -brigReq :: Galley (ByteString, Word16) +brigReq :: Galley r (ByteString, Word16) brigReq = do h <- encodeUtf8 <$> view (options . optBrig . epHost) p <- portNumber . fromIntegral <$> view (options . optBrig . epPort) return (h, p) -sparReq :: Galley (ByteString, Word16) +sparReq :: Galley r (ByteString, Word16) sparReq = do h <- encodeUtf8 <$> view (options . optSpar . epHost) p <- portNumber . fromIntegral <$> view (options . optSpar . epPort) @@ -51,8 +55,17 @@ sparReq = do -- gundeckReq lives in Galley.Intra.Push -call :: LT.Text -> (Request -> Request) -> Galley (Response (Maybe LB.ByteString)) -call n r = recovering x1 rpcHandlers (const (rpc n r)) +call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LB.ByteString)) +call0 n r = liftGalley0 $ recovering x1 rpcHandlers (const (rpc n r)) + +callBrig :: Member BrigAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callBrig r = liftGalley0 $ call0 "brig" r + +callSpar :: Member SparAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callSpar r = liftGalley0 $ call0 "spar" r + +callBot :: Member BotAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callBot r = liftGalley0 $ call0 "brig" r x1 :: RetryPolicy x1 = limitRetries 1 diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 742b32f9714..7218a22c37c 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -131,8 +131,8 @@ bodyParserErrorFormatter _ _ errMsg = type CombinedAPI = GalleyAPI.ServantAPI :<|> Internal.ServantAPI :<|> ToServantApi FederationGalley.Api :<|> Servant.Raw -refreshMetrics :: Galley () -refreshMetrics = do +refreshMetrics :: Galley r () +refreshMetrics = liftGalley0 $ do m <- view monitor q <- view deleteQueue Internal.safeForever "refreshMetrics" $ do diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index dc4f17a31ed..a533cdbd513 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -32,11 +32,11 @@ import Galley.App import Galley.Options import Imports -rangeChecked :: Within a n m => a -> Galley (Range n m a) +rangeChecked :: Within a n m => a -> Galley r (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} -rangeCheckedMaybe :: Within a n m => Maybe a -> Galley (Maybe (Range n m a)) +rangeCheckedMaybe :: Within a n m => Maybe a -> Galley r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -45,7 +45,7 @@ rangeCheckedMaybe (Just a) = Just <$> rangeChecked a newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) -checkedConvSize :: Foldable f => f a -> Galley (ConvSizeChecked f a) +checkedConvSize :: Foldable f => f a -> Galley r (ConvSizeChecked f a) checkedConvSize x = do o <- view options let minV :: Integer = 0 @@ -54,5 +54,5 @@ checkedConvSize x = do then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: String -> Galley a +throwErr :: String -> Galley r a throwErr = throwM . invalidRange . fromString diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index cd61c67eb42..3c2cf9e9184 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -39,6 +39,7 @@ import Brig.Types import qualified Control.Concurrent.Async as Async import Control.Lens (at, ix, preview, view, (.~), (?~)) import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Trans.Maybe import Data.Aeson hiding (json) import qualified Data.ByteString as BS import Data.ByteString.Conversion @@ -59,9 +60,7 @@ import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Ascii as Ascii import Data.Time.Clock (getCurrentTime) -import Database.CQL.IO import Galley.API.Mapping -import qualified Galley.Data as Data import Galley.Options (Opts, optFederator) import Galley.Types hiding (LocalMember (..)) import Galley.Types.Conversations.Intra @@ -3247,7 +3246,6 @@ testOne2OneConversationRequest :: Bool -> Actor -> DesiredMembership -> TestM () testOne2OneConversationRequest shouldBeLocal actor desired = do alice <- qTagUnsafe <$> randomQualifiedUser (bob, expectedConvId) <- generateRemoteAndConvId shouldBeLocal alice - db <- view tsCass convId <- do let req = UpsertOne2OneConversationRequest alice bob actor desired Nothing @@ -3260,20 +3258,34 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do case shouldBeLocal of True -> do - mems <- runClient db $ do - lmems <- fmap (qUntagged . qualifyAs alice . lmId) <$> Data.members (qUnqualified convId) - rmems <- fmap (qUntagged . rmId) <$> Data.lookupRemoteMembers (qUnqualified convId) - pure (lmems <> rmems) - let actorId = case actor of - LocalActor -> qUntagged alice - RemoteActor -> qUntagged bob - liftIO $ isJust (find (actorId ==) mems) @?= (desired == Included) - liftIO $ filter (actorId /=) mems @?= [] + members <- case actor of + LocalActor -> runMaybeT $ do + resp <- lift $ getConvQualified (tUnqualified alice) convId + guard $ statusCode resp == 200 + conv <- lift $ responseJsonError resp + pure . map omQualifiedId . cmOthers . cnvMembers $ conv + RemoteActor -> do + fedGalleyClient <- view tsFedGalleyClient + GetConversationsResponse convs <- + FederatedGalley.getConversations + fedGalleyClient + (tDomain bob) + FederatedGalley.GetConversationsRequest + { FederatedGalley.gcrUserId = tUnqualified bob, + FederatedGalley.gcrConvIds = [qUnqualified convId] + } + pure + . fmap (map omQualifiedId . rcmOthers . rcnvMembers) + . listToMaybe + $ convs + liftIO $ case desired of + Included -> members @?= Just [] + Excluded -> members @?= Nothing False -> do - mems <- runClient db $ do - smap <- Data.remoteConversationStatus (tUnqualified alice) [qTagUnsafe convId] - case Map.lookup (qTagUnsafe convId) smap of - Just _ -> pure [qUntagged alice] - _ -> pure [] - when (actor == LocalActor) $ - liftIO $ isJust (find (qUntagged alice ==) mems) @?= (desired == Included) + found <- do + let rconv = mkConv (qUnqualified convId) (tUnqualified bob) roleNameWireAdmin [] + (resp, _) <- + withTempMockFederator (const (FederatedGalley.GetConversationsResponse [rconv])) $ + getConvQualified (tUnqualified alice) convId + pure $ statusCode resp == 200 + liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 01d7cf94509..161b1a2636c 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -324,7 +324,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients [member] + clients' <- Cql.runClient cassState $ Data.lookupClients' [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index b023b3abf56..9d458076467 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -256,7 +256,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients [member] + clients' <- Cql.runClient cassState $ Data.lookupClients' [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 212834e6032..a0521b675a8 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -128,7 +128,7 @@ import Wire.API.User.Identity (mkSimpleSampleUref) ------------------------------------------------------------------------------- -- API Operations --- | A class for monads with access to a Galley instance +-- | A class for monads with access to a Galley r instance class HasGalley m where viewGalley :: m GalleyR viewGalleyOpts :: m Opts.Opts From 14cac8b7a3c538ea4e0bafd916cfaf5e42019b18 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 27 Oct 2021 19:30:37 +0200 Subject: [PATCH 50/88] Allow configuring nginz so it serves the deeplink for apps to discover the backend (#1889) Allow nginz to serve a deeplink (see also https://docs.wire.com/how-to/associate/deeplink.html ) Co-authored-by: jschaul --- changelog.d/2-features/nginz-deeplink | 1 + .../nginz/templates/conf/_deeplink.html.tpl | 15 ++++++++++++ .../nginz/templates/conf/_deeplink.json.tpl | 24 +++++++++++++++++++ charts/nginz/templates/conf/_nginx.conf.tpl | 19 +++++++++++++++ charts/nginz/templates/configmap.yaml | 4 ++++ charts/nginz/values.yaml | 9 +++++++ 6 files changed, 72 insertions(+) create mode 100644 changelog.d/2-features/nginz-deeplink create mode 100644 charts/nginz/templates/conf/_deeplink.html.tpl create mode 100644 charts/nginz/templates/conf/_deeplink.json.tpl diff --git a/changelog.d/2-features/nginz-deeplink b/changelog.d/2-features/nginz-deeplink new file mode 100644 index 00000000000..67ca834d7fd --- /dev/null +++ b/changelog.d/2-features/nginz-deeplink @@ -0,0 +1 @@ +Allow configuring nginz so it serve the deeplink for apps to discover the backend \ No newline at end of file diff --git a/charts/nginz/templates/conf/_deeplink.html.tpl b/charts/nginz/templates/conf/_deeplink.html.tpl new file mode 100644 index 00000000000..4e9b458defb --- /dev/null +++ b/charts/nginz/templates/conf/_deeplink.html.tpl @@ -0,0 +1,15 @@ +{{- define "nginz_deeplink.html" }} +{{/* See https://docs.wire.com/how-to/associate/deeplink.html + (or search for "deeplink" on docs.wire.com) + for details on use of the deeplink*/}} + + + + {{- if hasKey .Values.nginx_conf "deeplink" }} + Click here for access + {{- else }} + No Deep Link. + {{- end }} + + +{{- end }} diff --git a/charts/nginz/templates/conf/_deeplink.json.tpl b/charts/nginz/templates/conf/_deeplink.json.tpl new file mode 100644 index 00000000000..da5ddb19a6d --- /dev/null +++ b/charts/nginz/templates/conf/_deeplink.json.tpl @@ -0,0 +1,24 @@ +{{- define "nginz_deeplink.json" }} +{{- if hasKey .Values.nginx_conf "deeplink" }} +{{- with .Values.nginx_conf.deeplink }} +{{/* See https://docs.wire.com/how-to/associate/deeplink.html + (or search for "deeplink" on docs.wire.com) + for details on use of the deeplink*/}} +{ + "endpoints" : { + {{- with .endpoints }} + "backendURL" : {{ .backendURL | quote }}, + "backendWSURL": {{ .backendWSURL | quote }}, + "blackListURL": {{ .blackListURL | quote }}, + "teamsURL": {{ .teamsURL | quote }}, + "accountsURL": {{ .accountsURL | quote }}, + "websiteURL": {{ .websiteURL | quote }} + {{- end }} + }, + "title" : {{ .title | quote }} +} +{{- end }} +{{- else }} +{} +{{- end }} +{{- end }} diff --git a/charts/nginz/templates/conf/_nginx.conf.tpl b/charts/nginz/templates/conf/_nginx.conf.tpl index d5f888b2b7f..1e3d9937046 100644 --- a/charts/nginz/templates/conf/_nginx.conf.tpl +++ b/charts/nginz/templates/conf/_nginx.conf.tpl @@ -344,6 +344,25 @@ http { image/png png; } } + + {{- if hasKey .Values.nginx_conf "deeplink" }} + location ~* ^/deeplink.(json|html)$ { + zauth off; + root /etc/wire/nginz/conf/; + types { + application/json json; + text/html html; + } + if ($request_method = 'OPTIONS') { + add_header 'Access-Control-Allow-Methods' "GET, OPTIONS"; + add_header 'Access-Control-Allow-Headers' "$http_access_control_request_headers, DNT,X-Mx-ReqToken,Keep-Alive,User-Agent,X-Requested-With,If-Modified-Since,Cache-Control,Content-Type"; + add_header 'Content-Type' 'text/plain; charset=UTF-8'; + add_header 'Content-Length' 0; + return 204; + } + more_set_headers 'Access-Control-Allow-Origin: $http_origin'; + } + {{- end }} } } {{- end }} diff --git a/charts/nginz/templates/configmap.yaml b/charts/nginz/templates/configmap.yaml index b14e4042ecb..cb571488170 100644 --- a/charts/nginz/templates/configmap.yaml +++ b/charts/nginz/templates/configmap.yaml @@ -6,6 +6,10 @@ data: {{- include "nginz_upstreams.txt" . | indent 4 }} zwagger-config.js: |2 {{- include "nginz_zwagger-config.js" . | indent 4 }} + deeplink.json: |2 +{{- include "nginz_deeplink.json" . | indent 4 }} + deeplink.html: |2 +{{- include "nginz_deeplink.html" . | indent 4 }} {{ (.Files.Glob "conf/static/*").AsConfig | indent 2 }} kind: ConfigMap metadata: diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 2d006ddb7b9..5c0f7ebd819 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -32,6 +32,15 @@ nginx_conf: worker_rlimit_nofile: 131072 worker_connections: 65536 swagger_root: /var/www/swagger + # deeplink: + # endpoints: + # backendURL: "https://prod-nginz-https.wire.com" + # backendWSURL: "https://prod-nginz-ssl.wire.com" + # blackListURL: "https://clientblacklist.wire.com/prod" + # teamsURL: "https://teams.wire.com" + # accountsURL: "https://accounts.wire.com" + # websiteURL: "https://wire.com" + # title: "Production" disabled_paths: - /conversations/last-events - ~* ^/conversations/([^/]*)/knock From 698d5f6fbbf2e6cf4cd6c63e5c5f53542b47ac3e Mon Sep 17 00:00:00 2001 From: Julia Longtin Date: Fri, 29 Oct 2021 12:16:08 +0200 Subject: [PATCH 51/88] upgrade webapp to federation-capable (not for production use!) version. (#1892) --- changelog.d/0-release-notes/webapp-upgrade | 2 +- charts/webapp/values.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade index cc3ced05b21..922f3c8e62d 100644 --- a/changelog.d/0-release-notes/webapp-upgrade +++ b/changelog.d/0-release-notes/webapp-upgrade @@ -1 +1 @@ -Upgrade Webapp to Release: 2021-10-04-production.0 and image tag: 2021-10-04-production.0-v0.28.29-0-188919c +Upgrade Webapp to image tag: 20021-10-28-federation-m1 diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index cd36874f5c5..80def916765 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2021-10-04-production.0-v0.28.29-0-188919c" + tag: "2021-10-28-federation-M1" service: https: externalPort: 443 From 8dbf8d9a661553745d2b05232e8e1405ecd6d8be Mon Sep 17 00:00:00 2001 From: fisx Date: Sun, 31 Oct 2021 09:31:43 +0100 Subject: [PATCH 52/88] [feature config] self-deleting messages (#1857) * Add self-deleting messages feature config. * Fix: cassandra's update doesn't work as you'd think! * Ormolu. * make git-add-cassandra-schema * Fix syntax error in cql query. * Changelog. --- changelog.d/0-release-notes/pr-1857 | 1 + .../pr-1857-self-deleting-messages-feature | 1 + docs/reference/cassandra-schema.cql | 2 + libs/galley-types/src/Galley/Types/Teams.hs | 12 +++- .../test/unit/Test/Galley/Types.hs | 1 + .../src/Wire/API/Event/FeatureConfig.hs | 4 +- .../src/Wire/API/Routes/Public/Galley.hs | 12 +++- libs/wire-api/src/Wire/API/Swagger.hs | 1 + libs/wire-api/src/Wire/API/Team/Feature.hs | 48 +++++++++++++- .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 1 + services/galley/galley.cabal | 3 +- services/galley/schema/src/Main.hs | 4 +- .../V54_TeamFeatureSelfDeletingMessages.hs | 34 ++++++++++ services/galley/src/Galley/API/Internal.hs | 8 +++ services/galley/src/Galley/API/Public.hs | 9 ++- .../galley/src/Galley/API/Teams/Features.hs | 21 ++++++- services/galley/src/Galley/Data.hs | 2 +- .../galley/src/Galley/Data/TeamFeatures.hs | 62 +++++++++++++++---- .../test/integration/API/Teams/Feature.hs | 51 ++++++++++++++- 19 files changed, 250 insertions(+), 27 deletions(-) create mode 100644 changelog.d/0-release-notes/pr-1857 create mode 100644 changelog.d/2-features/pr-1857-self-deleting-messages-feature create mode 100644 services/galley/schema/src/V54_TeamFeatureSelfDeletingMessages.hs diff --git a/changelog.d/0-release-notes/pr-1857 b/changelog.d/0-release-notes/pr-1857 new file mode 100644 index 00000000000..0592108c6f7 --- /dev/null +++ b/changelog.d/0-release-notes/pr-1857 @@ -0,0 +1 @@ +Deploy galley before brig. diff --git a/changelog.d/2-features/pr-1857-self-deleting-messages-feature b/changelog.d/2-features/pr-1857-self-deleting-messages-feature new file mode 100644 index 00000000000..dbfd30c783f --- /dev/null +++ b/changelog.d/2-features/pr-1857-self-deleting-messages-feature @@ -0,0 +1 @@ +End-points for configuring self-deleting messages. \ No newline at end of file diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 5df3899b420..7b70e2f4642 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -422,6 +422,8 @@ CREATE TABLE galley_test.team_features ( file_sharing int, legalhold_status int, search_visibility_status int, + self_deleting_messages_status int, + self_deleting_messages_ttl int, sso_status int, validate_saml_emails int ) WITH bloom_filter_fp_chance = 0.1 diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index bcbc0ce3ecc..8e727e90a1d 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -31,6 +31,7 @@ module Galley.Types.Teams flagAppLockDefaults, flagClassifiedDomains, flagConferenceCalling, + flagSelfDeletingMessages, Defaults (..), unDefaults, FeatureSSO (..), @@ -214,7 +215,8 @@ data FeatureFlags = FeatureFlags _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'TeamFeatureAppLock)), _flagClassifiedDomains :: !(TeamFeatureStatus 'TeamFeatureClassifiedDomains), _flagFileSharing :: !(Defaults (TeamFeatureStatus 'TeamFeatureFileSharing)), - _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)) + _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)), + _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) } deriving (Eq, Show, Generic) @@ -260,9 +262,10 @@ instance FromJSON FeatureFlags where <*> (fromMaybe defaultClassifiedDomains <$> (obj .:? "classifiedDomains")) <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "fileSharing")) <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "conferenceCalling")) + <*> (fromMaybe (Defaults defaultSelfDeletingMessagesStatus) <$> (obj .:? "selfDeletingMessages")) instance ToJSON FeatureFlags where - toJSON (FeatureFlags sso legalhold searchVisibility appLock classifiedDomains fileSharing conferenceCalling) = + toJSON (FeatureFlags sso legalhold searchVisibility appLock classifiedDomains fileSharing conferenceCalling selfDeletingMessages) = object $ [ "sso" .= sso, "legalhold" .= legalhold, @@ -270,7 +273,8 @@ instance ToJSON FeatureFlags where "appLock" .= appLock, "classifiedDomains" .= classifiedDomains, "fileSharing" .= fileSharing, - "conferenceCalling" .= conferenceCalling + "conferenceCalling" .= conferenceCalling, + "selfDeletingMessages" .= selfDeletingMessages ] instance FromJSON FeatureSSO where @@ -362,6 +366,7 @@ roleHiddenPermissions role = HiddenPermissions p p ChangeTeamFeature TeamFeatureAppLock, ChangeTeamFeature TeamFeatureFileSharing, ChangeTeamFeature TeamFeatureClassifiedDomains {- the features not listed here can only be changed in stern -}, + ChangeTeamFeature TeamFeatureSelfDeletingMessages, ReadIdp, CreateUpdateDeleteIdp, CreateReadDeleteScimToken, @@ -381,6 +386,7 @@ roleHiddenPermissions role = HiddenPermissions p p ViewTeamFeature TeamFeatureFileSharing, ViewTeamFeature TeamFeatureClassifiedDomains, ViewTeamFeature TeamFeatureConferenceCalling, + ViewTeamFeature TeamFeatureSelfDeletingMessages, ViewLegalHoldUserSettings, ViewTeamSearchVisibility ] diff --git a/libs/galley-types/test/unit/Test/Galley/Types.hs b/libs/galley-types/test/unit/Test/Galley/Types.hs index 73791c71a6e..3ed957c77d0 100644 --- a/libs/galley-types/test/unit/Test/Galley/Types.hs +++ b/libs/galley-types/test/unit/Test/Galley/Types.hs @@ -96,3 +96,4 @@ instance Arbitrary FeatureFlags where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index d6177821af1..d64dac272f6 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -30,7 +30,7 @@ import Data.Json.Util (ToJSONObject (..)) import Data.Schema import qualified Data.Swagger as S import Imports -import Wire.API.Team.Feature (TeamFeatureAppLockConfig, TeamFeatureClassifiedDomainsConfig, TeamFeatureName (..), TeamFeatureStatusNoConfig, TeamFeatureStatusWithConfig) +import Wire.API.Team.Feature (TeamFeatureAppLockConfig, TeamFeatureClassifiedDomainsConfig, TeamFeatureName (..), TeamFeatureSelfDeletingMessagesConfig, TeamFeatureStatusNoConfig, TeamFeatureStatusWithConfig) data Event = Event { _eventType :: EventType, @@ -53,6 +53,7 @@ data EventData = EdFeatureWithoutConfigChanged TeamFeatureStatusNoConfig | EdFeatureApplockChanged (TeamFeatureStatusWithConfig TeamFeatureAppLockConfig) | EdFeatureClassifiedDomainsChanged (TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig) + | EdFeatureSelfDeletingMessagesChanged (TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig) deriving (Eq, Show, Generic) makePrisms ''EventData @@ -73,6 +74,7 @@ taggedEventDataSchema = TeamFeatureFileSharing -> tag _EdFeatureWithoutConfigChanged (unnamed schema) TeamFeatureClassifiedDomains -> tag _EdFeatureClassifiedDomainsChanged (unnamed schema) TeamFeatureConferenceCalling -> tag _EdFeatureWithoutConfigChanged (unnamed schema) + TeamFeatureSelfDeletingMessages -> tag _EdFeatureSelfDeletingMessagesChanged (unnamed schema) eventObjectSchema :: ObjectSchema SwaggerDoc Event eventObjectSchema = diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 41cd9d2ae17..136c82de3a9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -601,6 +601,7 @@ data Api routes = Api '[Servant.JSON] (PostOtrResponses MessageSendingStatus) (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus), + -- team features teamFeatureStatusSSOGet :: routes :- FeatureStatusGet 'TeamFeatureSSO, @@ -652,6 +653,12 @@ data Api routes = Api teamFeatureStatusConferenceCallingGet :: routes :- FeatureStatusGet 'TeamFeatureConferenceCalling, + teamFeatureStatusSelfDeletingMessagesGet :: + routes + :- FeatureStatusGet 'TeamFeatureSelfDeletingMessages, + teamFeatureStatusSelfDeletingMessagesPut :: + routes + :- FeatureStatusPut 'TeamFeatureSelfDeletingMessages, featureAllFeatureConfigsGet :: routes :- AllFeatureConfigsGet, @@ -681,7 +688,10 @@ data Api routes = Api :- FeatureConfigGet 'TeamFeatureClassifiedDomains, featureConfigConferenceCallingGet :: routes - :- FeatureConfigGet 'TeamFeatureConferenceCalling + :- FeatureConfigGet 'TeamFeatureConferenceCalling, + featureConfigSelfDeletingMessagesGet :: + routes + :- FeatureConfigGet 'TeamFeatureSelfDeletingMessages } deriving (Generic) diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 17f75474c8a..f746c3465c3 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -128,6 +128,7 @@ models = Team.Feature.modelForTeamFeature Team.Feature.TeamFeatureClassifiedDomains, Team.Feature.modelTeamFeatureAppLockConfig, Team.Feature.modelTeamFeatureClassifiedDomainsConfig, + Team.Feature.modelTeamFeatureSelfDeletingMessagesConfig, Team.Invitation.modelTeamInvitation, Team.Invitation.modelTeamInvitationList, Team.Invitation.modelTeamInvitationRequest, diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index c943a4db1e0..f466fe3102c 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -22,6 +22,7 @@ module Wire.API.Team.Feature ( TeamFeatureName (..), TeamFeatureStatus, TeamFeatureAppLockConfig (..), + TeamFeatureSelfDeletingMessagesConfig (..), TeamFeatureClassifiedDomainsConfig (..), TeamFeatureStatusValue (..), FeatureHasNoConfig, @@ -33,6 +34,7 @@ module Wire.API.Team.Feature AllFeatureConfigs (..), defaultAppLockStatus, defaultClassifiedDomains, + defaultSelfDeletingMessagesStatus, -- * Swagger typeTeamFeatureName, @@ -41,6 +43,7 @@ module Wire.API.Team.Feature modelTeamFeatureStatusWithConfig, modelTeamFeatureAppLockConfig, modelTeamFeatureClassifiedDomainsConfig, + modelTeamFeatureSelfDeletingMessagesConfig, modelForTeamFeature, ) where @@ -90,10 +93,13 @@ import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) -- * services/galley/test/integration/API/Teams/Feature.hs -- * add an integration test for the feature -- * extend testAllFeatures +-- * consider personal-account configurability (like for `conferenceCalling`, see +-- eg. https://github.com/wireapp/wire-server/pull/1811, +-- https://github.com/wireapp/wire-server/pull/1818) -- --- --- An overview of places to change (including compiler errors and failing tests) can be found --- in eg. https://github.com/wireapp/wire-server/pull/1652. +-- An example of all the places to change (including compiler errors and failing tests) can be found +-- in eg. https://github.com/wireapp/wire-server/pull/1652. (applock and conference calling also +-- add interesting aspects, though.) -- -- Using something like '[minBound..]' on those expressions would require dependent types. We -- could generate exhaustive lists of those calls using TH, along the lines of: @@ -119,6 +125,7 @@ data TeamFeatureName | TeamFeatureFileSharing | TeamFeatureClassifiedDomains | TeamFeatureConferenceCalling + | TeamFeatureSelfDeletingMessages deriving stock (Eq, Show, Ord, Generic, Enum, Bounded, Typeable) deriving (Arbitrary) via (GenericUniform TeamFeatureName) @@ -162,6 +169,10 @@ instance KnownTeamFeatureName 'TeamFeatureConferenceCalling where type KnownTeamFeatureNameSymbol 'TeamFeatureConferenceCalling = "conferenceCalling" knownTeamFeatureName = TeamFeatureConferenceCalling +instance KnownTeamFeatureName 'TeamFeatureSelfDeletingMessages where + type KnownTeamFeatureNameSymbol 'TeamFeatureSelfDeletingMessages = "selfDeletingMessages" + knownTeamFeatureName = TeamFeatureSelfDeletingMessages + instance FromByteString TeamFeatureName where parser = Parser.takeByteString >>= \b -> @@ -179,6 +190,7 @@ instance FromByteString TeamFeatureName where Right "fileSharing" -> pure TeamFeatureFileSharing Right "classifiedDomains" -> pure TeamFeatureClassifiedDomains Right "conferenceCalling" -> pure TeamFeatureConferenceCalling + Right "selfDeletingMessages" -> pure TeamFeatureSelfDeletingMessages Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t -- TODO: how do we make this consistent with 'KnownTeamFeatureNameSymbol'? add a test for @@ -193,6 +205,7 @@ instance ToByteString TeamFeatureName where builder TeamFeatureFileSharing = "fileSharing" builder TeamFeatureClassifiedDomains = "classifiedDomains" builder TeamFeatureConferenceCalling = "conferenceCalling" + builder TeamFeatureSelfDeletingMessages = "selfDeletingMessages" instance ToSchema TeamFeatureName where schema = @@ -280,6 +293,7 @@ type family TeamFeatureStatus (a :: TeamFeatureName) :: * where TeamFeatureStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig TeamFeatureStatus 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig TeamFeatureStatus 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig type FeatureHasNoConfig (a :: TeamFeatureName) = (TeamFeatureStatus a ~ TeamFeatureStatusNoConfig) :: Constraint @@ -294,6 +308,7 @@ modelForTeamFeature name@TeamFeatureAppLock = modelTeamFeatureStatusWithConfig n modelForTeamFeature TeamFeatureFileSharing = modelTeamFeatureStatusNoConfig modelForTeamFeature name@TeamFeatureClassifiedDomains = modelTeamFeatureStatusWithConfig name modelTeamFeatureClassifiedDomainsConfig modelForTeamFeature TeamFeatureConferenceCalling = modelTeamFeatureStatusNoConfig +modelForTeamFeature name@TeamFeatureSelfDeletingMessages = modelTeamFeatureStatusWithConfig name modelTeamFeatureSelfDeletingMessagesConfig ---------------------------------------------------------------------- -- TeamFeatureStatusNoConfig @@ -409,6 +424,33 @@ defaultAppLockStatus = TeamFeatureEnabled (TeamFeatureAppLockConfig (EnforceAppLock False) 60) +---------------------------------------------------------------------- +-- TeamFeatureSelfDeletingMessagesConfig + +data TeamFeatureSelfDeletingMessagesConfig = TeamFeatureSelfDeletingMessagesConfig + { sdmEnforcedTimeoutSeconds :: Int32 + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema TeamFeatureSelfDeletingMessagesConfig) + deriving (Arbitrary) via (GenericUniform TeamFeatureSelfDeletingMessagesConfig) + +instance ToSchema TeamFeatureSelfDeletingMessagesConfig where + schema = + object "TeamFeatureSelfDeletingMessagesConfig" $ + TeamFeatureSelfDeletingMessagesConfig + <$> sdmEnforcedTimeoutSeconds .= field "enforcedTimeoutSeconds" schema + +modelTeamFeatureSelfDeletingMessagesConfig :: Doc.Model +modelTeamFeatureSelfDeletingMessagesConfig = + Doc.defineModel "TeamFeatureSelfDeletingMessagesConfig" $ do + Doc.property "enforcedTimeoutSeconds" Doc.int32' $ Doc.description "optional; default: `0` (no enforcement)" + +defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig +defaultSelfDeletingMessagesStatus = + TeamFeatureStatusWithConfig + TeamFeatureEnabled + (TeamFeatureSelfDeletingMessagesConfig 0) + ---------------------------------------------------------------------- -- internal diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 97dc0e0aa3d..6e09181e543 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -204,6 +204,7 @@ tests = testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureFileSharing), testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureClassifiedDomains), testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureConferenceCalling), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), testRoundTrip @Team.Feature.TeamFeatureStatusValue, testRoundTrip @Team.Invitation.InvitationRequest, testRoundTrip @Team.Invitation.Invitation, diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 81c99088c3a..36693c8b65f 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 8bf007e90cc28a7b92252e0fccfb998d850e30df040205e1bc7316b9008a0c9f +-- hash: 503d71d65ade51f149de711b6c0b958b0d7de6c3472c4831fc5549c20410b37a name: galley version: 0.83.0 @@ -385,6 +385,7 @@ executable galley-schema V51_FeatureFileSharing V52_FeatureConferenceCalling V53_AddRemoteConvStatus + V54_TeamFeatureSelfDeletingMessages Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index c350df9f4dc..369a4644368 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -56,6 +56,7 @@ import qualified V50_AddLegalholdWhitelisted import qualified V51_FeatureFileSharing import qualified V52_FeatureConferenceCalling import qualified V53_AddRemoteConvStatus +import qualified V54_TeamFeatureSelfDeletingMessages main :: IO () main = do @@ -97,7 +98,8 @@ main = do V50_AddLegalholdWhitelisted.migration, V51_FeatureFileSharing.migration, V52_FeatureConferenceCalling.migration, - V53_AddRemoteConvStatus.migration + V53_AddRemoteConvStatus.migration, + V54_TeamFeatureSelfDeletingMessages.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Data -- (see also docs/developer/cassandra-interaction.md) diff --git a/services/galley/schema/src/V54_TeamFeatureSelfDeletingMessages.hs b/services/galley/schema/src/V54_TeamFeatureSelfDeletingMessages.hs new file mode 100644 index 00000000000..35b2236e868 --- /dev/null +++ b/services/galley/schema/src/V54_TeamFeatureSelfDeletingMessages.hs @@ -0,0 +1,34 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V54_TeamFeatureSelfDeletingMessages + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 54 "Add feature config for self-deleting messages" $ do + schema' + [r| ALTER TABLE team_features ADD ( + self_deleting_messages_status int, + self_deleting_messages_ttl int + ) + |] diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5cc940a4579..b939cf2d361 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -174,6 +174,12 @@ data InternalApi routes = InternalApi iTeamFeatureStatusConferenceCallingGet :: routes :- IFeatureStatusGet 'Public.TeamFeatureConferenceCalling, + iTeamFeatureStatusSelfDeletingMessagesPut :: + routes + :- IFeatureStatusPut 'Public.TeamFeatureSelfDeletingMessages, + iTeamFeatureStatusSelfDeletingMessagesGet :: + routes + :- IFeatureStatusGet 'Public.TeamFeatureSelfDeletingMessages, -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members for all conversations the user was in iDeleteUser :: @@ -281,6 +287,8 @@ servantSitemap = iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + iTeamFeatureStatusSelfDeletingMessagesPut = iPutTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal, + iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, iDeleteUser = rmUser, iConnect = Create.createConnectConversation, iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 900e4b052ff..e4213142718 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -162,6 +162,12 @@ servantSitemap = GalleyAPI.teamFeatureStatusConferenceCallingGet = getFeatureStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal . DoAuth, + GalleyAPI.teamFeatureStatusSelfDeletingMessagesGet = + getFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + . DoAuth, + GalleyAPI.teamFeatureStatusSelfDeletingMessagesPut = + setFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal + . DoAuth, GalleyAPI.featureAllFeatureConfigsGet = Features.getAllFeatureConfigs, GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.TeamFeatureSSO Features.getSSOStatusInternal, @@ -171,7 +177,8 @@ servantSitemap = GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.TeamFeatureAppLock Features.getAppLockInternal, GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, - GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal + GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal } sitemap :: Routes ApiBuilder (Galley GalleyEffects) () diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index b34917162d3..cb14611e9ac 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -38,6 +38,8 @@ module Galley.API.Teams.Features setFileSharingInternal, getConferenceCallingInternal, setConferenceCallingInternal, + getSelfDeletingMessagesInternal, + setSelfDeletingMessagesInternal, DoAuth (..), GetFeatureInternalParam, ) @@ -162,7 +164,8 @@ getAllFeatureConfigs zusr = do getStatus @'Public.TeamFeatureAppLock getAppLockInternal, getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal + getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley r Response @@ -181,7 +184,8 @@ getAllFeatures uid tid = do getStatus @'Public.TeamFeatureAppLock getAppLockInternal, getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal + getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] where getStatus :: @@ -404,6 +408,19 @@ setConferenceCallingInternal :: Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () +getSelfDeletingMessagesInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) +getSelfDeletingMessagesInternal = \case + Left _ -> pure Public.defaultSelfDeletingMessagesStatus + Right tid -> + TeamFeatures.getSelfDeletingMessagesStatus tid + <&> maybe Public.defaultSelfDeletingMessagesStatus id + +setSelfDeletingMessagesInternal :: + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) +setSelfDeletingMessagesInternal = TeamFeatures.setSelfDeletingMessagesStatus + pushFeatureConfigEvent :: Member GundeckAccess r => TeamId -> Event.Event -> Galley r () pushFeatureConfigEvent tid event = do memList <- Data.teamMembersForFanout tid diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 4d2e02de642..44663d52eee 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -206,7 +206,7 @@ mkResultSet page = ResultSet (result page) typ | otherwise = ResultSetComplete schemaVersion :: Int32 -schemaVersion = 53 +schemaVersion = 54 -- | Insert a conversation code insertCode :: Code -> Galley r () diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 93109ac3144..3a4421177ba 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -22,6 +22,8 @@ module Galley.Data.TeamFeatures setFeatureStatusNoConfig, getApplockFeatureStatus, setApplockFeatureStatus, + getSelfDeletingMessagesStatus, + setSelfDeletingMessagesStatus, HasStatusCol (..), ) where @@ -66,6 +68,8 @@ instance HasStatusCol 'TeamFeatureFileSharing where statusCol = "file_sharing" instance HasStatusCol 'TeamFeatureConferenceCalling where statusCol = "conference_calling" +instance HasStatusCol 'TeamFeatureSelfDeletingMessages where statusCol = "self_deleting_messages_status" + getFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) m. ( MonadClient m, @@ -93,11 +97,11 @@ setFeatureStatusNoConfig :: m (TeamFeatureStatus a) setFeatureStatusNoConfig tid status = do let flag = Public.tfwoStatus status - retry x5 $ write update (params Quorum (flag, tid)) + retry x5 $ write insert (params Quorum (tid, flag)) pure status where - update :: PrepQuery W (TeamFeatureStatusValue, TeamId) () - update = fromString $ "update team_features set " <> statusCol @a <> " = ? where team_id = ?" + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue) () + insert = fromString $ "insert into team_features (team_id, " <> statusCol @a <> ") values (?, ?)" getApplockFeatureStatus :: forall m. @@ -126,15 +130,51 @@ setApplockFeatureStatus tid status = do let statusValue = Public.tfwcStatus status enforce = Public.applockEnforceAppLock . Public.tfwcConfig $ status timeout = Public.applockInactivityTimeoutSecs . Public.tfwcConfig $ status - retry x5 $ write update (params Quorum (statusValue, enforce, timeout, tid)) + retry x5 $ write insert (params Quorum (tid, statusValue, enforce, timeout)) pure status where - update :: PrepQuery W (TeamFeatureStatusValue, Public.EnforceAppLock, Int32, TeamId) () - update = + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Public.EnforceAppLock, Int32) () + insert = fromString $ - "update team_features set " + "insert into team_features (team_id, " <> statusCol @'Public.TeamFeatureAppLock - <> " = ?, " - <> "app_lock_enforce = ?, " - <> "app_lock_inactivity_timeout_secs = ? " - <> "where team_id = ?" + <> ", app_lock_enforce, app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" + +getSelfDeletingMessagesStatus :: + forall m. + (MonadClient m) => + TeamId -> + m (Maybe (TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages)) +getSelfDeletingMessagesStatus tid = do + let q = query1 select (params Quorum (Identity tid)) + mTuple <- retry x1 q + pure $ + mTuple >>= \(mbStatusValue, mbTimeout) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (Public.TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout) + where + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32) + select = + fromString $ + "select " + <> statusCol @'Public.TeamFeatureSelfDeletingMessages + <> ", self_deleting_messages_ttl " + <> "from team_features where team_id = ?" + +setSelfDeletingMessagesStatus :: + (MonadClient m) => + TeamId -> + TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> + m (TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) +setSelfDeletingMessagesStatus tid status = do + let statusValue = Public.tfwcStatus status + timeout = Public.sdmEnforcedTimeoutSeconds . Public.tfwcConfig $ status + retry x5 $ write insert (params Quorum (tid, statusValue, timeout)) + pure status + where + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Int32) () + insert = + fromString $ + "insert into team_features (team_id, " + <> statusCol @'Public.TeamFeatureSelfDeletingMessages + <> ", self_deleting_messages_ttl) " + <> "values (?, ?, ?)" diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 2c2394f0c80..76c5f7b408d 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -67,7 +67,8 @@ tests s = test s "Classified Domains (disabled)" testClassifiedDomainsDisabled, test s "All features" testAllFeatures, test s "Feature Configs / Team Features Consistency" testFeatureConfigConsistency, - test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled + test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, + test s "SelfDeletingMessages" $ testSelfDeletingMessages ] testSSO :: TestM () @@ -377,6 +378,47 @@ testSimpleFlag defaultValue = do setFlagInternal defaultValue getFlag defaultValue +testSelfDeletingMessages :: TestM () +testSelfDeletingMessages = do + -- personal users + let setting :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages + setting stat tout = + Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig + stat + (Public.TeamFeatureSelfDeletingMessagesConfig tout) + + personalUser <- Util.randomUser + Util.getFeatureConfig Public.TeamFeatureSelfDeletingMessages personalUser + !!! responseJsonEither === const (Right $ setting TeamFeatureEnabled 0) + + -- team users + galley <- view tsGalley + (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 + + let checkSet :: TeamFeatureStatusValue -> Int32 -> TestM () + checkSet stat tout = do + Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSelfDeletingMessages + galley + tid + (setting stat tout) + + -- internal, public (/team/:tid/features), and team-agnostic (/feature-configs). + checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> TestM () + checkGet stat tout = do + let expected = setting stat tout + forM_ + [ Util.getTeamFeatureFlagInternal Public.TeamFeatureSelfDeletingMessages tid, + Util.getTeamFeatureFlagWithGalley Public.TeamFeatureSelfDeletingMessages galley owner tid, + Util.getFeatureConfig Public.TeamFeatureSelfDeletingMessages owner + ] + (!!! responseJsonEither === const (Right expected)) + + checkGet TeamFeatureEnabled 0 + checkSet TeamFeatureDisabled 0 + checkGet TeamFeatureDisabled 0 + checkSet TeamFeatureEnabled 30 + checkGet TeamFeatureEnabled 30 + -- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all -- features are there. testAllFeatures :: TestM () @@ -411,7 +453,12 @@ testAllFeatures = do TeamFeatureEnabled (Public.TeamFeatureClassifiedDomainsConfig [Domain "example.com"]), toS TeamFeatureConferenceCalling - .= Public.TeamFeatureStatusNoConfig confCalling + .= Public.TeamFeatureStatusNoConfig confCalling, + toS TeamFeatureSelfDeletingMessages + .= ( Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig + TeamFeatureEnabled + (Public.TeamFeatureSelfDeletingMessagesConfig 0) + ) ] toS :: TeamFeatureName -> Text toS = TE.decodeUtf8 . toByteString' From 7d336c681ab6ea25ab572753eab83a65e162d6a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 1 Nov 2021 09:37:11 +0100 Subject: [PATCH 53/88] Add a o2o conversation test in getting conversations in the federation API --- .../galley/test/integration/API/Federation.hs | 35 +++++++++++++------ 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 2665106b2d8..22758186839 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -88,27 +88,42 @@ tests s = getConversationsAllFound :: TestM () getConversationsAllFound = do - bob <- randomUser - - -- create & get group conv - aliceQ <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + bobQ <- randomQualifiedUser + let bob = qUnqualified bobQ + lBob = toLocalUnsafe (qDomain bobQ) (qUnqualified bobQ) + (rAlice, cnv1Id) <- generateRemoteAndConvId True lBob + let aliceQ = qUntagged rAlice carlQ <- randomQualifiedUser connectUsers bob (singleton (qUnqualified carlQ)) connectWithRemoteUser bob aliceQ + -- create & get group conv cnv2 <- responseJsonError =<< postConvWithRemoteUsers bob defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} - getConvs bob (Just $ Left [qUnqualified (cnvQualifiedId cnv2)]) Nothing !!! do - const 200 === statusCode - const (Just (Just [cnvQualifiedId cnv2])) - === fmap (fmap (map cnvQualifiedId . convList)) . responseJsonMaybe + -- create a one-to-one conversation between bob and alice + do + let createO2O = + UpsertOne2OneConversationRequest + { uooLocalUser = lBob, + uooRemoteUser = rAlice, + uooActor = LocalActor, + uooActorDesiredMembership = Included, + uooConvId = Just cnv1Id + } + UpsertOne2OneConversationResponse cnv1IdReturned <- + responseJsonError + =<< iUpsertOne2OneConversation createO2O + liftIO $ assertEqual "Mismatch in the generated conversation ID" cnv1IdReturned cnv1Id - -- FUTUREWORK: also create a one2one conversation + getConvs bob (Just . Left . fmap qUnqualified $ [cnv1Id, cnvQualifiedId cnv2]) Nothing !!! do + const 200 === statusCode + const (Just . Just . sort $ [cnv1Id, cnvQualifiedId cnv2]) + === fmap (fmap (sort . map cnvQualifiedId . convList)) . responseJsonMaybe -- get conversations @@ -119,7 +134,7 @@ getConversationsAllFound = do (qDomain aliceQ) ( GetConversationsRequest (qUnqualified aliceQ) - (map (qUnqualified . cnvQualifiedId) [cnv2]) + (map qUnqualified [cnv1Id, cnvQualifiedId cnv2]) ) let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) convs From c38b87f5282dbd632080feb38f2a6777159264aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 1 Nov 2021 09:40:25 +0100 Subject: [PATCH 54/88] Add a change log --- changelog.d/6-federation/extend-get-conversations-test | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/6-federation/extend-get-conversations-test diff --git a/changelog.d/6-federation/extend-get-conversations-test b/changelog.d/6-federation/extend-get-conversations-test new file mode 100644 index 00000000000..8de3baa748c --- /dev/null +++ b/changelog.d/6-federation/extend-get-conversations-test @@ -0,0 +1 @@ +Add a one-to-one conversation test in getting conversations in the federation API From d3202e8728da4e32531fe72497435bb118f2cf31 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 1 Nov 2021 09:41:16 +0100 Subject: [PATCH 55/88] Revert "Add a o2o conversation test in getting conversations in the federation API" This reverts commit 7d336c681ab6ea25ab572753eab83a65e162d6a4. --- .../galley/test/integration/API/Federation.hs | 35 ++++++------------- 1 file changed, 10 insertions(+), 25 deletions(-) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 22758186839..2665106b2d8 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -88,42 +88,27 @@ tests s = getConversationsAllFound :: TestM () getConversationsAllFound = do - bobQ <- randomQualifiedUser - let bob = qUnqualified bobQ - lBob = toLocalUnsafe (qDomain bobQ) (qUnqualified bobQ) - (rAlice, cnv1Id) <- generateRemoteAndConvId True lBob - let aliceQ = qUntagged rAlice + bob <- randomUser + + -- create & get group conv + aliceQ <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") carlQ <- randomQualifiedUser connectUsers bob (singleton (qUnqualified carlQ)) connectWithRemoteUser bob aliceQ - -- create & get group conv cnv2 <- responseJsonError =<< postConvWithRemoteUsers bob defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} - -- create a one-to-one conversation between bob and alice - do - let createO2O = - UpsertOne2OneConversationRequest - { uooLocalUser = lBob, - uooRemoteUser = rAlice, - uooActor = LocalActor, - uooActorDesiredMembership = Included, - uooConvId = Just cnv1Id - } - UpsertOne2OneConversationResponse cnv1IdReturned <- - responseJsonError - =<< iUpsertOne2OneConversation createO2O - liftIO $ assertEqual "Mismatch in the generated conversation ID" cnv1IdReturned cnv1Id - - getConvs bob (Just . Left . fmap qUnqualified $ [cnv1Id, cnvQualifiedId cnv2]) Nothing !!! do + getConvs bob (Just $ Left [qUnqualified (cnvQualifiedId cnv2)]) Nothing !!! do const 200 === statusCode - const (Just . Just . sort $ [cnv1Id, cnvQualifiedId cnv2]) - === fmap (fmap (sort . map cnvQualifiedId . convList)) . responseJsonMaybe + const (Just (Just [cnvQualifiedId cnv2])) + === fmap (fmap (map cnvQualifiedId . convList)) . responseJsonMaybe + + -- FUTUREWORK: also create a one2one conversation -- get conversations @@ -134,7 +119,7 @@ getConversationsAllFound = do (qDomain aliceQ) ( GetConversationsRequest (qUnqualified aliceQ) - (map qUnqualified [cnv1Id, cnvQualifiedId cnv2]) + (map (qUnqualified . cnvQualifiedId) [cnv2]) ) let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) convs From 71761cc368dd92069531fd5ef55345f40aafd016 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 1 Nov 2021 09:44:28 +0100 Subject: [PATCH 56/88] Revert "Add a change log" This reverts commit c38b87f5282dbd632080feb38f2a6777159264aa. --- changelog.d/6-federation/extend-get-conversations-test | 1 - 1 file changed, 1 deletion(-) delete mode 100644 changelog.d/6-federation/extend-get-conversations-test diff --git a/changelog.d/6-federation/extend-get-conversations-test b/changelog.d/6-federation/extend-get-conversations-test deleted file mode 100644 index 8de3baa748c..00000000000 --- a/changelog.d/6-federation/extend-get-conversations-test +++ /dev/null @@ -1 +0,0 @@ -Add a one-to-one conversation test in getting conversations in the federation API From 615c66696662ff3b94382c9bcbb88a0ab69e7f30 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 1 Nov 2021 16:59:53 +0100 Subject: [PATCH 57/88] Delete old changelog entries (#1898) --- changelog.d/0-release-notes/sft-2-1-15 | 1 - changelog.d/0-release-notes/team-settings-upgrade | 1 - changelog.d/0-release-notes/webapp-upgrade | 1 - changelog.d/1-api-changes/remove-list-conversations-endpoint | 1 - changelog.d/1-api-changes/self-member-id-qualified | 2 -- changelog.d/2-features/nginz-deeplink | 1 - changelog.d/2-features/pr-1519 | 1 - changelog.d/3-bug-fixes/pr-1677 | 1 - changelog.d/3-bug-fixes/pr-1828 | 1 - changelog.d/5-internal/deflake-maketarget | 1 - changelog.d/5-internal/deflake-phone | 1 - changelog.d/5-internal/delete-internal-get-conn-status | 1 - changelog.d/5-internal/direnv_buildEnv | 1 - changelog.d/5-internal/fed-connections-data | 1 - changelog.d/5-internal/fix-swagger-errors | 1 - changelog.d/5-internal/galley-polysemy | 1 - changelog.d/5-internal/helmfile | 1 - changelog.d/5-internal/hs-certificate-master | 1 - changelog.d/5-internal/one2one-upsert | 1 - changelog.d/5-internal/reenable-kind | 1 - changelog.d/5-internal/refactor-tagged-qualified | 1 - changelog.d/5-internal/saml2-effect | 1 - changelog.d/5-internal/servantify-add-member | 1 - changelog.d/5-internal/simplify-mock-federator | 1 - changelog.d/5-internal/spar-no-io-2 | 1 - changelog.d/6-federation/access-update-remove-remotes | 1 - changelog.d/6-federation/check-connections | 1 - changelog.d/6-federation/check-connections-create | 1 - changelog.d/6-federation/check-server-cert-usage | 1 - changelog.d/6-federation/close-grpc-client | 1 - changelog.d/6-federation/delete-conversations | 1 - changelog.d/6-federation/ensure-one-creator-member | 1 - changelog.d/6-federation/fed-connections | 1 - changelog.d/6-federation/federator-log-level | 1 - changelog.d/6-federation/fix-remote-conv | 1 - changelog.d/6-federation/list-remote-connections | 1 - changelog.d/6-federation/optimize-user-deletion | 1 - changelog.d/6-federation/parallel-rpcs | 1 - changelog.d/6-federation/unqualify-conv-id | 1 - changelog.d/6-federation/unqualify-creator-id | 1 - changelog.d/6-federation/update-one2ones | 1 - 41 files changed, 42 deletions(-) delete mode 100644 changelog.d/0-release-notes/sft-2-1-15 delete mode 100644 changelog.d/0-release-notes/team-settings-upgrade delete mode 100644 changelog.d/0-release-notes/webapp-upgrade delete mode 100644 changelog.d/1-api-changes/remove-list-conversations-endpoint delete mode 100644 changelog.d/1-api-changes/self-member-id-qualified delete mode 100644 changelog.d/2-features/nginz-deeplink delete mode 100644 changelog.d/2-features/pr-1519 delete mode 100644 changelog.d/3-bug-fixes/pr-1677 delete mode 100644 changelog.d/3-bug-fixes/pr-1828 delete mode 100644 changelog.d/5-internal/deflake-maketarget delete mode 100644 changelog.d/5-internal/deflake-phone delete mode 100644 changelog.d/5-internal/delete-internal-get-conn-status delete mode 100644 changelog.d/5-internal/direnv_buildEnv delete mode 100644 changelog.d/5-internal/fed-connections-data delete mode 100644 changelog.d/5-internal/fix-swagger-errors delete mode 100644 changelog.d/5-internal/galley-polysemy delete mode 100644 changelog.d/5-internal/helmfile delete mode 100644 changelog.d/5-internal/hs-certificate-master delete mode 100644 changelog.d/5-internal/one2one-upsert delete mode 100644 changelog.d/5-internal/reenable-kind delete mode 100644 changelog.d/5-internal/refactor-tagged-qualified delete mode 100644 changelog.d/5-internal/saml2-effect delete mode 100644 changelog.d/5-internal/servantify-add-member delete mode 100644 changelog.d/5-internal/simplify-mock-federator delete mode 100644 changelog.d/5-internal/spar-no-io-2 delete mode 100644 changelog.d/6-federation/access-update-remove-remotes delete mode 100644 changelog.d/6-federation/check-connections delete mode 100644 changelog.d/6-federation/check-connections-create delete mode 100644 changelog.d/6-federation/check-server-cert-usage delete mode 100644 changelog.d/6-federation/close-grpc-client delete mode 100644 changelog.d/6-federation/delete-conversations delete mode 100644 changelog.d/6-federation/ensure-one-creator-member delete mode 100644 changelog.d/6-federation/fed-connections delete mode 100644 changelog.d/6-federation/federator-log-level delete mode 100644 changelog.d/6-federation/fix-remote-conv delete mode 100644 changelog.d/6-federation/list-remote-connections delete mode 100644 changelog.d/6-federation/optimize-user-deletion delete mode 100644 changelog.d/6-federation/parallel-rpcs delete mode 100644 changelog.d/6-federation/unqualify-conv-id delete mode 100644 changelog.d/6-federation/unqualify-creator-id delete mode 100644 changelog.d/6-federation/update-one2ones diff --git a/changelog.d/0-release-notes/sft-2-1-15 b/changelog.d/0-release-notes/sft-2-1-15 deleted file mode 100644 index 5d9fd71dacf..00000000000 --- a/changelog.d/0-release-notes/sft-2-1-15 +++ /dev/null @@ -1 +0,0 @@ -Upgrade SFT to 2.1.15 diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade deleted file mode 100644 index 147a2a0bd08..00000000000 --- a/changelog.d/0-release-notes/team-settings-upgrade +++ /dev/null @@ -1 +0,0 @@ -Upgrade team settings to Release: [v4.2.0](https://github.com/wireapp/wire-team-settings/releases/tag/v4.2.0) and image tag: 4.2.0-v0.28.28-1e2ef7 diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade deleted file mode 100644 index 922f3c8e62d..00000000000 --- a/changelog.d/0-release-notes/webapp-upgrade +++ /dev/null @@ -1 +0,0 @@ -Upgrade Webapp to image tag: 20021-10-28-federation-m1 diff --git a/changelog.d/1-api-changes/remove-list-conversations-endpoint b/changelog.d/1-api-changes/remove-list-conversations-endpoint deleted file mode 100644 index 60539f03a99..00000000000 --- a/changelog.d/1-api-changes/remove-list-conversations-endpoint +++ /dev/null @@ -1 +0,0 @@ -Remove `POST /list-conversations` endpoint. diff --git a/changelog.d/1-api-changes/self-member-id-qualified b/changelog.d/1-api-changes/self-member-id-qualified deleted file mode 100644 index 0b7ac33985a..00000000000 --- a/changelog.d/1-api-changes/self-member-id-qualified +++ /dev/null @@ -1,2 +0,0 @@ -The member.self ID in conversation endpoints is qualified and available as -"qualified_id". The old unqualified "id" is still available. diff --git a/changelog.d/2-features/nginz-deeplink b/changelog.d/2-features/nginz-deeplink deleted file mode 100644 index 67ca834d7fd..00000000000 --- a/changelog.d/2-features/nginz-deeplink +++ /dev/null @@ -1 +0,0 @@ -Allow configuring nginz so it serve the deeplink for apps to discover the backend \ No newline at end of file diff --git a/changelog.d/2-features/pr-1519 b/changelog.d/2-features/pr-1519 deleted file mode 100644 index 80b6a161ed5..00000000000 --- a/changelog.d/2-features/pr-1519 +++ /dev/null @@ -1 +0,0 @@ -SFT: allow using TURN discovery using 'turnDiscoveryEnabled' diff --git a/changelog.d/3-bug-fixes/pr-1677 b/changelog.d/3-bug-fixes/pr-1677 deleted file mode 100644 index 21385b64e1f..00000000000 --- a/changelog.d/3-bug-fixes/pr-1677 +++ /dev/null @@ -1 +0,0 @@ -Fix an issue related to installing the SFT helm chart as a sub chart to the wire-server chart. diff --git a/changelog.d/3-bug-fixes/pr-1828 b/changelog.d/3-bug-fixes/pr-1828 deleted file mode 100644 index f711d6561b3..00000000000 --- a/changelog.d/3-bug-fixes/pr-1828 +++ /dev/null @@ -1 +0,0 @@ -SAML columns (Issuer, NameID) in CSV files with team members. \ No newline at end of file diff --git a/changelog.d/5-internal/deflake-maketarget b/changelog.d/5-internal/deflake-maketarget deleted file mode 100644 index 3da6dfa1c3a..00000000000 --- a/changelog.d/5-internal/deflake-maketarget +++ /dev/null @@ -1 +0,0 @@ -Add a 'make flake-PATTERN' target to run a subset of tests multiple times to trigger a failure case in flaky tests diff --git a/changelog.d/5-internal/deflake-phone b/changelog.d/5-internal/deflake-phone deleted file mode 100644 index 20b3c5bb4fa..00000000000 --- a/changelog.d/5-internal/deflake-phone +++ /dev/null @@ -1 +0,0 @@ -Avoid a flaky test to fail related to phone updates and improve failure output. diff --git a/changelog.d/5-internal/delete-internal-get-conn-status b/changelog.d/5-internal/delete-internal-get-conn-status deleted file mode 100644 index ce78ab05b0d..00000000000 --- a/changelog.d/5-internal/delete-internal-get-conn-status +++ /dev/null @@ -1 +0,0 @@ -Brig: Delete deprecated `GET /i/users/connections-status` endpoint. \ No newline at end of file diff --git a/changelog.d/5-internal/direnv_buildEnv b/changelog.d/5-internal/direnv_buildEnv deleted file mode 100644 index 8ee4394ab61..00000000000 --- a/changelog.d/5-internal/direnv_buildEnv +++ /dev/null @@ -1 +0,0 @@ -Replace shell.nix with direnv + nixpkgs.buildEnv based setup \ No newline at end of file diff --git a/changelog.d/5-internal/fed-connections-data b/changelog.d/5-internal/fed-connections-data deleted file mode 100644 index ece769f80e0..00000000000 --- a/changelog.d/5-internal/fed-connections-data +++ /dev/null @@ -1 +0,0 @@ -Make connection DB functions work with Qualified IDs diff --git a/changelog.d/5-internal/fix-swagger-errors b/changelog.d/5-internal/fix-swagger-errors deleted file mode 100644 index 85628ccf63b..00000000000 --- a/changelog.d/5-internal/fix-swagger-errors +++ /dev/null @@ -1 +0,0 @@ -Fix more Swagger validation errors. diff --git a/changelog.d/5-internal/galley-polysemy b/changelog.d/5-internal/galley-polysemy deleted file mode 100644 index 528c615de11..00000000000 --- a/changelog.d/5-internal/galley-polysemy +++ /dev/null @@ -1 +0,0 @@ -Turn `Galley` into a polysemy monad stack. diff --git a/changelog.d/5-internal/helmfile b/changelog.d/5-internal/helmfile deleted file mode 100644 index c3689c20a19..00000000000 --- a/changelog.d/5-internal/helmfile +++ /dev/null @@ -1 +0,0 @@ -Internal CI tooling improvement: decrease integration setup time by using helmfile. diff --git a/changelog.d/5-internal/hs-certificate-master b/changelog.d/5-internal/hs-certificate-master deleted file mode 100644 index c9c67da740f..00000000000 --- a/changelog.d/5-internal/hs-certificate-master +++ /dev/null @@ -1 +0,0 @@ -Depend on hs-certificate master instead of our fork diff --git a/changelog.d/5-internal/one2one-upsert b/changelog.d/5-internal/one2one-upsert deleted file mode 100644 index 5371eb9a786..00000000000 --- a/changelog.d/5-internal/one2one-upsert +++ /dev/null @@ -1 +0,0 @@ -Add internal endpoint to insert or update a 1-1 conversation. This is to be used by brig when updating the status of a connection. diff --git a/changelog.d/5-internal/reenable-kind b/changelog.d/5-internal/reenable-kind deleted file mode 100644 index 118fbbad0a2..00000000000 --- a/changelog.d/5-internal/reenable-kind +++ /dev/null @@ -1 +0,0 @@ -Update helm to 3.6.3 in developer tooling (nix-shell) diff --git a/changelog.d/5-internal/refactor-tagged-qualified b/changelog.d/5-internal/refactor-tagged-qualified deleted file mode 100644 index e884a8bb704..00000000000 --- a/changelog.d/5-internal/refactor-tagged-qualified +++ /dev/null @@ -1 +0,0 @@ -Improve the `Qualified` abstraction and make local/remote tagging safer diff --git a/changelog.d/5-internal/saml2-effect b/changelog.d/5-internal/saml2-effect deleted file mode 100644 index 6c97bc700a6..00000000000 --- a/changelog.d/5-internal/saml2-effect +++ /dev/null @@ -1 +0,0 @@ -Add some new Spar effects, completely isolating us from saml2-web-sso interface diff --git a/changelog.d/5-internal/servantify-add-member b/changelog.d/5-internal/servantify-add-member deleted file mode 100644 index 234c506a47d..00000000000 --- a/changelog.d/5-internal/servantify-add-member +++ /dev/null @@ -1 +0,0 @@ -Convert legacy POST conversations/:cnv/members endpoint to Servant diff --git a/changelog.d/5-internal/simplify-mock-federator b/changelog.d/5-internal/simplify-mock-federator deleted file mode 100644 index 8bbbdcf8ddf..00000000000 --- a/changelog.d/5-internal/simplify-mock-federator +++ /dev/null @@ -1 +0,0 @@ -Simplify mock federator interface by removing unnecessary arguments. diff --git a/changelog.d/5-internal/spar-no-io-2 b/changelog.d/5-internal/spar-no-io-2 deleted file mode 100644 index b682ca5002b..00000000000 --- a/changelog.d/5-internal/spar-no-io-2 +++ /dev/null @@ -1 +0,0 @@ -Replace the `Spar` newtype, instead using `Sem` directly. diff --git a/changelog.d/6-federation/access-update-remove-remotes b/changelog.d/6-federation/access-update-remove-remotes deleted file mode 100644 index 448f53770ac..00000000000 --- a/changelog.d/6-federation/access-update-remove-remotes +++ /dev/null @@ -1 +0,0 @@ -Remove remote guests as well as local ones when "Guests and services" is disabled in a group conversation, and propagate removal to remote members. diff --git a/changelog.d/6-federation/check-connections b/changelog.d/6-federation/check-connections deleted file mode 100644 index ee2c5674c77..00000000000 --- a/changelog.d/6-federation/check-connections +++ /dev/null @@ -1 +0,0 @@ -Check connections when adding remote users to a local conversation and local users to remote conversations. diff --git a/changelog.d/6-federation/check-connections-create b/changelog.d/6-federation/check-connections-create deleted file mode 100644 index 4f6f007f1ab..00000000000 --- a/changelog.d/6-federation/check-connections-create +++ /dev/null @@ -1 +0,0 @@ -Check connections when creating group and team conversations with remote members. diff --git a/changelog.d/6-federation/check-server-cert-usage b/changelog.d/6-federation/check-server-cert-usage deleted file mode 100644 index 7953d9292d5..00000000000 --- a/changelog.d/6-federation/check-server-cert-usage +++ /dev/null @@ -1 +0,0 @@ -Server certificates without the "serverAuth" extended usage flag are now rejected when connecting to a remote federator. diff --git a/changelog.d/6-federation/close-grpc-client b/changelog.d/6-federation/close-grpc-client deleted file mode 100644 index 750ae3d9b6e..00000000000 --- a/changelog.d/6-federation/close-grpc-client +++ /dev/null @@ -1 +0,0 @@ -Close GRPC client after making a request to a remote federator. diff --git a/changelog.d/6-federation/delete-conversations b/changelog.d/6-federation/delete-conversations deleted file mode 100644 index 6fcac46d765..00000000000 --- a/changelog.d/6-federation/delete-conversations +++ /dev/null @@ -1 +0,0 @@ -Support deleting conversations with federated users diff --git a/changelog.d/6-federation/ensure-one-creator-member b/changelog.d/6-federation/ensure-one-creator-member deleted file mode 100644 index 471240b0977..00000000000 --- a/changelog.d/6-federation/ensure-one-creator-member +++ /dev/null @@ -1 +0,0 @@ -Ensure that the conversation creator is included only once in notifications sent to remote users \ No newline at end of file diff --git a/changelog.d/6-federation/fed-connections b/changelog.d/6-federation/fed-connections deleted file mode 100644 index f5aa2e774d7..00000000000 --- a/changelog.d/6-federation/fed-connections +++ /dev/null @@ -1 +0,0 @@ -Allow connecting to remote users. One to one conversations are not created yet. diff --git a/changelog.d/6-federation/federator-log-level b/changelog.d/6-federation/federator-log-level deleted file mode 100644 index 63cd4052e1e..00000000000 --- a/changelog.d/6-federation/federator-log-level +++ /dev/null @@ -1 +0,0 @@ -Make federator's default log level Info \ No newline at end of file diff --git a/changelog.d/6-federation/fix-remote-conv b/changelog.d/6-federation/fix-remote-conv deleted file mode 100644 index e3932e6d28b..00000000000 --- a/changelog.d/6-federation/fix-remote-conv +++ /dev/null @@ -1 +0,0 @@ -The creator of a conversation now appears as a member when the conversation is fetched from a remote backend diff --git a/changelog.d/6-federation/list-remote-connections b/changelog.d/6-federation/list-remote-connections deleted file mode 100644 index 90ebdc89f04..00000000000 --- a/changelog.d/6-federation/list-remote-connections +++ /dev/null @@ -1 +0,0 @@ -Include remote connections in the response to `POST /list-connections` diff --git a/changelog.d/6-federation/optimize-user-deletion b/changelog.d/6-federation/optimize-user-deletion deleted file mode 100644 index e5e083c6023..00000000000 --- a/changelog.d/6-federation/optimize-user-deletion +++ /dev/null @@ -1 +0,0 @@ -When a user gets deleted, notify remotes about conversations and connections in chunks of 1000 (#1872, #1883) \ No newline at end of file diff --git a/changelog.d/6-federation/parallel-rpcs b/changelog.d/6-federation/parallel-rpcs deleted file mode 100644 index 53d9fb8d3fe..00000000000 --- a/changelog.d/6-federation/parallel-rpcs +++ /dev/null @@ -1 +0,0 @@ -Make federated requests to multiple backends in parallel. diff --git a/changelog.d/6-federation/unqualify-conv-id b/changelog.d/6-federation/unqualify-conv-id deleted file mode 100644 index 65579183b13..00000000000 --- a/changelog.d/6-federation/unqualify-conv-id +++ /dev/null @@ -1 +0,0 @@ -Make conversation ID of `RemoteConversation` unqualified and move it out of the metadata record. diff --git a/changelog.d/6-federation/unqualify-creator-id b/changelog.d/6-federation/unqualify-creator-id deleted file mode 100644 index ba68724e09e..00000000000 --- a/changelog.d/6-federation/unqualify-creator-id +++ /dev/null @@ -1 +0,0 @@ -Make the conversation creator field in the `on-conversation-created` RPC unqualified. diff --git a/changelog.d/6-federation/update-one2ones b/changelog.d/6-federation/update-one2ones deleted file mode 100644 index 1d19a087c9a..00000000000 --- a/changelog.d/6-federation/update-one2ones +++ /dev/null @@ -1 +0,0 @@ -Update One2One conversation when connection status changes From 36220d61c23cc13a283d1cc101142166b871a1dc Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 2 Nov 2021 13:37:03 +0100 Subject: [PATCH 58/88] Test sending message to multiple remote domains (#1899) --- .../5-internal/test-fed-message-multi-domain | 1 + services/galley/test/integration/API.hs | 184 +++++++++++------- .../galley/test/integration/API/Federation.hs | 9 +- services/galley/test/integration/API/Util.hs | 28 ++- 4 files changed, 142 insertions(+), 80 deletions(-) create mode 100644 changelog.d/5-internal/test-fed-message-multi-domain diff --git a/changelog.d/5-internal/test-fed-message-multi-domain b/changelog.d/5-internal/test-fed-message-multi-domain new file mode 100644 index 00000000000..6414bf856c0 --- /dev/null +++ b/changelog.d/5-internal/test-fed-message-multi-domain @@ -0,0 +1 @@ +Test sending message to multiple remote domains \ No newline at end of file diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 3c2cf9e9184..8999fb3bb08 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -46,6 +46,7 @@ import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LBS import qualified Data.Code as Code import Data.Domain (Domain (Domain), domainText) +import Data.Either.Extra (eitherToMaybe) import Data.Id import Data.Json.Util (toBase64Text, toUTCTimeMillis) import Data.List.NonEmpty (NonEmpty (..)) @@ -583,9 +584,12 @@ postCryptoMessage5 = do where listToByteString = BS.intercalate "," . map toByteString' --- | Sets up a conversation on Backend A known as "owning backend". One of the --- users from Backend A will send the message, it is expected that message will --- be sent successfully. +-- | Sets up a conversation on Backend A known as "owning backend". All user's +-- on this backend have names begining with 'A'. The conversation has a couple +-- of users from backend B and one user from backend C. +-- +-- One of the users from Backend A will send the message, it is expected that +-- message will be sent successfully. postMessageQualifiedLocalOwningBackendSuccess :: TestM () postMessageQualifiedLocalOwningBackendSuccess = do -- WS receive timeout @@ -595,66 +599,123 @@ postMessageQualifiedLocalOwningBackendSuccess = do -- Domain which owns the converstaion owningDomain <- viewFederationDomain - (aliceOwningDomain, aliceClient) <- randomUserWithClientQualified (someLastPrekeys !! 0) - (bobOwningDomain, bobClient) <- randomUserWithClientQualified (someLastPrekeys !! 1) - bobClient2 <- randomClient (qUnqualified bobOwningDomain) (someLastPrekeys !! 2) - (chadOwningDomain, chadClient) <- randomUserWithClientQualified (someLastPrekeys !! 3) - deeId <- randomId - deeClient <- liftIO $ generate arbitrary - let remoteDomain = Domain "far-away.example.com" - deeRemote = Qualified deeId remoteDomain + (alice, aliceClient) <- randomUserWithClientQualified (someLastPrekeys !! 0) + (alex, alexClient) <- randomUserWithClientQualified (someLastPrekeys !! 1) + alexClient2 <- randomClient (qUnqualified alex) (someLastPrekeys !! 2) + (amy, amyClient) <- randomUserWithClientQualified (someLastPrekeys !! 3) - let aliceUnqualified = qUnqualified aliceOwningDomain - bobUnqualified = qUnqualified bobOwningDomain - chadUnqualified = qUnqualified chadOwningDomain + let bDomain = Domain "b.far-away.example.com" + cDomain = Domain "c.far-away.example.com" + randomQuidAndClients d n = (,) <$> randomQualifiedId d <*> liftIO (replicateM n $ generate arbitrary) + (bob, [bobClient]) <- randomQuidAndClients bDomain 1 + (bart, [bartClient1, bartClient2]) <- randomQuidAndClients bDomain 2 + (carl, [carlClient]) <- randomQuidAndClients cDomain 1 - connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) - connectWithRemoteUser aliceUnqualified deeRemote + let aliceU = qUnqualified alice + alexU = qUnqualified alex + amyU = qUnqualified amy + + connectLocalQualifiedUsers aliceU (list1 alex [amy]) + forM_ [bob, bart, carl] $ connectWithRemoteUser aliceU - -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUsers - aliceUnqualified - defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} + aliceU + defNewConv {newConvQualifiedUsers = [alex, amy, bob, bart, carl]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp - WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do + WS.bracketAsClientRN cannon [(alexU, alexClient), (alexU, alexClient2), (amyU, amyClient)] $ \[wsAlex1, wsAlex2, wsAmy] -> do let message = - [ (bobOwningDomain, bobClient, "text-for-bob"), - (bobOwningDomain, bobClient2, "text-for-bob2"), - (chadOwningDomain, chadClient, "text-for-chad"), - (deeRemote, deeClient, "text-for-dee") + [ (alex, alexClient, "text-for-alex"), + (alex, alexClient2, "text-for-alex2"), + (amy, amyClient, "text-for-amy"), + (bob, bobClient, "text-for-bob"), + (bart, bartClient1, "text-for-bart1"), + (bart, bartClient2, "text-for-bart2"), + (carl, carlClient, "text-for-carl") ] - let brigApi = + let mkPubClient c = PubClient c Nothing + brigApi d = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> - pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) + pure $ + if + | d == bDomain -> + UserMap . Map.fromList $ + [ (qUnqualified bob, Set.singleton (mkPubClient bobClient)), + (qUnqualified bart, Set.fromList (map mkPubClient [bartClient1, bartClient2])) + ] + | d == cDomain -> UserMap (Map.singleton (qUnqualified carl) (Set.singleton (PubClient carlClient Nothing))) + | otherwise -> mempty } - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.onMessageSent = \_ _ -> pure () } - (resp2, requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi + (resp2, requests) <- postProteusMessageQualifiedWithMockFederator aliceU aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi pure resp2 !!! do const 201 === statusCode assertMismatchQualified mempty mempty mempty mempty - + let encodedTextForAlex1 = toBase64Text "text-for-alex" + encodedTextForAlex2 = toBase64Text "text-for-alex2" + encodedTextForAmy = toBase64Text "text-for-amy" + encodedTextForBob = toBase64Text "text-for-bob" + encodedTextForBart1 = toBase64Text "text-for-bart1" + encodedTextForBart2 = toBase64Text "text-for-bart2" + encodedTextForCarl = toBase64Text "text-for-carl" + encodedData = toBase64Text "data" liftIO $ do - let expectedRequests = - [ (F.Brig, "get-user-clients"), - (F.Galley, "on-message-sent") - ] - forM_ (zip requests expectedRequests) $ \(req, (component, rpcPath)) -> do - F.domain req @?= domainText (qDomain deeRemote) - fmap F.component (F.request req) @?= Just component - fmap F.path (F.request req) @?= Just ("/federation/" <> rpcPath) - let encodedTextForBob = toBase64Text "text-for-bob" - encodedTextForChad = toBase64Text "text-for-chad" - encodedData = toBase64Text "data" - WS.assertMatch_ t wsBob (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient bobClient encodedTextForBob) - WS.assertMatch_ t wsChad (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient chadClient encodedTextForChad) + let matchReq domain component r = F.domain r == domainText domain && (F.component <$> F.request r) == Just component + filterReq domain component = filter (matchReq domain component) requests + bBrigReq <- assertOne $ filterReq bDomain F.Brig + bGalleyReq <- assertOne $ filterReq bDomain F.Galley + cBrigReq <- assertOne $ filterReq cDomain F.Brig + cGalleyReq <- assertOne $ filterReq cDomain F.Galley + + (F.path <$> F.request bBrigReq) @?= Just "/federation/get-user-clients" + (sort . FederatedBrig.gucUsers <$> parseFedRequest bBrigReq) @?= Right (sort $ qUnqualified <$> [bob, bart]) + (F.path <$> F.request cBrigReq) @?= Just "/federation/get-user-clients" + parseFedRequest cBrigReq @?= Right (FederatedBrig.GetUserClients [qUnqualified carl]) + + (F.path <$> F.request bGalleyReq) @?= Just "/federation/on-message-sent" + bActualNotif <- assertRight $ parseFedRequest bGalleyReq + let bExpectedNotif = + FederatedGalley.RemoteMessage + { rmTime = FederatedGalley.rmTime bActualNotif, + rmData = Just $ toBase64Text "data", + rmSender = alice, + rmSenderClient = aliceClient, + rmConversation = qUnqualified convId, + rmPriority = Nothing, + rmPush = True, + rmTransient = False, + rmRecipients = + UserClientMap $ + Map.fromList + [ (qUnqualified bob, Map.singleton bobClient encodedTextForBob), + ( qUnqualified bart, + Map.fromList + [ (bartClient1, encodedTextForBart1), + (bartClient2, encodedTextForBart2) + ] + ) + ] + } + bActualNotif @?= bExpectedNotif + (F.path <$> F.request cGalleyReq) @?= Just "/federation/on-message-sent" + cActualNotif <- assertRight $ parseFedRequest cGalleyReq + let cExpectedNotif = + bExpectedNotif + { FederatedGalley.rmRecipients = + UserClientMap $ Map.fromList [(qUnqualified carl, Map.singleton carlClient encodedTextForCarl)] + } + cActualNotif @?= cExpectedNotif + + WS.assertMatch_ t wsAlex1 (wsAssertOtr' encodedData convId alice aliceClient alexClient encodedTextForAlex1) + WS.assertMatch_ t wsAlex2 (wsAssertOtr' encodedData convId alice aliceClient alexClient2 encodedTextForAlex2) + WS.assertMatch_ t wsAmy (wsAssertOtr' encodedData convId alice aliceClient amyClient encodedTextForAmy) -- | Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is @@ -694,12 +755,12 @@ postMessageQualifiedLocalOwningBackendMissingClients = do let message = [(chadOwningDomain, chadClient, "text-for-chad")] -- FUTUREWORK: Mock federator and ensure that message is not propagated to remotes WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } - galleyApi = emptyFederatedGalley + galleyApi _ = emptyFederatedGalley (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi @@ -771,7 +832,7 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do ] -- FUTUREWORK: Mock federator and ensure that a message to Dee is sent - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \getUserClients -> let lookupClients uid @@ -780,7 +841,7 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do | otherwise = Nothing in pure $ UserMap . Map.fromList . mapMaybe lookupClients $ FederatedBrig.gucUsers getUserClients } - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.onMessageSent = \_ _ -> pure () } @@ -851,11 +912,11 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } - galleyApi = emptyFederatedGalley + galleyApi _ = emptyFederatedGalley -- Missing Bob, chadClient2 and Dee let message = [(chadOwningDomain, chadClient, "text-for-chad")] @@ -984,12 +1045,12 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do (deeRemote, deeClient, "text-for-dee") ] - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.onMessageSent = \_ _ -> throwError err503 {errBody = "Down for maintenance."} } @@ -1023,13 +1084,13 @@ postMessageQualifiedRemoteOwningBackendFailure = do let remoteDomain = Domain "far-away.example.com" convId = Qualified convIdUnqualified remoteDomain - let galleyApi = + let galleyApi _ = emptyFederatedGalley { FederatedGalley.sendMessage = \_ _ -> throwError err503 {errBody = "Down for maintenance."} } (resp2, _requests) <- - postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId [] "data" Message.MismatchReportAll emptyFederatedBrig galleyApi + postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId [] "data" Message.MismatchReportAll (const emptyFederatedBrig) galleyApi pure resp2 !!! do const 533 === statusCode @@ -1063,13 +1124,13 @@ postMessageQualifiedRemoteOwningBackendSuccess = do Message.mssFailedToSend = mempty } message = [(bobOwningDomain, bobClient, "text-for-bob"), (deeRemote, deeClient, "text-for-dee")] - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.sendMessage = \_ _ -> pure (FederatedGalley.MessageSendResponse (Right mss)) } (resp2, _requests) <- - postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll emptyFederatedBrig galleyApi + postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll (const emptyFederatedBrig) galleyApi pure resp2 !!! do const 201 === statusCode @@ -2001,8 +2062,8 @@ testDeleteTeamConversationWithRemoteMembers = do connectWithRemoteUser alice remoteBob - let brigApi = emptyFederatedBrig - galleyApi = + let brigApi _ = emptyFederatedBrig + galleyApi _ = emptyFederatedGalley { onConversationUpdated = \_domain _update -> pure () } @@ -2015,20 +2076,13 @@ testDeleteTeamConversationWithRemoteMembers = do !!! const 200 === statusCode liftIO $ do - let convUpdates = mapMaybe parseFedRequest received - convUpdate <- case (filter ((== ConversationActionDelete) . cuAction) convUpdates) of + let convUpdates = mapMaybe (eitherToMaybe . parseFedRequest) received + convUpdate <- case filter ((== ConversationActionDelete) . cuAction) convUpdates of [] -> assertFailure "No ConversationUpdate requests received" [convDelete] -> pure convDelete _ -> assertFailure "Multiple ConversationUpdate requests received" cuAlreadyPresentUsers convUpdate @?= [bobId] cuOrigUserId convUpdate @?= qalice - where - parseFedRequest :: FromJSON a => F.FederatedRequest -> Maybe a - parseFedRequest fr = - case F.request fr of - Just r -> - (decode . cs) (F.body r) - Nothing -> Nothing testGetQualifiedLocalConv :: TestM () testGetQualifiedLocalConv = do diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 2665106b2d8..67b259a8356 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -22,7 +22,7 @@ import API.Util import Bilge import Bilge.Assert import Control.Lens hiding ((#)) -import Data.Aeson (FromJSON, ToJSON (..), eitherDecode) +import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS @@ -976,10 +976,3 @@ onUserDeleted = do FedGalley.cuConvId eveDomainRPCReq @?= qUnqualified groupConvId FedGalley.cuAlreadyPresentUsers eveDomainRPCReq @?= [qUnqualified eve] FedGalley.cuAction eveDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) - where - parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a - parseFedRequest fr = - case F.request fr of - Just r -> - (eitherDecode . cs) (F.body r) - Nothing -> Left "No request" diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index a0521b675a8..391387d15c1 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -685,8 +685,8 @@ postProteusMessageQualifiedWithMockFederator :: [(Qualified UserId, ClientId, ByteString)] -> ByteString -> ClientMismatchStrategy -> - FederatedBrig.Api (AsServerT Handler) -> - FederatedGalley.Api (AsServerT Handler) -> + (Domain -> FederatedBrig.Api (AsServerT Handler)) -> + (Domain -> FederatedGalley.Api (AsServerT Handler)) -> TestM (ResponseLBS, Mock.ReceivedRequests) postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat brigApi galleyApi = do localDomain <- viewFederationDomain @@ -2252,19 +2252,22 @@ withTempMockFederator' resp action = do withTempServantMockFederator :: (MonadMask m, MonadIO m, HasGalley m) => - FederatedBrig.Api (AsServerT Handler) -> - FederatedGalley.Api (AsServerT Handler) -> + (Domain -> FederatedBrig.Api (AsServerT Handler)) -> + (Domain -> FederatedGalley.Api (AsServerT Handler)) -> Domain -> SessionT m b -> m (b, Mock.ReceivedRequests) withTempServantMockFederator brigApi galleyApi originDomain = withTempMockFederator' mock where - server :: ServerT (ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api) Handler - server = genericServerT brigApi :<|> genericServerT galleyApi + server :: Domain -> ServerT CombinedBrigAndGalleyAPI Handler + server d = genericServerT (brigApi d) :<|> genericServerT (galleyApi d) mock :: F.FederatedRequest -> IO F.OutwardResponse - mock = makeFedRequestToServant @(ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api) originDomain server + mock req = + makeFedRequestToServant @CombinedBrigAndGalleyAPI originDomain (server (Domain (F.domain req))) req + +type CombinedBrigAndGalleyAPI = ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api makeFedRequestToServant :: forall (api :: *). @@ -2462,10 +2465,21 @@ fedRequestsForDomain domain component = && fmap F.component (F.request req) == Just component ) +parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a +parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs +assertJust :: (HasCallStack, MonadIO m) => Maybe a -> m a +assertJust (Just a) = pure a +assertJust Nothing = liftIO $ assertFailure "Expected Just, got Nothing" + iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> TestM ResponseLBS iUpsertOne2OneConversation req = do galley <- view tsGalley From d670e3bb1579a7068320e64c28707d9ced9233af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 2 Nov 2021 13:47:31 +0100 Subject: [PATCH 59/88] Remove Locale from the UserProfile model (#1888) * Remove the profile locale from the publicly facing user profiles --- changelog.d/1-api-changes/remove-locale-in-user-profiles | 1 + libs/wire-api/src/Wire/API/User.hs | 6 +----- .../test/golden/testObject_UserProfile_user_2.json | 1 - .../Test/Wire/API/Golden/Generated/UserProfile_user.hs | 8 -------- libs/wire-api/test/unit/Test/Wire/API/User.hs | 2 +- services/galley/test/integration/API/Util.hs | 1 - 6 files changed, 3 insertions(+), 16 deletions(-) create mode 100644 changelog.d/1-api-changes/remove-locale-in-user-profiles diff --git a/changelog.d/1-api-changes/remove-locale-in-user-profiles b/changelog.d/1-api-changes/remove-locale-in-user-profiles new file mode 100644 index 00000000000..bab32abbbb7 --- /dev/null +++ b/changelog.d/1-api-changes/remove-locale-in-user-profiles @@ -0,0 +1 @@ +Remove locale from publicly facing user profiles (but not from the self profile) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 7a98a355eb4..e5cb2e78f07 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -213,7 +213,6 @@ data UserProfile = UserProfile -- i.e. it is a "bot". profileService :: Maybe ServiceRef, profileHandle :: Maybe Handle, - profileLocale :: Maybe Locale, profileExpire :: Maybe UTCTimeMillis, profileTeam :: Maybe TeamId, profileEmail :: Maybe Email, @@ -238,7 +237,6 @@ instance ToSchema UserProfile where .= fmap (fromMaybe False) (opt (field "deleted" schema)) <*> profileService .= opt (field "service" schema) <*> profileHandle .= opt (field "handle" schema) - <*> profileLocale .= opt (field "locale" schema) <*> profileExpire .= opt (field "expires_at" schema) <*> profileTeam .= opt (field "team" schema) <*> profileEmail .= opt (field "email" schema) @@ -429,7 +427,6 @@ connectedProfile u legalHoldStatus = profileAssets = userAssets u, profileAccentId = userAccentId u, profileService = userService u, - profileLocale = Just (userLocale u), profileDeleted = userDeleted u, profileExpire = userExpire u, profileTeam = userTeam u, @@ -459,8 +456,7 @@ publicProfile u legalHoldStatus = profileLegalholdStatus } = connectedProfile u legalHoldStatus in UserProfile - { profileLocale = Nothing, - profileEmail = Nothing, + { profileEmail = Nothing, profileQualifiedId, profileHandle, profileName, diff --git a/libs/wire-api/test/golden/testObject_UserProfile_user_2.json b/libs/wire-api/test/golden/testObject_UserProfile_user_2.json index 0e515e092a5..ed38b1acdff 100644 --- a/libs/wire-api/test/golden/testObject_UserProfile_user_2.json +++ b/libs/wire-api/test/golden/testObject_UserProfile_user_2.json @@ -7,7 +7,6 @@ "handle": "emsonpvo3-x_4ys4qjtjtkfgx.mag6pi2ldq.77m5vnsn_tte41r-0vwgklpeejr1t4se0bknu4tsuqs-njzh34-ba_mj8lm5x6aro4o.2wsqe0ldx", "id": "00000002-0000-0002-0000-000000000001", "legalhold_status": "no_consent", - "locale": "ny-MU", "name": "si4v󴃿\u001b^'ゟk喁\u0015?􈒳\u0000Bw;\u00083*R/𨄵lrI", "picture": [], "qualified_id": { diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserProfile_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserProfile_user.hs index b9363e28b80..e1586dde396 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserProfile_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserProfile_user.hs @@ -20,10 +20,8 @@ module Test.Wire.API.Golden.Generated.UserProfile_user where import Data.Domain (Domain (Domain, _domainText)) import Data.Handle (Handle (Handle, fromHandle)) -import Data.ISO3166_CountryCodes (CountryCode (MU)) import Data.Id (Id (Id)) import Data.Json.Util (readUTCTimeMillis) -import qualified Data.LanguageCodes (ISO639_1 (NY)) import Data.LegalHold (UserLegalHoldStatus (..)) import Data.Qualified (Qualified (Qualified, qDomain, qUnqualified)) import qualified Data.UUID as UUID (fromString) @@ -31,10 +29,7 @@ import Imports (Bool (False, True), Maybe (Just, Nothing), fromJust) import Wire.API.Provider.Service (ServiceRef (ServiceRef, _serviceRefId, _serviceRefProvider)) import Wire.API.User ( ColourId (ColourId, fromColourId), - Country (Country, fromCountry), Email (Email, emailDomain, emailLocal), - Language (Language), - Locale (Locale, lCountry, lLanguage), Name (Name, fromName), Pict (Pict, fromPict), UserProfile (..), @@ -55,7 +50,6 @@ testObject_UserProfile_user_1 = profileDeleted = False, profileService = Nothing, profileHandle = Nothing, - profileLocale = Nothing, profileExpire = Nothing, profileTeam = Nothing, profileEmail = Nothing, @@ -89,8 +83,6 @@ testObject_UserProfile_user_2 = "emsonpvo3-x_4ys4qjtjtkfgx.mag6pi2ldq.77m5vnsn_tte41r-0vwgklpeejr1t4se0bknu4tsuqs-njzh34-ba_mj8lm5x6aro4o.2wsqe0ldx" } ), - profileLocale = - Just (Locale {lLanguage = Language Data.LanguageCodes.NY, lCountry = Just (Country {fromCountry = MU})}), profileExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T01:42:22.437Z")), profileTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000002"))), profileEmail = Just (Email {emailLocal = "\172353 ", emailDomain = ""}), diff --git a/libs/wire-api/test/unit/Test/Wire/API/User.hs b/libs/wire-api/test/unit/Test/Wire/API/User.hs index 86c4a0687fe..cea7b4f227e 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/User.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/User.hs @@ -47,7 +47,7 @@ testUserProfile = do uid <- Id <$> UUID.nextRandom let domain = Domain "example.com" let colour = ColourId 0 - let userProfile = UserProfile (Qualified uid domain) (Name "name") (Pict []) [] colour False Nothing Nothing Nothing Nothing Nothing Nothing UserLegalHoldNoConsent + let userProfile = UserProfile (Qualified uid domain) (Name "name") (Pict []) [] colour False Nothing Nothing Nothing Nothing Nothing UserLegalHoldNoConsent let profileJSONAsText = show $ Aeson.encode userProfile let msg = "toJSON encoding must not convert Nothing to null, but instead omit those json fields for backwards compatibility. UserProfileJSON:" <> profileJSONAsText assertBool msg (not $ "null" `isInfixOf` profileJSONAsText) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 391387d15c1..952121b98af 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -2209,7 +2209,6 @@ mkProfile quid name = profileDeleted = False, profileService = Nothing, profileHandle = Nothing, - profileLocale = Nothing, profileExpire = Nothing, profileTeam = Nothing, profileEmail = Nothing, From 747eba6c3b95c20c869c898c601c1de107d5ba19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 2 Nov 2021 13:48:59 +0100 Subject: [PATCH 60/88] Extend a Federation API Test for Getting Conversations (#1896) * Add a one-to-one conversation test in getting conversations in the federation API --- .../extend-get-conversations-test | 1 + .../galley/test/integration/API/Federation.hs | 35 +++++++++++++------ 2 files changed, 26 insertions(+), 10 deletions(-) create mode 100644 changelog.d/6-federation/extend-get-conversations-test diff --git a/changelog.d/6-federation/extend-get-conversations-test b/changelog.d/6-federation/extend-get-conversations-test new file mode 100644 index 00000000000..8de3baa748c --- /dev/null +++ b/changelog.d/6-federation/extend-get-conversations-test @@ -0,0 +1 @@ +Add a one-to-one conversation test in getting conversations in the federation API diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 67b259a8356..b107d5c22b1 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -88,27 +88,42 @@ tests s = getConversationsAllFound :: TestM () getConversationsAllFound = do - bob <- randomUser - - -- create & get group conv - aliceQ <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + bobQ <- randomQualifiedUser + let bob = qUnqualified bobQ + lBob = toLocalUnsafe (qDomain bobQ) (qUnqualified bobQ) + (rAlice, cnv1Id) <- generateRemoteAndConvId True lBob + let aliceQ = qUntagged rAlice carlQ <- randomQualifiedUser connectUsers bob (singleton (qUnqualified carlQ)) connectWithRemoteUser bob aliceQ + -- create & get group conv cnv2 <- responseJsonError =<< postConvWithRemoteUsers bob defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} - getConvs bob (Just $ Left [qUnqualified (cnvQualifiedId cnv2)]) Nothing !!! do - const 200 === statusCode - const (Just (Just [cnvQualifiedId cnv2])) - === fmap (fmap (map cnvQualifiedId . convList)) . responseJsonMaybe + -- create a one-to-one conversation between bob and alice + do + let createO2O = + UpsertOne2OneConversationRequest + { uooLocalUser = lBob, + uooRemoteUser = rAlice, + uooActor = LocalActor, + uooActorDesiredMembership = Included, + uooConvId = Just cnv1Id + } + UpsertOne2OneConversationResponse cnv1IdReturned <- + responseJsonError + =<< iUpsertOne2OneConversation createO2O + liftIO $ assertEqual "Mismatch in the generated conversation ID" cnv1IdReturned cnv1Id - -- FUTUREWORK: also create a one2one conversation + getConvs bob (Just . Left . fmap qUnqualified $ [cnv1Id, cnvQualifiedId cnv2]) Nothing !!! do + const 200 === statusCode + const (Just . Just . sort $ [cnv1Id, cnvQualifiedId cnv2]) + === fmap (fmap (sort . map cnvQualifiedId . convList)) . responseJsonMaybe -- get conversations @@ -119,7 +134,7 @@ getConversationsAllFound = do (qDomain aliceQ) ( GetConversationsRequest (qUnqualified aliceQ) - (map (qUnqualified . cnvQualifiedId) [cnv2]) + (map qUnqualified [cnv1Id, cnvQualifiedId cnv2]) ) let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) convs From 81d5a1c457883abceba2c26f06c2be9804626cca Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 2 Nov 2021 14:39:39 +0100 Subject: [PATCH 61/88] Galley polysemy (2/5) - Store effects (#1890) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Introduce ConversationStore effect An effect for creating and deleting conversations. This commit also moves the corresponding Cassandra-specific code to the `Galley.Cassandra` hierarchy. This is for better module organisation: effects should depend on `Data` modules (for action types), but not on the specific implementation of these effects. It also avoids include cycles. * Add Paging module and ListItems effect * Add MemberStore effect * Add TeamStore effect * Add ListItems effect for teams * Add TeamMemberStore effect * Add ClientStore effect * Add CodeStore effect * Remove Data module * Add CHANGELOG entry * Add ServiceStore effect Also add `createBotMember` action to `MemberStore`. Co-authored-by: Marko Dimjašević --- changelog.d/5-internal/polysemy-store | 1 + .../src/Galley/Types/Conversations/Members.hs | 16 +- libs/types-common/src/Data/Qualified.hs | 1 + .../brig/test/integration/API/Provider.hs | 10 +- services/galley/galley.cabal | 35 +- services/galley/package.yaml | 3 + services/galley/src/Galley/API/Clients.hs | 32 +- services/galley/src/Galley/API/Create.hs | 146 +- services/galley/src/Galley/API/Federation.hs | 81 +- services/galley/src/Galley/API/Internal.hs | 63 +- services/galley/src/Galley/API/LegalHold.hs | 281 +++- .../src/Galley/API/LegalHold/Conflicts.hs | 10 +- services/galley/src/Galley/API/Mapping.hs | 2 +- services/galley/src/Galley/API/Message.hs | 29 +- services/galley/src/Galley/API/One2One.hs | 54 +- services/galley/src/Galley/API/Query.hs | 188 ++- services/galley/src/Galley/API/Teams.hs | 440 ++++-- .../galley/src/Galley/API/Teams/Features.hs | 78 +- services/galley/src/Galley/API/Update.hs | 409 ++++-- services/galley/src/Galley/API/Util.hs | 167 ++- services/galley/src/Galley/App.hs | 108 +- services/galley/src/Galley/Cassandra.hs | 23 + .../galley/src/Galley/Cassandra/Client.hs | 64 + services/galley/src/Galley/Cassandra/Code.hs | 58 + .../src/Galley/Cassandra/Conversation.hs | 362 +++++ .../Galley/Cassandra/Conversation/Members.hs | 361 +++++ .../src/Galley/Cassandra/ConversationList.hs | 87 ++ .../galley/src/Galley/Cassandra/LegalHold.hs | 30 + .../galley/src/Galley/Cassandra/Paging.hs | 97 ++ .../galley/src/Galley/Cassandra/Services.hs | 78 + services/galley/src/Galley/Cassandra/Store.hs | 31 + services/galley/src/Galley/Cassandra/Team.hs | 423 ++++++ services/galley/src/Galley/Data.hs | 1274 ----------------- services/galley/src/Galley/Data/Access.hs | 60 + .../galley/src/Galley/Data/Conversation.hs | 89 ++ .../src/Galley/Data/Conversation/Types.hs | 61 + services/galley/src/Galley/Data/LegalHold.hs | 12 +- services/galley/src/Galley/Data/Queries.hs | 2 +- services/galley/src/Galley/Data/ResultSet.hs | 51 + services/galley/src/Galley/Data/Scope.hs | 34 + services/galley/src/Galley/Data/Services.hs | 62 +- services/galley/src/Galley/Data/Types.hs | 52 +- services/galley/src/Galley/Effects.hs | 37 +- .../galley/src/Galley/Effects/ClientStore.hs | 44 + .../galley/src/Galley/Effects/CodeStore.hs | 43 + .../src/Galley/Effects/ConversationStore.hs | 112 ++ .../galley/src/Galley/Effects/ListItems.hs | 37 + .../galley/src/Galley/Effects/MemberStore.hs | 72 + services/galley/src/Galley/Effects/Paging.hs | 72 + .../Effects/RemoteConversationListStore.hs | 43 + .../galley/src/Galley/Effects/ServiceStore.hs | 42 + .../src/Galley/Effects/TeamMemberStore.hs | 40 + .../galley/src/Galley/Effects/TeamStore.hs | 119 ++ services/galley/src/Galley/Env.hs | 60 + services/galley/src/Galley/External.hs | 4 +- services/galley/src/Galley/Intra/Journal.hs | 34 +- services/galley/src/Galley/Run.hs | 4 +- .../galley/src/Galley/Types/ToUserRole.hs | 30 + services/galley/src/Galley/Validation.hs | 16 +- .../test/integration/API/Teams/LegalHold.hs | 4 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 4 +- .../galley/test/unit/Test/Galley/Mapping.hs | 2 +- 62 files changed, 4226 insertions(+), 2058 deletions(-) create mode 100644 changelog.d/5-internal/polysemy-store create mode 100644 services/galley/src/Galley/Cassandra.hs create mode 100644 services/galley/src/Galley/Cassandra/Client.hs create mode 100644 services/galley/src/Galley/Cassandra/Code.hs create mode 100644 services/galley/src/Galley/Cassandra/Conversation.hs create mode 100644 services/galley/src/Galley/Cassandra/Conversation/Members.hs create mode 100644 services/galley/src/Galley/Cassandra/ConversationList.hs create mode 100644 services/galley/src/Galley/Cassandra/LegalHold.hs create mode 100644 services/galley/src/Galley/Cassandra/Paging.hs create mode 100644 services/galley/src/Galley/Cassandra/Services.hs create mode 100644 services/galley/src/Galley/Cassandra/Store.hs create mode 100644 services/galley/src/Galley/Cassandra/Team.hs delete mode 100644 services/galley/src/Galley/Data.hs create mode 100644 services/galley/src/Galley/Data/Access.hs create mode 100644 services/galley/src/Galley/Data/Conversation.hs create mode 100644 services/galley/src/Galley/Data/Conversation/Types.hs create mode 100644 services/galley/src/Galley/Data/ResultSet.hs create mode 100644 services/galley/src/Galley/Data/Scope.hs create mode 100644 services/galley/src/Galley/Effects/ClientStore.hs create mode 100644 services/galley/src/Galley/Effects/CodeStore.hs create mode 100644 services/galley/src/Galley/Effects/ConversationStore.hs create mode 100644 services/galley/src/Galley/Effects/ListItems.hs create mode 100644 services/galley/src/Galley/Effects/MemberStore.hs create mode 100644 services/galley/src/Galley/Effects/Paging.hs create mode 100644 services/galley/src/Galley/Effects/RemoteConversationListStore.hs create mode 100644 services/galley/src/Galley/Effects/ServiceStore.hs create mode 100644 services/galley/src/Galley/Effects/TeamMemberStore.hs create mode 100644 services/galley/src/Galley/Effects/TeamStore.hs create mode 100644 services/galley/src/Galley/Env.hs create mode 100644 services/galley/src/Galley/Types/ToUserRole.hs diff --git a/changelog.d/5-internal/polysemy-store b/changelog.d/5-internal/polysemy-store new file mode 100644 index 00000000000..98d604a47a4 --- /dev/null +++ b/changelog.d/5-internal/polysemy-store @@ -0,0 +1 @@ +Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy. diff --git a/libs/galley-types/src/Galley/Types/Conversations/Members.hs b/libs/galley-types/src/Galley/Types/Conversations/Members.hs index 42a3fb9ddad..cd172988eb1 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Members.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Members.hs @@ -22,6 +22,8 @@ module Galley.Types.Conversations.Members remoteMemberToOther, LocalMember (..), localMemberToOther, + newMember, + newMemberWithRole, MemberStatus (..), defMemberStatus, ) @@ -32,7 +34,7 @@ import Data.Id as Id import Data.Qualified import Imports import Wire.API.Conversation -import Wire.API.Conversation.Role (RoleName) +import Wire.API.Conversation.Role (RoleName, roleNameWireAdmin) import Wire.API.Provider.Service (ServiceRef) -- | Internal (cassandra) representation of a remote conversation member. @@ -59,6 +61,18 @@ data LocalMember = LocalMember } deriving stock (Show) +newMember :: UserId -> LocalMember +newMember u = newMemberWithRole (u, roleNameWireAdmin) + +newMemberWithRole :: (UserId, RoleName) -> LocalMember +newMemberWithRole (u, r) = + LocalMember + { lmId = u, + lmService = Nothing, + lmStatus = defMemberStatus, + lmConvRoleName = r + } + localMemberToOther :: Domain -> LocalMember -> OtherMember localMemberToOther domain x = OtherMember diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 4bce70e078a..fb89c8e86bb 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -21,6 +21,7 @@ module Data.Qualified ( -- * Qualified + QTag (..), Qualified (..), qToPair, QualifiedWithTag, diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index fb3a09bbc0e..d67ddf9476f 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -580,15 +580,9 @@ testBadFingerprint config db brig galley _cannon = do testAddRemoveBotTeam :: Config -> DB.ClientState -> Brig -> Galley -> Cannon -> Http () testAddRemoveBotTeam config db brig galley cannon = withTestService config db brig defServiceApp $ \sref buf -> do - (u1, u2, h, tid, cid, pid, sid) <- prepareBotUsersTeam brig galley sref - let (uid1, uid2) = (userId u1, userId u2) - quid1 = userQualifiedId u1 + (u1, u2, h, _, cid, pid, sid) <- prepareBotUsersTeam brig galley sref + let quid1 = userQualifiedId u1 localDomain = qDomain quid1 - -- Ensure cannot add bots to managed conversations - cidFail <- Team.createManagedConv galley tid uid1 [uid2] Nothing - addBot brig uid1 pid sid cidFail !!! do - const 403 === statusCode - const (Just "invalid-conversation") === fmap Error.label . responseJsonMaybe testAddRemoveBotUtil localDomain pid sid cid u1 u2 h sref buf brig galley cannon testBotTeamOnlyConv :: Config -> DB.ClientState -> Brig -> Galley -> Cannon -> Http () diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 36693c8b65f..37905a23de0 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 503d71d65ade51f149de711b6c0b958b0d7de6c3472c4831fc5549c20410b37a +-- hash: 1b185cc3a9afe5d7a6c21c93d6c031963a5eb924885b6314ffc92ce96c6b545d name: galley version: 0.83.0 @@ -45,18 +45,44 @@ library Galley.API.Util Galley.App Galley.Aws - Galley.Data + Galley.Cassandra + Galley.Cassandra.Client + Galley.Cassandra.Code + Galley.Cassandra.Conversation + Galley.Cassandra.Conversation.Members + Galley.Cassandra.ConversationList + Galley.Cassandra.LegalHold + Galley.Cassandra.Paging + Galley.Cassandra.Services + Galley.Cassandra.Store + Galley.Cassandra.Team + Galley.Data.Access + Galley.Data.Conversation + Galley.Data.Conversation.Types Galley.Data.CustomBackend Galley.Data.Instances Galley.Data.LegalHold Galley.Data.Queries + Galley.Data.ResultSet + Galley.Data.Scope Galley.Data.SearchVisibility Galley.Data.Services Galley.Data.TeamFeatures Galley.Data.TeamNotifications Galley.Data.Types Galley.Effects + Galley.Effects.ClientStore + Galley.Effects.CodeStore + Galley.Effects.ConversationStore Galley.Effects.FireAndForget + Galley.Effects.ListItems + Galley.Effects.MemberStore + Galley.Effects.Paging + Galley.Effects.RemoteConversationListStore + Galley.Effects.ServiceStore + Galley.Effects.TeamMemberStore + Galley.Effects.TeamStore + Galley.Env Galley.External Galley.External.LegalHoldService Galley.Intra.Client @@ -70,6 +96,7 @@ library Galley.Queue Galley.Run Galley.Types.Clients + Galley.Types.ToUserRole Galley.Types.UserList Galley.Validation Main @@ -78,7 +105,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fplugin=Polysemy.Plugin build-depends: HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 @@ -124,6 +151,8 @@ library , optparse-applicative >=0.10 , pem , polysemy + , polysemy-plugin + , polysemy-wire-zoo , proto-lens >=0.2 , protobuf >=0.2 , raw-strings-qq >=1.0 diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 03a557c84e7..ebc59277a50 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -26,6 +26,7 @@ dependencies: library: source-dirs: src + ghc-options: -fplugin=Polysemy.Plugin dependencies: - aeson >=0.11 - amazonka >=1.4.5 @@ -66,6 +67,8 @@ library: - optparse-applicative >=0.10 - pem - polysemy + - polysemy-plugin + - polysemy-wire-zoo - protobuf >=0.2 - proto-lens >=0.2 - QuickCheck >=2.14 diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index e9c90bf5a29..03fc8f75e16 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -25,8 +25,8 @@ where import Control.Lens (view) import Data.Id import Galley.App -import qualified Galley.Data as Data import Galley.Effects +import qualified Galley.Effects.ClientStore as E import qualified Galley.Intra.Client as Intra import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) @@ -35,25 +35,37 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities -getClientsH :: Member BrigAccess r => UserId -> Galley r Response +getClientsH :: + Members '[BrigAccess, ClientStore] r => + UserId -> + Galley r Response getClientsH usr = do json <$> getClients usr -getClients :: Member BrigAccess r => UserId -> Galley r [ClientId] +getClients :: + Members '[BrigAccess, ClientStore] r => + UserId -> + Galley r [ClientId] getClients usr = do isInternal <- view $ options . optSettings . setIntraListing clts <- if isInternal then fromUserClients <$> Intra.lookupClients [usr] - else Data.lookupClients [usr] + else liftSem $ E.getClients [usr] return $ clientIds usr clts -addClientH :: UserId ::: ClientId -> Galley r Response -addClientH (usr ::: clt) = do - Data.updateClient True usr clt +addClientH :: + Member ClientStore r => + UserId ::: ClientId -> + Galley r Response +addClientH (usr ::: clt) = liftSem $ do + E.createClient usr clt return empty -rmClientH :: UserId ::: ClientId -> Galley r Response -rmClientH (usr ::: clt) = do - Data.updateClient False usr clt +rmClientH :: + Member ClientStore r => + UserId ::: ClientId -> + Galley r Response +rmClientH (usr ::: clt) = liftSem $ do + E.deleteClient usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 182deff3267..3bc6e8f2ddc 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -6,7 +6,7 @@ -- the terms of the GNU Affero General Public License as published by the Free -- Software Foundation, either version 3 of the License, or (at your option) any -- later version. --- + -- This program is distributed in the hope that it will be useful, but WITHOUT -- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more @@ -39,10 +39,15 @@ import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Data.Access +import qualified Galley.Data.Conversation as Data +import Galley.Data.Conversation.Types import Galley.Effects +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.TeamStore as E import Galley.Intra.Push -import Galley.Types +import Galley.Types.Conversations.Members import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notTeamMember) import Galley.Types.UserList import Galley.Validation @@ -51,8 +56,10 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities +import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.Event.Conversation hiding (Conversation) import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Routes.Public.Galley (ConversationResponse) import Wire.API.Routes.Public.Util @@ -65,7 +72,7 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm -- -- See Note [managed conversations]. createGroupConversation :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => UserId -> ConnId -> Public.NewConvUnmanaged -> @@ -78,7 +85,7 @@ createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. internalCreateManagedConversationH :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do @@ -86,7 +93,7 @@ internalCreateManagedConversationH (zusr ::: zcon ::: req) = do handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv internalCreateManagedConversation :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => UserId -> ConnId -> NewConvManaged -> @@ -97,6 +104,7 @@ internalCreateManagedConversation zusr zcon (NewConvManaged body) = do Just tinfo -> createTeamGroupConv zusr zcon tinfo body ensureNoLegalholdConflicts :: + Member TeamStore r => [Remote UserId] -> [UserId] -> Galley r () @@ -108,7 +116,7 @@ ensureNoLegalholdConflicts remotes locals = do -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => UserId -> ConnId -> NewConvUnmanaged -> @@ -121,23 +129,34 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do ensureConnected lusr allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- - Data.createConversation - lusr - name - (access body) - (accessRole body) - checkedUsers - (newConvTeam body) - (newConvMessageTimer body) - (newConvReceiptMode body) - (newConvUsersRole body) + liftSem $ + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } notifyCreatedConversation Nothing zusr (Just zcon) c conversationCreated zusr c -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Only supports unmanaged conversations. createTeamGroupConv :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + BrigAccess, + FederatorAccess, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.ConvTeamInfo -> @@ -149,10 +168,10 @@ createTeamGroupConv zusr zcon tinfo body = do let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo - zusrMembership <- Data.teamMember convTeam zusr + zusrMembership <- liftSem $ E.getTeamMember convTeam zusr void $ permissionCheck CreateConversation zusrMembership checkedUsers <- checkedConvSize allUsers - convLocalMemberships <- mapM (Data.teamMember convTeam) (ulLocals allUsers) + convLocalMemberships <- mapM (liftSem . E.getTeamMember convTeam) (ulLocals allUsers) ensureAccessRole (accessRole body) (zip (ulLocals allUsers) convLocalMemberships) -- In teams we don't have 1:1 conversations, only regular conversations. We want -- users without the 'AddRemoveConvMember' permission to still be able to create @@ -172,16 +191,20 @@ createTeamGroupConv zusr zcon tinfo body = do ensureConnectedToRemotes lusr (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) conv <- - Data.createConversation - lusr - name - (access body) - (accessRole body) - checkedUsers - (newConvTeam body) - (newConvMessageTimer body) - (newConvReceiptMode body) - (newConvUsersRole body) + liftSem $ + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } now <- liftIO getCurrentTime -- NOTE: We only send (conversation) events to members of the conversation notifyCreatedConversation (Just now) zusr (Just zcon) conv @@ -190,18 +213,29 @@ createTeamGroupConv zusr zcon tinfo body = do ---------------------------------------------------------------------------- -- Other kinds of conversations -createSelfConversation :: UserId -> Galley r ConversationResponse +createSelfConversation :: + Member ConversationStore r => + UserId -> + Galley r ConversationResponse createSelfConversation zusr = do lusr <- qualifyLocal zusr - c <- Data.conversation (Id . toUUID $ zusr) + c <- liftSem $ E.getConversation (Id . toUUID $ zusr) maybe (create lusr) (conversationExisted zusr) c where create lusr = do - c <- Data.createSelfConversation lusr Nothing + c <- liftSem $ E.createSelfConversation lusr Nothing conversationCreated zusr c createOne2OneConversation :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + forall r. + Members + '[ BrigAccess, + ConversationStore, + FederatorAccess, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> NewConvUnmanaged -> @@ -229,14 +263,20 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do (createOne2OneConversationUnchecked lusr zcon n mtid . qUntagged) other where + verifyMembership :: TeamId -> UserId -> Galley r () verifyMembership tid u = do - membership <- Data.teamMember tid u + membership <- liftSem $ E.getTeamMember tid u when (isNothing membership) $ throwM noBindingTeamMembers + checkBindingTeamPermissions :: + Local UserId -> + Local UserId -> + TeamId -> + Galley r (Maybe TeamId) checkBindingTeamPermissions lusr lother tid = do - zusrMembership <- Data.teamMember tid (tUnqualified lusr) + zusrMembership <- liftSem $ E.getTeamMember tid (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership - Data.teamBinding tid >>= \case + liftSem (E.getTeamBinding tid) >>= \case Just Binding -> do verifyMembership tid (tUnqualified lusr) verifyMembership tid (tUnqualified lother) @@ -245,7 +285,7 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do Nothing -> throwM teamNotFound createLegacyOne2OneConversationUnchecked :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -254,17 +294,17 @@ createLegacyOne2OneConversationUnchecked :: Galley r ConversationResponse createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other - mc <- Data.conversation (tUnqualified lcnv) + mc <- liftSem $ E.getConversation (tUnqualified lcnv) case mc of Just c -> conversationExisted (tUnqualified self) c Nothing -> do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) - c <- Data.createLegacyOne2OneConversation self x y name mtid + c <- liftSem $ E.createLegacyOne2OneConversation self x y name mtid notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -280,7 +320,7 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess] r => Local ConvId -> Local UserId -> ConnId -> @@ -289,11 +329,11 @@ createOne2OneConversationLocally :: Qualified UserId -> Galley r ConversationResponse createOne2OneConversationLocally lcnv self zcon name mtid other = do - mc <- Data.conversation (tUnqualified lcnv) + mc <- liftSem $ E.getConversation (tUnqualified lcnv) case mc of Just c -> conversationExisted (tUnqualified self) c Nothing -> do - c <- Data.createOne2OneConversation lcnv self other name mtid + c <- liftSem $ E.createOne2OneConversation (tUnqualified lcnv) self other name mtid notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c conversationCreated (tUnqualified self) c @@ -309,7 +349,7 @@ createOne2OneConversationRemotely _ _ _ _ _ _ = throwM federationNotImplemented createConnectConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore] r => UserId -> Maybe ConnId -> Connect -> @@ -331,7 +371,7 @@ createConnectConversationWithRemote _ _ _ = throwM federationNotImplemented createLegacyConnectConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore] r => Local UserId -> Maybe ConnId -> Local UserId -> @@ -340,11 +380,11 @@ createLegacyConnectConversation :: createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) n <- rangeCheckedMaybe (cName j) - conv <- Data.conversation (Data.localOne2OneConvId x y) + conv <- liftSem $ E.getConversation (Data.localOne2OneConvId x y) maybe (create x y n) (update n) conv where create x y n = do - c <- Data.createConnectConversation lusr x y n + c <- liftSem $ E.createConnectConversation x y n now <- liftIO getCurrentTime let lcid = qualifyAs lusr (Data.convId c) e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) @@ -364,7 +404,7 @@ createLegacyConnectConversation lusr conn lrecipient j = do connect n conv | otherwise -> do lcid <- qualifyLocal (Data.convId conv) - mm <- Data.addMember lcid lusr + mm <- liftSem $ E.createMember lcid lusr let conv' = conv { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm @@ -384,8 +424,8 @@ createLegacyConnectConversation lusr conn lrecipient j = do localDomain <- viewFederationDomain let qconv = Qualified (Data.convId conv) localDomain n' <- case n of - Just x -> do - Data.updateConversation (Data.convId conv) x + Just x -> liftSem $ do + E.setConversationName (Data.convId conv) x return . Just $ fromRange x Nothing -> return $ Data.convName conv t <- liftIO getCurrentTime @@ -456,11 +496,11 @@ toUUIDs a b = do return (a', b') accessRole :: NewConv -> AccessRole -accessRole b = fromMaybe Data.defRole (newConvAccessRole b) +accessRole b = fromMaybe defRole (newConvAccessRole b) access :: NewConv -> [Access] access a = case Set.toList (newConvAccess a) of - [] -> Data.defRegularConvAccess + [] -> defRegularConvAccess (x : xs) -> x : xs newConvMembers :: Local x -> NewConv -> UserList UserId diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 5889cb12a1a..c0d81ce437e 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -39,10 +39,13 @@ import Galley.API.Update (notifyConversationMetadataUpdate) import qualified Galley.API.Update as API import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Effects +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.MemberStore as E import Galley.Intra.User (getConnections) import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) +import Galley.Types.UserList import Imports import Servant (ServerT) import Servant.API.Generic (ToServantApi) @@ -86,7 +89,7 @@ federationSitemap = } onConversationCreated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> NewRemoteConversation ConvId -> Galley r () @@ -124,15 +127,17 @@ onConversationCreated domain rc = do pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] getConversations :: + Member ConversationStore r => Domain -> GetConversationsRequest -> Galley r GetConversationsResponse getConversations domain (GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain - GetConversationsResponse - . mapMaybe (Mapping.conversationToRemote localDomain ruid) - <$> Data.localConversations cids + liftSem $ + GetConversationsResponse + . mapMaybe (Mapping.conversationToRemote localDomain ruid) + <$> E.getConversations cids getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList @@ -140,7 +145,7 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai -- | Update the local database with information on conversation members joining -- or leaving. Finally, push out notifications to local users. onConversationUpdated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> ConversationUpdate -> Galley r () @@ -153,7 +158,9 @@ onConversationUpdated requestingDomain cu = do -- Note: we generally do not send notifications to users that are not part of -- the conversation (from our point of view), to prevent spam from the remote -- backend. See also the comment below. - (presentUsers, allUsersArePresent) <- Data.filterRemoteConvMembers (cuAlreadyPresentUsers cu) qconvId + (presentUsers, allUsersArePresent) <- + liftSem $ + E.selectRemoteMembers (cuAlreadyPresentUsers cu) rconvId -- Perform action, and determine extra notification targets. -- @@ -171,17 +178,17 @@ onConversationUpdated requestingDomain cu = do case allAddedUsers of [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. (u : us) -> pure (Just $ ConversationActionAddMembers (u :| us) role, addedLocalUsers) - ConversationActionRemoveMembers toRemove -> do + ConversationActionRemoveMembers toRemove -> liftSem $ do let localUsers = getLocalUsers localDomain toRemove - Data.removeLocalMembersFromRemoteConv rconvId localUsers + E.deleteMembersInRemoteConversation rconvId localUsers pure (Just $ cuAction cu, []) ConversationActionRename _ -> pure (Just $ cuAction cu, []) ConversationActionMessageTimerUpdate _ -> pure (Just $ cuAction cu, []) ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, []) ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, []) ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionDelete -> do - Data.removeLocalMembersFromRemoteConv rconvId presentUsers + ConversationActionDelete -> liftSem $ do + E.deleteMembersInRemoteConversation rconvId presentUsers pure (Just $ cuAction cu, []) unless allUsersArePresent $ @@ -203,7 +210,7 @@ onConversationUpdated requestingDomain cu = do pushConversationEvent Nothing event targets [] addLocalUsersToRemoteConv :: - Member BrigAccess r => + Members '[BrigAccess, MemberStore] r => Remote ConvId -> Qualified UserId -> [UserId] -> @@ -225,12 +232,24 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do -- Update the local view of the remote conversation by adding only those local -- users that are connected to the adder - Data.addLocalMembersToRemoteConv remoteConvId connectedList + liftSem $ E.createMembersInRemoteConversation remoteConvId connectedList pure connected -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => Domain -> LeaveConversationRequest -> Galley r LeaveConversationResponse @@ -251,7 +270,7 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients onMessageSent :: - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[BotAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> RemoteMessage ConvId -> Galley r () @@ -267,7 +286,9 @@ onMessageSent domain rmUnqualified = do } recipientMap = userClientMap $ rmRecipients rm msgs = toMapOf (itraversed <.> itraversed) recipientMap - (members, allMembers) <- Data.filterRemoteConvMembers (Map.keys recipientMap) convId + (members, allMembers) <- + liftSem $ + E.selectRemoteMembers (Map.keys recipientMap) (rmConversation rm) unless allMembers $ Log.warn $ Log.field "conversation" (toByteString' (qUnqualified convId)) @@ -292,7 +313,18 @@ onMessageSent domain rmUnqualified = do } sendMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => Domain -> MessageSendRequest -> Galley r MessageSendResponse @@ -304,7 +336,15 @@ sendMessage originDomain msr = do err = throwM . invalidPayload . LT.pack onUserDeleted :: - Members '[FederatorAccess, FireAndForget, ExternalAccess, GundeckAccess] r => + Members + '[ ConversationStore, + FederatorAccess, + FireAndForget, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => Domain -> UserDeletedConversationsNotification -> Galley r EmptyResponse @@ -316,8 +356,8 @@ onUserDeleted origDomain udcn = do spawnMany $ fromRange convIds <&> \c -> do lc <- qualifyLocal c - mconv <- Data.conversation c - Data.removeRemoteMembersFromLocalConv c (pure deletedUser) + mconv <- liftSem $ E.getConversation c + liftSem $ E.deleteMembers c (UserList [] [deletedUser]) for_ mconv $ \conv -> do when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ case Data.convType conv of @@ -331,6 +371,7 @@ onUserDeleted origDomain udcn = do Public.SelfConv -> pure () Public.RegularConv -> do let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) + botsAndMembers = convBotsAndMembers conv void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index b939cf2d361..2c8ad18c856 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -25,7 +25,6 @@ module Galley.API.Internal ) where -import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) import Control.Monad.Except (runExceptT) @@ -51,10 +50,16 @@ import qualified Galley.API.Teams as Teams import Galley.API.Teams.Features (DoAuth (..)) import qualified Galley.API.Teams.Features as Features import qualified Galley.API.Update as Update -import Galley.API.Util (JSON, isMember, qualifyLocal, viewFederationDomain) +import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Paging +import qualified Galley.Data.Conversation as Data import Galley.Effects +import Galley.Effects.ClientStore +import Galley.Effects.ConversationStore +import Galley.Effects.MemberStore +import Galley.Effects.Paging +import Galley.Effects.TeamStore import qualified Galley.Intra.Push as Intra import qualified Galley.Queue as Q import Galley.Types @@ -64,6 +69,7 @@ import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..), import Galley.Types.Teams hiding (MemberLeave) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility +import Galley.Types.UserList import Imports hiding (head) import Network.HTTP.Types (status200) import Network.Wai @@ -296,7 +302,7 @@ servantSitemap = iGetTeamFeature :: forall a r. - Public.KnownTeamFeatureName a => + (Public.KnownTeamFeatureName a, Member TeamStore r) => (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -304,7 +310,7 @@ iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: forall a r. - Public.KnownTeamFeatureName a => + (Public.KnownTeamFeatureName a, Member TeamStore r) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> @@ -474,20 +480,36 @@ sitemap = do capture "tid" rmUser :: - forall r. - Members '[BrigAccess, ExternalAccess, FederatorAccess, GundeckAccess] r => + forall p1 p2 r. + ( p1 ~ CassandraPaging, + p2 ~ InternalPaging, + Members + '[ BrigAccess, + ClientStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + GundeckAccess, + ListItems p1 ConvId, + ListItems p1 (Remote ConvId), + ListItems p2 TeamId, + MemberStore, + TeamStore + ] + r + ) => UserId -> Maybe ConnId -> Galley r () rmUser user conn = do - let n = toRange (Proxy @100) :: Range 1 100 Int32 - nRange1000 = rcast n :: Range 1 1000 Int32 - tids <- Data.teamIdsForPagination user Nothing n + let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 + tids <- liftSem $ listTeams user Nothing maxBound leaveTeams tids allConvIds <- Query.conversationIdsPageFrom user (GetPaginatedConversationIds Nothing nRange1000) lusr <- qualifyLocal user goConvPages lusr nRange1000 allConvIds - Data.eraseClients user + + liftSem $ deleteClients user where goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley r () goConvPages lusr range page = do @@ -501,23 +523,24 @@ rmUser user conn = do newCids <- Query.conversationIdsPageFrom usr nextQuery goConvPages lusr range newCids - leaveTeams tids = for_ (Cql.result tids) $ \tid -> do - mems <- Data.teamMembersForFanout tid + leaveTeams page = for_ (pageItems page) $ \tid -> do + mems <- getTeamMembersForFanout tid uncheckedDeleteTeamMember user conn tid user mems - leaveTeams =<< Cql.liftClient (Cql.nextPage tids) + page' <- liftSem $ listTeams user (Just (pageState page)) maxBound + leaveTeams page' -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity - leaveLocalConversations :: [ConvId] -> Galley r () + leaveLocalConversations :: Member MemberStore r => [ConvId] -> Galley r () leaveLocalConversations ids = do localDomain <- viewFederationDomain - cc <- Data.localConversations ids + cc <- liftSem $ getConversations ids pp <- for cc $ \c -> case Data.convType c of SelfConv -> return Nothing - One2OneConv -> Data.removeMember user (Data.convId c) >> return Nothing - ConnectConv -> Data.removeMember user (Data.convId c) >> return Nothing + One2OneConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing + ConnectConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing RegularConv | user `isMember` Data.convLocalMembers c -> do - Data.removeLocalMembersFromLocalConv (Data.convId c) (pure user) + liftSem $ deleteMembers (Data.convId c) (UserList [user] []) now <- liftIO getCurrentTime let e = Event @@ -578,7 +601,7 @@ safeForever funName action = threadDelay 60000000 -- pause to keep worst-case noise in logs manageable guardLegalholdPolicyConflictsH :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 48d9eed39a9..92ac4bd512c 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -52,11 +52,15 @@ import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Paging +import qualified Galley.Data.Conversation as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import qualified Galley.Data.LegalHold as LegalHoldData import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects +import Galley.Effects.Paging +import Galley.Effects.TeamMemberStore +import Galley.Effects.TeamStore import qualified Galley.External.LegalHoldService as LHService import qualified Galley.Intra.Client as Client import Galley.Intra.User (getConnectionsUnqualified, putConnectionInternal) @@ -94,15 +98,23 @@ isLegalHoldEnabledForTeam tid = do FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> isTeamLegalholdWhitelisted tid -createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response +createSettingsH :: + Member TeamStore r => + UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> + Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do newService <- fromJsonBody req setStatus status201 . json <$> createSettings zusr tid newService -createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley r Public.ViewLegalHoldService +createSettings :: + Member TeamStore r => + UserId -> + TeamId -> + Public.NewLegalHoldService -> + Galley r Public.ViewLegalHoldService createSettings zusr tid newService = do assertLegalHoldEnabledForTeam tid - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) @@ -116,13 +128,20 @@ createSettings zusr tid newService = do LegalHoldData.createSettings service pure . viewLegalHoldService $ service -getSettingsH :: UserId ::: TeamId ::: JSON -> Galley r Response +getSettingsH :: + Member TeamStore r => + UserId ::: TeamId ::: JSON -> + Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid -getSettings :: UserId -> TeamId -> Galley r Public.ViewLegalHoldService +getSettings :: + Member TeamStore r => + UserId -> + TeamId -> + Galley r Public.ViewLegalHoldService getSettings zusr tid = do - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership isenabled <- isLegalHoldEnabledForTeam tid mresult <- LegalHoldData.getSettings tid @@ -132,7 +151,21 @@ getSettings zusr tid = do (True, Just result) -> viewLegalHoldService result removeSettingsH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore, + TeamMemberStore InternalPaging + ] + r => UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> Galley r Response removeSettingsH (zusr ::: tid ::: req ::: _) = do @@ -141,7 +174,24 @@ removeSettingsH (zusr ::: tid ::: req ::: _) = do pure noContent removeSettings :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + ( Paging p, + Bounded (PagingBounds p TeamMember), + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore, + TeamMemberStore p + ] + r + ) => UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> @@ -149,7 +199,7 @@ removeSettings :: removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting assertLegalHoldEnabledForTeam tid - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) @@ -168,14 +218,31 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: - forall r. - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + forall p r. + ( Paging p, + Bounded (PagingBounds p TeamMember), + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore, + TeamMemberStore p + ] + r + ) => TeamId -> Galley r () -removeSettings' tid = do - -- Loop through team members and run this action. - Data.withTeamMembersWithChunks tid action - LegalHoldData.removeSettings tid +removeSettings' tid = + withChunks + (\mps -> liftSem (listTeamMembers tid mps maxBound)) + action where action :: [TeamMember] -> Galley r () action membs = do @@ -194,13 +261,13 @@ removeSettings' tid = do -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response +getUserStatusH :: Member TeamStore r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid -getUserStatus :: TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse +getUserStatus :: Member TeamStore r => TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do - mTeamMember <- Data.teamMember tid uid + mTeamMember <- liftSem $ getTeamMember tid uid teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember let status = view legalHoldStatus teamMember (mlk, lcid) <- case status of @@ -228,7 +295,20 @@ getUserStatus tid uid = do -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). grantConsentH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response grantConsentH (zusr ::: tid ::: _) = do @@ -241,12 +321,27 @@ data GrantConsentResult | GrantConsentAlreadyGranted grantConsent :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r GrantConsentResult grantConsent zusr tid = do - userLHStatus <- fmap (view legalHoldStatus) <$> Data.teamMember tid zusr + userLHStatus <- + liftSem $ + fmap (view legalHoldStatus) <$> getTeamMember tid zusr case userLHStatus of Nothing -> throwM teamMemberNotFound @@ -258,7 +353,20 @@ grantConsent zusr tid = do -- | Request to provision a device on the legal hold service for a user requestDeviceH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response requestDeviceH (zusr ::: tid ::: uid ::: _) = do @@ -272,7 +380,20 @@ data RequestDeviceResult requestDevice :: forall r. - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> TeamId -> UserId -> @@ -282,9 +403,9 @@ requestDevice zusr tid uid = do Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.requestDevice") - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - member <- maybe (throwM teamMemberNotFound) pure =<< Data.teamMember tid uid + member <- maybe (throwM teamMemberNotFound) pure =<< liftSem (getTeamMember tid uid) case member ^. legalHoldStatus of UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice lhs @@ -319,7 +440,20 @@ requestDevice zusr tid uid = do -- it gets interupted. There's really no reason to delete them anyways -- since they are replaced if needed when registering new LH devices. approveDeviceH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> Galley r Response approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do @@ -328,7 +462,20 @@ approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do pure empty approveDevice :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> TeamId -> UserId -> @@ -343,7 +490,9 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo unless (zusr == uid) (throwM accessDenied) assertOnTeam uid tid ensureReAuthorised zusr mPassword - userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> Data.teamMember tid uid + userLHStatus <- + liftSem $ + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid assertUserLHPending userLHStatus mPreKeys <- LegalHoldData.selectPendingPrekeys uid (prekeys, lastPrekey') <- case mPreKeys of @@ -372,7 +521,20 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo UserLegalHoldNoConsent -> throwM userLegalHoldNotPending disableForUserH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> Galley r Response disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do @@ -387,7 +549,20 @@ data DisableLegalHoldForUserResponse disableForUser :: forall r. - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> TeamId -> UserId -> @@ -397,10 +572,12 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.disableForUser") - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> Data.teamMember tid uid + userLHStatus <- + liftSem $ + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid if not $ userLHEnabled userLHStatus then pure DisableLegalHoldWasNotEnabled else disableLH userLHStatus $> DisableLegalHoldSuccess @@ -419,7 +596,20 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- or disabled, make sure the affected connections are screened for policy conflict (anybody -- with no-consent), and put those connections in the appropriate blocked state. changeLegalholdStatus :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => TeamId -> UserId -> UserLegalHoldStatus -> @@ -460,7 +650,11 @@ changeLegalholdStatus tid uid old new = do illegal = throwM userLegalHoldIllegalOperation -- FUTUREWORK: make this async? -blockNonConsentingConnections :: forall r. Member BrigAccess r => UserId -> Galley r () +blockNonConsentingConnections :: + forall r. + Members '[BrigAccess, TeamStore] r => + UserId -> + Galley r () blockNonConsentingConnections uid = do conns <- getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do @@ -477,7 +671,7 @@ blockNonConsentingConnections uid = do let (FutureWork @'Public.LegalholdPlusFederationNotImplemented -> _remoteUids, localUids) = (undefined, csTo <$> conns) -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do - teamsOfUsers <- Data.usersTeams others + teamsOfUsers <- liftSem $ getUsersTeams others filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others blockConflicts :: UserId -> [UserId] -> Galley r [String] @@ -530,7 +724,20 @@ getTeamLegalholdWhitelistedH tid = do -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. handleGroupConvPolicyConflicts :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> UserLegalHoldStatus -> Galley r () diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 42bebf1fe3b..e780222cbeb 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -29,8 +29,8 @@ import Data.Misc import qualified Data.Set as Set import Galley.API.Util import Galley.App -import qualified Galley.Data as Data import Galley.Effects +import Galley.Effects.TeamStore import qualified Galley.Intra.Client as Intra import Galley.Intra.User (getUser) import Galley.Options @@ -44,7 +44,7 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts guardQualifiedLegalholdPolicyConflicts :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => LegalholdProtectee -> QualifiedUserClients -> Galley r (Either LegalholdConflicts ()) @@ -63,7 +63,7 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do -- This is a fallback safeguard that shouldn't get triggered if backend and clients work as -- intended. guardLegalholdPolicyConflicts :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => LegalholdProtectee -> UserClients -> Galley r (Either LegalholdConflicts ()) @@ -78,7 +78,7 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do guardLegalholdPolicyConflictsUid :: forall r. - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => UserId -> UserClients -> Galley r (Either LegalholdConflicts ()) @@ -130,7 +130,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do -- (we could also get the profile from brig. would make the code slightly more -- concise, but not really help with the rpc back-and-forth, so, like, why?) mbUser <- accountUser <$$> getUser self - mbTeamMember <- join <$> for (mbUser >>= userTeam) (`Data.teamMember` self) + mbTeamMember <- liftSem $ join <$> for (mbUser >>= userTeam) (`getTeamMember` self) let lhStatus = maybe defUserLegalHoldStatus (view legalHoldStatus) mbTeamMember pure (lhStatus == UserLegalHoldNoConsent) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index 9ee604c32b2..e7ce9a86671 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -32,7 +32,7 @@ import Data.Id (UserId, idToText) import Data.Qualified import Galley.API.Util (qualifyLocal) import Galley.App -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Data.Types (convId) import Galley.Types.Conversations.Members import Imports diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 5f03241147f..4c61f562896 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -24,9 +24,11 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util import Galley.App -import qualified Galley.Data as Data import Galley.Data.Services as Data import Galley.Effects +import Galley.Effects.ClientStore +import Galley.Effects.ConversationStore +import Galley.Effects.MemberStore import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push @@ -188,7 +190,7 @@ getRemoteClients remoteMembers = <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) postRemoteOtrMessage :: - Member FederatorAccess r => + Members '[ConversationStore, FederatorAccess] r => Qualified UserId -> Qualified ConvId -> LByteString -> @@ -204,7 +206,18 @@ postRemoteOtrMessage sender conv rawMsg = do FederatedGalley.msResponse <$> runFederatedGalley (qDomain conv) rpc postQualifiedOtrMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserType -> Qualified UserId -> Maybe ConnId -> @@ -212,7 +225,7 @@ postQualifiedOtrMessage :: QualifiedNewOtrMessage -> Galley r (PostOtrResponse MessageSendingStatus) postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do - alive <- lift $ Data.isConvAlive convId + alive <- lift . liftSem $ isConversationAlive convId localDomain <- viewFederationDomain now <- liftIO getCurrentTime let nowMillis = toUTCTimeMillis now @@ -220,12 +233,12 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do senderUser = qUnqualified sender let senderClient = qualifiedNewOtrSender msg unless alive $ do - lift $ Data.deleteConversation convId + lift . liftSem $ deleteConversation convId throwError MessageNotSentConversationNotFound -- conversation members - localMembers <- lift $ Data.members convId - remoteMembers <- lift $ Data.lookupRemoteMembers convId + localMembers <- lift . liftSem $ getLocalMembers convId + remoteMembers <- lift . liftSem $ getRemoteMembers convId let localMemberIds = lmId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -245,7 +258,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do lift $ if isInternal then Clients.fromUserClients <$> Intra.lookupClients localMemberIds - else Data.lookupClients localMemberIds + else liftSem $ getClients localMemberIds let qualifiedLocalClients = Map.mapKeys (localDomain,) . makeUserMap (Set.fromList (map lmId localMembers)) diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index d9978a18b2d..1458e9c464c 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -24,20 +24,27 @@ where import Data.Id import Data.Qualified -import Galley.App (Galley) -import qualified Galley.Data as Data +import Galley.App (Galley, liftSem) +import Galley.Data.Conversation +import Galley.Effects.ConversationStore +import Galley.Effects.MemberStore import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (..)) import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.UserList (UserList (..)) import Imports +import Polysemy -iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley r UpsertOne2OneConversationResponse -iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do +iUpsertOne2OneConversation :: + forall r. + Members '[ConversationStore, MemberStore] r => + UpsertOne2OneConversationRequest -> + Galley r UpsertOne2OneConversationResponse +iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = liftSem $ do let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId - let dolocal :: Local ConvId -> Galley r () + let dolocal :: Local ConvId -> Sem r () dolocal lconvId = do - mbConv <- Data.conversation (tUnqualified lconvId) + mbConv <- getConversation (tUnqualified lconvId) case mbConv of Nothing -> do let members = @@ -46,27 +53,36 @@ iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do (LocalActor, Excluded) -> UserList [] [] (RemoteActor, Included) -> UserList [] [uooRemoteUser] (RemoteActor, Excluded) -> UserList [] [] - unless (null members) $ - Data.createConnectConversationWithRemote lconvId uooLocalUser members + unless (null members) . void $ + createConnectConversationWithRemote + (tUnqualified lconvId) + (tUnqualified uooLocalUser) + members Just conv -> do case (uooActor, uooActorDesiredMembership) of (LocalActor, Included) -> do - void $ Data.addMember lconvId uooLocalUser - unless (null (Data.convRemoteMembers conv)) $ - Data.acceptConnect (tUnqualified lconvId) - (LocalActor, Excluded) -> Data.removeMember (tUnqualified uooLocalUser) (tUnqualified lconvId) + void $ createMember lconvId uooLocalUser + unless (null (convRemoteMembers conv)) $ + acceptConnectConversation (tUnqualified lconvId) + (LocalActor, Excluded) -> + deleteMembers + (tUnqualified lconvId) + (UserList [tUnqualified uooLocalUser] []) (RemoteActor, Included) -> do - void $ Data.addMembers lconvId (UserList [] [uooRemoteUser]) - unless (null (Data.convLocalMembers conv)) $ - Data.acceptConnect (tUnqualified lconvId) - (RemoteActor, Excluded) -> Data.removeRemoteMembersFromLocalConv (tUnqualified lconvId) (pure uooRemoteUser) - doremote :: Remote ConvId -> Galley r () + void $ createMembers (tUnqualified lconvId) (UserList [] [uooRemoteUser]) + unless (null (convLocalMembers conv)) $ + acceptConnectConversation (tUnqualified lconvId) + (RemoteActor, Excluded) -> + deleteMembers + (tUnqualified lconvId) + (UserList [] [uooRemoteUser]) + doremote :: Remote ConvId -> Sem r () doremote rconvId = case (uooActor, uooActorDesiredMembership) of (LocalActor, Included) -> do - Data.addLocalMembersToRemoteConv rconvId [tUnqualified uooLocalUser] + createMembersInRemoteConversation rconvId [tUnqualified uooLocalUser] (LocalActor, Excluded) -> do - Data.removeLocalMembersFromRemoteConv rconvId [tUnqualified uooLocalUser] + deleteMembersInRemoteConversation rconvId [tUnqualified uooLocalUser] (RemoteActor, _) -> pure () foldQualified uooLocalUser dolocal doremote convId diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 0666e32b506..6b07b1d18f6 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -51,9 +51,13 @@ import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Paging +import Galley.Data.ResultSet import qualified Galley.Data.Types as Data import Galley.Effects +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.ListItems as E +import qualified Galley.Effects.MemberStore as E import Galley.Types import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles @@ -63,6 +67,7 @@ import Network.Wai import Network.Wai.Predicate hiding (result, setStatus) import Network.Wai.Utilities import qualified Network.Wai.Utilities.Error as Wai +import Polysemy import qualified System.Logger.Class as Logger import UnliftIO (pooledForConcurrentlyN) import Wire.API.Conversation (ConversationCoverView (..)) @@ -76,11 +81,18 @@ import Wire.API.Federation.Error import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public -getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley r Response +getBotConversationH :: + Member ConversationStore r => + BotId ::: ConvId ::: JSON -> + Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv -getBotConversation :: BotId -> ConvId -> Galley r Public.BotConvView +getBotConversation :: + Member ConversationStore r => + BotId -> + ConvId -> + Galley r Public.BotConvView getBotConversation zbot zcnv = do (c, _) <- getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) (botUserId zbot) zcnv domain <- viewFederationDomain @@ -94,12 +106,21 @@ getBotConversation zbot zcnv = do | otherwise = Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) -getUnqualifiedConversation :: UserId -> ConvId -> Galley r Public.Conversation +getUnqualifiedConversation :: + Member ConversationStore r => + UserId -> + ConvId -> + Galley r Public.Conversation getUnqualifiedConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv Mapping.conversationView zusr c -getConversation :: UserId -> Qualified ConvId -> Galley r Public.Conversation +getConversation :: + forall r. + Member ConversationStore r => + UserId -> + Qualified ConvId -> + Galley r Public.Conversation getConversation zusr cnv = do lusr <- qualifyLocal zusr foldQualified @@ -116,7 +137,11 @@ getConversation zusr cnv = do [conv] -> pure conv _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") -getRemoteConversations :: UserId -> [Remote ConvId] -> Galley r [Public.Conversation] +getRemoteConversations :: + Member ConversationStore r => + UserId -> + [Remote ConvId] -> + Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error @@ -157,6 +182,7 @@ partitionGetConversationFailures = bimap concat concat . partitionEithers . map split (FailedGetConversation convs (FailedGetConversationRemotely _)) = Right convs getRemoteConversationsWithFailures :: + Member ConversationStore r => UserId -> [Remote ConvId] -> Galley r ([FailedGetConversation], [Public.Conversation]) @@ -165,7 +191,7 @@ getRemoteConversationsWithFailures zusr convs = do lusr <- qualifyLocal zusr -- get self member statuses from the database - statusMap <- Data.remoteConversationStatus zusr convs + statusMap <- liftSem $ E.getRemoteConversationStatus zusr convs let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation remoteView rconv = Mapping.remoteConversationView @@ -205,21 +231,30 @@ getRemoteConversationsWithFailures zusr convs = do . Logger.field "error" (show e) throwE e -getConversationRoles :: UserId -> ConvId -> Galley r Public.ConversationRolesList +getConversationRoles :: + Member ConversationStore r => + UserId -> + ConvId -> + Galley r Public.ConversationRolesList getConversationRoles zusr cnv = do void $ getConversationAndCheckMembership zusr cnv -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley r (Public.ConversationList ConvId) -conversationIdsPageFromUnqualified zusr start msize = do +conversationIdsPageFromUnqualified :: + Member (ListItems LegacyPaging ConvId) r => + UserId -> + Maybe ConvId -> + Maybe (Range 1 1000 Int32) -> + Galley r (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified zusr start msize = liftSem $ do let size = fromMaybe (toRange (Proxy @1000)) msize - ids <- Data.conversationIdsFrom zusr start size + ids <- E.listItems zusr start size pure $ Public.ConversationList - (Data.resultSetResult ids) - (Data.resultSetType ids == Data.ResultSetTruncated) + (resultSetResult ids) + (resultSetType ids == ResultSetTruncated) -- | Lists conversation ids for the logged in user in a paginated way. -- @@ -229,32 +264,53 @@ conversationIdsPageFromUnqualified zusr start msize = do -- -- - After local conversations, remote conversations are listed ordered -- - lexicographically by their domain and then by their id. -conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley r Public.ConvIdsPage +conversationIdsPageFrom :: + forall p r. + ( p ~ CassandraPaging, + Members '[ListItems p ConvId, ListItems p (Remote ConvId)] r + ) => + UserId -> + Public.GetPaginatedConversationIds -> + Galley r Public.ConvIdsPage conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localDomain <- viewFederationDomain - case gmtprState of - Just (Public.ConversationPagingState Public.PagingRemotes stateBS) -> remotesOnly (mkState <$> stateBS) (fromRange gmtprSize) + liftSem $ case gmtprState of + Just (Public.ConversationPagingState Public.PagingRemotes stateBS) -> + remotesOnly (mkState <$> stateBS) gmtprSize _ -> localsAndRemotes localDomain (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize where mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley r Public.ConvIdsPage + localsAndRemotes :: + Domain -> + Maybe C.PagingState -> + Range 1 1000 Int32 -> + Sem r Public.ConvIdsPage localsAndRemotes localDomain pagingState size = do - localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) <$> Data.localConversationIdsPageFrom zusr pagingState size + localPage <- + pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) + <$> E.listItems zusr pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. else do - remotePage <- remotesOnly Nothing remainingSize + -- remainingSize <= size and remainingSize >= 1, so it is safe to convert to Range + remotePage <- remotesOnly Nothing (unsafeRange remainingSize) pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} - remotesOnly :: Maybe C.PagingState -> Int32 -> Galley r Public.ConvIdsPage + remotesOnly :: + Members '[ListItems p (Remote ConvId)] r => + Maybe C.PagingState -> + Range 1 1000 Int32 -> + Sem r Public.ConvIdsPage remotesOnly pagingState size = - pageToConvIdPage Public.PagingRemotes <$> Data.remoteConversationIdsPageFrom zusr pagingState size + pageToConvIdPage Public.PagingRemotes + . fmap (qUntagged @'QRemote) + <$> E.listItems zusr pagingState size - pageToConvIdPage :: Public.LocalOrRemoteTable -> Data.PageWithState (Qualified ConvId) -> Public.ConvIdsPage - pageToConvIdPage table page@Data.PageWithState {..} = + pageToConvIdPage :: Public.LocalOrRemoteTable -> C.PageWithState (Qualified ConvId) -> Public.ConvIdsPage + pageToConvIdPage table page@C.PageWithState {..} = Public.MultiTablePage { mtpResults = pwsResults, mtpHasMore = C.pwsHasMore page, @@ -262,6 +318,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do } getConversations :: + Members '[ListItems LegacyPaging ConvId, ConversationStore] r => UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> @@ -272,38 +329,48 @@ getConversations user mids mstart msize = do flip ConversationList more <$> mapM (Mapping.conversationView user) cs getConversationsInternal :: + Members '[ConversationStore, ListItems LegacyPaging ConvId] r => UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley r (Public.ConversationList Data.Conversation) getConversationsInternal user mids mstart msize = do - (more, ids) <- getIds mids + (more, ids) <- liftSem $ getIds mids let localConvIds = ids cs <- - Data.localConversations localConvIds - >>= filterM removeDeleted + liftSem (E.getConversations localConvIds) + >>= filterM (liftSem . removeDeleted) >>= filterM (pure . isMember user . Data.convLocalMembers) pure $ Public.ConversationList cs more where size = fromMaybe (toRange (Proxy @32)) msize -- get ids and has_more flag + getIds :: + Members '[ConversationStore, ListItems LegacyPaging ConvId] r => + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Sem r (Bool, [ConvId]) getIds (Just ids) = (False,) - <$> Data.localConversationIdsOf + <$> E.selectConversations user (fromCommaSeparatedList (fromRange ids)) getIds Nothing = do - r <- Data.conversationIdsFrom user mstart (rcast size) - let hasMore = Data.resultSetType r == Data.ResultSetTruncated - pure (hasMore, Data.resultSetResult r) - + r <- E.listItems user mstart (rcast size) + let hasMore = resultSetType r == ResultSetTruncated + pure (hasMore, resultSetResult r) + + removeDeleted :: + Member ConversationStore r => + Data.Conversation -> + Sem r Bool removeDeleted c - | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False + | Data.isConvDeleted c = E.deleteConversation (Data.convId c) >> pure False | otherwise = pure True listConversations :: + Member ConversationStore r => UserId -> Public.ListConversations -> Galley r Public.ConversationsResponse @@ -311,10 +378,12 @@ listConversations user (Public.ListConversations ids) = do luser <- qualifyLocal user let (localIds, remoteIds) = partitionQualified luser (fromRange ids) - (foundLocalIds, notFoundLocalIds) <- foundsAndNotFounds (Data.localConversationIdsOf user) localIds + (foundLocalIds, notFoundLocalIds) <- + liftSem $ + foundsAndNotFounds (E.selectConversations user) localIds localInternalConversations <- - Data.localConversations foundLocalIds + liftSem (E.getConversations foundLocalIds) >>= filterM removeDeleted >>= filterM (pure . isMember user . Data.convLocalMembers) localConversations <- mapM (Mapping.conversationView user) localInternalConversations @@ -343,9 +412,12 @@ listConversations user (Public.ListConversations ids) = do crFailed = failedConvsRemotely } where - removeDeleted :: Data.Conversation -> Galley r Bool + removeDeleted :: + Member ConversationStore r => + Data.Conversation -> + Galley r Bool removeDeleted c - | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False + | Data.isConvDeleted c = liftSem $ E.deleteConversation (Data.convId c) >> pure False | otherwise = pure True foundsAndNotFounds :: (Monad m, Eq a) => ([a] -> m [a]) -> [a] -> m ([a], [a]) foundsAndNotFounds f xs = do @@ -354,6 +426,7 @@ listConversations user (Public.ListConversations ids) = do pure (founds, notFounds) iterateConversations :: + Members '[ListItems LegacyPaging ConvId, ConversationStore] r => UserId -> Range 1 500 Int32 -> ([Data.Conversation] -> Galley r a) -> @@ -371,36 +444,49 @@ iterateConversations uid pageSize handleConvs = go Nothing _ -> pure [] pure $ resultHead : resultTail -internalGetMemberH :: ConvId ::: UserId -> Galley r Response +internalGetMemberH :: + Members '[ConversationStore, MemberStore] r => + ConvId ::: UserId -> + Galley r Response internalGetMemberH (cnv ::: usr) = do json <$> getLocalSelf usr cnv -getLocalSelf :: UserId -> ConvId -> Galley r (Maybe Public.Member) +getLocalSelf :: + Members '[ConversationStore, MemberStore] r => + UserId -> + ConvId -> + Galley r (Maybe Public.Member) getLocalSelf usr cnv = do lusr <- qualifyLocal usr - alive <- Data.isConvAlive cnv - if alive - then Mapping.localMemberToSelf lusr <$$> Data.member cnv usr - else Nothing <$ Data.deleteConversation cnv - -getConversationMetaH :: ConvId -> Galley r Response + liftSem $ do + alive <- E.isConversationAlive cnv + if alive + then Mapping.localMemberToSelf lusr <$$> E.getLocalMember cnv usr + else Nothing <$ E.deleteConversation cnv + +getConversationMetaH :: + Member ConversationStore r => + ConvId -> + Galley r Response getConversationMetaH cnv = do getConversationMeta cnv <&> \case Nothing -> setStatus status404 empty Just meta -> json meta -getConversationMeta :: ConvId -> Galley r (Maybe ConversationMetadata) -getConversationMeta cnv = do - alive <- Data.isConvAlive cnv - localDomain <- viewFederationDomain +getConversationMeta :: + Member ConversationStore r => + ConvId -> + Galley r (Maybe ConversationMetadata) +getConversationMeta cnv = liftSem $ do + alive <- E.isConversationAlive cnv if alive - then Data.conversationMeta localDomain cnv + then E.getConversationMetadata cnv else do - Data.deleteConversation cnv + E.deleteConversation cnv pure Nothing getConversationByReusableCode :: - Member BrigAccess r => + Members '[CodeStore, ConversationStore, BrigAccess, TeamStore] r => UserId -> Key -> Value -> diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index b2d8f0681da..4b899c4e36e 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -61,7 +61,8 @@ import Brig.Types.Intra (accountUser) import Brig.Types.Team (TeamSize (..)) import Control.Lens import Control.Monad.Catch -import Data.ByteString.Conversion hiding (fromList) +import Data.ByteString.Conversion (List, toByteString) +import qualified Data.ByteString.Conversion import Data.ByteString.Lazy.Builder (lazyByteString) import qualified Data.CaseInsensitive as CI import Data.Csv (EncodeOptions (..), Quoting (QuoteAll), encodeDefaultOrderedByNameWith) @@ -70,11 +71,11 @@ import Data.Id import qualified Data.LegalHold as LH import qualified Data.List.Extra as List import Data.List1 (list1) +import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Misc (HttpsUrl, mkHttpsUrl) import Data.Qualified import Data.Range as Range -import Data.Set (fromList) import qualified Data.Set as Set import Data.Time.Clock (UTCTime (..), getCurrentTime) import qualified Data.UUID as UUID @@ -85,12 +86,20 @@ import qualified Galley.API.Teams.Notifications as APITeamQueue import qualified Galley.API.Update as API import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Paging +import qualified Galley.Data.Conversation as Data import qualified Galley.Data.LegalHold as Data +import qualified Galley.Data.ResultSet as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.ListItems as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.Paging as E +import qualified Galley.Effects.TeamMemberStore as E +import qualified Galley.Effects.TeamStore as E import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push @@ -106,14 +115,15 @@ import Galley.Types.Conversations.Roles as Roles import Galley.Types.Teams hiding (newTeam) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility +import Galley.Types.UserList import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus) import Network.Wai.Utilities +import Polysemy import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log -import UnliftIO.Async (mapConcurrently) import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription (ConvNotFound, NotATeamMember, operationDenied) import qualified Wire.API.Notification as Public @@ -129,40 +139,45 @@ import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) -getTeamH :: UserId ::: TeamId ::: JSON -> Galley r Response +getTeamH :: Member TeamStore r => UserId ::: TeamId ::: JSON -> Galley r Response getTeamH (zusr ::: tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid -getTeamInternalH :: TeamId ::: JSON -> Galley r Response +getTeamInternalH :: Member TeamStore r => TeamId ::: JSON -> Galley r Response getTeamInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< getTeamInternal tid + maybe (throwM teamNotFound) (pure . json) =<< liftSem (E.getTeam tid) -getTeamInternal :: TeamId -> Galley r (Maybe TeamData) -getTeamInternal = Data.team - -getTeamNameInternalH :: TeamId ::: JSON -> Galley r Response +getTeamNameInternalH :: Member TeamStore r => TeamId ::: JSON -> Galley r Response getTeamNameInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< getTeamNameInternal tid + maybe (throwM teamNotFound) (pure . json) =<< liftSem (getTeamNameInternal tid) -getTeamNameInternal :: TeamId -> Galley r (Maybe TeamName) -getTeamNameInternal = fmap (fmap TeamName) . Data.teamName +getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) +getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName -getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley r Response +getManyTeamsH :: + (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> + Galley r Response getManyTeamsH (zusr ::: range ::: size ::: _) = json <$> getManyTeams zusr range size -getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley r Public.TeamList +getManyTeams :: + (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + UserId -> + Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> + Range 1 100 Int32 -> + Galley r Public.TeamList getManyTeams zusr range size = withTeamIds zusr range size $ \more ids -> do teams <- mapM (lookupTeam zusr) ids pure (Public.newTeamList (catMaybes teams) more) -lookupTeam :: UserId -> TeamId -> Galley r (Maybe Public.Team) +lookupTeam :: Member TeamStore r => UserId -> TeamId -> Galley r (Maybe Public.Team) lookupTeam zusr tid = do - tm <- Data.teamMember tid zusr + tm <- liftSem $ E.getTeamMember tid zusr if isJust tm then do - t <- Data.team tid + t <- liftSem $ E.getTeam tid when (Just PendingDelete == (tdStatus <$> t)) $ do q <- view deleteQueue void $ Q.tryPush q (TeamItem tid zusr Nothing) @@ -170,7 +185,7 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members '[GundeckAccess, BrigAccess] r => + Members '[GundeckAccess, BrigAccess, TeamStore] r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do @@ -179,7 +194,7 @@ createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createNonBindingTeam :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, TeamStore] r => UserId -> ConnId -> Public.NonBindingNewTeam -> @@ -196,12 +211,20 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "Teams.createNonBindingTeam") - team <- Data.createTeam Nothing zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) NonBinding + team <- + liftSem $ + E.createTeam + Nothing + zusr + (body ^. newTeamName) + (body ^. newTeamIcon) + (body ^. newTeamIconKey) + NonBinding finishCreateTeam team owner others (Just zcon) pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, TeamStore] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do @@ -210,34 +233,39 @@ createBindingTeamH (zusr ::: tid ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createBindingTeam :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, TeamStore] r => UserId -> TeamId -> BindingNewTeam -> Galley r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus - team <- Data.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding + team <- + liftSem $ + E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing pure tid -updateTeamStatusH :: Member BrigAccess r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response +updateTeamStatusH :: + Members '[BrigAccess, TeamStore] r => + TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> + Galley r Response updateTeamStatusH (tid ::: req ::: _) = do teamStatusUpdate <- fromJsonBody req updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: Member BrigAccess r => TeamId -> TeamStatusUpdate -> Galley r () +updateTeamStatus :: Members '[BrigAccess, TeamStore] r => TeamId -> TeamStatusUpdate -> Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do - oldStatus <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) + oldStatus <- tdStatus <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) valid <- validateTransition (oldStatus, newStatus) when valid $ do journal newStatus cur - Data.updateTeamStatus tid newStatus + liftSem $ E.setTeamStatus tid newStatus where journal Suspended _ = Journal.teamSuspend tid journal Active c = do - teamCreationTime <- Data.teamCreationTime tid + teamCreationTime <- liftSem $ E.getTeamCreationTime tid -- When teams are created, they are activated immediately. In this situation, Brig will -- most likely report team size as 0 due to ES taking some time to index the team creator. -- This is also very difficult to test, so is not tested. @@ -258,7 +286,7 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (_, _) -> throwM invalidTeamStatusUpdate updateTeamH :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -267,28 +295,28 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty updateTeam :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => UserId -> ConnId -> TeamId -> Public.TeamUpdateData -> Galley r () updateTeam zusr zcon tid updateData = do - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ E.getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "Teams.updateTeam") void $ permissionCheck SetTeamData zusrMembership - Data.updateTeam tid updateData + liftSem $ E.setTeamData tid updateData now <- liftIO getCurrentTime - memList <- Data.teamMembersForFanout tid + memList <- getTeamMembersForFanout tid let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -298,14 +326,14 @@ deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do -- | 'TeamDeleteData' is only required for binding teams deleteTeam :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley r () deleteTeam zusr zcon tid mBody = do - team <- Data.team tid >>= ifNothing teamNotFound + team <- liftSem (E.getTeam tid) >>= ifNothing teamNotFound case tdStatus team of Deleted -> throwM teamNotFound @@ -316,18 +344,18 @@ deleteTeam zusr zcon tid mBody = do queueTeamDeletion tid zusr (Just zcon) where checkPermissions team = do - void $ permissionCheck DeleteTeam =<< Data.teamMember tid zusr + void $ permissionCheck DeleteTeam =<< liftSem (E.getTeamMember tid zusr) when ((tdTeam team) ^. teamBinding == Binding) $ do body <- mBody & ifNothing (invalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: TeamId -> Galley r () +internalDeleteBindingTeamWithOneMember :: Member TeamStore r => TeamId -> Galley r () internalDeleteBindingTeamWithOneMember tid = do - team <- Data.team tid + team <- liftSem (E.getTeam tid) unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ throwM noBindingTeam - mems <- Data.teamMembersWithLimit tid (unsafeRange 2) + mems <- liftSem $ E.getTeamMembersWithLimit tid (unsafeRange 2) case mems ^. teamMembers of (mem : []) -> queueTeamDeletion tid (mem ^. userId) Nothing _ -> throwM notAOneMemberTeam @@ -335,23 +363,33 @@ internalDeleteBindingTeamWithOneMember tid = do -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. uncheckedDeleteTeam :: forall r. - Members '[BrigAccess, ExternalAccess, GundeckAccess, SparAccess] r => + Members + '[ BrigAccess, + ExternalAccess, + GundeckAccess, + MemberStore, + SparAccess, + TeamStore + ] + r => UserId -> Maybe ConnId -> TeamId -> Galley r () uncheckedDeleteTeam zusr zcon tid = do - team <- Data.team tid + team <- liftSem $ E.getTeam tid when (isJust team) $ do Spar.deleteTeam tid now <- liftIO getCurrentTime - convs <- filter (not . view managedConversation) <$> Data.teamConversations tid + convs <- + liftSem $ + filter (not . view managedConversation) <$> E.getTeamConversations tid -- Even for LARGE TEAMS, we _DO_ want to fetch all team members here because we -- want to generate conversation deletion events for non-team users. This should -- be fine as it is done once during the life team of a team and we still do not -- fanout this particular event to all team members anyway. And this is anyway -- done asynchronously - membs <- Data.teamMembersCollectedWithPagination tid + membs <- liftSem $ E.getTeamMembers tid (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue @@ -363,7 +401,7 @@ uncheckedDeleteTeam zusr zcon tid = do mapM_ (deleteUser . view userId) membs Journal.teamDelete tid Data.unsetTeamLegalholdWhitelisted tid - Data.deleteTeam tid + liftSem $ E.deleteTeam tid where pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () pushDeleteEvents membs e ue = do @@ -393,7 +431,7 @@ uncheckedDeleteTeam zusr zcon tid = do localDomain <- viewFederationDomain let qconvId = Qualified (c ^. conversationId) localDomain qorig = Qualified zusr localDomain - (bots, convMembs) <- localBotsAndUsers <$> Data.members (c ^. conversationId) + (bots, convMembs) <- liftSem $ localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) -- Only nonTeamMembers need to get any events, since on team deletion, -- all team users are deleted immediately after these events are sent -- and will thus never be able to see these events in practice. @@ -405,9 +443,13 @@ uncheckedDeleteTeam zusr zcon tid = do let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) -getTeamConversationRoles :: UserId -> TeamId -> Galley r Public.ConversationRolesList +getTeamConversationRoles :: + Member TeamStore r => + UserId -> + TeamId -> + Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - mem <- Data.teamMember tid zusr + mem <- liftSem $ E.getTeamMember tid zusr case mem of Nothing -> throwErrorDescriptionType @NotATeamMember Just _ -> do @@ -415,26 +457,34 @@ getTeamConversationRoles zusr tid = do -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response +getTeamMembersH :: + Member TeamStore r => + UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> + Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do (memberList, withPerms) <- getTeamMembers zusr tid maxResults pure . json $ teamMemberListJson withPerms memberList -getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) +getTeamMembers :: + Member TeamStore r => + UserId -> + TeamId -> + Range 1 Public.HardTruncationLimit Int32 -> + Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) getTeamMembers zusr tid maxResults = do - Data.teamMember tid zusr >>= \case + liftSem (E.getTeamMember tid zusr) >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember Just m -> do - mems <- Data.teamMembersWithLimit tid maxResults + mems <- liftSem $ E.getTeamMembersWithLimit tid maxResults let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) getTeamMembersCSVH :: - Member BrigAccess r => + (Members '[BrigAccess, TeamStore] r) => UserId ::: TeamId ::: JSON -> Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do - Data.teamMember tid zusr >>= \case + liftSem (E.getTeamMember tid zusr) >>= \case Nothing -> throwM accessDenied Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwM accessDenied @@ -443,6 +493,8 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do -- the response will not contain a correct error message, but rather be an -- http error such as 'InvalidChunkHeaders'. The exception however still -- reaches the middleware and is being tracked in logging and metrics. + -- + -- FUTUREWORK: rewrite this using some streaming primitive (e.g. polysemy's Input) pure $ responseStream status200 @@ -454,21 +506,25 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do writeString headerLine flush evalGalley env $ do - Data.withTeamMembersWithChunks tid $ \members -> do - inviters <- lookupInviterHandle members - users <- lookupUser <$> lookupActivatedUsers (fmap (view userId) members) - richInfos <- lookupRichInfo <$> getRichInfoMultiUser (fmap (view userId) members) - liftIO $ do - writeString - ( encodeDefaultOrderedByNameWith - defaultEncodeOptions - (mapMaybe (teamExportUser users inviters richInfos) members) - ) - flush + E.withChunks pager $ + \members -> do + inviters <- lookupInviterHandle members + users <- lookupUser <$> lookupActivatedUsers (fmap (view userId) members) + richInfos <- lookupRichInfo <$> getRichInfoMultiUser (fmap (view userId) members) + liftIO $ do + writeString + ( encodeDefaultOrderedByNameWith + defaultEncodeOptions + (mapMaybe (teamExportUser users inviters richInfos) members) + ) + flush where headerLine :: LByteString headerLine = encodeDefaultOrderedByNameWith (defaultEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser]) + pager :: Maybe (InternalPagingState TeamMember) -> Galley GalleyEffects (InternalPage TeamMember) + pager mps = liftSem $ E.listTeamMembers tid mps maxBound + defaultEncodeOptions :: EncodeOptions defaultEncodeOptions = EncodeOptions @@ -535,66 +591,97 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId (UserScimExternalId _) -> Nothing -bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response +bulkGetTeamMembersH :: + Member TeamStore r => + UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> + Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do UserIdList uids <- fromJsonBody body (memberList, withPerms) <- bulkGetTeamMembers zusr tid maxResults uids pure . json $ teamMemberListJson withPerms memberList -- | like 'getTeamMembers', but with an explicit list of users we are to return. -bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley r (TeamMemberList, TeamMember -> Bool) +bulkGetTeamMembers :: + Member TeamStore r => + UserId -> + TeamId -> + Range 1 HardTruncationLimit Int32 -> + [UserId] -> + Galley r (TeamMemberList, TeamMember -> Bool) bulkGetTeamMembers zusr tid maxResults uids = do unless (length uids <= fromIntegral (fromRange maxResults)) $ throwM bulkGetMemberLimitExceeded - Data.teamMember tid zusr >>= \case + liftSem (E.getTeamMember tid zusr) >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - mems <- Data.teamMembersLimited tid uids + Just m -> liftSem $ do + mems <- E.selectTeamMembers tid uids let withPerms = (m `canSeePermsOf`) hasMore = ListComplete pure (newTeamMemberList mems hasMore, withPerms) -getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response +getTeamMemberH :: + Member TeamStore r => + UserId ::: TeamId ::: UserId ::: JSON -> + Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do (member, withPerms) <- getTeamMember zusr tid uid pure . json $ teamMemberJson withPerms member -getTeamMember :: UserId -> TeamId -> UserId -> Galley r (Public.TeamMember, Public.TeamMember -> Bool) +getTeamMember :: + Member TeamStore r => + UserId -> + TeamId -> + UserId -> + Galley r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ E.getTeamMember tid zusr case zusrMembership of Nothing -> throwErrorDescriptionType @NotATeamMember Just m -> do let withPerms = (m `canSeePermsOf`) - Data.teamMember tid uid >>= \case + liftSem (E.getTeamMember tid uid) >>= \case Nothing -> throwM teamMemberNotFound Just member -> pure (member, withPerms) -internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley r Response +internalDeleteBindingTeamWithOneMemberH :: + Member TeamStore r => + TeamId -> + Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do internalDeleteBindingTeamWithOneMember tid pure (empty & setStatus status202) -uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley r Response +uncheckedGetTeamMemberH :: + Member TeamStore r => + TeamId ::: UserId ::: JSON -> + Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid -uncheckedGetTeamMember :: TeamId -> UserId -> Galley r TeamMember +uncheckedGetTeamMember :: + Member TeamStore r => + TeamId -> + UserId -> + Galley r TeamMember uncheckedGetTeamMember tid uid = do - Data.teamMember tid uid >>= ifNothing teamMemberNotFound + liftSem (E.getTeamMember tid uid) >>= ifNothing teamMemberNotFound -uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley r Response +uncheckedGetTeamMembersH :: + Member TeamStore r => + TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> + Galley r Response uncheckedGetTeamMembersH (tid ::: maxResults ::: _) = do json <$> uncheckedGetTeamMembers tid maxResults uncheckedGetTeamMembers :: + Member TeamStore r => TeamId -> Range 1 HardTruncationLimit Int32 -> Galley r TeamMemberList -uncheckedGetTeamMembers tid maxResults = Data.teamMembersWithLimit tid maxResults +uncheckedGetTeamMembers tid maxResults = liftSem $ E.getTeamMembersWithLimit tid maxResults addTeamMemberH :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -603,7 +690,7 @@ addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty addTeamMember :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => UserId -> ConnId -> TeamId -> @@ -616,7 +703,7 @@ addTeamMember zusr zcon tid nmem = do . Log.field "action" (Log.val "Teams.addTeamMember") -- verify permissions zusrMembership <- - Data.teamMember tid zusr + liftSem (E.getTeamMember tid zusr) >>= permissionCheck AddTeamMember let targetPermissions = nmem ^. ntmNewTeamMember . permissions targetPermissions `ensureNotElevated` zusrMembership @@ -625,12 +712,12 @@ addTeamMember zusr zcon tid nmem = do ensureConnectedToLocals zusr [uid] (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) - memList <- Data.teamMembersForFanout tid + memList <- getTeamMembersForFanout tid void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList -- This function is "unchecked" because there is no need to check for user binding (invite only). uncheckedAddTeamMemberH :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do @@ -639,12 +726,12 @@ uncheckedAddTeamMemberH (tid ::: req ::: _) = do return empty uncheckedAddTeamMember :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => TeamId -> NewTeamMember -> Galley r () uncheckedAddTeamMember tid nmem = do - mems <- Data.teamMembersForFanout tid + mems <- getTeamMembersForFanout tid (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem mems @@ -652,7 +739,7 @@ uncheckedAddTeamMember tid nmem = do Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds updateTeamMemberH :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, TeamStore] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -663,7 +750,7 @@ updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, TeamStore] r => UserId -> ConnId -> TeamId -> @@ -677,15 +764,15 @@ updateTeamMember zusr zcon tid targetMember = do . Log.field "action" (Log.val "Teams.updateTeamMember") -- get the team and verify permissions - team <- tdTeam <$> (Data.team tid >>= ifNothing teamNotFound) + team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) user <- - Data.teamMember tid zusr + liftSem (E.getTeamMember tid zusr) >>= permissionCheck SetMemberPermissions -- user may not elevate permissions targetPermissions `ensureNotElevated` user previousMember <- - Data.teamMember tid targetId >>= \case + liftSem (E.getTeamMember tid targetId) >>= \case Nothing -> -- target user must be in same team throwM teamMemberNotFound @@ -697,9 +784,9 @@ updateTeamMember zusr zcon tid targetMember = do $ throwM accessDenied -- update target in Cassandra - Data.updateTeamMember (previousMember ^. permissions) tid targetId targetPermissions + liftSem $ E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions - updatedMembers <- Data.teamMembersForFanout tid + updatedMembers <- getTeamMembersForFanout tid updateJournal team updatedMembers updatePeers targetId targetPermissions updatedMembers where @@ -732,7 +819,15 @@ updateTeamMember zusr zcon tid targetMember = do for_ pushPriv $ \p -> push1 $ p & pushConn .~ Just zcon deleteTeamMemberH :: - Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> Galley r Response deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do @@ -747,7 +842,15 @@ data TeamMemberDeleteResult -- | 'TeamMemberDeleteData' is only required for binding teams deleteTeamMember :: - Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -758,15 +861,15 @@ deleteTeamMember zusr zcon tid remove mBody = do Log.debug $ Log.field "targets" (toByteString remove) . Log.field "action" (Log.val "Teams.deleteTeamMember") - zusrMember <- Data.teamMember tid zusr - targetMember <- Data.teamMember tid remove + zusrMember <- liftSem $ E.getTeamMember tid zusr + targetMember <- liftSem $ E.getTeamMember tid remove void $ permissionCheck RemoveTeamMember zusrMember do dm <- maybe (throwM teamMemberNotFound) pure zusrMember tm <- maybe (throwM teamMemberNotFound) pure targetMember unless (canDeleteMember dm tm) $ throwM accessDenied - team <- tdTeam <$> (Data.team tid >>= ifNothing teamNotFound) - mems <- Data.teamMembersForFanout tid + team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + mems <- getTeamMembersForFanout tid if team ^. teamBinding == Binding && isJust targetMember then do body <- mBody & ifNothing (invalidPayload "missing request body") @@ -790,7 +893,15 @@ deleteTeamMember zusr zcon tid remove mBody = do -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. uncheckedDeleteTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BrigAccess, + ConversationStore, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserId -> Maybe ConnId -> TeamId -> @@ -800,7 +911,7 @@ uncheckedDeleteTeamMember :: uncheckedDeleteTeamMember zusr zcon tid remove mems = do now <- liftIO getCurrentTime pushMemberLeaveEvent now - Data.removeTeamMember tid remove + liftSem $ E.deleteTeamMember tid remove removeFromConvsAndPushConvLeaveEvent now where -- notify all team members. @@ -818,11 +929,11 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do localDomain <- viewFederationDomain let tmids = Set.fromList $ map (view userId) (mems ^. teamMembers) let edata = Conv.EdMembersLeave (Conv.QualifiedUserIdList [Qualified remove localDomain]) - cc <- Data.teamConversations tid + cc <- liftSem $ E.getTeamConversations tid for_ cc $ \c -> - Data.conversation (c ^. conversationId) >>= \conv -> + liftSem (E.getConversation (c ^. conversationId)) >>= \conv -> for_ conv $ \dc -> when (remove `isMember` Data.convLocalMembers dc) $ do - Data.removeMember remove (c ^. conversationId) + liftSem $ E.deleteMembers (c ^. conversationId) (UserList [remove] []) -- If the list was truncated, then the tmids list is incomplete so we simply drop these events unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc @@ -838,22 +949,48 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do push1 $ p & pushConn .~ zcon External.deliverAsync (bots `zip` repeat y) -getTeamConversations :: UserId -> TeamId -> Galley r Public.TeamConversationList +getTeamConversations :: + Member TeamStore r => + UserId -> + TeamId -> + Galley r Public.TeamConversationList getTeamConversations zusr tid = do - tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + tm <- + liftSem (E.getTeamMember tid zusr) + >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) - Public.newTeamConversationList <$> Data.teamConversations tid + liftSem $ Public.newTeamConversationList <$> E.getTeamConversations tid -getTeamConversation :: UserId -> TeamId -> ConvId -> Galley r Public.TeamConversation +getTeamConversation :: + Member TeamStore r => + UserId -> + TeamId -> + ConvId -> + Galley r Public.TeamConversation getTeamConversation zusr tid cid = do - tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + tm <- + liftSem (E.getTeamMember tid zusr) + >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) - Data.teamConversation tid cid >>= maybe (throwErrorDescriptionType @ConvNotFound) pure + liftSem (E.getTeamConversation tid cid) + >>= maybe (throwErrorDescriptionType @ConvNotFound) pure deleteTeamConversation :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -864,15 +1001,21 @@ deleteTeamConversation zusr zcon _tid cid = do lconv <- qualifyLocal cid void $ API.deleteLocalConversation lusr zcon lconv -getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley r Response +getSearchVisibilityH :: + Member TeamStore r => + UserId ::: TeamId ::: JSON -> + Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ E.getTeamMember tid uid void $ permissionCheck ViewTeamSearchVisibility zusrMembership json <$> getSearchVisibilityInternal tid -setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response +setSearchVisibilityH :: + Member TeamStore r => + UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> + Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ E.getTeamMember tid uid void $ permissionCheck ChangeTeamSearchVisibility zusrMembership setSearchVisibilityInternal tid =<< fromJsonBody req pure noContent @@ -889,7 +1032,10 @@ setSearchVisibilityH (uid ::: tid ::: req ::: _) = do -- The last case returns those team IDs which have an associated -- user. Additionally 'k' is passed in a 'hasMore' indication (which is -- always false if the third lookup-case is used). +-- +-- FUTUREWORK: avoid CPS withTeamIds :: + (Member TeamStore r, Member (ListItems LegacyPaging TeamId) r) => UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> @@ -897,29 +1043,28 @@ withTeamIds :: Galley r a withTeamIds usr range size k = case range of Nothing -> do - r <- Data.teamIdsFrom usr Nothing (rcast size) + r <- liftSem $ E.listItems usr Nothing (rcast size) k (Data.resultSetType r == Data.ResultSetTruncated) (Data.resultSetResult r) Just (Right c) -> do - r <- Data.teamIdsFrom usr (Just c) (rcast size) + r <- liftSem $ E.listItems usr (Just c) (rcast size) k (Data.resultSetType r == Data.ResultSetTruncated) (Data.resultSetResult r) - Just (Left cc) -> do - ids <- Data.teamIdsOf usr cc + Just (Left (fromRange -> cc)) -> do + ids <- liftSem $ E.selectTeams usr (Data.ByteString.Conversion.fromList cc) k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: [UserId] -> Galley r () +ensureUnboundUsers :: Member TeamStore r => [UserId] -> Galley r () ensureUnboundUsers uids = do -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. - ts <- liftGalley0 $ mapConcurrently Data.oneUserTeam uids - let teams = toList $ fromList (catMaybes ts) - binds <- liftGalley0 $ mapConcurrently Data.teamBinding teams - when (any ((==) (Just Binding)) binds) $ + teams <- liftSem $ Map.elems <$> E.getUsersTeams uids + binds <- liftSem $ E.getTeamsBindings teams + when (any (== Binding) binds) $ throwM userBindingExists -ensureNonBindingTeam :: TeamId -> Galley r () +ensureNonBindingTeam :: Member TeamStore r => TeamId -> Galley r () ensureNonBindingTeam tid = do - team <- Data.team tid >>= ifNothing teamNotFound + team <- liftSem (E.getTeam tid) >>= ifNothing teamNotFound when ((tdTeam team) ^. teamBinding == Binding) $ throwM noAddToBinding @@ -956,7 +1101,7 @@ ensureNotTooLargeForLegalHold tid teamSize = do unlessM (teamSizeBelowLimit teamSize) $ do throwM tooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: Member BrigAccess r => TeamId -> Galley r () +ensureNotTooLargeToActivateLegalHold :: Members '[BrigAccess] r => TeamId -> Galley r () ensureNotTooLargeToActivateLegalHold tid = do (TeamSize teamSize) <- BrigTeam.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do @@ -974,7 +1119,7 @@ teamSizeBelowLimit teamSize = do pure True addTeamMemberInternal :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => TeamId -> Maybe UserId -> Maybe ConnId -> @@ -986,13 +1131,13 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi Log.field "targets" (toByteString (new ^. userId)) . Log.field "action" (Log.val "Teams.addTeamMemberInternal") sizeBeforeAdd <- ensureNotTooLarge tid - Data.addTeamMember tid new - cc <- filter (view managedConversation) <$> Data.teamConversations tid + liftSem $ E.createTeamMember tid new + cc <- liftSem $ filter (view managedConversation) <$> E.getTeamConversations tid now <- liftIO getCurrentTime for_ cc $ \c -> do lcid <- qualifyLocal (c ^. conversationId) luid <- qualifyLocal (new ^. userId) - Data.addMember lcid luid + liftSem $ E.createMember lcid luid let e = newEvent MemberJoin tid now & eventData ?~ EdMemberJoin (new ^. userId) push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn APITeamQueue.pushTeamEvent tid e @@ -1036,7 +1181,7 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID u = if UUID.version u == 1 then Just u else Nothing finishCreateTeam :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => Team -> TeamMember -> [TeamMember] -> @@ -1044,33 +1189,34 @@ finishCreateTeam :: Galley r () finishCreateTeam team owner others zcon = do let zusr = owner ^. userId - for_ (owner : others) $ - Data.addTeamMember (team ^. teamId) + liftSem $ + for_ (owner : others) $ + E.createTeamMember (team ^. teamId) now <- liftIO getCurrentTime let e = newEvent TeamCreate (team ^. teamId) now & eventData ?~ EdTeamCreate team let r = membersToRecipients Nothing others push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b +withBindingTeam :: Member TeamStore r => UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do - tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound - binding <- Data.teamBinding tid >>= ifNothing teamNotFound + tid <- liftSem (E.getOneUserTeam zusr) >>= ifNothing teamNotFound + binding <- liftSem (E.getTeamBinding tid) >>= ifNothing teamNotFound case binding of Binding -> callback tid NonBinding -> throwM nonBindingTeam -getBindingTeamIdH :: UserId -> Galley r Response +getBindingTeamIdH :: Member TeamStore r => UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: UserId -> Galley r TeamId +getBindingTeamId :: Member TeamStore r => UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: UserId -> Galley r Response +getBindingTeamMembersH :: Member TeamStore r => UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: UserId -> Galley r TeamMemberList +getBindingTeamMembers :: Member TeamStore r => UserId -> Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> - Data.teamMembersForFanout tid + getTeamMembersForFanout tid canUserJoinTeamH :: Member BrigAccess r => TeamId -> Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty @@ -1115,13 +1261,13 @@ setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do throwM teamSearchVisibilityNotEnabled SearchVisibilityData.setSearchVisibility tid searchVisibility -userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley r Response +userIsTeamOwnerH :: Member TeamStore r => TeamId ::: UserId ::: JSON -> Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty False -> throwM accessDenied -userIsTeamOwner :: TeamId -> UserId -> Galley r Bool +userIsTeamOwner :: Member TeamStore r => TeamId -> UserId -> Galley r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index cb14611e9ac..8122a7059db 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -59,10 +59,12 @@ import Galley.API.LegalHold import Galley.API.Teams (ensureNotTooLargeToActivateLegalHold) import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Paging import qualified Galley.Data.SearchVisibility as SearchVisibilityData import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects +import Galley.Effects.Paging +import Galley.Effects.TeamStore import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush, push1) import Galley.Options import Galley.Types.Teams hiding (newTeam) @@ -87,7 +89,7 @@ data DoAuth = DoAuth UserId | DontDoAuth -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - Public.KnownTeamFeatureName a => + (Public.KnownTeamFeatureName a, Member TeamStore r) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -95,7 +97,7 @@ getFeatureStatus :: getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ getTeamMember tid uid void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -104,7 +106,7 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - Public.KnownTeamFeatureName a => + (Public.KnownTeamFeatureName a, Member TeamStore r) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -113,7 +115,7 @@ setFeatureStatus :: setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ getTeamMember tid uid void $ permissionCheck (ChangeTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -122,28 +124,29 @@ setFeatureStatus setter doauth tid status = do -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: forall (a :: Public.TeamFeatureName) r. - Public.KnownTeamFeatureName a => + (Public.KnownTeamFeatureName a, Member TeamStore r) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> Galley r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do - mbTeam <- Data.oneUserTeam zusr + mbTeam <- liftSem $ getOneUserTeam zusr case mbTeam of Nothing -> getter (Left (Just zusr)) Just tid -> do - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership assertTeamExists tid getter (Right tid) -getAllFeatureConfigs :: UserId -> Galley r AllFeatureConfigs +getAllFeatureConfigs :: Member TeamStore r => UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do - mbTeam <- Data.oneUserTeam zusr - zusrMembership <- maybe (pure Nothing) (flip Data.teamMember zusr) mbTeam + mbTeam <- liftSem $ getOneUserTeam zusr + zusrMembership <- maybe (pure Nothing) (liftSem . (flip getTeamMember zusr)) mbTeam let getStatus :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus a) + Aeson.ToJSON (Public.TeamFeatureStatus a), + Member TeamStore r ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> Galley r (Text, Aeson.Value) @@ -168,11 +171,11 @@ getAllFeatureConfigs zusr = do getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] -getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley r Response +getAllFeaturesH :: Member TeamStore r => UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid -getAllFeatures :: UserId -> TeamId -> Galley r Aeson.Value +getAllFeatures :: forall r. Member TeamStore r => UserId -> TeamId -> Galley r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -189,7 +192,7 @@ getAllFeatures uid tid = do ] where getStatus :: - forall (a :: Public.TeamFeatureName) r. + forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => @@ -215,7 +218,7 @@ setFeatureStatusNoConfig :: ( Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a, - Member GundeckAccess r + Members '[GundeckAccess, TeamStore] r ) => (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> TeamId -> @@ -245,7 +248,7 @@ getSSOStatusInternal = FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) @@ -265,7 +268,7 @@ getTeamSearchVisibilityAvailableInternal = FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled setTeamSearchVisibilityAvailableInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) @@ -285,7 +288,7 @@ getValidateSAMLEmailsInternal = getDef = pure Public.TeamFeatureDisabled setValidateSAMLEmailsInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) @@ -303,7 +306,7 @@ getDigitalSignaturesInternal = getDef = pure Public.TeamFeatureDisabled setDigitalSignaturesInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) @@ -318,7 +321,24 @@ getLegalholdStatusInternal (Right tid) = do False -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled setLegalholdStatusInternal :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + ( Paging p, + Bounded (PagingBounds p TeamMember), + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore, + TeamMemberStore p + ] + r + ) => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) @@ -364,7 +384,7 @@ getFeatureStatusWithDefaultConfig lens' = <&> Public.tfwoStatus . view unDefaults setFileSharingInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) @@ -402,13 +422,15 @@ getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) setConferenceCallingInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () -getSelfDeletingMessagesInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) +getSelfDeletingMessagesInternal :: + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) getSelfDeletingMessagesInternal = \case Left _ -> pure Public.defaultSelfDeletingMessagesStatus Right tid -> @@ -421,9 +443,13 @@ setSelfDeletingMessagesInternal :: Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesInternal = TeamFeatures.setSelfDeletingMessagesStatus -pushFeatureConfigEvent :: Member GundeckAccess r => TeamId -> Event.Event -> Galley r () +pushFeatureConfigEvent :: + Members '[GundeckAccess, TeamStore] r => + TeamId -> + Event.Event -> + Galley r () pushFeatureConfigEvent tid event = do - memList <- Data.teamMembersForFanout tid + memList <- getTeamMembersForFanout tid when ((memList ^. teamMemberListType) == ListTruncated) $ do Log.warn $ Log.field "action" (Log.val "Features.pushFeatureConfigEvent") diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index dee504abe4f..be63e45d5ea 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -92,10 +92,17 @@ import Galley.API.Mapping import Galley.API.Message import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Services +import qualified Galley.Data.Access as Data +import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) import Galley.Effects +import qualified Galley.Effects.ClientStore as E +import qualified Galley.Effects.CodeStore as E +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.TeamStore as E import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push @@ -105,6 +112,7 @@ import Galley.Types import Galley.Types.Bot hiding (addBot) import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients +import Galley.Types.Conversations.Members (newMember) import Galley.Types.Conversations.Roles (Action (..), RoleName, roleNameWireMember) import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList @@ -115,6 +123,7 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) import Network.Wai.Utilities +import Polysemy import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import qualified Wire.API.Conversation.Code as Public @@ -138,44 +147,66 @@ import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client -acceptConvH :: Member GundeckAccess r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response +acceptConvH :: + Members '[ConversationStore, GundeckAccess, MemberStore] r => + UserId ::: Maybe ConnId ::: ConvId -> + Galley r Response acceptConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> acceptConv usr conn cnv -acceptConv :: Member GundeckAccess r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation +acceptConv :: + Members '[ConversationStore, GundeckAccess, MemberStore] r => + UserId -> + Maybe ConnId -> + ConvId -> + Galley r Conversation acceptConv usr conn cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem (E.getConversation cnv) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) conv' <- acceptOne2One usr conv conn conversationView usr conv' -blockConvH :: UserId ::: ConvId -> Galley r Response +blockConvH :: + Members '[ConversationStore, MemberStore] r => + UserId ::: ConvId -> + Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv -blockConv :: UserId -> ConvId -> Galley r () +blockConv :: + Members '[ConversationStore, MemberStore] r => + UserId -> + ConvId -> + Galley r () blockConv zusr cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem (E.getConversation cnv) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ throwM $ invalidOp "block: invalid conversation type" let mems = Data.convLocalMembers conv - when (zusr `isMember` mems) $ Data.removeMember zusr cnv + when (zusr `isMember` mems) . liftSem $ + E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: - Member GundeckAccess r => + Members '[ConversationStore, GundeckAccess, MemberStore] r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response unblockConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> unblockConv usr conn cnv unblockConv :: - Member GundeckAccess r => + Members '[ConversationStore, GundeckAccess, MemberStore] r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation unblockConv usr conn cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem (E.getConversation cnv) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ throwM $ invalidOp "unblock: invalid conversation type" @@ -240,7 +271,19 @@ updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented performAccessUpdateAction :: forall r. - Members '[BrigAccess, BotAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BrigAccess, + BotAccess, + CodeStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => Qualified UserId -> Data.Conversation -> ConversationAccessData -> @@ -255,16 +298,16 @@ performAccessUpdateAction qusr conv target = do ) $ lift $ do key <- mkKey (tUnqualified lcnv) - Data.deleteCode key ReusableCode + liftSem $ E.deleteCode key ReusableCode -- Determine bots and members to be removed - let filterBotsAndMembers = filterActivated >=> filterTeammates + let filterBotsAndMembers = filterActivated >=> (liftSem . filterTeammates) let current = convBotsAndMembers conv -- initial bots and members desired <- lift $ filterBotsAndMembers current -- desired bots and members let toRemove = bmDiff current desired -- bots and members to be removed -- Update Cassandra - lift $ Data.updateConversationAccess (tUnqualified lcnv) target + lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) target lift . fireAndForget $ do -- Remove bots traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) @@ -288,13 +331,13 @@ performAccessUpdateAction qusr conv target = do pure $ bm {bmLocals = Set.fromList activated} | otherwise = pure bm - filterTeammates :: BotsAndMembers -> Galley r BotsAndMembers + filterTeammates :: BotsAndMembers -> Sem r BotsAndMembers filterTeammates bm = do -- In a team-only conversation we also want to remove bots and guests case (cupAccessRole target, Data.convTeam conv) of (TeamAccessRole, Just tid) -> do onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> - isJust <$> Data.teamMember tid user + isJust <$> E.getTeamMember tid user pure $ BotsAndMembers { bmLocals = Set.fromList onlyTeamUsers, @@ -364,7 +407,7 @@ updateConversationMessageTimerUnqualified usr zcon cnv update = do updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: - Members UpdateConversationActions r => + (Member ConversationStore r, Members UpdateConversationActions r) => UserId -> ConnId -> Qualified ConvId -> @@ -401,13 +444,19 @@ deleteLocalConversation lusr con lcnv = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete +-- FUTUREWORK: split conversation actions into multiple types so that we can +-- have more granular effect constraints type UpdateConversationActions = '[ BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, - GundeckAccess + GundeckAccess, + CodeStore, + ConversationStore, + MemberStore, + TeamStore ] -- | Update a local conversation, and notify all local and remote members. @@ -461,34 +510,35 @@ performAction qusr conv action = case action of pure (mempty, action) ConversationActionRename rename -> lift $ do cn <- rangeChecked (cupName rename) - Data.updateConversation (Data.convId conv) cn + liftSem $ E.setConversationName (Data.convId conv) cn pure (mempty, action) ConversationActionMessageTimerUpdate update -> do guard $ Data.convMessageTimer conv /= cupMessageTimer update - lift $ Data.updateConversationMessageTimer (Data.convId conv) (cupMessageTimer update) + lift . liftSem $ E.setConversationMessageTimer (Data.convId conv) (cupMessageTimer update) pure (mempty, action) ConversationActionReceiptModeUpdate update -> do guard $ Data.convReceiptMode conv /= Just (cruReceiptMode update) - lift $ Data.updateConversationReceiptMode (Data.convId conv) (cruReceiptMode update) + lift . liftSem $ E.setConversationReceiptMode (Data.convId conv) (cruReceiptMode update) pure (mempty, action) ConversationActionMemberUpdate target update -> lift $ do lcnv <- qualifyLocal (Data.convId conv) void $ ensureOtherMember lcnv target conv - Data.updateOtherMemberLocalConv lcnv target update + liftSem $ E.setOtherMember lcnv target update pure (mempty, action) ConversationActionAccessUpdate update -> do performAccessUpdateAction qusr conv update pure (mempty, action) ConversationActionDelete -> lift $ do let cid = Data.convId conv - (`Data.deleteCode` ReusableCode) =<< mkKey cid - case Data.convTeam conv of - Nothing -> Data.deleteConversation cid - Just tid -> Data.removeTeamConv tid cid + key <- mkKey cid + liftSem $ E.deleteCode key ReusableCode + liftSem $ case Data.convTeam conv of + Nothing -> E.deleteConversation cid + Just tid -> E.deleteTeamConversation tid cid pure (mempty, action) addCodeH :: - Members '[ExternalAccess, GundeckAccess] r => + Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => UserId ::: ConnId ::: ConvId -> Galley r Response addCodeH (usr ::: zcon ::: cnv) = @@ -502,7 +552,7 @@ data AddCodeResult addCode :: forall r. - Members '[ExternalAccess, GundeckAccess] r => + Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => UserId -> ConnId -> ConvId -> @@ -511,16 +561,18 @@ addCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem (E.getConversation cnv) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureConvMember (Data.convLocalMembers conv) usr ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv - mCode <- Data.lookupCode key ReusableCode + mCode <- liftSem $ E.getCode key ReusableCode case mCode of Nothing -> do code <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TODO: configurable - Data.insertCode code + liftSem $ E.createCode code now <- liftIO getCurrentTime conversationCode <- createCode code let event = Event ConvCodeUpdate qcnv qusr now (EdConvCodeUpdate conversationCode) @@ -536,14 +588,14 @@ addCode usr zcon cnv = do return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: - Members '[ExternalAccess, GundeckAccess] r => + Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => UserId ::: ConnId ::: ConvId -> Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv rmCode :: - Members '[ExternalAccess, GundeckAccess] r => + Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => UserId -> ConnId -> ConvId -> @@ -552,29 +604,40 @@ rmCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem (E.getConversation cnv) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureConvMember (Data.convLocalMembers conv) usr ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv - Data.deleteCode key ReusableCode + liftSem $ E.deleteCode key ReusableCode now <- liftIO getCurrentTime let event = Event ConvCodeDelete qcnv qusr now EdConvCodeDelete pushConversationEvent (Just zcon) event (map lmId users) bots pure event -getCodeH :: UserId ::: ConvId -> Galley r Response +getCodeH :: + Members '[CodeStore, ConversationStore] r => + UserId ::: ConvId -> + Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv -getCode :: UserId -> ConvId -> Galley r Public.ConversationCode +getCode :: + Members '[CodeStore, ConversationStore] r => + UserId -> + ConvId -> + Galley r Public.ConversationCode getCode usr cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem (E.getConversation cnv) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr key <- mkKey cnv c <- - Data.lookupCode key ReusableCode + liftSem (E.getCode key ReusableCode) >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) returnCode c @@ -583,18 +646,28 @@ returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley r Response +checkReusableCodeH :: Member CodeStore r => JsonRequest Public.ConversationCode -> Galley r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode pure empty -checkReusableCode :: Public.ConversationCode -> Galley r () +checkReusableCode :: Member CodeStore r => Public.ConversationCode -> Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode joinConversationByReusableCodeH :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + FederatorAccess, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> Galley r Response joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do @@ -602,7 +675,17 @@ joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode joinConversationByReusableCode :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + FederatorAccess, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Public.ConversationCode -> @@ -612,14 +695,32 @@ joinConversationByReusableCode zusr zcon convCode = do joinConversation zusr zcon (codeConversation c) CodeAccess joinConversationByIdH :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + FederatorAccess, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: ConvId ::: JSON -> Galley r Response joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = handleUpdateResult <$> joinConversationById zusr zcon cnv joinConversationById :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + FederatorAccess, + ConversationStore, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -628,7 +729,16 @@ joinConversationById zusr zcon cnv = joinConversation zusr zcon cnv LinkAccess joinConversation :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + FederatorAccess, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -659,12 +769,13 @@ joinConversation zusr zcon cnv access = do -- | Add users to a conversation without performing any checks. Return extra -- notification targets and the action performed. addMembersToLocalConversation :: + Members '[MemberStore] r => Local ConvId -> UserList UserId -> RoleName -> MaybeT (Galley r) (BotsAndMembers, ConversationAction) addMembersToLocalConversation lcnv users role = do - (lmems, rmems) <- lift $ Data.addMembers lcnv (fmap (,role) users) + (lmems, rmems) <- lift . liftSem $ E.createMembers (tUnqualified lcnv) (fmap (,role) users) neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users let action = ConversationActionAddMembers neUsers role pure (bmFromMembers lmems rmems, action) @@ -693,10 +804,10 @@ performAddMemberAction qusr conv invited role = do checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () checkLocals lcnv (Just tid) newUsers = do - tms <- Data.teamMembersLimited tid newUsers + tms <- liftSem $ E.selectTeamMembers tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers ensureAccessRole (Data.convAccessRole conv) userMembershipMap - tcv <- Data.teamConversation tid (tUnqualified lcnv) + tcv <- liftSem $ E.getTeamConversation tid (tUnqualified lcnv) when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged ensureConnectedOrSameTeam qusr newUsers @@ -783,7 +894,7 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do ConversationActionAddMembers users role updateSelfMember :: - Members '[GundeckAccess, ExternalAccess] r => + Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore] r => UserId -> ConnId -> Qualified ConvId -> @@ -791,19 +902,29 @@ updateSelfMember :: Galley r () updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr - exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr + exists <- liftSem $ foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr unless exists (throwErrorDescriptionType @ConvNotFound) - Data.updateSelfMember lusr qcnv lusr update + liftSem $ E.setSelfMember qcnv lusr update now <- liftIO getCurrentTime let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) pushConversationEvent (Just zcon) e [zusr] [] where + checkLocalMembership :: + Members '[MemberStore] r => + Local ConvId -> + Local UserId -> + Sem r Bool checkLocalMembership lcnv lusr = isMember (tUnqualified lusr) - <$> Data.members (tUnqualified lcnv) + <$> E.getLocalMembers (tUnqualified lcnv) + checkRemoteMembership :: + Members '[ConversationStore] r => + Remote ConvId -> + Local UserId -> + Sem r Bool checkRemoteMembership rcnv lusr = isJust . Map.lookup rcnv - <$> Data.remoteConversationStatus (tUnqualified lusr) [rcnv] + <$> E.getRemoteConversationStatus (tUnqualified lusr) [rcnv] updateData luid = MemberUpdateData { misTarget = qUntagged luid, @@ -924,6 +1045,7 @@ removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed performRemoveMemberAction :: + Member MemberStore r => Data.Conversation -> [Qualified UserId] -> MaybeT (Galley r) () @@ -931,10 +1053,7 @@ performRemoveMemberAction conv victims = do loc <- qualifyLocal () let presentVictims = filter (isConvMember loc conv) victims guard . not . null $ presentVictims - - let (lvictims, rvictims) = partitionQualified loc presentVictims - traverse_ (lift . Data.removeLocalMembersFromLocalConv (Data.convId conv)) (nonEmpty lvictims) - traverse_ (lift . Data.removeRemoteMembersFromLocalConv (Data.convId conv)) (nonEmpty rvictims) + lift . liftSem $ E.deleteMembers (Data.convId conv) (toUserList loc presentVictims) -- | Remove a member from a local conversation. removeMemberFromLocalConv :: @@ -969,7 +1088,18 @@ handleOtrResult = \case OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound postBotMessageH :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> Galley r Response postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do @@ -978,7 +1108,18 @@ postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do handleOtrResult =<< postBotMessage zbot zcnv val' message postBotMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => BotId -> ConvId -> Public.OtrFilterMissing -> @@ -988,7 +1129,18 @@ postBotMessage zbot zcnv val message = postNewOtrMessage Bot (botUserId zbot) Nothing zcnv val message postProteusMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1002,7 +1154,18 @@ postProteusMessage zusr zcon conv msg = do else postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) postOtrMessageUnqualified :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -1037,7 +1200,7 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage postProtoOtrBroadcastH :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do @@ -1046,7 +1209,7 @@ postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcastH :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do @@ -1055,7 +1218,7 @@ postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcast :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => UserId -> ConnId -> Public.OtrFilterMissing -> @@ -1075,7 +1238,7 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep -- | bots are not supported on broadcast postNewOtrBroadcast :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => UserId -> Maybe ConnId -> OtrFilterMissing -> @@ -1092,7 +1255,17 @@ postNewOtrBroadcast usr con val msg = do pushSome (catMaybes toUsers) postNewOtrMessage :: - Members '[BotAccess, BrigAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserType -> UserId -> Maybe ConnId -> @@ -1183,10 +1356,10 @@ updateLocalConversationName :: Public.ConversationRename -> Galley r (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do - alive <- Data.isConvAlive (tUnqualified lcnv) + alive <- liftSem $ E.isConversationAlive (tUnqualified lcnv) if alive then updateLiveLocalConversationName lusr zcon lcnv convRename - else Nothing <$ Data.deleteConversation (tUnqualified lcnv) + else liftSem $ Nothing <$ E.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: Members UpdateConversationActions r => @@ -1222,7 +1395,7 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e isTypingH :: - Member GundeckAccess r => + Members '[GundeckAccess, MemberStore] r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do @@ -1231,7 +1404,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do pure empty isTyping :: - Member GundeckAccess r => + Members '[GundeckAccess, MemberStore] r => UserId -> ConnId -> ConvId -> @@ -1241,7 +1414,7 @@ isTyping zusr zcon cnv typingData = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified zusr localDomain - mm <- Data.members cnv + mm <- liftSem $ E.getLocalMembers cnv unless (zusr `isMember` mm) $ throwErrorDescriptionType @ConvNotFound now <- liftIO getCurrentTime @@ -1255,16 +1428,24 @@ isTyping zusr zcon cnv typingData = do addServiceH :: JsonRequest Service -> Galley r Response addServiceH req = do - Data.insertService =<< fromJsonBody req + insertService =<< fromJsonBody req return empty rmServiceH :: JsonRequest ServiceRef -> Galley r Response rmServiceH req = do - Data.deleteService =<< fromJsonBody req + deleteService =<< fromJsonBody req return empty addBotH :: - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ ClientStore, + ConversationStore, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest AddBot -> Galley r Response addBotH (zusr ::: zcon ::: req) = do @@ -1272,20 +1453,45 @@ addBotH (zusr ::: zcon ::: req) = do json <$> addBot zusr zcon bot addBot :: - Members '[ExternalAccess, GundeckAccess] r => + forall r. + Members + '[ ClientStore, + ConversationStore, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> AddBot -> Galley r Event addBot zusr zcon b = do lusr <- qualifyLocal zusr - c <- Data.conversation (b ^. addBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + c <- + liftSem (E.getConversation (b ^. addBotConv)) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) -- Check some preconditions on adding bots to a conversation for_ (Data.convTeam c) $ teamConvChecks (b ^. addBotConv) (bots, users) <- regularConvChecks lusr c t <- liftIO getCurrentTime - Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient) - (e, bm) <- Data.addBotMember (qUntagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t + liftSem $ E.createClient (botUserId (b ^. addBotId)) (b ^. addBotClient) + bm <- liftSem $ E.createBotMember (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) + let e = + Event + MemberJoin + (qUntagged (qualifyAs lusr (b ^. addBotConv))) + (qUntagged lusr) + t + ( EdMembersJoin + ( SimpleMembers + [ SimpleMember + (qUntagged (qualifyAs lusr (botUserId (botMemId bm)))) + roleNameWireAdmin + ] + ) + ) for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon External.deliverAsync ((bm : bots) `zip` repeat e) @@ -1301,13 +1507,14 @@ addBot zusr zcon b = do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] return (bots, users) + teamConvChecks :: ConvId -> TeamId -> Galley r () teamConvChecks cid tid = do - tcv <- Data.teamConversation tid cid + tcv <- liftSem $ E.getTeamConversation tid cid when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged rmBotH :: - Members '[ExternalAccess, GundeckAccess] r => + Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore] r => UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley r Response rmBotH (zusr ::: zcon ::: req) = do @@ -1315,13 +1522,15 @@ rmBotH (zusr ::: zcon ::: req) = do handleUpdateResult <$> rmBot zusr zcon bot rmBot :: - Members '[ExternalAccess, GundeckAccess] r => + Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore] r => UserId -> Maybe ConnId -> RemoveBot -> Galley r (UpdateResult Event) rmBot zusr zcon b = do - c <- Data.conversation (b ^. rmBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + c <- + liftSem (E.getConversation (b ^. rmBotConv)) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) localDomain <- viewFederationDomain let qcnv = Qualified (Data.convId c) localDomain qusr = Qualified zusr localDomain @@ -1336,8 +1545,8 @@ rmBot zusr zcon b = do let e = Event MemberLeave qcnv qusr t evd for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn .~ zcon - Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) - Data.eraseClients (botUserId (b ^. rmBotId)) + liftSem $ E.deleteMembers (Data.convId c) (UserList [botUserId (b ^. rmBotId)] []) + liftSem $ E.deleteClients (botUserId (b ^. rmBotId)) External.deliverAsync (bots `zip` repeat e) pure $ Updated e @@ -1372,7 +1581,7 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: - Member BrigAccess r => + Members '[BrigAccess, ClientStore, TeamStore] r => UserId -> ClientId -> OtrRecipients -> @@ -1398,8 +1607,8 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ clts <- if isInternal then Clients.fromUserClients <$> Intra.lookupClients users - else Data.lookupClients users - let membs = Data.newMember <$> users + else liftSem $ E.getClients users + let membs = newMember <$> users handleOtrResponse User usr clt rcps membs clts val now go where maybeFetchLimitedTeamMemberList limit tid uListInFilter = do @@ -1409,15 +1618,15 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ let localUserIdsToLookup = Set.toList $ Set.union (Set.fromList localUserIdsInFilter) (Set.fromList localUserIdsInRcps) unless (length localUserIdsToLookup <= limit) $ throwM broadcastLimitExceeded - Data.teamMembersLimited tid localUserIdsToLookup + liftSem $ E.selectTeamMembers tid localUserIdsToLookup maybeFetchAllMembersInTeam tid = do - mems <- Data.teamMembersForFanout tid + mems <- getTeamMembersForFanout tid when (mems ^. teamMemberListType == ListTruncated) $ throwM broadcastLimitExceeded pure (mems ^. teamMembers) withValidOtrRecipients :: - Member BrigAccess r => + Members '[BrigAccess, ClientStore, ConversationStore, MemberStore, TeamStore] r => UserType -> UserId -> ClientId -> @@ -1428,23 +1637,23 @@ withValidOtrRecipients :: ([(LocalMember, ClientId, Text)] -> Galley r ()) -> Galley r OtrResult withValidOtrRecipients utype usr clt cnv rcps val now go = do - alive <- Data.isConvAlive cnv + alive <- liftSem $ E.isConversationAlive cnv if not alive then do - Data.deleteConversation cnv + liftSem $ E.deleteConversation cnv pure $ OtrConversationNotFound mkErrorDescription else do - localMembers <- Data.members cnv + localMembers <- liftSem $ E.getLocalMembers cnv let localMemberIds = lmId <$> localMembers isInternal <- view $ options . optSettings . setIntraListing clts <- if isInternal then Clients.fromUserClients <$> Intra.lookupClients localMemberIds - else Data.lookupClients localMemberIds + else liftSem $ E.getClients localMemberIds handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1556,10 +1765,10 @@ checkOtrRecipients usr sid prs vms vcs val now OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss -- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b +withBindingTeam :: Member TeamStore r => UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do - tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound - binding <- Data.teamBinding tid >>= ifNothing teamNotFound + tid <- liftSem (E.getOneUserTeam zusr) >>= ifNothing teamNotFound + binding <- liftSem (E.getTeamBinding tid) >>= ifNothing teamNotFound case binding of Binding -> callback tid NonBinding -> throwM nonBindingTeam diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index bbcf15950d7..a95e26c0452 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -40,11 +40,15 @@ import qualified Data.Text.Lazy as LT import Data.Time import Galley.API.Error import Galley.App -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes import Galley.Effects +import Galley.Effects.CodeStore +import Galley.Effects.ConversationStore +import Galley.Effects.MemberStore +import Galley.Effects.TeamStore import qualified Galley.External as External import Galley.Intra.Push import Galley.Intra.User @@ -89,16 +93,20 @@ ensureAccessRole role users = case role of -- -- Team members are always considered connected, so we only check 'ensureConnected' -- for non-team-members of the _given_ user -ensureConnectedOrSameTeam :: Member BrigAccess r => Qualified UserId -> [UserId] -> Galley r () +ensureConnectedOrSameTeam :: + Members '[BrigAccess, TeamStore] r => + Qualified UserId -> + [UserId] -> + Galley r () ensureConnectedOrSameTeam _ [] = pure () ensureConnectedOrSameTeam (Qualified u domain) uids = do -- FUTUREWORK(federation, #1262): handle remote users (can't be part of the same team, just check connections) localDomain <- viewFederationDomain when (localDomain == domain) $ do - uTeams <- Data.userTeams u + uTeams <- liftSem $ getUserTeams u -- We collect all the relevant uids from same teams as the origin user - sameTeamUids <- forM uTeams $ \team -> - fmap (view userId) <$> Data.teamMembersLimited team uids + sameTeamUids <- liftSem . forM uTeams $ \team -> + fmap (view userId) <$> selectTeamMembers team uids -- Do not check connections for users that are on the same team ensureConnectedToLocals u (uids \\ join sameTeamUids) @@ -147,7 +155,7 @@ ensureActionAllowed action self = case isActionAllowed action (convMemberRole se -- | Comprehensive permission check, taking action-specific logic into account. ensureConversationActionAllowed :: - IsConvMember mem => + (IsConvMember mem, Member TeamStore r) => ConversationAction -> Data.Conversation -> mem -> @@ -170,7 +178,7 @@ ensureConversationActionAllowed action conv self = do loc ( \lusr -> do void $ - Data.teamMember tid (tUnqualified lusr) + liftSem (getTeamMember tid (tUnqualified lusr)) >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) ) (\_ -> throwM federationNotImplemented) @@ -189,7 +197,7 @@ ensureConversationActionAllowed action conv self = do case Data.convTeam conv of Just tid -> do -- Access mode change for managed conversation is not allowed - tcv <- Data.teamConversation tid (Data.convId conv) + tcv <- liftSem $ getTeamConversation tid (Data.convId conv) when (maybe False (view managedConversation) tcv) $ throwM invalidManagedConvOp -- Access mode change might result in members being removed from the @@ -231,32 +239,37 @@ permissionCheck p = \case else throwErrorDescription (operationDenied p) Nothing -> throwErrorDescriptionType @NotATeamMember -assertTeamExists :: TeamId -> Galley r () +assertTeamExists :: Members '[TeamStore] r => TeamId -> Galley r () assertTeamExists tid = do - teamExists <- isJust <$> Data.team tid + teamExists <- liftSem $ isJust <$> getTeam tid if teamExists then pure () else throwM teamNotFound -assertOnTeam :: UserId -> TeamId -> Galley r () +assertOnTeam :: Members '[TeamStore] r => UserId -> TeamId -> Galley r () assertOnTeam uid tid = do - Data.teamMember tid uid >>= \case + liftSem (getTeamMember tid uid) >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember Just _ -> return () -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). -permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley r () +permissionCheckTeamConv :: + Members '[ConversationStore, TeamStore] r => + UserId -> + ConvId -> + Perm -> + Galley r () permissionCheckTeamConv zusr cnv perm = - Data.conversation cnv >>= \case + liftSem (getConversation cnv) >>= \case Just cnv' -> case Data.convTeam cnv' of - Just tid -> void $ permissionCheck perm =<< Data.teamMember tid zusr + Just tid -> void $ permissionCheck perm =<< liftSem (getTeamMember tid zusr) Nothing -> pure () Nothing -> throwErrorDescriptionType @ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: - Member GundeckAccess r => + Members '[ConversationStore, MemberStore, GundeckAccess] r => UserId -> Data.Conversation -> Maybe ConnId -> @@ -269,18 +282,18 @@ acceptOne2One usr conv conn = do if usr `isMember` mems then return conv else do - mm <- Data.addMember lcid lusr + mm <- liftSem $ createMember lcid lusr return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of - [_, _] | usr `isMember` mems -> promote + [_, _] | usr `isMember` mems -> liftSem promote [_, _] -> throwErrorDescriptionType @ConvNotFound _ -> do when (length mems > 2) $ throwM badConvState now <- liftIO getCurrentTime - mm <- Data.addMember lcid lusr + mm <- liftSem $ createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] - conv' <- if isJust (find ((usr /=) . lmId) mems) then promote else pure conv + conv' <- if isJust (find ((usr /=) . lmId) mems) then liftSem promote else pure conv let mems' = mems <> toList mm for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect @@ -290,7 +303,7 @@ acceptOne2One usr conv conn = do cid = Data.convId conv mems = Data.convLocalMembers conv promote = do - Data.acceptConnect cid + acceptConnectConversation cid return $ conv {Data.convType = One2OneConv} badConvState = mkError status500 "bad-state" $ @@ -455,17 +468,6 @@ membersToRecipients :: Maybe UserId -> [TeamMember] -> [Recipient] membersToRecipients Nothing = map (userRecipient . view userId) membersToRecipients (Just u) = map userRecipient . filter (/= u) . map (view userId) --- | Note that we use 2 nearly identical functions but slightly different --- semantics; when using `getSelfMemberFromLocals`, if that user is _not_ part --- of the conversation, we don't want to disclose that such a conversation with --- that id exists. -getSelfMemberFromLocals :: - (Foldable t, Monad m) => - UserId -> - t LocalMember -> - ExceptT ConvNotFound m LocalMember -getSelfMemberFromLocals = getLocalMember (mkErrorDescription :: ConvNotFound) - -- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. getSelfMemberFromLocalsLegacy :: Foldable t => @@ -473,7 +475,8 @@ getSelfMemberFromLocalsLegacy :: t LocalMember -> Galley r LocalMember getSelfMemberFromLocalsLegacy usr lmems = - eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromLocals usr lmems + eitherM throwErrorDescription pure . runExceptT $ + getMember lmId (mkErrorDescription :: ConvNotFound) usr lmems -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). @@ -487,35 +490,10 @@ ensureOtherMember loc quid conv = (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) -getSelfMemberFromRemotes :: - (Foldable t, Monad m) => - Remote UserId -> - t RemoteMember -> - ExceptT ConvNotFound m RemoteMember -getSelfMemberFromRemotes = getRemoteMember (mkErrorDescription :: ConvNotFound) - getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley r RemoteMember getSelfMemberFromRemotesLegacy usr rmems = eitherM throwErrorDescription pure . runExceptT $ - getSelfMemberFromRemotes usr rmems - --- | Since we search by local user ID, we know that the member must be local. -getLocalMember :: - (Foldable t, Monad m) => - e -> - UserId -> - t LocalMember -> - ExceptT e m LocalMember -getLocalMember = getMember lmId - --- | Since we search by remote user ID, we know that the member must be remote. -getRemoteMember :: - (Foldable t, Monad m) => - e -> - Remote UserId -> - t RemoteMember -> - ExceptT e m RemoteMember -getRemoteMember = getMember rmId + getMember rmId (mkErrorDescription :: ConvNotFound) usr rmems getQualifiedMember :: Monad m => @@ -527,8 +505,8 @@ getQualifiedMember :: getQualifiedMember loc e qusr conv = foldQualified loc - (\lusr -> Left <$> getLocalMember e (tUnqualified lusr) (Data.convLocalMembers conv)) - (\rusr -> Right <$> getRemoteMember e rusr (Data.convRemoteMembers conv)) + (\lusr -> Left <$> getMember lmId e (tUnqualified lusr) (Data.convLocalMembers conv)) + (\rusr -> Right <$> getMember rmId e rusr (Data.convRemoteMembers conv)) qusr getMember :: @@ -545,6 +523,7 @@ getMember :: getMember p ex u = hoistEither . note ex . find ((u ==) . p) getConversationAndCheckMembership :: + Member ConversationStore r => UserId -> ConvId -> Galley r Data.Conversation @@ -557,15 +536,17 @@ getConversationAndCheckMembership uid cnv = do pure conv getConversationAndMemberWithError :: - IsConvMemberId uid mem => + (Member ConversationStore r, IsConvMemberId uid mem) => Error -> uid -> ConvId -> Galley r (Data.Conversation, mem) getConversationAndMemberWithError ex usr convId = do - c <- Data.conversation convId >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + c <- + liftSem (getConversation convId) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) when (DataTypes.isConvDeleted c) $ do - Data.deleteConversation convId + liftSem $ deleteConversation convId throwErrorDescriptionType @ConvNotFound loc <- qualifyLocal () member <- @@ -604,20 +585,32 @@ pushConversationEvent conn e users bots = do push1 $ p & set pushConn conn External.deliverAsync (toList bots `zip` repeat e) -verifyReusableCode :: ConversationCode -> Galley r DataTypes.Code +verifyReusableCode :: + Member CodeStore r => + ConversationCode -> + Galley r DataTypes.Code verifyReusableCode convCode = do c <- - Data.lookupCode (conversationKey convCode) DataTypes.ReusableCode + liftSem (getCode (conversationKey convCode) DataTypes.ReusableCode) >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) unless (DataTypes.codeValue c == conversationCode convCode) $ throwM (errorDescriptionTypeToWai @CodeNotFound) return c -ensureConversationAccess :: Member BrigAccess r => UserId -> ConvId -> Access -> Galley r Data.Conversation +ensureConversationAccess :: + Members '[BrigAccess, ConversationStore, TeamStore] r => + UserId -> + ConvId -> + Access -> + Galley r Data.Conversation ensureConversationAccess zusr cnv access = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem (getConversation cnv) + >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv access - zusrMembership <- maybe (pure Nothing) (`Data.teamMember` zusr) (Data.convTeam conv) + zusrMembership <- + liftSem $ + maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv @@ -840,21 +833,29 @@ consentGiven = \case UserLegalHoldEnabled -> ConsentGiven UserLegalHoldNoConsent -> ConsentNotGiven -checkConsent :: Map UserId TeamId -> UserId -> Galley r ConsentGiven +checkConsent :: + Member TeamStore r => + Map UserId TeamId -> + UserId -> + Galley r ConsentGiven checkConsent teamsOfUsers other = do consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other -- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user -- doesn't belong to a team. -getLHStatus :: Maybe TeamId -> UserId -> Galley r UserLegalHoldStatus +getLHStatus :: + Member TeamStore r => + Maybe TeamId -> + UserId -> + Galley r UserLegalHoldStatus getLHStatus teamOfUser other = do case teamOfUser of Nothing -> pure defUserLegalHoldStatus Just team -> do - mMember <- Data.teamMember team other + mMember <- liftSem $ getTeamMember team other pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember -anyLegalholdActivated :: [UserId] -> Galley r Bool +anyLegalholdActivated :: Member TeamStore r => [UserId] -> Galley r Bool anyLegalholdActivated uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -863,31 +864,39 @@ anyLegalholdActivated uids = do where check = do flip anyM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- Data.usersTeams uidsPage + teamsOfUsers <- liftSem $ getUsersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage -allLegalholdConsentGiven :: [UserId] -> Galley r Bool +allLegalholdConsentGiven :: Member TeamStore r => [UserId] -> Galley r Bool allLegalholdConsentGiven uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False FeatureLegalHoldDisabledByDefault -> do flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- Data.usersTeams uidsPage + teamsOfUsers <- liftSem $ getUsersTeams uidsPage allM (\uid -> (== ConsentGiven) . consentGiven <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do -- For this feature the implementation is more efficient. Being part of -- a whitelisted team is equivalent to have given consent to be in a -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsPage <- nub . Map.elems <$> Data.usersTeams uidsPage + teamsPage <- liftSem $ nub . Map.elems <$> getUsersTeams uidsPage allM isTeamLegalholdWhitelisted teamsPage -- | Add to every uid the legalhold status -getLHStatusForUsers :: [UserId] -> Galley r [(UserId, UserLegalHoldStatus)] +getLHStatusForUsers :: + Member TeamStore r => + [UserId] -> + Galley r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do - teamsOfUsers <- Data.usersTeams uidsChunk + teamsOfUsers <- liftSem $ getUsersTeams uidsChunk for uidsChunk $ \uid -> do (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid ) + +getTeamMembersForFanout :: Member TeamStore r => TeamId -> Galley r TeamMemberList +getTeamMembersForFanout tid = do + lim <- fanoutLimit + liftSem $ getTeamMembersWithLimit tid lim diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 10ba4724994..ad7436253e8 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -77,10 +76,8 @@ import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') import Data.Default (def) -import Data.Id (ConnId, TeamId, UserId) import qualified Data.List.NonEmpty as NE import Data.Metrics.Middleware -import Data.Misc (Fingerprint, Rsa) import qualified Data.ProtocolBuffers as Proto import Data.Proxy (Proxy (..)) import Data.Range @@ -90,8 +87,16 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Galley.API.Error import qualified Galley.Aws as Aws +import Galley.Cassandra.Client +import Galley.Cassandra.Code +import Galley.Cassandra.Conversation +import Galley.Cassandra.Conversation.Members +import Galley.Cassandra.ConversationList +import Galley.Cassandra.Services +import Galley.Cassandra.Team import Galley.Effects import qualified Galley.Effects.FireAndForget as E +import Galley.Env import Galley.Options import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams @@ -111,45 +116,18 @@ import qualified OpenSSL.X509.SystemStore as Ssl import Polysemy import Polysemy.Internal (Append) import qualified Polysemy.Reader as P +import qualified Polysemy.TinyLog as P import qualified Servant import Ssl.Util -import System.Logger.Class hiding (Error, info) +import System.Logger.Class import qualified System.Logger.Extended as Logger import qualified UnliftIO.Exception as UnliftIO import Util.Options import Wire.API.Federation.Client (HasFederatorConfig (..)) -data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) - deriving (Eq, Ord, Show) - --- | Main application environment. -data Env = Env - { _reqId :: RequestId, - _monitor :: Metrics, - _options :: Opts, - _applog :: Logger, - _manager :: Manager, - _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time? - _brig :: Endpoint, -- FUTUREWORK: see _federator - _cstate :: ClientState, - _deleteQueue :: Q.Queue DeleteItem, - _extEnv :: ExtEnv, - _aEnv :: Maybe Aws.Env - } - --- | Environment specific to the communication with external --- service providers. -data ExtEnv = ExtEnv - { _extGetManager :: (Manager, [Fingerprint Rsa] -> Ssl.SSL -> IO ()) - } - -makeLenses ''Env - -makeLenses ''ExtEnv - -- MTL-style effects derived from the old implementation of the Galley monad. -- They will disappear as we introduce more high-level effects into Galley. -type GalleyEffects0 = '[P.Reader ClientState, P.Reader Env, Embed IO, Final IO] +type GalleyEffects0 = '[P.TinyLog, P.Reader ClientState, P.Reader Env, Embed IO, Final IO] type GalleyEffects = Append GalleyEffects1 GalleyEffects0 @@ -198,7 +176,7 @@ currentFanoutLimit o = do unsafeRange (min maxTeamSize optFanoutLimit) -- Define some invariants for the options used -validateOptions :: Logger.Logger -> Opts -> IO () +validateOptions :: Logger -> Opts -> IO () validateOptions l o = do let settings = view optSettings o optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit o @@ -221,9 +199,7 @@ validateOptions l o = do error "setMaxTeamSize cannot be < setTruncationLimit" instance MonadLogger (Galley r) where - log l m = do - e <- ask - Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) + log l m = Galley $ P.polylog l m instance MonadHttp (Galley r) where handleRequestWithCont req handler = do @@ -314,6 +290,15 @@ evalGalley0 e = . embedToFinal @IO . P.runReader e . P.runReader (e ^. cstate) + . interpretTinyLog e + +interpretTinyLog :: + Members '[Embed IO] r => + Env -> + Sem (P.TinyLog ': r) a -> + Sem r a +interpretTinyLog e = interpret $ \case + P.Polylog l m -> Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) evalGalley :: Env -> Galley GalleyEffects a -> IO a evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 @@ -321,7 +306,7 @@ evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -reqIdMsg :: RequestId -> Msg -> Msg +reqIdMsg :: RequestId -> Logger.Msg -> Logger.Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} @@ -360,6 +345,40 @@ toServantHandler env galley = do mkCode = statusCode . WaiError.code mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . WaiError.code +withLH :: + Member (P.Reader Env) r => + (Teams.FeatureLegalHold -> Sem (eff ': r) a -> Sem r a) -> + Sem (eff ': r) a -> + Sem r a +withLH f action = do + lh <- P.asks (view (options . optSettings . setFeatureFlags . Teams.flagLegalHold)) + f lh action + +interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a +interpretGalleyToGalley0 = + Galley + . interpretInternalTeamListToCassandra + . interpretTeamListToCassandra + . interpretLegacyConversationListToCassandra + . interpretRemoteConversationListToCassandra + . interpretConversationListToCassandra + . withLH interpretTeamMemberStoreToCassandra + . withLH interpretTeamStoreToCassandra + . interpretServiceStoreToCassandra + . interpretMemberStoreToCassandra + . interpretConversationStoreToCassandra + . interpretCodeStoreToCassandra + . interpretClientStoreToCassandra + . interpretFireAndForget + . interpretIntra + . interpretBot + . interpretFederator + . interpretExternal + . interpretSpar + . interpretGundeck + . interpretBrig + . unGalley + ---------------------------------------------------------------------------------- ---- temporary MonadUnliftIO support code for the polysemy refactoring @@ -393,16 +412,3 @@ liftGalley0 (Galley m) = Galley $ subsume_ m liftSem :: Sem r a -> Galley r a liftSem m = Galley m - -interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a -interpretGalleyToGalley0 = - Galley - . interpretFireAndForget - . interpretIntra - . interpretBot - . interpretFederator - . interpretExternal - . interpretSpar - . interpretGundeck - . interpretBrig - . unGalley diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs new file mode 100644 index 00000000000..a32e4fdce1a --- /dev/null +++ b/services/galley/src/Galley/Cassandra.hs @@ -0,0 +1,23 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra (schemaVersion) where + +import Imports + +schemaVersion :: Int32 +schemaVersion = 54 diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs new file mode 100644 index 00000000000..4f01535cd68 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -0,0 +1,64 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Client + ( interpretClientStoreToCassandra, + lookupClients, + ) +where + +import Cassandra +import Control.Arrow +import Data.Id +import Data.List.Split (chunksOf) +import Galley.Cassandra.Store +import qualified Galley.Data.Queries as Cql +import Galley.Effects.ClientStore (ClientStore (..)) +import Galley.Types.Clients (Clients) +import qualified Galley.Types.Clients as Clients +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import qualified UnliftIO + +updateClient :: Bool -> UserId -> ClientId -> Client () +updateClient add usr cls = do + let q = if add then Cql.addMemberClient else Cql.rmMemberClient + retry x5 $ write (q cls) (params Quorum (Identity usr)) + +-- Do, at most, 16 parallel lookups of up to 128 users each +lookupClients :: [UserId] -> Client Clients +lookupClients users = + Clients.fromList . concat . concat + <$> forM (chunksOf 2048 users) (UnliftIO.mapConcurrently getClients . chunksOf 128) + where + getClients us = + map (second fromSet) + <$> retry x1 (query Cql.selectClients (params Quorum (Identity us))) + +eraseClients :: UserId -> Client () +eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user))) + +interpretClientStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ClientStore ': r) a -> + Sem r a +interpretClientStoreToCassandra = interpret $ \case + GetClients uids -> embedClient $ lookupClients uids + CreateClient uid cid -> embedClient $ updateClient True uid cid + DeleteClient uid cid -> embedClient $ updateClient False uid cid + DeleteClients uid -> embedClient $ eraseClients uid diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs new file mode 100644 index 00000000000..e03b3414a99 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -0,0 +1,58 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Code + ( interpretCodeStoreToCassandra, + ) +where + +import Brig.Types.Code +import Cassandra +import Galley.Cassandra.Store +import qualified Galley.Data.Queries as Cql +import Galley.Data.Types +import Galley.Effects.CodeStore (CodeStore (..)) +import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretCodeStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (CodeStore ': r) a -> + Sem r a +interpretCodeStoreToCassandra = interpret $ \case + GetCode k s -> embedClient $ lookupCode k s + CreateCode code -> embedClient $ insertCode code + DeleteCode k s -> embedClient $ deleteCode k s + +-- | Insert a conversation code +insertCode :: Code -> Client () +insertCode c = do + let k = codeKey c + let v = codeValue c + let cnv = codeConversation c + let t = round (codeTTL c) + let s = codeScope c + retry x5 (write Cql.insertCode (params Quorum (k, v, cnv, s, t))) + +-- | Lookup a conversation by code. +lookupCode :: Key -> Scope -> Client (Maybe Code) +lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params Quorum (k, s))) + +-- | Delete a code associated with the given conversation key +deleteCode :: Key -> Scope -> Client () +deleteCode k s = retry x5 $ write Cql.deleteCode (params Quorum (k, s)) diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs new file mode 100644 index 00000000000..5cdb4bd3f5a --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -0,0 +1,362 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Conversation + ( createConversation, + deleteConversation, + interpretConversationStoreToCassandra, + ) +where + +import Cassandra +import Data.ByteString.Conversion +import Data.Id +import qualified Data.Map as Map +import Data.Misc +import Data.Qualified +import Data.Range +import qualified Data.UUID.Tagged as U +import Data.UUID.V4 (nextRandom) +import Galley.Cassandra.Conversation.Members +import Galley.Cassandra.Store +import Galley.Data.Access +import Galley.Data.Conversation +import Galley.Data.Conversation.Types +import qualified Galley.Data.Queries as Cql +import Galley.Effects.ConversationStore (ConversationStore (..)) +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Galley.Validation +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import Polysemy.TinyLog +import qualified System.Logger as Log +import qualified UnliftIO +import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation.Role (roleNameWireAdmin) + +createConversation :: NewConversation -> Client Conversation +createConversation (NewConversation ty usr acc arole name mtid mtimer recpt users role) = do + conv <- Id <$> liftIO nextRandom + retry x5 $ case mtid of + Nothing -> + write Cql.insertConv (params Quorum (conv, ty, usr, Set (toList acc), arole, fmap fromRange name, Nothing, mtimer, recpt)) + Just tid -> batch $ do + setType BatchLogged + setConsistency Quorum + addPrepQuery Cql.insertConv (conv, ty, usr, Set (toList acc), arole, fmap fromRange name, Just tid, mtimer, recpt) + addPrepQuery Cql.insertTeamConv (tid, conv, False) + let newUsers = fmap (,role) (fromConvSize users) + (lmems, rmems) <- addMembers conv (ulAddLocal (usr, roleNameWireAdmin) newUsers) + pure $ + Conversation + { convId = conv, + convType = ty, + convCreator = usr, + convName = fmap fromRange name, + convAccess = acc, + convAccessRole = arole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = mtid, + convDeleted = Nothing, + convMessageTimer = mtimer, + convReceiptMode = recpt + } + +createConnectConversation :: + U.UUID U.V4 -> + U.UUID U.V4 -> + Maybe (Range 1 256 Text) -> + Client Conversation +createConnectConversation a b name = do + let conv = localOne2OneConvId a b + a' = Id . U.unpack $ a + retry x5 $ + write Cql.insertConv (params Quorum (conv, ConnectConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + (lmems, rmems) <- addMembers conv (UserList [a'] []) + pure + Conversation + { convId = conv, + convType = ConnectConv, + convCreator = a', + convName = fmap fromRange name, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +createConnectConversationWithRemote :: + ConvId -> + UserId -> + UserList UserId -> + Client Conversation +createConnectConversationWithRemote cid creator m = do + retry x5 $ + write Cql.insertConv (params Quorum (cid, ConnectConv, creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) + -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + (lmems, rmems) <- addMembers cid m + pure + Conversation + { convId = cid, + convType = ConnectConv, + convCreator = creator, + convName = Nothing, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +createLegacyOne2OneConversation :: + Local x -> + U.UUID U.V4 -> + U.UUID U.V4 -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Client Conversation +createLegacyOne2OneConversation loc a b name ti = do + let conv = localOne2OneConvId a b + a' = Id (U.unpack a) + b' = Id (U.unpack b) + createOne2OneConversation + conv + (qualifyAs loc a') + (qUntagged (qualifyAs loc b')) + name + ti + +createOne2OneConversation :: + ConvId -> + Local UserId -> + Qualified UserId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Client Conversation +createOne2OneConversation conv self other name mtid = do + retry x5 $ case mtid of + Nothing -> write Cql.insertConv (params Quorum (conv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + Just tid -> batch $ do + setType BatchLogged + setConsistency Quorum + addPrepQuery Cql.insertConv (conv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) + addPrepQuery Cql.insertTeamConv (tid, conv, False) + (lmems, rmems) <- addMembers conv (toUserList self [qUntagged self, other]) + pure + Conversation + { convId = conv, + convType = ConnectConv, + convCreator = tUnqualified self, + convName = fmap fromRange name, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +createSelfConversation :: Local UserId -> Maybe (Range 1 256 Text) -> Client Conversation +createSelfConversation lusr name = do + let usr = tUnqualified lusr + conv = selfConv usr + lconv = qualifyAs lusr conv + retry x5 $ + write Cql.insertConv (params Quorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + (lmems, rmems) <- addMembers (tUnqualified lconv) (UserList [tUnqualified lusr] []) + pure + Conversation + { convId = conv, + convType = SelfConv, + convCreator = usr, + convName = fmap fromRange name, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +deleteConversation :: ConvId -> Client () +deleteConversation cid = do + retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) + + localMembers <- members cid + remoteMembers <- lookupRemoteMembers cid + + removeMembersFromLocalConv cid $ + UserList (lmId <$> localMembers) (rmId <$> remoteMembers) + + retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) + +conversationMeta :: ConvId -> Client (Maybe ConversationMetadata) +conversationMeta conv = + fmap toConvMeta + <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) + where + toConvMeta (t, c, a, r, n, i, _, mt, rm) = + ConversationMetadata t c (defAccess t a) (maybeRole t r) n i mt rm + +isConvAlive :: ConvId -> Client Bool +isConvAlive cid = do + result <- retry x1 (query1 Cql.isConvDeleted (params Quorum (Identity cid))) + case runIdentity <$> result of + Nothing -> pure False + Just Nothing -> pure True + Just (Just True) -> pure False + Just (Just False) -> pure True + +updateConvType :: ConvId -> ConvType -> Client () +updateConvType cid ty = + retry x5 $ + write Cql.updateConvType (params Quorum (ty, cid)) + +updateConvName :: ConvId -> Range 1 256 Text -> Client () +updateConvName cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) + +updateConvAccess :: ConvId -> ConversationAccessData -> Client () +updateConvAccess cid (ConversationAccessData acc role) = + retry x5 $ + write Cql.updateConvAccess (params Quorum (Set (toList acc), role, cid)) + +updateConvReceiptMode :: ConvId -> ReceiptMode -> Client () +updateConvReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params Quorum (receiptMode, cid)) + +updateConvMessageTimer :: ConvId -> Maybe Milliseconds -> Client () +updateConvMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) + +getConversation :: ConvId -> Client (Maybe Conversation) +getConversation conv = do + cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) + remoteMems <- UnliftIO.async $ lookupRemoteMembers conv + mbConv <- + toConv conv + <$> members conv + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait cdata + return mbConv >>= conversationGC + +{- "Garbage collect" the conversation, i.e. the conversation may be + marked as deleted, in which case we delete it and return Nothing -} +conversationGC :: + Maybe Conversation -> + Client (Maybe Conversation) +conversationGC conv = case join (convDeleted <$> conv) of + (Just True) -> do + sequence_ $ deleteConversation . convId <$> conv + return Nothing + _ -> return conv + +localConversations :: + (Members '[Embed IO, P.Reader ClientState, TinyLog] r) => + [ConvId] -> + Sem r [Conversation] +localConversations [] = return [] +localConversations ids = do + cs <- embedClient $ do + convs <- UnliftIO.async fetchConvs + mems <- UnliftIO.async $ memberLists ids + remoteMems <- UnliftIO.async $ remoteMemberLists ids + zipWith4 toConv ids + <$> UnliftIO.wait mems + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait convs + foldrM flatten [] (zip ids cs) + where + fetchConvs = do + cs <- retry x1 $ query Cql.selectConvs (params Quorum (Identity ids)) + let m = Map.fromList $ map (\(c, t, u, n, a, r, i, d, mt, rm) -> (c, (t, u, n, a, r, i, d, mt, rm))) cs + return $ map (`Map.lookup` m) ids + flatten (i, c) cc = case c of + Nothing -> do + warn $ Log.msg ("No conversation for: " <> toByteString i) + return cc + Just c' -> return (c' : cc) + +-- | Takes a list of conversation ids and returns those found for the given +-- user. +localConversationIdsOf :: UserId -> [ConvId] -> Client [ConvId] +localConversationIdsOf usr cids = do + runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) + +-- | Takes a list of remote conversation ids and fetches member status flags +-- for the given user +remoteConversationStatus :: + UserId -> + [Remote ConvId] -> + Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatus uid = + fmap mconcat + . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) + . bucketRemote + +remoteConversationStatusOnDomain :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomain uid rconvs = + Map.fromList . map toPair + <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) + where + toPair (conv, omus, omur, oar, oarr, hid, hidr) = + ( qualifyAs rconvs conv, + toMemberStatus (omus, omur, oar, oarr, hid, hidr) + ) + +interpretConversationStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState, TinyLog] r => + Sem (ConversationStore ': r) a -> + Sem r a +interpretConversationStoreToCassandra = interpret $ \case + CreateConversation nc -> embedClient $ createConversation nc + CreateConnectConversation x y name -> + embedClient $ createConnectConversation x y name + CreateConnectConversationWithRemote cid lusr mems -> + embedClient $ createConnectConversationWithRemote cid lusr mems + CreateLegacyOne2OneConversation loc x y name tid -> + embedClient $ createLegacyOne2OneConversation loc x y name tid + CreateOne2OneConversation conv self other name mtid -> + embedClient $ createOne2OneConversation conv self other name mtid + CreateSelfConversation lusr name -> + embedClient $ createSelfConversation lusr name + GetConversation cid -> embedClient $ getConversation cid + GetConversations cids -> localConversations cids + GetConversationMetadata cid -> embedClient $ conversationMeta cid + IsConversationAlive cid -> embedClient $ isConvAlive cid + SelectConversations uid cids -> embedClient $ localConversationIdsOf uid cids + GetRemoteConversationStatus uid cids -> embedClient $ remoteConversationStatus uid cids + SetConversationType cid ty -> embedClient $ updateConvType cid ty + SetConversationName cid value -> embedClient $ updateConvName cid value + SetConversationAccess cid value -> embedClient $ updateConvAccess cid value + SetConversationReceiptMode cid value -> embedClient $ updateConvReceiptMode cid value + SetConversationMessageTimer cid value -> embedClient $ updateConvMessageTimer cid value + DeleteConversation cid -> embedClient $ deleteConversation cid diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs new file mode 100644 index 00000000000..a39e0f0ae25 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -0,0 +1,361 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Conversation.Members + ( addMembers, + members, + memberLists, + remoteMemberLists, + lookupRemoteMembers, + removeMembersFromLocalConv, + toMemberStatus, + interpretMemberStoreToCassandra, + ) +where + +import Cassandra +import Data.Domain +import Data.Id +import qualified Data.List.Extra as List +import qualified Data.Map as Map +import Data.Monoid +import Data.Qualified +import Galley.Cassandra.Services +import Galley.Cassandra.Store +import Galley.Data.Instances () +import qualified Galley.Data.Queries as Cql +import Galley.Effects.MemberStore +import Galley.Types.Conversations.Members +import Galley.Types.ToUserRole +import Galley.Types.UserList +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import qualified UnliftIO +import Wire.API.Conversation.Member +import Wire.API.Conversation.Role +import Wire.API.Provider.Service + +-- | Add members to a local conversation. +-- Conversation is local, so we can add any member to it (including remote ones). +-- When the role is not specified, it defaults to admin. +-- Please make sure the conversation doesn't exceed the maximum size! +addMembers :: + ToUserRole a => + ConvId -> + UserList a -> + Client ([LocalMember], [RemoteMember]) +addMembers conv (fmap toUserRole -> UserList lusers rusers) = do + -- batch statement with 500 users are known to be above the batch size limit + -- and throw "Batch too large" errors. Therefor we chunk requests and insert + -- sequentially. (parallelizing would not aid performance as the partition + -- key, i.e. the convId, is on the same cassandra node) + -- chunk size 32 was chosen to lead to batch statements + -- below the batch threshold + -- With chunk size of 64: + -- [galley] Server warning: Batch for [galley_test.member, galley_test.user] is of size 7040, exceeding specified threshold of 5120 by 1920. + -- + for_ (List.chunksOf 32 lusers) $ \chunk -> do + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + for_ chunk $ \(u, r) -> do + -- User is local, too, so we add it to both the member and the user table + addPrepQuery Cql.insertMember (conv, u, Nothing, Nothing, r) + addPrepQuery Cql.insertUserConv (u, conv) + + for_ (List.chunksOf 32 rusers) $ \chunk -> do + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do + -- User is remote, so we only add it to the member_remote_user + -- table, but the reverse mapping has to be done on the remote + -- backend; so we assume an additional call to their backend has + -- been (or will be) made separately. See Galley.API.Update.addMembers + addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) + + pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) + +removeMembersFromLocalConv :: ConvId -> UserList UserId -> Client () +removeMembersFromLocalConv cnv victims = void $ do + UnliftIO.concurrently + (removeLocalMembersFromLocalConv cnv (ulLocals victims)) + (removeRemoteMembersFromLocalConv cnv (ulRemotes victims)) + +removeLocalMembersFromLocalConv :: ConvId -> [UserId] -> Client () +removeLocalMembersFromLocalConv _ [] = pure () +removeLocalMembersFromLocalConv cnv victims = do + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + for_ victims $ \victim -> do + addPrepQuery Cql.removeMember (cnv, victim) + addPrepQuery Cql.deleteUserConv (victim, cnv) + +removeRemoteMembersFromLocalConv :: ConvId -> [Remote UserId] -> Client () +removeRemoteMembersFromLocalConv _ [] = pure () +removeRemoteMembersFromLocalConv cnv victims = do + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + for_ victims $ \(qUntagged -> Qualified uid domain) -> + addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) + +memberLists :: [ConvId] -> Client [[LocalMember]] +memberLists convs = do + mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) + let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems + return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs + where + insert (_, Nothing) acc = acc + insert (conv, Just mem) acc = + let f = (Just . maybe [mem] (mem :)) + in Map.alter f conv acc + mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = + (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) + +members :: ConvId -> Client [LocalMember] +members = fmap concat . memberLists . pure + +toMemberStatus :: + ( -- otr muted + Maybe MutedStatus, + Maybe Text, + -- otr archived + Maybe Bool, + Maybe Text, + -- hidden + Maybe Bool, + Maybe Text + ) -> + MemberStatus +toMemberStatus (omus, omur, oar, oarr, hid, hidr) = + MemberStatus + { msOtrMutedStatus = omus, + msOtrMutedRef = omur, + msOtrArchived = fromMaybe False oar, + msOtrArchivedRef = oarr, + msHidden = fromMaybe False hid, + msHiddenRef = hidr + } + +toMember :: + ( UserId, + Maybe ServiceId, + Maybe ProviderId, + Maybe Cql.MemberStatus, + -- otr muted + Maybe MutedStatus, + Maybe Text, + -- otr archived + Maybe Bool, + Maybe Text, + -- hidden + Maybe Bool, + Maybe Text, + -- conversation role name + Maybe RoleName + ) -> + Maybe LocalMember +toMember (usr, srv, prv, Just 0, omus, omur, oar, oarr, hid, hidr, crn) = + Just $ + LocalMember + { lmId = usr, + lmService = newServiceRef <$> srv <*> prv, + lmStatus = toMemberStatus (omus, omur, oar, oarr, hid, hidr), + lmConvRoleName = fromMaybe roleNameWireAdmin crn + } +toMember _ = Nothing + +toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember +toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) + +newRemoteMemberWithRole :: Remote (UserId, RoleName) -> RemoteMember +newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = + RemoteMember + { rmId = qualifyAs ur u, + rmConvRoleName = r + } + +remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] +remoteMemberLists convs = do + mems <- retry x1 $ query Cql.selectRemoteMembers (params Quorum (Identity convs)) + let convMembers = foldr (insert . mkMem) Map.empty mems + return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs + where + insert (conv, mem) acc = + let f = (Just . maybe [mem] (mem :)) + in Map.alter f conv acc + mkMem (cnv, domain, usr, role) = (cnv, toRemoteMember usr domain role) + +lookupRemoteMembers :: ConvId -> Client [RemoteMember] +lookupRemoteMembers conv = join <$> remoteMemberLists [conv] + +member :: + ConvId -> + UserId -> + Client (Maybe LocalMember) +member cnv usr = + (toMember =<<) + <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) + +-- | Set local users as belonging to a remote conversation. This is invoked by a +-- remote galley when users from the current backend are added to conversations +-- on the remote end. +addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Client () +addLocalMembersToRemoteConv _ [] = pure () +addLocalMembersToRemoteConv rconv users = do + -- FUTUREWORK: consider using pooledMapConcurrentlyN + for_ (List.chunksOf 32 users) $ \chunk -> + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + for_ chunk $ \u -> + addPrepQuery + Cql.insertUserRemoteConv + (u, tDomain rconv, tUnqualified rconv) + +updateSelfMember :: + Qualified ConvId -> + Local UserId -> + MemberUpdate -> + Client () +updateSelfMember qcnv lusr = + foldQualified + lusr + updateSelfMemberLocalConv + updateSelfMemberRemoteConv + qcnv + lusr + +updateSelfMemberLocalConv :: + Local ConvId -> + Local UserId -> + MemberUpdate -> + Client () +updateSelfMemberLocalConv lcid luid mup = do + retry x5 . batch $ do + setType BatchUnLogged + setConsistency Quorum + for_ (mupOtrMuteStatus mup) $ \ms -> + addPrepQuery + Cql.updateOtrMemberMutedStatus + (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) + for_ (mupOtrArchive mup) $ \a -> + addPrepQuery + Cql.updateOtrMemberArchived + (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) + for_ (mupHidden mup) $ \h -> + addPrepQuery + Cql.updateMemberHidden + (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) + +updateSelfMemberRemoteConv :: + Remote ConvId -> + Local UserId -> + MemberUpdate -> + Client () +updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do + retry x5 . batch $ do + setType BatchUnLogged + setConsistency Quorum + for_ (mupOtrMuteStatus mup) $ \ms -> + addPrepQuery + Cql.updateRemoteOtrMemberMutedStatus + (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) + for_ (mupOtrArchive mup) $ \a -> + addPrepQuery + Cql.updateRemoteOtrMemberArchived + (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) + for_ (mupHidden mup) $ \h -> + addPrepQuery + Cql.updateRemoteMemberHidden + (h, mupHiddenRef mup, domain, cid, tUnqualified luid) + +updateOtherMemberLocalConv :: + Local ConvId -> + Qualified UserId -> + OtherMemberUpdate -> + Client () +updateOtherMemberLocalConv lcid quid omu = + do + let addQuery r + | tDomain lcid == qDomain quid = + addPrepQuery + Cql.updateMemberConvRoleName + (r, tUnqualified lcid, qUnqualified quid) + | otherwise = + addPrepQuery + Cql.updateRemoteMemberConvRoleName + (r, tUnqualified lcid, qDomain quid, qUnqualified quid) + retry x5 . batch $ do + setType BatchUnLogged + setConsistency Quorum + traverse_ addQuery (omuConvRoleName omu) + +-- | Select only the members of a remote conversation from a list of users. +-- Return the filtered list and a boolean indicating whether the all the input +-- users are members. +filterRemoteConvMembers :: + [UserId] -> + Remote ConvId -> + Client ([UserId], Bool) +filterRemoteConvMembers users (qUntagged -> Qualified conv dom) = + fmap Data.Monoid.getAll + . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) + <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users + where + filterMember :: UserId -> Client [UserId] + filterMember user = + fmap (map runIdentity) + . retry x1 + $ query Cql.selectRemoteConvMembers (params Quorum (user, dom, conv)) + +removeLocalMembersFromRemoteConv :: + -- | The conversation to remove members from + Remote ConvId -> + -- | Members to remove local to this backend + [UserId] -> + Client () +removeLocalMembersFromRemoteConv _ [] = pure () +removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) + +interpretMemberStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (MemberStore ': r) a -> + Sem r a +interpretMemberStoreToCassandra = interpret $ \case + CreateMembers cid ul -> embedClient $ addMembers cid ul + CreateMembersInRemoteConversation rcid uids -> + embedClient $ addLocalMembersToRemoteConv rcid uids + CreateBotMember sr bid cid -> embedClient $ addBotMember sr bid cid + GetLocalMember cid uid -> embedClient $ member cid uid + GetLocalMembers cid -> embedClient $ members cid + GetRemoteMembers rcid -> embedClient $ lookupRemoteMembers rcid + SelectRemoteMembers uids rcnv -> embedClient $ filterRemoteConvMembers uids rcnv + SetSelfMember qcid luid upd -> embedClient $ updateSelfMember qcid luid upd + SetOtherMember lcid quid upd -> + embedClient $ updateOtherMemberLocalConv lcid quid upd + DeleteMembers cnv ul -> embedClient $ removeMembersFromLocalConv cnv ul + DeleteMembersInRemoteConversation rcnv uids -> + embedClient $ + removeLocalMembersFromRemoteConv rcnv uids diff --git a/services/galley/src/Galley/Cassandra/ConversationList.hs b/services/galley/src/Galley/Cassandra/ConversationList.hs new file mode 100644 index 00000000000..804f8278727 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/ConversationList.hs @@ -0,0 +1,87 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.ConversationList + ( interpretConversationListToCassandra, + interpretRemoteConversationListToCassandra, + interpretLegacyConversationListToCassandra, + ) +where + +import Cassandra +import Data.Id +import Data.Qualified +import Data.Range +import Galley.Cassandra.Paging +import Galley.Cassandra.Store +import Galley.Data.Instances () +import qualified Galley.Data.Queries as Cql +import Galley.Data.ResultSet +import Galley.Effects.ListItems +import Imports hiding (max) +import Polysemy +import qualified Polysemy.Reader as P + +-- | Deprecated, use 'localConversationIdsPageFrom' +conversationIdsFrom :: + UserId -> + Maybe ConvId -> + Range 1 1000 Int32 -> + Client (ResultSet ConvId) +conversationIdsFrom usr start (fromRange -> max) = + mkResultSet . strip . fmap runIdentity <$> case start of + Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) + Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) (max + 1)) + where + strip p = p {result = take (fromIntegral max) (result p)} + +localConversationIdsPageFrom :: + UserId -> + Maybe PagingState -> + Range 1 1000 Int32 -> + Client (PageWithState ConvId) +localConversationIdsPageFrom usr pagingState (fromRange -> max) = + fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) + +remoteConversationIdsPageFrom :: + UserId -> + Maybe PagingState -> + Int32 -> + Client (PageWithState (Remote ConvId)) +remoteConversationIdsPageFrom usr pagingState max = + uncurry toRemoteUnsafe <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) + +interpretConversationListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems CassandraPaging ConvId ': r) a -> + Sem r a +interpretConversationListToCassandra = interpret $ \case + ListItems uid ps max -> embedClient $ localConversationIdsPageFrom uid ps max + +interpretRemoteConversationListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems CassandraPaging (Remote ConvId) ': r) a -> + Sem r a +interpretRemoteConversationListToCassandra = interpret $ \case + ListItems uid ps max -> embedClient $ remoteConversationIdsPageFrom uid ps (fromRange max) + +interpretLegacyConversationListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems LegacyPaging ConvId ': r) a -> + Sem r a +interpretLegacyConversationListToCassandra = interpret $ \case + ListItems uid ps max -> embedClient $ conversationIdsFrom uid ps max diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs new file mode 100644 index 00000000000..d5494780773 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -0,0 +1,30 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.LegalHold (isTeamLegalholdWhitelisted) where + +import Cassandra +import Data.Id +import Galley.Data.Queries as Q +import Galley.Types.Teams +import Imports + +isTeamLegalholdWhitelisted :: FeatureLegalHold -> TeamId -> Client Bool +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid = + isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params Quorum (Identity tid)))) diff --git a/services/galley/src/Galley/Cassandra/Paging.hs b/services/galley/src/Galley/Cassandra/Paging.hs new file mode 100644 index 00000000000..d2ea8e4cd26 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Paging.hs @@ -0,0 +1,97 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Paging + ( CassandraPaging, + LegacyPaging, + InternalPaging, + InternalPage (..), + InternalPagingState (..), + mkInternalPage, + ipNext, + ) +where + +import Cassandra +import Data.Id +import Data.Qualified +import Data.Range +import Galley.Data.ResultSet +import qualified Galley.Effects.Paging as E +import Imports +import Wire.API.Team.Member (HardTruncationLimit, TeamMember) + +-- | This paging system uses Cassandra's 'PagingState' to keep track of state, +-- and does not rely on ordering. This is the preferred way of paging across +-- multiple tables, as in 'MultiTablePaging'. +data CassandraPaging + +type instance E.PagingState CassandraPaging a = PagingState + +type instance E.Page CassandraPaging a = PageWithState a + +type instance E.PagingBounds CassandraPaging ConvId = Range 1 1000 Int32 + +type instance E.PagingBounds CassandraPaging (Remote ConvId) = Range 1 1000 Int32 + +type instance E.PagingBounds CassandraPaging TeamId = Range 1 100 Int32 + +-- | This paging system is based on ordering, and keeps track of state using +-- the id of the next item to fetch. Implementations of this paging system also +-- contain extra logic to detect if the last page has been fetched. +data LegacyPaging + +type instance E.PagingState LegacyPaging a = a + +type instance E.Page LegacyPaging a = ResultSet a + +type instance E.PagingBounds LegacyPaging ConvId = Range 1 1000 Int32 + +type instance E.PagingBounds LegacyPaging TeamId = Range 1 100 Int32 + +data InternalPaging + +data InternalPagingState a = forall s. InternalPagingState (Page s, s -> Client a) + +deriving instance (Functor InternalPagingState) + +data InternalPage a = forall s. InternalPage (Page s, s -> Client a, [a]) + +deriving instance (Functor InternalPage) + +mkInternalPage :: Page s -> (s -> Client a) -> Client (InternalPage a) +mkInternalPage p f = do + items <- traverse f (result p) + pure $ InternalPage (p, f, items) + +ipNext :: InternalPagingState a -> Client (InternalPage a) +ipNext (InternalPagingState (p, f)) = do + p' <- nextPage p + mkInternalPage p' f + +type instance E.PagingState InternalPaging a = InternalPagingState a + +type instance E.Page InternalPaging a = InternalPage a + +type instance E.PagingBounds InternalPaging TeamMember = Range 1 HardTruncationLimit Int32 + +type instance E.PagingBounds InternalPaging TeamId = Range 1 100 Int32 + +instance E.Paging InternalPaging where + pageItems (InternalPage (_, _, items)) = items + pageHasMore (InternalPage (p, _, _)) = hasMore p + pageState (InternalPage (p, f, _)) = InternalPagingState (p, f) diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs new file mode 100644 index 00000000000..f96fc02ae74 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -0,0 +1,78 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Services where + +import Cassandra +import Control.Lens +import Data.Id +import Galley.Cassandra.Store +import Galley.Data.Queries +import Galley.Data.Services +import Galley.Effects.ServiceStore (ServiceStore (..)) +import Galley.Types hiding (Conversation) +import Galley.Types.Bot +import Galley.Types.Conversations.Members (newMember) +import Imports +import Polysemy +import qualified Polysemy.Reader as P + +-- FUTUREWORK: support adding bots to a remote conversation +addBotMember :: ServiceRef -> BotId -> ConvId -> Client BotMember +addBotMember s bot cnv = do + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + addPrepQuery insertUserConv (botUserId bot, cnv) + addPrepQuery insertBot (cnv, bot, sid, pid) + pure (BotMember mem) + where + pid = s ^. serviceRefProvider + sid = s ^. serviceRefId + mem = (newMember (botUserId bot)) {lmService = Just s} + +-- Service -------------------------------------------------------------------- + +interpretServiceStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ServiceStore ': r) a -> + Sem r a +interpretServiceStoreToCassandra = interpret $ \case + CreateService s -> embedClient $ insertService s + GetService sr -> embedClient $ lookupService sr + DeleteService sr -> embedClient $ deleteService sr + +insertService :: MonadClient m => Service -> m () +insertService s = do + let sid = s ^. serviceRef . serviceRefId + let pid = s ^. serviceRef . serviceRefProvider + let tok = s ^. serviceToken + let url = s ^. serviceUrl + let fps = Set (s ^. serviceFingerprints) + let ena = s ^. serviceEnabled + retry x5 $ write insertSrv (params Quorum (pid, sid, url, tok, fps, ena)) + +lookupService :: MonadClient m => ServiceRef -> m (Maybe Service) +lookupService s = + fmap toService + <$> retry x1 (query1 selectSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) + where + toService (url, tok, Set fps, ena) = + newService s url tok fps & set serviceEnabled ena + +deleteService :: MonadClient m => ServiceRef -> m () +deleteService s = retry x5 (write rmSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) diff --git a/services/galley/src/Galley/Cassandra/Store.hs b/services/galley/src/Galley/Cassandra/Store.hs new file mode 100644 index 00000000000..d610321fcc0 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Store.hs @@ -0,0 +1,31 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Store + ( embedClient, + ) +where + +import Cassandra +import Imports +import Polysemy +import Polysemy.Reader as P + +embedClient :: Members '[Embed IO, P.Reader ClientState] r => Client a -> Sem r a +embedClient client = do + cs <- P.ask + embed @IO $ runClient cs client diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs new file mode 100644 index 00000000000..6369050ec74 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -0,0 +1,423 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Team + ( interpretTeamStoreToCassandra, + interpretTeamMemberStoreToCassandra, + interpretTeamListToCassandra, + interpretInternalTeamListToCassandra, + ) +where + +import Cassandra +import Cassandra.Util +import Control.Exception (ErrorCall (ErrorCall)) +import Control.Lens hiding ((<|)) +import Control.Monad.Catch (throwM) +import Control.Monad.Extra (ifM) +import Data.Id as Id +import Data.Json.Util (UTCTimeMillis (..)) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) +import qualified Data.Map.Strict as Map +import Data.Range +import qualified Data.Set as Set +import Data.UUID.V4 (nextRandom) +import qualified Galley.Cassandra.Conversation as C +import Galley.Cassandra.LegalHold (isTeamLegalholdWhitelisted) +import Galley.Cassandra.Paging +import Galley.Cassandra.Store +import Galley.Data.Instances () +import qualified Galley.Data.Queries as Cql +import Galley.Data.ResultSet +import Galley.Effects.ListItems +import Galley.Effects.TeamMemberStore +import Galley.Effects.TeamStore (TeamStore (..)) +import Galley.Types.Teams hiding + ( DeleteTeam, + GetTeamConversations, + SetTeamData, + ) +import qualified Galley.Types.Teams as Teams +import Galley.Types.Teams.Intra +import Imports hiding (Set, max) +import Polysemy +import qualified Polysemy.Reader as P +import qualified UnliftIO +import Wire.API.Team.Member + +interpretTeamStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + FeatureLegalHold -> + Sem (TeamStore ': r) a -> + Sem r a +interpretTeamStoreToCassandra lh = interpret $ \case + CreateTeamMember tid mem -> embedClient $ addTeamMember tid mem + SetTeamMemberPermissions perm0 tid uid perm1 -> + embedClient $ updateTeamMember perm0 tid uid perm1 + CreateTeam t uid n i k b -> embedClient $ createTeam t uid n i k b + DeleteTeamMember tid uid -> embedClient $ removeTeamMember tid uid + GetBillingTeamMembers tid -> embedClient $ listBillingTeamMembers tid + GetTeam tid -> embedClient $ team tid + GetTeamName tid -> embedClient $ getTeamName tid + GetTeamConversation tid cid -> embedClient $ teamConversation tid cid + GetTeamConversations tid -> embedClient $ getTeamConversations tid + SelectTeams uid tids -> embedClient $ teamIdsOf uid tids + GetTeamMember tid uid -> embedClient $ teamMember lh tid uid + GetTeamMembersWithLimit tid n -> embedClient $ teamMembersWithLimit lh tid n + GetTeamMembers tid -> embedClient $ teamMembersCollectedWithPagination lh tid + SelectTeamMembers tid uids -> embedClient $ teamMembersLimited lh tid uids + GetUserTeams uid -> embedClient $ userTeams uid + GetUsersTeams uids -> embedClient $ usersTeams uids + GetOneUserTeam uid -> embedClient $ oneUserTeam uid + GetTeamsBindings tid -> embedClient $ getTeamsBindings tid + GetTeamBinding tid -> embedClient $ getTeamBinding tid + GetTeamCreationTime tid -> embedClient $ teamCreationTime tid + DeleteTeam tid -> embedClient $ deleteTeam tid + DeleteTeamConversation tid cid -> embedClient $ removeTeamConv tid cid + SetTeamData tid upd -> embedClient $ updateTeam tid upd + SetTeamStatus tid st -> embedClient $ updateTeamStatus tid st + +interpretTeamListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems LegacyPaging TeamId ': r) a -> + Sem r a +interpretTeamListToCassandra = interpret $ \case + ListItems uid ps lim -> embedClient $ teamIdsFrom uid ps lim + +interpretInternalTeamListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems InternalPaging TeamId ': r) a -> + Sem r a +interpretInternalTeamListToCassandra = interpret $ \case + ListItems uid mps lim -> embedClient $ case mps of + Nothing -> do + page <- teamIdsForPagination uid Nothing lim + mkInternalPage page pure + Just ps -> ipNext ps + +interpretTeamMemberStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + FeatureLegalHold -> + Sem (TeamMemberStore InternalPaging ': r) a -> + Sem r a +interpretTeamMemberStoreToCassandra lh = interpret $ \case + ListTeamMembers tid mps lim -> embedClient $ case mps of + Nothing -> do + page <- teamMembersForPagination tid Nothing lim + mkInternalPage page (newTeamMember' lh tid) + Just ps -> ipNext ps + +createTeam :: + Maybe TeamId -> + UserId -> + Range 1 256 Text -> + Range 1 256 Text -> + Maybe (Range 1 256 Text) -> + TeamBinding -> + Client Team +createTeam t uid (fromRange -> n) (fromRange -> i) k b = do + tid <- maybe (Id <$> liftIO nextRandom) return t + retry x5 $ write Cql.insertTeam (params Quorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) + pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) + where + initialStatus Binding = PendingActive -- Team becomes Active after User account activation + initialStatus NonBinding = Active + +listBillingTeamMembers :: TeamId -> Client [UserId] +listBillingTeamMembers tid = + fmap runIdentity + <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) + +getTeamName :: TeamId -> Client (Maybe Text) +getTeamName tid = + fmap runIdentity + <$> retry x1 (query1 Cql.selectTeamName (params Quorum (Identity tid))) + +teamConversation :: TeamId -> ConvId -> Client (Maybe TeamConversation) +teamConversation t c = + fmap (newTeamConversation c . runIdentity) + <$> retry x1 (query1 Cql.selectTeamConv (params Quorum (t, c))) + +getTeamConversations :: TeamId -> Client [TeamConversation] +getTeamConversations t = + map (uncurry newTeamConversation) + <$> retry x1 (query Cql.selectTeamConvs (params Quorum (Identity t))) + +teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (ResultSet TeamId) +teamIdsFrom usr range (fromRange -> max) = + mkResultSet . fmap runIdentity . strip <$> case range of + Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) + Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) (max + 1)) + where + strip p = p {result = take (fromIntegral max) (result p)} + +teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (Page TeamId) +teamIdsForPagination usr range (fromRange -> max) = + fmap runIdentity <$> case range of + Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) max) + Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) max) + +teamMember :: FeatureLegalHold -> TeamId -> UserId -> Client (Maybe TeamMember) +teamMember lh t u = + newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params Quorum (t, u))) + where + newTeamMember'' :: + UserId -> + Maybe (Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> + Client (Maybe TeamMember) + newTeamMember'' _ Nothing = pure Nothing + newTeamMember'' uid (Just (perms, minvu, minvt, mulhStatus)) = + Just <$> newTeamMember' lh t (uid, perms, minvu, minvt, mulhStatus) + +addTeamMember :: TeamId -> TeamMember -> Client () +addTeamMember t m = + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + addPrepQuery + Cql.insertTeamMember + ( t, + m ^. userId, + m ^. permissions, + m ^? invitation . _Just . _1, + m ^? invitation . _Just . _2 + ) + addPrepQuery Cql.insertUserTeam (m ^. userId, t) + when (m `hasPermission` SetBilling) $ + addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) + +updateTeamMember :: + -- | Old permissions, used for maintaining 'billing_team_member' table + Permissions -> + TeamId -> + UserId -> + -- | New permissions + Permissions -> + Client () +updateTeamMember oldPerms tid uid newPerms = do + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + addPrepQuery Cql.updatePermissions (newPerms, tid, uid) + + when (SetBilling `Set.member` acquiredPerms) $ + addPrepQuery Cql.insertBillingTeamMember (tid, uid) + + when (SetBilling `Set.member` lostPerms) $ + addPrepQuery Cql.deleteBillingTeamMember (tid, uid) + where + permDiff = Set.difference `on` view Teams.self + acquiredPerms = newPerms `permDiff` oldPerms + lostPerms = oldPerms `permDiff` newPerms + +removeTeamMember :: TeamId -> UserId -> Client () +removeTeamMember t m = + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + addPrepQuery Cql.deleteTeamMember (t, m) + addPrepQuery Cql.deleteUserTeam (m, t) + addPrepQuery Cql.deleteBillingTeamMember (t, m) + +team :: TeamId -> Client (Maybe TeamData) +team tid = + fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params Quorum (Identity tid))) + where + toTeam (u, n, i, k, d, s, st, b) = + let t = newTeam tid u n i (fromMaybe NonBinding b) & teamIconKey .~ k + status = if d then PendingDelete else fromMaybe Active s + in TeamData t status (writeTimeToUTC <$> st) + +teamIdsOf :: UserId -> [TeamId] -> Client [TeamId] +teamIdsOf usr tids = + map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params Quorum (usr, toList tids))) + +teamMembersWithLimit :: + FeatureLegalHold -> + TeamId -> + Range 1 HardTruncationLimit Int32 -> + Client TeamMemberList +teamMembersWithLimit lh t (fromRange -> limit) = do + -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size + pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP Quorum (Identity t) (limit + 1))) + ms <- mapM (newTeamMember' lh t) . take (fromIntegral limit) $ result pageTuple + pure $ + if hasMore pageTuple + then newTeamMemberList ms ListTruncated + else newTeamMemberList ms ListComplete + +-- NOTE: Use this function with care... should only be required when deleting a team! +-- Maybe should be left explicitly for the caller? +teamMembersCollectedWithPagination :: FeatureLegalHold -> TeamId -> Client [TeamMember] +teamMembersCollectedWithPagination lh tid = do + mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) + collectTeamMembersPaginated [] mems + where + collectTeamMembersPaginated acc mems = do + tMembers <- mapM (newTeamMember' lh tid) (result mems) + if (null $ result mems) + then collectTeamMembersPaginated (tMembers ++ acc) =<< nextPage mems + else return (tMembers ++ acc) + +-- Lookup only specific team members: this is particularly useful for large teams when +-- needed to look up only a small subset of members (typically 2, user to perform the action +-- and the target user) +teamMembersLimited :: FeatureLegalHold -> TeamId -> [UserId] -> Client [TeamMember] +teamMembersLimited lh t u = + mapM (newTeamMember' lh t) + =<< retry x1 (query Cql.selectTeamMembers' (params Quorum (t, u))) + +userTeams :: UserId -> Client [TeamId] +userTeams u = + map runIdentity + <$> retry x1 (query Cql.selectUserTeams (params Quorum (Identity u))) + +usersTeams :: [UserId] -> Client (Map UserId TeamId) +usersTeams uids = do + pairs :: [(UserId, TeamId)] <- + catMaybes + <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeam uid) uids + pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs + +oneUserTeam :: UserId -> Client (Maybe TeamId) +oneUserTeam u = + fmap runIdentity + <$> retry x1 (query1 Cql.selectOneUserTeam (params Quorum (Identity u))) + +teamCreationTime :: TeamId -> Client (Maybe TeamCreationTime) +teamCreationTime t = + checkCreation . fmap runIdentity + <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params Quorum (Identity t))) + where + checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts + checkCreation _ = Nothing + +getTeamBinding :: TeamId -> Client (Maybe TeamBinding) +getTeamBinding t = + fmap (fromMaybe NonBinding . runIdentity) + <$> retry x1 (query1 Cql.selectTeamBinding (params Quorum (Identity t))) + +getTeamsBindings :: [TeamId] -> Client [TeamBinding] +getTeamsBindings = + fmap catMaybes + . UnliftIO.pooledMapConcurrentlyN 8 getTeamBinding + +deleteTeam :: TeamId -> Client () +deleteTeam tid = do + -- TODO: delete service_whitelist records that mention this team + retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) + mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) + removeTeamMembers mems + cnvs <- teamConversationsForPagination tid Nothing (unsafeRange 2000) + removeConvs cnvs + retry x5 $ write Cql.deleteTeam (params Quorum (Deleted, tid)) + where + removeConvs :: Page TeamConversation -> Client () + removeConvs cnvs = do + for_ (result cnvs) $ removeTeamConv tid . view conversationId + unless (null $ result cnvs) $ + removeConvs =<< liftClient (nextPage cnvs) + + removeTeamMembers :: + Page + ( UserId, + Permissions, + Maybe UserId, + Maybe UTCTimeMillis, + Maybe UserLegalHoldStatus + ) -> + Client () + removeTeamMembers mems = do + mapM_ (removeTeamMember tid . view _1) (result mems) + unless (null $ result mems) $ + removeTeamMembers =<< liftClient (nextPage mems) + +removeTeamConv :: TeamId -> ConvId -> Client () +removeTeamConv tid cid = liftClient $ do + retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + addPrepQuery Cql.markConvDeleted (Identity cid) + addPrepQuery Cql.deleteTeamConv (tid, cid) + C.deleteConversation cid + +updateTeamStatus :: TeamId -> TeamStatus -> Client () +updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) + +updateTeam :: TeamId -> TeamUpdateData -> Client () +updateTeam tid u = retry x5 . batch $ do + setType BatchLogged + setConsistency Quorum + for_ (u ^. nameUpdate) $ \n -> + addPrepQuery Cql.updateTeamName (fromRange n, tid) + for_ (u ^. iconUpdate) $ \i -> + addPrepQuery Cql.updateTeamIcon (fromRange i, tid) + for_ (u ^. iconKeyUpdate) $ \k -> + addPrepQuery Cql.updateTeamIconKey (fromRange k, tid) + +-- | Construct 'TeamMember' from database tuple. +-- If FeatureLegalHoldWhitelistTeamsAndImplicitConsent is enabled set UserLegalHoldDisabled +-- if team is whitelisted. +-- +-- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the +-- other is 'Just', which can only be caused by inconsistent database content. +newTeamMember' :: + FeatureLegalHold -> + TeamId -> + (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> + Client TeamMember +newTeamMember' lh tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do + mk minvu minvt >>= maybeGrant + where + maybeGrant :: TeamMember -> Client TeamMember + maybeGrant m = + ifM + (isTeamLegalholdWhitelisted lh tid) + (pure (grantImplicitConsent m)) + (pure m) + + grantImplicitConsent :: TeamMember -> TeamMember + grantImplicitConsent = + legalHoldStatus %~ \case + UserLegalHoldNoConsent -> UserLegalHoldDisabled + -- the other cases don't change; we just enumerate them to catch future changes in + -- 'UserLegalHoldStatus' better. + UserLegalHoldDisabled -> UserLegalHoldDisabled + UserLegalHoldPending -> UserLegalHoldPending + UserLegalHoldEnabled -> UserLegalHoldEnabled + + mk (Just invu) (Just invt) = pure $ TeamMember uid perms (Just (invu, invt)) lhStatus + mk Nothing Nothing = pure $ TeamMember uid perms Nothing lhStatus + mk _ _ = throwM $ ErrorCall "TeamMember with incomplete metadata." + +teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Client (Page TeamConversation) +teamConversationsForPagination tid start (fromRange -> max) = + fmap (uncurry newTeamConversation) <$> case start of + Just c -> paginate Cql.selectTeamConvsFrom (paramsP Quorum (tid, c) max) + Nothing -> paginate Cql.selectTeamConvs (paramsP Quorum (Identity tid) max) + +type RawTeamMember = (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) + +-- This function has a bit of a difficult type to work with because we don't +-- have a pure function of type RawTeamMember -> TeamMember so we cannot fmap +-- over the ResultSet. We don't want to mess around with the Result size +-- nextPage either otherwise +teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Client (Page RawTeamMember) +teamMembersForPagination tid start (fromRange -> max) = + case start of + Just u -> paginate Cql.selectTeamMembersFrom (paramsP Quorum (tid, u) max) + Nothing -> paginate Cql.selectTeamMembers (paramsP Quorum (Identity tid) max) diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs deleted file mode 100644 index 44663d52eee..00000000000 --- a/services/galley/src/Galley/Data.hs +++ /dev/null @@ -1,1274 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Data - ( ResultSet, - ResultSetType (..), - PageWithState (..), - mkResultSet, - resultSetType, - resultSetResult, - schemaVersion, - - -- * Teams - addTeamMember, - updateTeamMember, - createTeam, - removeTeamMember, - listBillingTeamMembers, - team, - Galley.Data.teamName, - teamConversation, - teamConversations, - teamIdsFrom, - teamIdsForPagination, - teamIdsOf, - teamMember, - withTeamMembersWithChunks, - teamMembersWithLimit, - teamMembersForFanout, - teamMembersCollectedWithPagination, - teamMembersLimited, - userTeams, - usersTeams, - oneUserTeam, - Galley.Data.teamBinding, - teamCreationTime, - deleteTeam, - removeTeamConv, - updateTeam, - updateTeamStatus, - - -- * Conversations - Conversation (..), - convMetadata, - convAccessData, - acceptConnect, - conversation, - conversationIdsFrom, - localConversationIdsOf, - remoteConversationStatus, - localConversationIdsPageFrom, - localConversationIdRowsForPagination, - localConversations, - conversationMeta, - conversationsRemote, - createConnectConversation, - createConnectConversationWithRemote, - createConversation, - createLegacyOne2OneConversation, - createOne2OneConversation, - createSelfConversation, - isConvAlive, - updateConversation, - updateConversationAccess, - updateConversationReceiptMode, - updateConversationMessageTimer, - deleteConversation, - lookupReceiptMode, - remoteConversationIdsPageFrom, - - -- * Conversation Members - addMember, - addMembers, - addLocalMembersToRemoteConv, - member, - members, - lookupRemoteMembers, - removeMember, - removeLocalMembersFromLocalConv, - removeRemoteMembersFromLocalConv, - removeLocalMembersFromRemoteConv, - updateSelfMember, - updateSelfMemberLocalConv, - updateSelfMemberRemoteConv, - updateOtherMember, - updateOtherMemberLocalConv, - updateOtherMemberRemoteConv, - ToUserRole (..), - toQualifiedUserRole, - filterRemoteConvMembers, - - -- * Conversation Codes - lookupCode, - deleteCode, - insertCode, - - -- * Clients - eraseClients, - lookupClients, - lookupClients', - updateClient, - - -- * Utilities - localOne2OneConvId, - newMember, - - -- * Defaults - defRole, - defRegularConvAccess, - ) -where - -import Brig.Types.Code -import Cassandra -import Cassandra.Util -import Control.Arrow (second) -import Control.Exception (ErrorCall (ErrorCall)) -import Control.Lens hiding ((<|)) -import Control.Monad.Catch (throwM) -import Control.Monad.Extra (ifM) -import Data.ByteString.Conversion hiding (parser) -import Data.Domain (Domain) -import Data.Id as Id -import Data.Json.Util (UTCTimeMillis (..)) -import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) -import qualified Data.List.Extra as List -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Data.List.Split (chunksOf) -import qualified Data.Map.Strict as Map -import Data.Misc (Milliseconds) -import qualified Data.Monoid -import Data.Qualified -import Data.Range -import qualified Data.Set as Set -import qualified Data.UUID.Tagged as U -import Data.UUID.V4 (nextRandom) -import Galley.App -import Galley.Data.Instances () -import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) -import qualified Galley.Data.Queries as Cql -import Galley.Data.Types as Data -import Galley.Types hiding (Conversation) -import Galley.Types.Bot (newServiceRef) -import Galley.Types.Clients (Clients) -import qualified Galley.Types.Clients as Clients -import Galley.Types.Conversations.Members -import Galley.Types.Conversations.Roles -import Galley.Types.Teams hiding - ( Event, - EventType (..), - self, - teamConversations, - teamMembers, - ) -import qualified Galley.Types.Teams as Teams -import Galley.Types.Teams.Intra -import Galley.Types.UserList -import Galley.Validation -import Imports hiding (Set, max) -import qualified System.Logger.Class as Log -import qualified UnliftIO -import Wire.API.Team.Member - --- We use this newtype to highlight the fact that the 'Page' wrapped in here --- can not reliably used for paging. --- --- The reason for this is that Cassandra returns 'hasMore' as true if the --- page size requested is equal to result size. To work around this we --- actually request for one additional element and drop the last value if --- necessary. This means however that 'nextPage' does not work properly as --- we would miss a value on every page size. --- Thus, and since we don't want to expose the ResultSet constructor --- because it gives access to `nextPage`, we give accessors to the results --- and a more typed `hasMore` (ResultSetComplete | ResultSetTruncated) -data ResultSet a = ResultSet - { resultSetResult :: [a], - resultSetType :: ResultSetType - } - deriving stock (Show, Functor, Foldable, Traversable) - --- | A more descriptive type than using a simple bool to represent `hasMore` -data ResultSetType - = ResultSetComplete - | ResultSetTruncated - deriving stock (Eq, Show) - -mkResultSet :: Page a -> ResultSet a -mkResultSet page = ResultSet (result page) typ - where - typ - | hasMore page = ResultSetTruncated - | otherwise = ResultSetComplete - -schemaVersion :: Int32 -schemaVersion = 54 - --- | Insert a conversation code -insertCode :: Code -> Galley r () -insertCode c = do - let k = codeKey c - let v = codeValue c - let cnv = codeConversation c - let t = round (codeTTL c) - let s = codeScope c - retry x5 (write Cql.insertCode (params Quorum (k, v, cnv, s, t))) - --- | Lookup a conversation by code. -lookupCode :: Key -> Scope -> Galley r (Maybe Code) -lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params Quorum (k, s))) - --- | Delete a code associated with the given conversation key -deleteCode :: Key -> Scope -> Galley r () -deleteCode k s = retry x5 $ write Cql.deleteCode (params Quorum (k, s)) - --- Teams -------------------------------------------------------------------- - -team :: TeamId -> Galley r (Maybe TeamData) -team tid = - fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params Quorum (Identity tid))) - where - toTeam (u, n, i, k, d, s, st, b) = - let t = newTeam tid u n i (fromMaybe NonBinding b) & teamIconKey .~ k - status = if d then PendingDelete else fromMaybe Active s - in TeamData t status (writeTimeToUTC <$> st) - -teamName :: TeamId -> Galley r (Maybe Text) -teamName tid = - fmap runIdentity - <$> retry x1 (query1 Cql.selectTeamName (params Quorum (Identity tid))) - -teamIdsOf :: UserId -> Range 1 32 (List TeamId) -> Galley r [TeamId] -teamIdsOf usr (fromList . fromRange -> tids) = - map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params Quorum (usr, tids))) - -teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (ResultSet TeamId) -teamIdsFrom usr range (fromRange -> max) = - mkResultSet . fmap runIdentity . strip <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) - Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) (max + 1)) - where - strip p = p {result = take (fromIntegral max) (result p)} - -teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (Page TeamId) -teamIdsForPagination usr range (fromRange -> max) = - fmap runIdentity <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) max) - Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) max) - -teamConversation :: TeamId -> ConvId -> Galley r (Maybe TeamConversation) -teamConversation t c = - fmap (newTeamConversation c . runIdentity) - <$> retry x1 (query1 Cql.selectTeamConv (params Quorum (t, c))) - -teamConversations :: TeamId -> Galley r [TeamConversation] -teamConversations t = - map (uncurry newTeamConversation) - <$> retry x1 (query Cql.selectTeamConvs (params Quorum (Identity t))) - -teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page TeamConversation) -teamConversationsForPagination tid start (fromRange -> max) = - fmap (uncurry newTeamConversation) <$> case start of - Just c -> paginate Cql.selectTeamConvsFrom (paramsP Quorum (tid, c) max) - Nothing -> paginate Cql.selectTeamConvs (paramsP Quorum (Identity tid) max) - -teamMembersForFanout :: TeamId -> Galley r TeamMemberList -teamMembersForFanout t = fanoutLimit >>= teamMembersWithLimit t - -teamMembersWithLimit :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley r TeamMemberList -teamMembersWithLimit t (fromRange -> limit) = do - -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size - pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP Quorum (Identity t) (limit + 1))) - ms <- mapM (newTeamMember' t) . take (fromIntegral limit) $ result pageTuple - pure $ - if hasMore pageTuple - then newTeamMemberList ms ListTruncated - else newTeamMemberList ms ListComplete - --- This function has a bit of a difficult type to work with because we don't have a pure function of type --- (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> TeamMember so we --- cannot fmap over the ResultSet. We don't want to mess around with the Result size nextPage either otherwise -teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) -teamMembersForPagination tid start (fromRange -> max) = - case start of - Just u -> paginate Cql.selectTeamMembersFrom (paramsP Quorum (tid, u) max) - Nothing -> paginate Cql.selectTeamMembers (paramsP Quorum (Identity tid) max) - --- NOTE: Use this function with care... should only be required when deleting a team! --- Maybe should be left explicitly for the caller? -teamMembersCollectedWithPagination :: TeamId -> Galley r [TeamMember] -teamMembersCollectedWithPagination tid = do - mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) - collectTeamMembersPaginated [] mems - where - collectTeamMembersPaginated acc mems = do - tMembers <- mapM (newTeamMember' tid) (result mems) - if (null $ result mems) - then collectTeamMembersPaginated (tMembers ++ acc) =<< liftClient (nextPage mems) - else return (tMembers ++ acc) - --- Lookup only specific team members: this is particularly useful for large teams when --- needed to look up only a small subset of members (typically 2, user to perform the action --- and the target user) -teamMembersLimited :: TeamId -> [UserId] -> Galley r [TeamMember] -teamMembersLimited t u = - mapM (newTeamMember' t) - =<< retry x1 (query Cql.selectTeamMembers' (params Quorum (t, u))) - -teamMember :: TeamId -> UserId -> Galley r (Maybe TeamMember) -teamMember t u = newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params Quorum (t, u))) - where - newTeamMember'' :: - UserId -> - Maybe (Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> - Galley r (Maybe TeamMember) - newTeamMember'' _ Nothing = pure Nothing - newTeamMember'' uid (Just (perms, minvu, minvt, mulhStatus)) = - Just <$> newTeamMember' t (uid, perms, minvu, minvt, mulhStatus) - -userTeams :: UserId -> Galley r [TeamId] -userTeams u = - map runIdentity - <$> retry x1 (query Cql.selectUserTeams (params Quorum (Identity u))) - -usersTeams :: [UserId] -> Galley r (Map UserId TeamId) -usersTeams uids = liftClient $ do - pairs :: [(UserId, TeamId)] <- - catMaybes - <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeamC uid) uids - pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs - -oneUserTeam :: UserId -> Galley r (Maybe TeamId) -oneUserTeam = liftClient . oneUserTeamC - -oneUserTeamC :: UserId -> Client (Maybe TeamId) -oneUserTeamC u = - fmap runIdentity - <$> retry x1 (query1 Cql.selectOneUserTeam (params Quorum (Identity u))) - -teamCreationTime :: TeamId -> Galley r (Maybe TeamCreationTime) -teamCreationTime t = - checkCreation . fmap runIdentity - <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params Quorum (Identity t))) - where - checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts - checkCreation _ = Nothing - -teamBinding :: TeamId -> Galley r (Maybe TeamBinding) -teamBinding t = - fmap (fromMaybe NonBinding . runIdentity) - <$> retry x1 (query1 Cql.selectTeamBinding (params Quorum (Identity t))) - -createTeam :: - Maybe TeamId -> - UserId -> - Range 1 256 Text -> - Range 1 256 Text -> - Maybe (Range 1 256 Text) -> - TeamBinding -> - Galley r Team -createTeam t uid (fromRange -> n) (fromRange -> i) k b = do - tid <- maybe (Id <$> liftIO nextRandom) return t - retry x5 $ write Cql.insertTeam (params Quorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) - pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) - where - initialStatus Binding = PendingActive -- Team becomes Active after User account activation - initialStatus NonBinding = Active - -deleteTeam :: TeamId -> Galley r () -deleteTeam tid = do - -- TODO: delete service_whitelist records that mention this team - retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) - mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) - removeTeamMembers mems - cnvs <- teamConversationsForPagination tid Nothing (unsafeRange 2000) - removeConvs cnvs - retry x5 $ write Cql.deleteTeam (params Quorum (Deleted, tid)) - where - removeConvs :: Page TeamConversation -> Galley r () - removeConvs cnvs = do - for_ (result cnvs) $ removeTeamConv tid . view conversationId - unless (null $ result cnvs) $ - removeConvs =<< liftClient (nextPage cnvs) - - removeTeamMembers :: - Page - ( UserId, - Permissions, - Maybe UserId, - Maybe UTCTimeMillis, - Maybe UserLegalHoldStatus - ) -> - Galley r () - removeTeamMembers mems = do - mapM_ (removeTeamMember tid . view _1) (result mems) - unless (null $ result mems) $ - removeTeamMembers =<< liftClient (nextPage mems) - -addTeamMember :: TeamId -> TeamMember -> Galley r () -addTeamMember t m = - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery - Cql.insertTeamMember - ( t, - m ^. userId, - m ^. permissions, - m ^? invitation . _Just . _1, - m ^? invitation . _Just . _2 - ) - addPrepQuery Cql.insertUserTeam (m ^. userId, t) - when (m `hasPermission` SetBilling) $ - addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) - -updateTeamMember :: - -- | Old permissions, used for maintaining 'billing_team_member' table - Permissions -> - TeamId -> - UserId -> - -- | New permissions - Permissions -> - Galley r () -updateTeamMember oldPerms tid uid newPerms = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.updatePermissions (newPerms, tid, uid) - - when (SetBilling `Set.member` acquiredPerms) $ - addPrepQuery Cql.insertBillingTeamMember (tid, uid) - - when (SetBilling `Set.member` lostPerms) $ - addPrepQuery Cql.deleteBillingTeamMember (tid, uid) - where - permDiff = Set.difference `on` view Teams.self - acquiredPerms = newPerms `permDiff` oldPerms - lostPerms = oldPerms `permDiff` newPerms - -removeTeamMember :: TeamId -> UserId -> Galley r () -removeTeamMember t m = - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.deleteTeamMember (t, m) - addPrepQuery Cql.deleteUserTeam (m, t) - addPrepQuery Cql.deleteBillingTeamMember (t, m) - -listBillingTeamMembers :: TeamId -> Galley r [UserId] -listBillingTeamMembers tid = - fmap runIdentity - <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) - -removeTeamConv :: TeamId -> ConvId -> Galley r () -removeTeamConv tid cid = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.markConvDeleted (Identity cid) - addPrepQuery Cql.deleteTeamConv (tid, cid) - deleteConversation cid - -updateTeamStatus :: TeamId -> TeamStatus -> Galley r () -updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) - -updateTeam :: TeamId -> TeamUpdateData -> Galley r () -updateTeam tid u = retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ (u ^. nameUpdate) $ \n -> - addPrepQuery Cql.updateTeamName (fromRange n, tid) - for_ (u ^. iconUpdate) $ \i -> - addPrepQuery Cql.updateTeamIcon (fromRange i, tid) - for_ (u ^. iconKeyUpdate) $ \k -> - addPrepQuery Cql.updateTeamIconKey (fromRange k, tid) - --- Conversations ------------------------------------------------------------ - -isConvAlive :: ConvId -> Galley r Bool -isConvAlive cid = do - result <- retry x1 (query1 Cql.isConvDeleted (params Quorum (Identity cid))) - case runIdentity <$> result of - Nothing -> pure False - Just Nothing -> pure True - Just (Just True) -> pure False - Just (Just False) -> pure True - -conversation :: ConvId -> Galley r (Maybe Conversation) -conversation conv = liftClient $ do - cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) - remoteMems <- UnliftIO.async $ lookupRemoteMembersC conv - mbConv <- - toConv conv - <$> membersC conv - <*> UnliftIO.wait remoteMems - <*> UnliftIO.wait cdata - return mbConv >>= conversationGC - -{- "Garbage collect" the conversation, i.e. the conversation may be - marked as deleted, in which case we delete it and return Nothing -} -conversationGC :: - Maybe Conversation -> - Client (Maybe Conversation) -conversationGC conv = case join (convDeleted <$> conv) of - (Just True) -> do - sequence_ $ deleteConversationC . convId <$> conv - return Nothing - _ -> return conv - -localConversations :: [ConvId] -> Galley r [Conversation] -localConversations [] = return [] -localConversations ids = do - cs <- liftClient $ do - convs <- UnliftIO.async fetchConvs - mems <- UnliftIO.async $ memberLists ids - remoteMems <- UnliftIO.async $ remoteMemberLists ids - zipWith4 toConv ids - <$> UnliftIO.wait mems - <*> UnliftIO.wait remoteMems - <*> UnliftIO.wait convs - foldrM flatten [] (zip ids cs) - where - fetchConvs = do - cs <- retry x1 $ query Cql.selectConvs (params Quorum (Identity ids)) - let m = Map.fromList $ map (\(c, t, u, n, a, r, i, d, mt, rm) -> (c, (t, u, n, a, r, i, d, mt, rm))) cs - return $ map (`Map.lookup` m) ids - flatten (i, c) cc = case c of - Nothing -> do - Log.warn $ Log.msg ("No conversation for: " <> toByteString i) - return cc - Just c' -> return (c' : cc) - -toConv :: - ConvId -> - [LocalMember] -> - [RemoteMember] -> - Maybe (ConvType, UserId, Maybe (Set Access), Maybe AccessRole, Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode) -> - Maybe Conversation -toConv cid mms remoteMems conv = - f mms <$> conv - where - f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm - -conversationMeta :: Domain -> ConvId -> Galley r (Maybe ConversationMetadata) -conversationMeta _localDomain conv = - fmap toConvMeta - <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) - where - toConvMeta (t, c, a, r, n, i, _, mt, rm) = - ConversationMetadata - t - c - (defAccess t a) - (maybeRole t r) - n - i - mt - rm - --- | Deprecated, use 'localConversationIdsPageFrom' -conversationIdsFrom :: - UserId -> - Maybe ConvId -> - Range 1 1000 Int32 -> - Galley r (ResultSet ConvId) -conversationIdsFrom usr start (fromRange -> max) = - mkResultSet . strip . fmap runIdentity <$> case start of - Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) - Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) (max + 1)) - where - strip p = p {result = take (fromIntegral max) (result p)} - -localConversationIdsPageFrom :: - UserId -> - Maybe PagingState -> - Range 1 1000 Int32 -> - Galley r (PageWithState ConvId) -localConversationIdsPageFrom usr pagingState (fromRange -> max) = - fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) - -remoteConversationIdsPageFrom :: UserId -> Maybe PagingState -> Int32 -> Galley r (PageWithState (Qualified ConvId)) -remoteConversationIdsPageFrom usr pagingState max = - uncurry (flip Qualified) <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) - -localConversationIdRowsForPagination :: UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Galley r (Page ConvId) -localConversationIdRowsForPagination usr start (fromRange -> max) = - runIdentity - <$$> case start of - Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) max) - Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) max) - --- | Takes a list of conversation ids and returns those found for the given --- user. -localConversationIdsOf :: UserId -> [ConvId] -> Galley r [ConvId] -localConversationIdsOf usr cids = do - runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) - --- | Takes a list of remote conversation ids and fetches member status flags --- for the given user -remoteConversationStatus :: - UserId -> - [Remote ConvId] -> - Galley r (Map (Remote ConvId) MemberStatus) -remoteConversationStatus uid = - liftClient - . fmap mconcat - . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomainC uid) - . bucketRemote - -remoteConversationStatusOnDomainC :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomainC uid rconvs = - Map.fromList . map toPair - <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) - where - toPair (conv, omus, omur, oar, oarr, hid, hidr) = - ( qualifyAs rconvs conv, - toMemberStatus (omus, omur, oar, oarr, hid, hidr) - ) - -conversationsRemote :: UserId -> Galley r [Remote ConvId] -conversationsRemote usr = do - uncurry toRemoteUnsafe <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) - -createConversation :: - Local UserId -> - Maybe (Range 1 256 Text) -> - [Access] -> - AccessRole -> - ConvSizeChecked UserList UserId -> - Maybe ConvTeamInfo -> - -- | Message timer - Maybe Milliseconds -> - Maybe ReceiptMode -> - RoleName -> - Galley r Conversation -createConversation lusr name acc role others tinfo mtimer recpt othersConversationRole = do - conv <- Id <$> liftIO nextRandom - let lconv = qualifyAs lusr conv - usr = tUnqualified lusr - retry x5 $ case tinfo of - Nothing -> - write Cql.insertConv (params Quorum (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Nothing, mtimer, recpt)) - Just ti -> batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.insertConv (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Just (cnvTeamId ti), mtimer, recpt) - addPrepQuery Cql.insertTeamConv (cnvTeamId ti, conv, cnvManaged ti) - let newUsers = fmap (,othersConversationRole) (fromConvSize others) - (lmems, rmems) <- addMembers lconv (ulAddLocal (tUnqualified lusr, roleNameWireAdmin) newUsers) - pure $ newConv conv RegularConv usr lmems rmems acc role name (cnvTeamId <$> tinfo) mtimer recpt - -createSelfConversation :: Local UserId -> Maybe (Range 1 256 Text) -> Galley r Conversation -createSelfConversation lusr name = do - let usr = tUnqualified lusr - conv = selfConv usr - lconv = qualifyAs lusr conv - retry x5 $ - write Cql.insertConv (params Quorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - (lmems, rmems) <- addMembers lconv (UserList [tUnqualified lusr] []) - pure $ newConv conv SelfConv usr lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing - -createConnectConversation :: - Local x -> - U.UUID U.V4 -> - U.UUID U.V4 -> - Maybe (Range 1 256 Text) -> - Galley r Conversation -createConnectConversation loc a b name = do - let conv = localOne2OneConvId a b - lconv = qualifyAs loc conv - a' = Id . U.unpack $ a - retry x5 $ - write Cql.insertConv (params Quorum (conv, ConnectConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - -- We add only one member, second one gets added later, - -- when the other user accepts the connection request. - (lmems, rmems) <- addMembers lconv (UserList [a'] []) - pure $ newConv conv ConnectConv a' lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing - -createConnectConversationWithRemote :: - Local ConvId -> - Local UserId -> - UserList UserId -> - Galley r () -createConnectConversationWithRemote lconvId creator m = do - retry x5 $ - write Cql.insertConv (params Quorum (tUnqualified lconvId, ConnectConv, tUnqualified creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) - -- We add only one member, second one gets added later, - -- when the other user accepts the connection request. - void $ addMembers lconvId m - -createLegacyOne2OneConversation :: - Local x -> - U.UUID U.V4 -> - U.UUID U.V4 -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Galley r Conversation -createLegacyOne2OneConversation loc a b name ti = do - let conv = localOne2OneConvId a b - lconv = qualifyAs loc conv - a' = Id (U.unpack a) - b' = Id (U.unpack b) - createOne2OneConversation - lconv - (qualifyAs loc a') - (qUntagged (qualifyAs loc b')) - name - ti - -createOne2OneConversation :: - Local ConvId -> - Local UserId -> - Qualified UserId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Galley r Conversation -createOne2OneConversation lconv self other name mtid = do - retry x5 $ case mtid of - Nothing -> write Cql.insertConv (params Quorum (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - Just tid -> batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.insertConv (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) - addPrepQuery Cql.insertTeamConv (tid, tUnqualified lconv, False) - (lmems, rmems) <- addMembers lconv (toUserList self [qUntagged self, other]) - pure $ newConv (tUnqualified lconv) One2OneConv (tUnqualified self) lmems rmems [PrivateAccess] privateRole name mtid Nothing Nothing - -updateConversation :: ConvId -> Range 1 256 Text -> Galley r () -updateConversation cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) - -updateConversationAccess :: ConvId -> ConversationAccessData -> Galley r () -updateConversationAccess cid (ConversationAccessData acc role) = - retry x5 $ - write Cql.updateConvAccess (params Quorum (Set (toList acc), role, cid)) - -updateConversationReceiptMode :: ConvId -> ReceiptMode -> Galley r () -updateConversationReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params Quorum (receiptMode, cid)) - -lookupReceiptMode :: ConvId -> Galley r (Maybe ReceiptMode) -lookupReceiptMode cid = join . fmap runIdentity <$> retry x1 (query1 Cql.selectReceiptMode (params Quorum (Identity cid))) - -updateConversationMessageTimer :: ConvId -> Maybe Milliseconds -> Galley r () -updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) - -deleteConversation :: ConvId -> Galley r () -deleteConversation = liftClient . deleteConversationC - -deleteConversationC :: ConvId -> Client () -deleteConversationC cid = do - retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) - - localMembers <- membersC cid - for_ (nonEmpty localMembers) $ \ms -> - removeLocalMembersFromLocalConvC cid (lmId <$> ms) - - remoteMembers <- lookupRemoteMembersC cid - for_ (nonEmpty remoteMembers) $ \ms -> - removeRemoteMembersFromLocalConvC cid (rmId <$> ms) - - retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) - -acceptConnect :: ConvId -> Galley r () -acceptConnect cid = retry x5 $ write Cql.updateConvType (params Quorum (One2OneConv, cid)) - --- | We deduce the conversation ID by adding the 4 components of the V4 UUID --- together pairwise, and then setting the version bits (v4) and variant bits --- (variant 2). This means that we always know what the UUID is for a --- one-to-one conversation which hopefully makes them unique. -localOne2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId -localOne2OneConvId a b = Id . U.unpack $ U.addv4 a b - -newConv :: - ConvId -> - ConvType -> - UserId -> - [LocalMember] -> - [RemoteMember] -> - [Access] -> - AccessRole -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Maybe Milliseconds -> - Maybe ReceiptMode -> - Conversation -newConv cid ct usr mems rMems acc role name tid mtimer rMode = - Conversation - { convId = cid, - convType = ct, - convCreator = usr, - convName = fromRange <$> name, - convAccess = acc, - convAccessRole = role, - convLocalMembers = mems, - convRemoteMembers = rMems, - convTeam = tid, - convDeleted = Nothing, - convMessageTimer = mtimer, - convReceiptMode = rMode - } - -convMetadata :: Conversation -> ConversationMetadata -convMetadata c = - ConversationMetadata - (convType c) - (convCreator c) - (convAccess c) - (convAccessRole c) - (convName c) - (convTeam c) - (convMessageTimer c) - (convReceiptMode c) - -convAccessData :: Conversation -> ConversationAccessData -convAccessData conv = - ConversationAccessData - (Set.fromList (convAccess conv)) - (convAccessRole conv) - -defAccess :: ConvType -> Maybe (Set Access) -> [Access] -defAccess SelfConv Nothing = [PrivateAccess] -defAccess ConnectConv Nothing = [PrivateAccess] -defAccess One2OneConv Nothing = [PrivateAccess] -defAccess RegularConv Nothing = defRegularConvAccess -defAccess SelfConv (Just (Set [])) = [PrivateAccess] -defAccess ConnectConv (Just (Set [])) = [PrivateAccess] -defAccess One2OneConv (Just (Set [])) = [PrivateAccess] -defAccess RegularConv (Just (Set [])) = defRegularConvAccess -defAccess _ (Just (Set (x : xs))) = x : xs - -maybeRole :: ConvType -> Maybe AccessRole -> AccessRole -maybeRole SelfConv _ = privateRole -maybeRole ConnectConv _ = privateRole -maybeRole One2OneConv _ = privateRole -maybeRole RegularConv Nothing = defRole -maybeRole RegularConv (Just r) = r - -defRole :: AccessRole -defRole = ActivatedAccessRole - -defRegularConvAccess :: [Access] -defRegularConvAccess = [InviteAccess] - -privateRole :: AccessRole -privateRole = PrivateAccessRole - -privateOnly :: Set Access -privateOnly = Set [PrivateAccess] - --- Conversation Members ----------------------------------------------------- - -member :: - ConvId -> - UserId -> - Galley r (Maybe LocalMember) -member cnv usr = - (toMember =<<) - <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) - -remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] -remoteMemberLists convs = do - mems <- retry x1 $ query Cql.selectRemoteMembers (params Quorum (Identity convs)) - let convMembers = foldr (insert . mkMem) Map.empty mems - return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs - where - insert (conv, mem) acc = - let f = (Just . maybe [mem] (mem :)) - in Map.alter f conv acc - mkMem (cnv, domain, usr, role) = (cnv, toRemoteMember usr domain role) - -toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember -toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) - -memberLists :: [ConvId] -> Client [[LocalMember]] -memberLists convs = do - mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) - let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems - return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs - where - insert (_, Nothing) acc = acc - insert (conv, Just mem) acc = - let f = (Just . maybe [mem] (mem :)) - in Map.alter f conv acc - mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = - (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) - -members :: ConvId -> Galley r [LocalMember] -members = liftClient . membersC - -membersC :: ConvId -> Client [LocalMember] -membersC = fmap concat . liftClient . memberLists . pure - -lookupRemoteMembers :: ConvId -> Galley r [RemoteMember] -lookupRemoteMembers = liftClient . lookupRemoteMembersC - -lookupRemoteMembersC :: ConvId -> Client [RemoteMember] -lookupRemoteMembersC conv = join <$> remoteMemberLists [conv] - --- | Add a member to a local conversation, as an admin. -addMember :: Local ConvId -> Local UserId -> Galley r [LocalMember] -addMember c u = fst <$> addMembers c (UserList [tUnqualified u] []) - -class ToUserRole a where - toUserRole :: a -> (UserId, RoleName) - -instance ToUserRole (UserId, RoleName) where - toUserRole = id - -instance ToUserRole UserId where - toUserRole uid = (uid, roleNameWireAdmin) - -toQualifiedUserRole :: ToUserRole a => Qualified a -> (Qualified UserId, RoleName) -toQualifiedUserRole = requalify . fmap toUserRole - where - requalify (Qualified (a, role) dom) = (Qualified a dom, role) - --- | Add members to a local conversation. --- Conversation is local, so we can add any member to it (including remote ones). --- When the role is not specified, it defaults to admin. --- Please make sure the conversation doesn't exceed the maximum size! -addMembers :: ToUserRole a => Local ConvId -> UserList a -> Galley r ([LocalMember], [RemoteMember]) -addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do - -- batch statement with 500 users are known to be above the batch size limit - -- and throw "Batch too large" errors. Therefor we chunk requests and insert - -- sequentially. (parallelizing would not aid performance as the partition - -- key, i.e. the convId, is on the same cassandra node) - -- chunk size 32 was chosen to lead to batch statements - -- below the batch threshold - -- With chunk size of 64: - -- [galley] Server warning: Batch for [galley_test.member, galley_test.user] is of size 7040, exceeding specified threshold of 5120 by 1920. - -- - for_ (List.chunksOf 32 lusers) $ \chunk -> do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ chunk $ \(u, r) -> do - -- User is local, too, so we add it to both the member and the user table - addPrepQuery Cql.insertMember (conv, u, Nothing, Nothing, r) - addPrepQuery Cql.insertUserConv (u, conv) - - for_ (List.chunksOf 32 rusers) $ \chunk -> do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do - -- User is remote, so we only add it to the member_remote_user - -- table, but the reverse mapping has to be done on the remote - -- backend; so we assume an additional call to their backend has - -- been (or will be) made separately. See Galley.API.Update.addMembers - addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) - - pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) - --- | Set local users as belonging to a remote conversation. This is invoked by a --- remote galley when users from the current backend are added to conversations --- on the remote end. -addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Galley r () -addLocalMembersToRemoteConv _ [] = pure () -addLocalMembersToRemoteConv rconv users = do - -- FUTUREWORK: consider using pooledMapConcurrentlyN - for_ (List.chunksOf 32 users) $ \chunk -> - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ chunk $ \u -> - addPrepQuery - Cql.insertUserRemoteConv - (u, tDomain rconv, tUnqualified rconv) - -updateSelfMember :: - Local x -> - Qualified ConvId -> - Local UserId -> - MemberUpdate -> - Galley r () -updateSelfMember loc = foldQualified loc updateSelfMemberLocalConv updateSelfMemberRemoteConv - -updateSelfMemberLocalConv :: - Local ConvId -> - Local UserId -> - MemberUpdate -> - Galley r () -updateSelfMemberLocalConv lcid luid mup = do - retry x5 . batch $ do - setType BatchUnLogged - setConsistency Quorum - for_ (mupOtrMuteStatus mup) $ \ms -> - addPrepQuery - Cql.updateOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) - for_ (mupOtrArchive mup) $ \a -> - addPrepQuery - Cql.updateOtrMemberArchived - (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) - for_ (mupHidden mup) $ \h -> - addPrepQuery - Cql.updateMemberHidden - (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) - -updateSelfMemberRemoteConv :: - Remote ConvId -> - Local UserId -> - MemberUpdate -> - Galley r () -updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do - retry x5 . batch $ do - setType BatchUnLogged - setConsistency Quorum - for_ (mupOtrMuteStatus mup) $ \ms -> - addPrepQuery - Cql.updateRemoteOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) - for_ (mupOtrArchive mup) $ \a -> - addPrepQuery - Cql.updateRemoteOtrMemberArchived - (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) - for_ (mupHidden mup) $ \h -> - addPrepQuery - Cql.updateRemoteMemberHidden - (h, mupHiddenRef mup, domain, cid, tUnqualified luid) - -updateOtherMember :: - Local x -> - Qualified ConvId -> - Qualified UserId -> - OtherMemberUpdate -> - Galley r () -updateOtherMember loc = foldQualified loc updateOtherMemberLocalConv updateOtherMemberRemoteConv - -updateOtherMemberLocalConv :: - Local ConvId -> - Qualified UserId -> - OtherMemberUpdate -> - Galley r () -updateOtherMemberLocalConv lcid quid omu = - do - let addQuery r - | tDomain lcid == qDomain quid = - addPrepQuery - Cql.updateMemberConvRoleName - (r, tUnqualified lcid, qUnqualified quid) - | otherwise = - addPrepQuery - Cql.updateRemoteMemberConvRoleName - (r, tUnqualified lcid, qDomain quid, qUnqualified quid) - retry x5 . batch $ do - setType BatchUnLogged - setConsistency Quorum - traverse_ addQuery (omuConvRoleName omu) - --- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-887 -updateOtherMemberRemoteConv :: - Remote ConvId -> - Qualified UserId -> - OtherMemberUpdate -> - Galley r () -updateOtherMemberRemoteConv _ _ _ = pure () - --- | Select only the members of a remote conversation from a list of users. --- Return the filtered list and a boolean indicating whether the all the input --- users are members. -filterRemoteConvMembers :: - [UserId] -> - Qualified ConvId -> - Galley r ([UserId], Bool) -filterRemoteConvMembers users (Qualified conv dom) = - liftClient $ - fmap Data.Monoid.getAll - . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) - <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users - where - filterMember :: UserId -> Client [UserId] - filterMember user = - fmap (map runIdentity) - . retry x1 - $ query Cql.selectRemoteConvMembers (params Quorum (user, dom, conv)) - -removeLocalMembersFromLocalConv :: ConvId -> NonEmpty UserId -> Galley r () -removeLocalMembersFromLocalConv cnv = liftClient . removeLocalMembersFromLocalConvC cnv - -removeLocalMembersFromLocalConvC :: ConvId -> NonEmpty UserId -> Client () -removeLocalMembersFromLocalConvC cnv victims = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ victims $ \victim -> do - addPrepQuery Cql.removeMember (cnv, victim) - addPrepQuery Cql.deleteUserConv (victim, cnv) - -removeRemoteMembersFromLocalConv :: ConvId -> NonEmpty (Remote UserId) -> Galley r () -removeRemoteMembersFromLocalConv cnv = liftClient . removeRemoteMembersFromLocalConvC cnv - -removeRemoteMembersFromLocalConvC :: ConvId -> NonEmpty (Remote UserId) -> Client () -removeRemoteMembersFromLocalConvC cnv victims = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ victims $ \(qUntagged -> Qualified uid domain) -> - addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) - -removeLocalMembersFromRemoteConv :: - -- | The conversation to remove members from - Remote ConvId -> - -- | Members to remove local to this backend - [UserId] -> - Galley r () -removeLocalMembersFromRemoteConv _ [] = pure () -removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) - -removeMember :: UserId -> ConvId -> Galley r () -removeMember usr cnv = retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.removeMember (cnv, usr) - addPrepQuery Cql.deleteUserConv (usr, cnv) - -newMember :: UserId -> LocalMember -newMember u = newMemberWithRole (u, roleNameWireAdmin) - -newMemberWithRole :: (UserId, RoleName) -> LocalMember -newMemberWithRole (u, r) = - LocalMember - { lmId = u, - lmService = Nothing, - lmStatus = defMemberStatus, - lmConvRoleName = r - } - -newRemoteMemberWithRole :: Remote (UserId, RoleName) -> RemoteMember -newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = - RemoteMember - { rmId = qualifyAs ur u, - rmConvRoleName = r - } - -toMemberStatus :: - ( -- otr muted - Maybe MutedStatus, - Maybe Text, - -- otr archived - Maybe Bool, - Maybe Text, - -- hidden - Maybe Bool, - Maybe Text - ) -> - MemberStatus -toMemberStatus (omus, omur, oar, oarr, hid, hidr) = - MemberStatus - { msOtrMutedStatus = omus, - msOtrMutedRef = omur, - msOtrArchived = fromMaybe False oar, - msOtrArchivedRef = oarr, - msHidden = fromMaybe False hid, - msHiddenRef = hidr - } - -toMember :: - ( UserId, - Maybe ServiceId, - Maybe ProviderId, - Maybe Cql.MemberStatus, - -- otr muted - Maybe MutedStatus, - Maybe Text, - -- otr archived - Maybe Bool, - Maybe Text, - -- hidden - Maybe Bool, - Maybe Text, - -- conversation role name - Maybe RoleName - ) -> - Maybe LocalMember -toMember (usr, srv, prv, Just 0, omus, omur, oar, oarr, hid, hidr, crn) = - Just $ - LocalMember - { lmId = usr, - lmService = newServiceRef <$> srv <*> prv, - lmStatus = toMemberStatus (omus, omur, oar, oarr, hid, hidr), - lmConvRoleName = fromMaybe roleNameWireAdmin crn - } -toMember _ = Nothing - --- Clients ------------------------------------------------------------------ - -updateClient :: Bool -> UserId -> ClientId -> Galley r () -updateClient add usr cls = do - let q = if add then Cql.addMemberClient else Cql.rmMemberClient - retry x5 $ write (q cls) (params Quorum (Identity usr)) - --- Do, at most, 16 parallel lookups of up to 128 users each -lookupClients :: [UserId] -> Galley r Clients -lookupClients = liftClient . lookupClients' - --- This is only used by tests -lookupClients' :: [UserId] -> Client Clients -lookupClients' users = - Clients.fromList . concat . concat - <$> forM (chunksOf 2048 users) (UnliftIO.mapConcurrently getClients . chunksOf 128) - where - getClients us = - map (second fromSet) - <$> retry x1 (query Cql.selectClients (params Quorum (Identity us))) - -eraseClients :: UserId -> Galley r () -eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user))) - --- Internal utilities - --- | Construct 'TeamMember' from database tuple. --- If FeatureLegalHoldWhitelistTeamsAndImplicitConsent is enabled set UserLegalHoldDisabled --- if team is whitelisted. --- --- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the --- other is 'Just', which can only be caused by inconsistent database content. -newTeamMember' :: TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> Galley r TeamMember -newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do - mk minvu minvt >>= maybeGrant - where - maybeGrant :: TeamMember -> Galley r TeamMember - maybeGrant m = - ifM - (isTeamLegalholdWhitelisted tid) - (pure (grantImplicitConsent m)) - (pure m) - - grantImplicitConsent :: TeamMember -> TeamMember - grantImplicitConsent = - legalHoldStatus %~ \case - UserLegalHoldNoConsent -> UserLegalHoldDisabled - -- the other cases don't change; we just enumerate them to catch future changes in - -- 'UserLegalHoldStatus' better. - UserLegalHoldDisabled -> UserLegalHoldDisabled - UserLegalHoldPending -> UserLegalHoldPending - UserLegalHoldEnabled -> UserLegalHoldEnabled - - mk (Just invu) (Just invt) = pure $ TeamMember uid perms (Just (invu, invt)) lhStatus - mk Nothing Nothing = pure $ TeamMember uid perms Nothing lhStatus - mk _ _ = throwM $ ErrorCall "TeamMember with incomplete metadata." - --- | Invoke the given action with a list of TeamMemberRows IDs --- which are looked up based on: -withTeamMembersWithChunks :: - TeamId -> - ([TeamMember] -> Galley r ()) -> - Galley r () -withTeamMembersWithChunks tid action = do - mems <- teamMembersForPagination tid Nothing (unsafeRange hardTruncationLimit) - handleMembers mems - where - handleMembers mems = do - tMembers <- mapM (newTeamMember' tid) (result mems) - action tMembers - when (hasMore mems) $ - handleMembers =<< liftClient (nextPage mems) -{-# INLINE withTeamMembersWithChunks #-} diff --git a/services/galley/src/Galley/Data/Access.hs b/services/galley/src/Galley/Data/Access.hs new file mode 100644 index 00000000000..e2dfb0b7f5e --- /dev/null +++ b/services/galley/src/Galley/Data/Access.hs @@ -0,0 +1,60 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.Access where + +import Cassandra +import qualified Data.Set as Set +import Galley.Data.Conversation.Types +import Imports hiding (Set) +import Wire.API.Conversation hiding (Conversation) + +defAccess :: ConvType -> Maybe (Set Access) -> [Access] +defAccess SelfConv Nothing = [PrivateAccess] +defAccess ConnectConv Nothing = [PrivateAccess] +defAccess One2OneConv Nothing = [PrivateAccess] +defAccess RegularConv Nothing = defRegularConvAccess +defAccess SelfConv (Just (Set [])) = [PrivateAccess] +defAccess ConnectConv (Just (Set [])) = [PrivateAccess] +defAccess One2OneConv (Just (Set [])) = [PrivateAccess] +defAccess RegularConv (Just (Set [])) = defRegularConvAccess +defAccess _ (Just (Set (x : xs))) = x : xs + +defRegularConvAccess :: [Access] +defRegularConvAccess = [InviteAccess] + +maybeRole :: ConvType -> Maybe AccessRole -> AccessRole +maybeRole SelfConv _ = privateRole +maybeRole ConnectConv _ = privateRole +maybeRole One2OneConv _ = privateRole +maybeRole RegularConv Nothing = defRole +maybeRole RegularConv (Just r) = r + +defRole :: AccessRole +defRole = ActivatedAccessRole + +privateRole :: AccessRole +privateRole = PrivateAccessRole + +privateOnly :: Set Access +privateOnly = Set [PrivateAccess] + +convAccessData :: Conversation -> ConversationAccessData +convAccessData conv = + ConversationAccessData + (Set.fromList (convAccess conv)) + (convAccessRole conv) diff --git a/services/galley/src/Galley/Data/Conversation.hs b/services/galley/src/Galley/Data/Conversation.hs new file mode 100644 index 00000000000..725161d7f0b --- /dev/null +++ b/services/galley/src/Galley/Data/Conversation.hs @@ -0,0 +1,89 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.Conversation + ( -- * Data Conversation types + Conversation (..), + NewConversation, + + -- * Utilities + isSelfConv, + isO2OConv, + isTeamConv, + isConvDeleted, + selfConv, + toConv, + localOne2OneConvId, + convMetadata, + ) +where + +import Cassandra +import Data.Id +import Data.Misc +import qualified Data.UUID.Tagged as U +import Galley.Data.Access +import Galley.Data.Conversation.Types +import Galley.Data.Instances () +import Galley.Types.Conversations.Members +import Imports hiding (Set) +import Wire.API.Conversation hiding (Conversation) + +isSelfConv :: Conversation -> Bool +isSelfConv = (SelfConv ==) . convType + +isO2OConv :: Conversation -> Bool +isO2OConv = (One2OneConv ==) . convType + +isTeamConv :: Conversation -> Bool +isTeamConv = isJust . convTeam + +isConvDeleted :: Conversation -> Bool +isConvDeleted = fromMaybe False . convDeleted + +selfConv :: UserId -> ConvId +selfConv uid = Id (toUUID uid) + +toConv :: + ConvId -> + [LocalMember] -> + [RemoteMember] -> + Maybe (ConvType, UserId, Maybe (Set Access), Maybe AccessRole, Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode) -> + Maybe Conversation +toConv cid mms remoteMems conv = + f mms <$> conv + where + f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm + +-- | We deduce the conversation ID by adding the 4 components of the V4 UUID +-- together pairwise, and then setting the version bits (v4) and variant bits +-- (variant 2). This means that we always know what the UUID is for a +-- one-to-one conversation which hopefully makes them unique. +localOne2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId +localOne2OneConvId a b = Id . U.unpack $ U.addv4 a b + +convMetadata :: Conversation -> ConversationMetadata +convMetadata c = + ConversationMetadata + (convType c) + (convCreator c) + (convAccess c) + (convAccessRole c) + (convName c) + (convTeam c) + (convMessageTimer c) + (convReceiptMode c) diff --git a/services/galley/src/Galley/Data/Conversation/Types.hs b/services/galley/src/Galley/Data/Conversation/Types.hs new file mode 100644 index 00000000000..6fb47c221da --- /dev/null +++ b/services/galley/src/Galley/Data/Conversation/Types.hs @@ -0,0 +1,61 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.Conversation.Types where + +import Data.Id +import Data.Misc +import Data.Range +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Galley.Validation +import Imports +import Wire.API.Conversation hiding (Conversation) +import Wire.API.Conversation.Role + +-- | Internal conversation type, corresponding directly to database schema. +-- Should never be sent to users (and therefore doesn't have 'FromJSON' or +-- 'ToJSON' instances). +data Conversation = Conversation + { convId :: ConvId, + convType :: ConvType, + convCreator :: UserId, + convName :: Maybe Text, + convAccess :: [Access], + convAccessRole :: AccessRole, + convLocalMembers :: [LocalMember], + convRemoteMembers :: [RemoteMember], + convTeam :: Maybe TeamId, + convDeleted :: Maybe Bool, + -- | Global message timer + convMessageTimer :: Maybe Milliseconds, + convReceiptMode :: Maybe ReceiptMode + } + deriving (Show) + +data NewConversation = NewConversation + { ncType :: ConvType, + ncCreator :: UserId, + ncAccess :: [Access], + ncAccessRole :: AccessRole, + ncName :: Maybe (Range 1 256 Text), + ncTeam :: Maybe TeamId, + ncMessageTimer :: Maybe Milliseconds, + ncReceiptMode :: Maybe ReceiptMode, + ncUsers :: ConvSizeChecked UserList UserId, + ncRole :: RoleName + } diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Data/LegalHold.hs index e975e223011..62171d21ed1 100644 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ b/services/galley/src/Galley/Data/LegalHold.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -39,10 +37,11 @@ import Control.Lens (unsnoc, view) import Data.Id import Data.LegalHold import Galley.App (Env, options) +import qualified Galley.Cassandra.LegalHold as C import Galley.Data.Instances () import Galley.Data.Queries as Q import qualified Galley.Options as Opts -import Galley.Types.Teams (FeatureLegalHold (..), flagLegalHold) +import Galley.Types.Teams (flagLegalHold) import Imports -- | Returns 'False' if legal hold is not enabled for this team @@ -99,8 +98,5 @@ unsetTeamLegalholdWhitelisted tid = isTeamLegalholdWhitelisted :: (MonadReader Env m, MonadClient m) => TeamId -> m Bool isTeamLegalholdWhitelisted tid = do - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case - FeatureLegalHoldDisabledPermanently -> pure False - FeatureLegalHoldDisabledByDefault -> pure False - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params Quorum (Identity tid)))) + lhFlag <- view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) + liftClient $ C.isTeamLegalholdWhitelisted lhFlag tid diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index a562b792f13..fc919ac3128 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -28,7 +28,7 @@ import Data.Json.Util import Data.LegalHold import Data.Misc import qualified Data.Text.Lazy as LT -import Galley.Data.Types +import Galley.Data.Scope import Galley.Types hiding (Conversation) import Galley.Types.Conversations.Roles import Galley.Types.Teams diff --git a/services/galley/src/Galley/Data/ResultSet.hs b/services/galley/src/Galley/Data/ResultSet.hs new file mode 100644 index 00000000000..78db286a0e8 --- /dev/null +++ b/services/galley/src/Galley/Data/ResultSet.hs @@ -0,0 +1,51 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.ResultSet where + +import Cassandra +import Imports + +-- We use this newtype to highlight the fact that the 'Page' wrapped in here +-- can not reliably used for paging. +-- +-- The reason for this is that Cassandra returns 'hasMore' as true if the +-- page size requested is equal to result size. To work around this we +-- actually request for one additional element and drop the last value if +-- necessary. This means however that 'nextPage' does not work properly as +-- we would miss a value on every page size. +-- Thus, and since we don't want to expose the ResultSet constructor +-- because it gives access to `nextPage`, we give accessors to the results +-- and a more typed `hasMore` (ResultSetComplete | ResultSetTruncated) +data ResultSet a = ResultSet + { resultSetResult :: [a], + resultSetType :: ResultSetType + } + deriving stock (Show, Functor, Foldable, Traversable) + +-- | A more descriptive type than using a simple bool to represent `hasMore` +data ResultSetType + = ResultSetComplete + | ResultSetTruncated + deriving stock (Eq, Show) + +mkResultSet :: Page a -> ResultSet a +mkResultSet page = ResultSet (result page) typ + where + typ + | hasMore page = ResultSetTruncated + | otherwise = ResultSetComplete diff --git a/services/galley/src/Galley/Data/Scope.hs b/services/galley/src/Galley/Data/Scope.hs new file mode 100644 index 00000000000..e966ca284ee --- /dev/null +++ b/services/galley/src/Galley/Data/Scope.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.Scope where + +import Cassandra hiding (Value) +import Imports + +data Scope = ReusableCode + deriving (Eq, Show, Generic) + +instance Cql Scope where + ctype = Tagged IntColumn + + toCql ReusableCode = CqlInt 1 + + fromCql (CqlInt 1) = return ReusableCode + fromCql _ = Left "unknown Scope" diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index f47bf123648..a8c21ead628 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -17,32 +17,16 @@ module Galley.Data.Services ( -- * BotMember - BotMember, - fromBotMember, + BotMember (..), newBotMember, botMemId, botMemService, - addBotMember, - - -- * Service - insertService, - lookupService, - deleteService, ) where -import Cassandra -import Control.Lens import Data.Id -import Data.Qualified -import Data.Time.Clock -import Galley.App -import Galley.Data (newMember) -import Galley.Data.Instances () -import Galley.Data.Queries import Galley.Types hiding (Conversation) import Galley.Types.Bot -import Galley.Types.Conversations.Roles import Imports -- BotMember ------------------------------------------------------------------ @@ -66,47 +50,3 @@ botMemId = BotId . lmId . fromBotMember botMemService :: BotMember -> ServiceRef botMemService = fromJust . lmService . fromBotMember - -addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley r (Event, BotMember) -addBotMember qorig s bot cnv now = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery insertUserConv (botUserId bot, cnv) - addPrepQuery insertBot (cnv, bot, sid, pid) - return (e, BotMember mem) - where - pid = s ^. serviceRefProvider - sid = s ^. serviceRefId - -- FUTUREWORK: support adding bots to a remote conversation - qcnv = Qualified cnv localDomain - localDomain = qDomain qorig - -- FUTUREWORK: support remote bots - e = Event MemberJoin qcnv qorig now (EdMembersJoin . SimpleMembers $ (fmap toSimpleMember [botUserId bot])) - mem = (newMember (botUserId bot)) {lmService = Just s} - - toSimpleMember :: UserId -> SimpleMember - toSimpleMember u = SimpleMember (Qualified u localDomain) roleNameWireAdmin - --- Service -------------------------------------------------------------------- - -insertService :: MonadClient m => Service -> m () -insertService s = do - let sid = s ^. serviceRef . serviceRefId - let pid = s ^. serviceRef . serviceRefProvider - let tok = s ^. serviceToken - let url = s ^. serviceUrl - let fps = Set (s ^. serviceFingerprints) - let ena = s ^. serviceEnabled - retry x5 $ write insertSrv (params Quorum (pid, sid, url, tok, fps, ena)) - -lookupService :: MonadClient m => ServiceRef -> m (Maybe Service) -lookupService s = - fmap toService - <$> retry x1 (query1 selectSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) - where - toService (url, tok, Set fps, ena) = - newService s url tok fps & set serviceEnabled ena - -deleteService :: MonadClient m => ServiceRef -> m () -deleteService s = retry x5 (write rmSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) diff --git a/services/galley/src/Galley/Data/Types.hs b/services/galley/src/Galley/Data/Types.hs index 0bfee9b74b9..3aae3e50eed 100644 --- a/services/galley/src/Galley/Data/Types.hs +++ b/services/galley/src/Galley/Data/Types.hs @@ -33,54 +33,17 @@ module Galley.Data.Types where import Brig.Types.Code -import Cassandra hiding (Value) import qualified Data.ByteString as BS import Data.ByteString.Conversion import Data.Id -import Data.Misc (Milliseconds) import Data.Range import qualified Data.Text.Ascii as Ascii -import Galley.Types (Access, AccessRole, ConvType (..), LocalMember, ReceiptMode) -import Galley.Types.Conversations.Members (RemoteMember) +import Galley.Data.Conversation +import Galley.Data.Scope import Imports import OpenSSL.EVP.Digest (digestBS, getDigestByName) import OpenSSL.Random (randBytes) --- | Internal conversation type, corresponding directly to database schema. --- Should never be sent to users (and therefore doesn't have 'FromJSON' or --- 'ToJSON' instances). -data Conversation = Conversation - { convId :: ConvId, - convType :: ConvType, - convCreator :: UserId, - convName :: Maybe Text, - convAccess :: [Access], - convAccessRole :: AccessRole, - convLocalMembers :: [LocalMember], - convRemoteMembers :: [RemoteMember], - convTeam :: Maybe TeamId, - convDeleted :: Maybe Bool, - -- | Global message timer - convMessageTimer :: Maybe Milliseconds, - convReceiptMode :: Maybe ReceiptMode - } - deriving (Show) - -isSelfConv :: Conversation -> Bool -isSelfConv = (SelfConv ==) . convType - -isO2OConv :: Conversation -> Bool -isO2OConv = (One2OneConv ==) . convType - -isTeamConv :: Conversation -> Bool -isTeamConv = isJust . convTeam - -isConvDeleted :: Conversation -> Bool -isConvDeleted = fromMaybe False . convDeleted - -selfConv :: UserId -> ConvId -selfConv uid = Id (toUUID uid) - -------------------------------------------------------------------------------- -- Code @@ -93,17 +56,6 @@ data Code = Code } deriving (Eq, Show, Generic) -data Scope = ReusableCode - deriving (Eq, Show, Generic) - -instance Cql Scope where - ctype = Tagged IntColumn - - toCql ReusableCode = CqlInt 1 - - fromCql (CqlInt 1) = return ReusableCode - fromCql _ = Left "unknown Scope" - toCode :: Key -> Scope -> (Value, Int32, ConvId) -> Code toCode k s (val, ttl, cnv) = Code diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 78aceb69541..4830b635e72 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -51,13 +51,36 @@ module Galley.Effects FireAndForget, interpretFireAndForget, + -- * Store effects + ClientStore, + CodeStore, + ConversationStore, + MemberStore, + ServiceStore, + TeamStore, + TeamMemberStore, + + -- * Paging effects + ListItems, + -- * Polysemy re-exports Member, Members, ) where +import Data.Id +import Data.Qualified +import Galley.Cassandra.Paging +import Galley.Effects.ClientStore +import Galley.Effects.CodeStore +import Galley.Effects.ConversationStore import Galley.Effects.FireAndForget +import Galley.Effects.ListItems +import Galley.Effects.MemberStore +import Galley.Effects.ServiceStore +import Galley.Effects.TeamMemberStore +import Galley.Effects.TeamStore import Imports import Polysemy @@ -105,5 +128,17 @@ type GalleyEffects1 = FederatorAccess, BotAccess, Intra, - FireAndForget + FireAndForget, + ClientStore, + CodeStore, + ConversationStore, + MemberStore, + ServiceStore, + TeamStore, + TeamMemberStore InternalPaging, + ListItems CassandraPaging ConvId, + ListItems CassandraPaging (Remote ConvId), + ListItems LegacyPaging ConvId, + ListItems LegacyPaging TeamId, + ListItems InternalPaging TeamId ] diff --git a/services/galley/src/Galley/Effects/ClientStore.hs b/services/galley/src/Galley/Effects/ClientStore.hs new file mode 100644 index 00000000000..451716d66a5 --- /dev/null +++ b/services/galley/src/Galley/Effects/ClientStore.hs @@ -0,0 +1,44 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ClientStore + ( -- * ClientStore Effect + ClientStore (..), + + -- * Create client + createClient, + + -- * Get client + getClients, + + -- * Delete client + deleteClient, + deleteClients, + ) +where + +import Data.Id +import Galley.Types.Clients +import Polysemy + +data ClientStore m a where + GetClients :: [UserId] -> ClientStore m Clients + CreateClient :: UserId -> ClientId -> ClientStore m () + DeleteClient :: UserId -> ClientId -> ClientStore m () + DeleteClients :: UserId -> ClientStore m () + +makeSem ''ClientStore diff --git a/services/galley/src/Galley/Effects/CodeStore.hs b/services/galley/src/Galley/Effects/CodeStore.hs new file mode 100644 index 00000000000..246210c230f --- /dev/null +++ b/services/galley/src/Galley/Effects/CodeStore.hs @@ -0,0 +1,43 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.CodeStore + ( -- * Code store effect + CodeStore (..), + + -- * Create code + createCode, + + -- * Read code, + getCode, + + -- * Delete code, + deleteCode, + ) +where + +import Brig.Types.Code +import Galley.Data.Types +import Imports +import Polysemy + +data CodeStore m a where + CreateCode :: Code -> CodeStore m () + GetCode :: Key -> Scope -> CodeStore m (Maybe Code) + DeleteCode :: Key -> Scope -> CodeStore m () + +makeSem ''CodeStore diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs new file mode 100644 index 00000000000..c1ee62e5d64 --- /dev/null +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -0,0 +1,112 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ConversationStore + ( -- * ConversationStore Effect + ConversationStore (..), + + -- * Create conversation + createConversation, + createConnectConversation, + createConnectConversationWithRemote, + createLegacyOne2OneConversation, + createOne2OneConversation, + createSelfConversation, + + -- * Read conversation + getConversation, + getConversations, + getConversationMetadata, + isConversationAlive, + getRemoteConversationStatus, + selectConversations, + + -- * Update conversation + setConversationType, + setConversationName, + setConversationAccess, + setConversationReceiptMode, + setConversationMessageTimer, + acceptConnectConversation, + + -- * Delete conversation + deleteConversation, + ) +where + +import Data.Id +import Data.Misc +import Data.Qualified +import Data.Range +import Data.UUID.Tagged +import Galley.Data.Conversation +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Imports +import Polysemy +import Wire.API.Conversation hiding (Conversation, Member) + +data ConversationStore m a where + CreateConversation :: NewConversation -> ConversationStore m Conversation + CreateConnectConversation :: + UUID V4 -> + UUID V4 -> + Maybe (Range 1 256 Text) -> + ConversationStore m Conversation + CreateConnectConversationWithRemote :: + ConvId -> + UserId -> + UserList UserId -> + ConversationStore m Conversation + CreateLegacyOne2OneConversation :: + Local x -> + UUID V4 -> + UUID V4 -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + ConversationStore m Conversation + CreateOne2OneConversation :: + ConvId -> + Local UserId -> + Qualified UserId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + ConversationStore m Conversation + CreateSelfConversation :: + Local UserId -> + Maybe (Range 1 256 Text) -> + ConversationStore m Conversation + DeleteConversation :: ConvId -> ConversationStore m () + GetConversation :: ConvId -> ConversationStore m (Maybe Conversation) + GetConversations :: [ConvId] -> ConversationStore m [Conversation] + GetConversationMetadata :: ConvId -> ConversationStore m (Maybe ConversationMetadata) + IsConversationAlive :: ConvId -> ConversationStore m Bool + GetRemoteConversationStatus :: + UserId -> + [Remote ConvId] -> + ConversationStore m (Map (Remote ConvId) MemberStatus) + SelectConversations :: UserId -> [ConvId] -> ConversationStore m [ConvId] + SetConversationType :: ConvId -> ConvType -> ConversationStore m () + SetConversationName :: ConvId -> Range 1 256 Text -> ConversationStore m () + SetConversationAccess :: ConvId -> ConversationAccessData -> ConversationStore m () + SetConversationReceiptMode :: ConvId -> ReceiptMode -> ConversationStore m () + SetConversationMessageTimer :: ConvId -> Maybe Milliseconds -> ConversationStore m () + +makeSem ''ConversationStore + +acceptConnectConversation :: Member ConversationStore r => ConvId -> Sem r () +acceptConnectConversation cid = setConversationType cid One2OneConv diff --git a/services/galley/src/Galley/Effects/ListItems.hs b/services/galley/src/Galley/Effects/ListItems.hs new file mode 100644 index 00000000000..0fe007f4963 --- /dev/null +++ b/services/galley/src/Galley/Effects/ListItems.hs @@ -0,0 +1,37 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ListItems + ( ListItems (..), + listItems, + ) +where + +import Data.Id +import Galley.Effects.Paging +import Imports +import Polysemy + +-- | General pagination-aware list-by-user effect +data ListItems p i m a where + ListItems :: + UserId -> + Maybe (PagingState p i) -> + PagingBounds p i -> + ListItems p i m (Page p i) + +makeSem ''ListItems diff --git a/services/galley/src/Galley/Effects/MemberStore.hs b/services/galley/src/Galley/Effects/MemberStore.hs new file mode 100644 index 00000000000..80688a48935 --- /dev/null +++ b/services/galley/src/Galley/Effects/MemberStore.hs @@ -0,0 +1,72 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.MemberStore + ( -- * Member store effect + MemberStore (..), + + -- * Create members + createMember, + createMembers, + createMembersInRemoteConversation, + createBotMember, + + -- * Read members + getLocalMember, + getLocalMembers, + getRemoteMembers, + selectRemoteMembers, + + -- * Update members + setSelfMember, + setOtherMember, + + -- * Delete members + deleteMembers, + deleteMembersInRemoteConversation, + ) +where + +import Data.Id +import Data.Qualified +import Galley.Data.Services +import Galley.Types.Bot +import Galley.Types.Conversations.Members +import Galley.Types.ToUserRole +import Galley.Types.UserList +import Imports +import Polysemy +import Wire.API.Conversation.Member hiding (Member) + +data MemberStore m a where + CreateMembers :: ToUserRole u => ConvId -> UserList u -> MemberStore m ([LocalMember], [RemoteMember]) + CreateMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () + CreateBotMember :: ServiceRef -> BotId -> ConvId -> MemberStore m BotMember + GetLocalMember :: ConvId -> UserId -> MemberStore m (Maybe LocalMember) + GetLocalMembers :: ConvId -> MemberStore m [LocalMember] + GetRemoteMembers :: ConvId -> MemberStore m [RemoteMember] + SelectRemoteMembers :: [UserId] -> Remote ConvId -> MemberStore m ([UserId], Bool) + SetSelfMember :: Qualified ConvId -> Local UserId -> MemberUpdate -> MemberStore m () + SetOtherMember :: Local ConvId -> Qualified UserId -> OtherMemberUpdate -> MemberStore m () + DeleteMembers :: ConvId -> UserList UserId -> MemberStore m () + DeleteMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () + +makeSem ''MemberStore + +-- | Add a member to a local conversation, as an admin. +createMember :: Member MemberStore r => Local ConvId -> Local UserId -> Sem r [LocalMember] +createMember c u = fst <$> createMembers (tUnqualified c) (UserList [tUnqualified u] []) diff --git a/services/galley/src/Galley/Effects/Paging.hs b/services/galley/src/Galley/Effects/Paging.hs new file mode 100644 index 00000000000..8fec9b20f6a --- /dev/null +++ b/services/galley/src/Galley/Effects/Paging.hs @@ -0,0 +1,72 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.Paging + ( -- * General paging types + Page, + PagingState, + PagingBounds, + Paging (..), + + -- * Utilities + withChunks, + + -- * Simple paging + SimplePaging, + ) +where + +import Imports + +type family Page p a :: (page :: *) | page -> p a + +type family PagingState p a = (ps :: *) + +type family PagingBounds p a :: * + +class Paging p where + pageItems :: Page p a -> [a] + pageHasMore :: Page p a -> Bool + pageState :: Page p a -> PagingState p a + +data SimplePaging + +type instance Page SimplePaging a = [a] + +type instance PagingState SimplePaging a = () + +type instance PagingBounds SimplePaging a = Int32 + +instance Paging SimplePaging where + pageItems = id + pageHasMore _ = False + pageState _ = () + +withChunks :: + (Paging p, Monad m) => + (Maybe (PagingState p i) -> m (Page p i)) -> + ([i] -> m ()) -> + m () +withChunks pager action = do + page <- pager Nothing + go page + where + go page = do + action (pageItems page) + when (pageHasMore page) $ do + page' <- pager (Just (pageState page)) + go page' diff --git a/services/galley/src/Galley/Effects/RemoteConversationListStore.hs b/services/galley/src/Galley/Effects/RemoteConversationListStore.hs new file mode 100644 index 00000000000..e1dec1ce376 --- /dev/null +++ b/services/galley/src/Galley/Effects/RemoteConversationListStore.hs @@ -0,0 +1,43 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.RemoteConversationListStore + ( RemoteConversationListStore (..), + listRemoteConversations, + getRemoteConversationStatus, + ) +where + +import Data.Id +import Data.Qualified +import Galley.Effects.Paging +import Galley.Types.Conversations.Members +import Imports +import Polysemy + +data RemoteConversationListStore p m a where + ListRemoteConversations :: + UserId -> + Maybe (PagingState p (Remote ConvId)) -> + Int32 -> + RemoteConversationListStore p m (Page p (Remote ConvId)) + GetRemoteConversationStatus :: + UserId -> + [Remote ConvId] -> + RemoteConversationListStore p m (Map (Remote ConvId) MemberStatus) + +makeSem ''RemoteConversationListStore diff --git a/services/galley/src/Galley/Effects/ServiceStore.hs b/services/galley/src/Galley/Effects/ServiceStore.hs new file mode 100644 index 00000000000..f9305e75090 --- /dev/null +++ b/services/galley/src/Galley/Effects/ServiceStore.hs @@ -0,0 +1,42 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ServiceStore + ( -- * Service effect + ServiceStore (..), + + -- * Create service + createService, + + -- * Read service + getService, + + -- * Delete service + deleteService, + ) +where + +import Galley.Types.Bot +import Imports +import Polysemy + +data ServiceStore m a where + CreateService :: Service -> ServiceStore m () + GetService :: ServiceRef -> ServiceStore m (Maybe Service) + DeleteService :: ServiceRef -> ServiceStore m () + +makeSem ''ServiceStore diff --git a/services/galley/src/Galley/Effects/TeamMemberStore.hs b/services/galley/src/Galley/Effects/TeamMemberStore.hs new file mode 100644 index 00000000000..618d349ec1f --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamMemberStore.hs @@ -0,0 +1,40 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamMemberStore + ( -- * Team member store effect + TeamMemberStore (..), + + -- * Team member pagination + listTeamMembers, + ) +where + +import Data.Id +import Galley.Effects.Paging +import Galley.Types.Teams +import Imports +import Polysemy + +data TeamMemberStore p m a where + ListTeamMembers :: + TeamId -> + Maybe (PagingState p TeamMember) -> + PagingBounds p TeamMember -> + TeamMemberStore p m (Page p TeamMember) + +makeSem ''TeamMemberStore diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs new file mode 100644 index 00000000000..541d87f39dc --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -0,0 +1,119 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamStore + ( -- * Team store effect + TeamStore (..), + + -- * Teams + + -- ** Create teams + createTeam, + + -- ** Read teams + getTeam, + getTeamName, + getTeamBinding, + getTeamsBindings, + getTeamConversation, + getTeamConversations, + getTeamCreationTime, + listTeams, + selectTeams, + getUserTeams, + getUsersTeams, + getOneUserTeam, + + -- ** Update teams + deleteTeamConversation, + setTeamData, + setTeamStatus, + + -- ** Delete teams + deleteTeam, + + -- * Team Members + + -- ** Create team members + createTeamMember, + + -- ** Read team members + getTeamMember, + getTeamMembersWithLimit, + getTeamMembers, + getBillingTeamMembers, + selectTeamMembers, + + -- ** Update team members + setTeamMemberPermissions, + + -- ** Delete team members + deleteTeamMember, + ) +where + +import Data.Id +import Data.Range +import Galley.Effects.ListItems +import Galley.Effects.Paging +import Galley.Types.Teams +import Galley.Types.Teams.Intra +import Imports +import Polysemy + +data TeamStore m a where + CreateTeamMember :: TeamId -> TeamMember -> TeamStore m () + SetTeamMemberPermissions :: Permissions -> TeamId -> UserId -> Permissions -> TeamStore m () + CreateTeam :: + Maybe TeamId -> + UserId -> + Range 1 256 Text -> + Range 1 256 Text -> + Maybe (Range 1 256 Text) -> + TeamBinding -> + TeamStore m Team + DeleteTeamMember :: TeamId -> UserId -> TeamStore m () + GetBillingTeamMembers :: TeamId -> TeamStore m [UserId] + GetTeam :: TeamId -> TeamStore m (Maybe TeamData) + GetTeamName :: TeamId -> TeamStore m (Maybe Text) + GetTeamConversation :: TeamId -> ConvId -> TeamStore m (Maybe TeamConversation) + GetTeamConversations :: TeamId -> TeamStore m [TeamConversation] + SelectTeams :: UserId -> [TeamId] -> TeamStore m [TeamId] + GetTeamMember :: TeamId -> UserId -> TeamStore m (Maybe TeamMember) + GetTeamMembersWithLimit :: TeamId -> Range 1 HardTruncationLimit Int32 -> TeamStore m TeamMemberList + GetTeamMembers :: TeamId -> TeamStore m [TeamMember] + SelectTeamMembers :: TeamId -> [UserId] -> TeamStore m [TeamMember] + GetUserTeams :: UserId -> TeamStore m [TeamId] + GetUsersTeams :: [UserId] -> TeamStore m (Map UserId TeamId) + GetOneUserTeam :: UserId -> TeamStore m (Maybe TeamId) + GetTeamsBindings :: [TeamId] -> TeamStore m [TeamBinding] + GetTeamBinding :: TeamId -> TeamStore m (Maybe TeamBinding) + GetTeamCreationTime :: TeamId -> TeamStore m (Maybe TeamCreationTime) + DeleteTeam :: TeamId -> TeamStore m () + DeleteTeamConversation :: TeamId -> ConvId -> TeamStore m () + SetTeamData :: TeamId -> TeamUpdateData -> TeamStore m () + SetTeamStatus :: TeamId -> TeamStatus -> TeamStore m () + +makeSem ''TeamStore + +listTeams :: + Member (ListItems p TeamId) r => + UserId -> + Maybe (PagingState p TeamId) -> + PagingBounds p TeamId -> + Sem r (Page p TeamId) +listTeams = listItems diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs new file mode 100644 index 00000000000..3be666ff2db --- /dev/null +++ b/services/galley/src/Galley/Env.hs @@ -0,0 +1,60 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Env where + +import Cassandra +import Control.Lens +import Data.Id +import Data.Metrics.Middleware +import Data.Misc (Fingerprint, Rsa) +import qualified Galley.Aws as Aws +import Galley.Options +import qualified Galley.Queue as Q +import Imports +import Network.HTTP.Client +import OpenSSL.Session as Ssl +import System.Logger +import Util.Options + +data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) + deriving (Eq, Ord, Show) + +-- | Main application environment. +data Env = Env + { _reqId :: RequestId, + _monitor :: Metrics, + _options :: Opts, + _applog :: Logger, + _manager :: Manager, + _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time? + _brig :: Endpoint, -- FUTUREWORK: see _federator + _cstate :: ClientState, + _deleteQueue :: Q.Queue DeleteItem, + _extEnv :: ExtEnv, + _aEnv :: Maybe Aws.Env + } + +-- | Environment specific to the communication with external +-- service providers. +data ExtEnv = ExtEnv + { _extGetManager :: (Manager, [Fingerprint Rsa] -> Ssl.SSL -> IO ()) + } + +makeLenses ''Env + +makeLenses ''ExtEnv diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index eb2024ee2d7..63e1cad55b9 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -30,8 +30,8 @@ import Data.ByteString.Conversion.To import Data.Id import Data.Misc import Galley.App +import Galley.Cassandra.Services import Galley.Data.Services (BotMember, botMemId, botMemService) -import qualified Galley.Data.Services as Data import Galley.Effects import Galley.Intra.User import Galley.Types (Event) @@ -75,7 +75,7 @@ deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where exec :: (BotMember, Event) -> Galley0 Bool exec (b, e) = - Data.lookupService (botMemService b) >>= \case + lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index 4cb9e07a3d7..f4bf8cd0c77 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -33,13 +33,15 @@ import Data.Proto import Data.Proto.Id import Data.ProtoLens (defMessage) import Data.Text (pack) +import Galley.API.Util import Galley.App import qualified Galley.Aws as Aws -import qualified Galley.Data as Data +import Galley.Effects.TeamStore import qualified Galley.Options as Opts import Galley.Types.Teams import Imports hiding (head) import Numeric.Natural +import Polysemy import Proto.TeamEvents (TeamEvent'EventData, TeamEvent'EventType (..)) import qualified Proto.TeamEvents_Fields as T import System.Logger (field, msg, val) @@ -49,7 +51,13 @@ import qualified System.Logger.Class as Log -- Team journal operations to SQS are a no-op when the service -- is started without journaling arguments -teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley r () +teamActivate :: + Member TeamStore r => + TeamId -> + Natural -> + Maybe Currency.Alpha -> + Maybe TeamCreationTime -> + Galley r () teamActivate tid teamSize cur time = do billingUserIds <- getBillingUserIds tid Nothing journalEvent TeamEvent'TEAM_ACTIVATE tid (Just $ evData teamSize billingUserIds cur) time @@ -88,31 +96,37 @@ evData memberCount billingUserIds cur = & T.maybe'currency .~ (pack . show <$> cur) -- FUTUREWORK: Remove this function and always get billing users ids using --- 'Data.listBillingTeamMembers'. This is required only until data is backfilled in the +-- 'getBillingTeamMembers'. This is required only until data is backfilled in the -- 'billing_team_user' table. -getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley r [UserId] +getBillingUserIds :: + Member TeamStore r => + TeamId -> + Maybe TeamMemberList -> + Galley r [UserId] getBillingUserIds tid maybeMemberList = do enableIndexedBillingTeamMembers <- view (options . Opts.optSettings . Opts.setEnableIndexedBillingTeamMembers . to (fromMaybe False)) case maybeMemberList of Nothing -> if enableIndexedBillingTeamMembers - then fetchFromDB - else handleList enableIndexedBillingTeamMembers =<< Data.teamMembersForFanout tid + then liftSem $ fetchFromDB + else do + mems <- getTeamMembersForFanout tid + handleList enableIndexedBillingTeamMembers mems Just list -> handleList enableIndexedBillingTeamMembers list where - fetchFromDB :: Galley r [UserId] - fetchFromDB = Data.listBillingTeamMembers tid + fetchFromDB :: Member TeamStore r => Sem r [UserId] + fetchFromDB = getBillingTeamMembers tid filterFromMembers :: TeamMemberList -> Galley r [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - handleList :: Bool -> TeamMemberList -> Galley r [UserId] + handleList :: Member TeamStore r => Bool -> TeamMemberList -> Galley r [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of ListTruncated -> if enableIndexedBillingTeamMembers - then fetchFromDB + then liftSem $ fetchFromDB else do Log.warn $ field "team" (toByteString tid) diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 7218a22c37c..a6e2e751531 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -37,7 +37,7 @@ import Galley.API.Federation (federationSitemap) import qualified Galley.API.Internal as Internal import Galley.App import qualified Galley.App as App -import qualified Galley.Data as Data +import Galley.Cassandra import Galley.Options (Opts, optGalley) import qualified Galley.Queue as Q import Imports @@ -82,7 +82,7 @@ mkApp o = do e <- App.createEnv m o let l = e ^. App.applog runClient (e ^. cstate) $ - versionCheck Data.schemaVersion + versionCheck schemaVersion let finalizer = do Log.info l $ Log.msg @Text "Galley application finished." Log.flush l diff --git a/services/galley/src/Galley/Types/ToUserRole.hs b/services/galley/src/Galley/Types/ToUserRole.hs new file mode 100644 index 00000000000..d68b87d514e --- /dev/null +++ b/services/galley/src/Galley/Types/ToUserRole.hs @@ -0,0 +1,30 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Types.ToUserRole where + +import Data.Id +import Wire.API.Conversation.Role + +class ToUserRole a where + toUserRole :: a -> (UserId, RoleName) + +instance ToUserRole (UserId, RoleName) where + toUserRole x = x + +instance ToUserRole UserId where + toUserRole uid = (uid, roleNameWireAdmin) diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index a533cdbd513..13471a96218 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -28,15 +28,18 @@ import Control.Lens import Control.Monad.Catch import Data.Range import Galley.API.Error -import Galley.App +import Galley.Env import Galley.Options import Imports -rangeChecked :: Within a n m => a -> Galley r (Range n m a) +rangeChecked :: (MonadThrow galley, Within a n m) => a -> galley (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} -rangeCheckedMaybe :: Within a n m => Maybe a -> Galley r (Maybe (Range n m a)) +rangeCheckedMaybe :: + (MonadThrow galley, Within a n m) => + Maybe a -> + galley (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -45,7 +48,10 @@ rangeCheckedMaybe (Just a) = Just <$> rangeChecked a newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) -checkedConvSize :: Foldable f => f a -> Galley r (ConvSizeChecked f a) +checkedConvSize :: + (MonadReader Env galley, MonadThrow galley, Foldable f) => + f a -> + galley (ConvSizeChecked f a) checkedConvSize x = do o <- view options let minV :: Integer = 0 @@ -54,5 +60,5 @@ checkedConvSize x = do then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: String -> Galley r a +throwErr :: MonadThrow galley => String -> galley a throwErr = throwM . invalidRange . fromString diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 161b1a2636c..2f16338b5af 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -65,7 +65,7 @@ import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) import qualified Data.Time.Clock as Time import qualified Galley.App as Galley -import qualified Galley.Data as Data +import Galley.Cassandra.Client import qualified Galley.Data.LegalHold as LegalHoldData import Galley.External.LegalHoldService (validateServiceKey) import Galley.Options (optSettings, setFeatureFlags) @@ -324,7 +324,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients' [member] + clients' <- Cql.runClient cassState $ lookupClients [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 9d458076467..c9ee4e914a4 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -59,7 +59,7 @@ import qualified Data.Set as Set import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) import qualified Galley.App as Galley -import qualified Galley.Data as Data +import Galley.Cassandra.Client import qualified Galley.Data.LegalHold as LegalHoldData import Galley.External.LegalHoldService (validateServiceKey) import Galley.Options (optSettings, setFeatureFlags) @@ -256,7 +256,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients' [member] + clients' <- Cql.runClient cassState $ lookupClients [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index ffda58da20e..d4d833b1703 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,7 +25,7 @@ import Data.Domain import Data.Id import Data.Qualified import Galley.API.Mapping -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Types.Conversations.Members import Imports import Test.Tasty From 19ac2dda2665071c65b3d96cdf0455e7b5e05289 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 2 Nov 2021 15:21:29 +0100 Subject: [PATCH 62/88] galley: Refactor Federation.onUserDeleted integration test (#1902) * Extract util to create One2One conv with remote user in tests * galley: Better explain the Federation.onUserDeleted test --- .../galley/test/integration/API/Federation.hs | 95 +++++++++---------- services/galley/test/integration/API/Util.hs | 28 +++++- 2 files changed, 70 insertions(+), 53 deletions(-) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index b107d5c22b1..d95d5275297 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -42,7 +42,6 @@ import Data.Time.Clock import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) import Galley.Types -import Galley.Types.Conversations.Intra import Gundeck.Types.Notification import Imports import Test.QuickCheck (arbitrary, generate) @@ -869,49 +868,48 @@ sendMessage = do Map.keysSet (userClientMap (FedGalley.rmRecipients rm)) @?= Set.singleton chadId +-- | There are 3 backends in action here: +-- +-- - Backend A (local) has Alice and Alex +-- - Backend B has Bob and Bart +-- - Backend C has Carl +-- +-- Bob is in these convs: +-- - One2One Conv with Alice (ooConvId) +-- - Group conv with all users (groupConvId) +-- +-- When bob gets deleted, backend A gets an RPC from bDomain stating that bob is +-- deleted and they would like bob to leave these converstaions: +-- - ooConvId -> Causes Alice to be notified +-- - groupConvId -> Causes Alice and Alex to be notified +-- - extraConvId -> Ignored +-- - noBobConvId -> Ignored onUserDeleted :: TestM () onUserDeleted = do cannon <- view tsCannon - let eveDomain = Domain "eve.example.com" + let bDomain = Domain "b.far-away.example.com" + cDomain = Domain "c.far-away.example.com" alice <- qTagUnsafe <$> randomQualifiedUser - (bob, ooConvId) <- generateRemoteAndConvId True alice - let bobDomain = tDomain bob - charlie <- randomQualifiedUser - dee <- randomQualifiedId bobDomain - eve <- randomQualifiedId eveDomain + alex <- randomQualifiedUser + (bob, ooConvId) <- generateRemoteAndConvIdWithDomain bDomain True alice + bart <- randomQualifiedId bDomain + carl <- randomQualifiedId cDomain connectWithRemoteUser (tUnqualified alice) (qUntagged bob) - connectUsers (tUnqualified alice) (pure (qUnqualified charlie)) - connectWithRemoteUser (tUnqualified alice) dee - connectWithRemoteUser (tUnqualified alice) eve + connectUsers (tUnqualified alice) (pure (qUnqualified alex)) + connectWithRemoteUser (tUnqualified alice) bart + connectWithRemoteUser (tUnqualified alice) carl -- create 1-1 conversation between alice and bob - iUpsertOne2OneConversation - UpsertOne2OneConversationRequest - { uooLocalUser = alice, - uooRemoteUser = bob, - uooActor = LocalActor, - uooActorDesiredMembership = Included, - uooConvId = Nothing - } - !!! const 200 === statusCode - iUpsertOne2OneConversation - UpsertOne2OneConversationRequest - { uooLocalUser = alice, - uooRemoteUser = bob, - uooActor = RemoteActor, - uooActorDesiredMembership = Included, - uooConvId = Just ooConvId - } - !!! const 200 === statusCode + createOne2OneConvWithRemote alice bob -- create group conversation with everybody groupConvId <- decodeQualifiedConvId <$> ( postConvWithRemoteUsers (tUnqualified alice) - defNewConv {newConvQualifiedUsers = [qUntagged bob, charlie, dee, eve]} + defNewConv {newConvQualifiedUsers = [qUntagged bob, alex, bart, carl]} ( postConvQualified (tUnqualified alice) defNewConv {newConvQualifiedUsers = [charlie]} - do + WS.bracketR2 cannon (tUnqualified alice) (qUnqualified alex) $ \(wsAlice, wsAlex) -> do (resp, rpcCalls) <- withTempMockFederator (const ()) $ do let udcn = FedGalley.UserDeletedConversationsNotification @@ -957,37 +954,37 @@ onUserDeleted = do -- Assert that bob gets removed from the conversation cmOthers (cnvMembers ooConvAfterDel) @?= [] - sort (map omQualifiedId (cmOthers (cnvMembers groupConvAfterDel))) @?= sort [charlie, dee, eve] + sort (map omQualifiedId (cmOthers (cnvMembers groupConvAfterDel))) @?= sort [alex, bart, carl] -- Assert that local user's get notifications only for the conversation -- bob was part of and it wasn't a One2OneConv void . WS.assertMatch (3 # Second) wsAlice $ wsAssertMembersLeave groupConvId (qUntagged bob) [qUntagged bob] - void . WS.assertMatch (3 # Second) wsCharlie $ + void . WS.assertMatch (3 # Second) wsAlex $ wsAssertMembersLeave groupConvId (qUntagged bob) [qUntagged bob] -- Alice shouldn't get any other notifications because we don't notify -- on One2One convs. -- - -- Charlie shouldn't get any other notifications because charlie was + -- Alex shouldn't get any other notifications because alex was -- not part of any other conversations with bob. - WS.assertNoEvent (1 # Second) [wsAlice, wsCharlie] + WS.assertNoEvent (1 # Second) [wsAlice, wsAlex] -- There should be only 2 RPC calls made only for groupConvId: 1 for bob's -- domain and 1 for eve's domain - length rpcCalls @?= 2 + assertEqual ("Expected 2 RPC calls, got: " <> show rpcCalls) 2 (length rpcCalls) - -- Assertions about RPC to Bob's domain - bobDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText bobDomain) rpcCalls + -- Assertions about RPC to bDomain + bobDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText bDomain) rpcCalls bobDomainRPCReq <- assertRight $ parseFedRequest bobDomainRPC FedGalley.cuOrigUserId bobDomainRPCReq @?= qUntagged bob FedGalley.cuConvId bobDomainRPCReq @?= qUnqualified groupConvId - sort (FedGalley.cuAlreadyPresentUsers bobDomainRPCReq) @?= sort [tUnqualified bob, qUnqualified dee] + sort (FedGalley.cuAlreadyPresentUsers bobDomainRPCReq) @?= sort [tUnqualified bob, qUnqualified bart] FedGalley.cuAction bobDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) - -- Assertions about RPC to Eve's domain - eveDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText eveDomain) rpcCalls - eveDomainRPCReq <- assertRight $ parseFedRequest eveDomainRPC - FedGalley.cuOrigUserId eveDomainRPCReq @?= qUntagged bob - FedGalley.cuConvId eveDomainRPCReq @?= qUnqualified groupConvId - FedGalley.cuAlreadyPresentUsers eveDomainRPCReq @?= [qUnqualified eve] - FedGalley.cuAction eveDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) + -- Assertions about RPC to 'cDomain' + cDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText cDomain) rpcCalls + cDomainRPCReq <- assertRight $ parseFedRequest cDomainRPC + FedGalley.cuOrigUserId cDomainRPCReq @?= qUntagged bob + FedGalley.cuConvId cDomainRPCReq @?= qUnqualified groupConvId + FedGalley.cuAlreadyPresentUsers cDomainRPCReq @?= [qUnqualified carl] + FedGalley.cuAction cDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 952121b98af..22bf552f9da 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -71,7 +71,7 @@ import qualified Galley.Options as Opts import qualified Galley.Run as Run import Galley.Types import qualified Galley.Types as Conv -import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..)) +import Galley.Types.Conversations.Intra import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.Conversations.Roles hiding (DeleteConversation) import Galley.Types.Teams hiding (Event, EventType (..), self) @@ -2484,11 +2484,31 @@ iUpsertOne2OneConversation req = do galley <- view tsGalley post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req) +createOne2OneConvWithRemote :: HasCallStack => Local UserId -> Remote UserId -> TestM () +createOne2OneConvWithRemote localUser remoteUser = do + let mkRequest actor mConvId = + UpsertOne2OneConversationRequest + { uooLocalUser = localUser, + uooRemoteUser = remoteUser, + uooActor = actor, + uooActorDesiredMembership = Included, + uooConvId = mConvId + } + ooConvId <- + fmap uuorConvId . responseJsonError + =<< iUpsertOne2OneConversation (mkRequest LocalActor Nothing) + Local UserId -> TestM (Remote UserId, Qualified ConvId) -generateRemoteAndConvId shouldBeLocal lUserId = do - other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") +generateRemoteAndConvId = generateRemoteAndConvIdWithDomain (Domain "far-away.example.com") + +generateRemoteAndConvIdWithDomain :: Domain -> Bool -> Local UserId -> TestM (Remote UserId, Qualified ConvId) +generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId = do + other <- Qualified <$> randomId <*> pure remoteDomain let convId = one2OneConvId (qUntagged lUserId) other isLocal = tDomain lUserId == qDomain convId if shouldBeLocal == isLocal then pure (qTagUnsafe other, convId) - else generateRemoteAndConvId shouldBeLocal lUserId + else generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId From 72ad58f4ecdb6310abf2f9de0598ad8c4f690be3 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 2 Nov 2021 16:13:26 +0100 Subject: [PATCH 63/88] Use WIRE_STACK_OPTIONS when building haddock (#1887) --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 980fffa3204..bcb634ff73e 100644 --- a/Makefile +++ b/Makefile @@ -54,12 +54,12 @@ services: init install # Build haddocks .PHONY: haddock haddock: - WIRE_STACK_OPTIONS="--haddock --haddock-internal" make fast + WIRE_STACK_OPTIONS="$(WIRE_STACK_OPTIONS) --haddock --haddock-internal" make fast # Build haddocks only for wire-server .PHONY: haddock-shallow haddock-shallow: - WIRE_STACK_OPTIONS="--haddock --haddock-internal --no-haddock-deps" make fast + WIRE_STACK_OPTIONS="$(WIRE_STACK_OPTIONS) --haddock --haddock-internal --no-haddock-deps" make fast # formats all Haskell files (which don't contain CPP) .PHONY: format From df7a4092b25e6a7c46976c150dfe6b2428182993 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 2 Nov 2021 17:29:28 +0100 Subject: [PATCH 64/88] Fix build (#1903) --- services/galley/test/integration/API/Federation.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index d95d5275297..ae2c4d92aa7 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -42,6 +42,7 @@ import Data.Time.Clock import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) import Galley.Types +import Galley.Types.Conversations.Intra import Gundeck.Types.Notification import Imports import Test.QuickCheck (arbitrary, generate) From db1730bb6b083fe9284416a8d1b27357a0e89763 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 3 Nov 2021 10:20:17 +0100 Subject: [PATCH 65/88] Federation: Document how to deploy local builds (#1880) * Update how-to.md and add script * add changelog --- changelog.d/4-docs/doc-more-helm-deploy | 1 + docs/developer/how-to.md | 87 +++++++++++++++---------- hack/bin/set-chart-image-version.sh | 18 +++++ 3 files changed, 73 insertions(+), 33 deletions(-) create mode 100644 changelog.d/4-docs/doc-more-helm-deploy create mode 100755 hack/bin/set-chart-image-version.sh diff --git a/changelog.d/4-docs/doc-more-helm-deploy b/changelog.d/4-docs/doc-more-helm-deploy new file mode 100644 index 00000000000..536e1c1178f --- /dev/null +++ b/changelog.d/4-docs/doc-more-helm-deploy @@ -0,0 +1 @@ +Federation: Document how to deploy local builds diff --git a/docs/developer/how-to.md b/docs/developer/how-to.md index 5cac999e3e8..883eabb8bdc 100644 --- a/docs/developer/how-to.md +++ b/docs/developer/how-to.md @@ -2,22 +2,6 @@ The following assume you have a working developer environment with all the dependencies listed in [./dependencies.md](./dependencies.md) available to you. - - -* [How to look at the swagger docs / UI locally](#how-to-look-at-the-swagger-docs--ui-locally) -* [How to run federation tests across two backends](#how-to-run-federation-tests-across-two-backends) - * [(1) Inspect/change the multi-backend test code](#1-inspectchange-the-multi-backend-test-code) - * [(2) Decide on code version](#2-decide-on-code-version) - * [(A) Use the latest compiled code from `develop`](#a-use-the-latest-compiled-code-from-develop) - * [Troubleshooting](#troubleshooting) - * [(B) Use code from your pull request](#b-use-code-from-your-pull-request) - * [(C) Use your local code](#c-use-your-local-code) - * [(3) Run multi-backend tests](#3-run-multi-backend-tests) - * [Run all integration tests on kubernetes](#run-all-integration-tests-on-kubernetes) - * [Run only the multi-backend tests](#run-only-the-multi-backend-tests) - - - ## How to look at the swagger docs / UI locally Terminal 1: @@ -44,24 +28,25 @@ Requirements: The process consists of: 1. Inspect/change the multi-backend tests -2. Decide on code to use by means of using docker images made available by CI, or making docker images available yourself. +2. Deploy two backends to kubernetes cluster 3. Run multi-backend test half-locally half-on-kubernetes or fully on kubernetes +4. Teardown -### (1) Inspect/change the multi-backend test code +### 1. Inspect/change the multi-backend test code Refer to `services/brig/test/integration/API/Federation/End2End.hs` for the current multi-backend tests. *Note that they only run if `INTEGRATION_FEDERATION_TESTS` is set to `1`. This is currently configured to be OFF when running regular brig integration tests (e.g. via `make -C services/brig integration`) but is by default ON when running tests on kubernetes or on CI, or when using the `services/brig/federation-tests.sh` script.* -### (2) Decide on code version +### 2. Deploy two backends to kubernetes cluster -Decide which code you would like to use for these tests by setting the `DOCKER_TAG` environment variable. The following options are detailed in the subsections below. +Decide which code you would like to deploy. The following options are detailed in the subsections below. -* (A) latest develop -* (B) latest commit on a given PR branch -* (C) local code +* 2.1 Deploy the the latest compiled code from `develop` +* 2.2 Deploy code from your pull request +* 2.3 Deploy your local code to a kind cluster -#### (A) Use the latest compiled code from `develop` +#### 2.1 Deploy the the latest compiled code from `develop` First, find the latest CI-compiled code made available as docker images: @@ -84,30 +69,37 @@ Let's assume the tags are the same(*) for both, then export an environment varia ``` export DOCKER_TAG=2.104.11 +export NAMESPACE="myname" +make kube-integration-setup ``` +This will create two full installations of wire-server on the kubernetes cluster you've configured to connect to, and should take ~10 minutes. The namespaces will be `$NAMESPACE` and `$NAMESPACE-fed2`. + + ##### Troubleshooting `make latest-tag` gives different tags for brig and nginz: * maybe CI hasn't finished, or failed. Look at concourse (`kubernetes-dev` pipeline) -#### (B) Use code from your pull request +#### 2.2 Deploy code from your pull request *Note: CI already runs multi-backend federation integration tests on your PR, so this section may not be often useful in practice. This is still documented for completeness and to help understand the relation between source code and compiled docker images on CI.* Check CI for the latest tag that has been created on your PR (expect this to take at least 30-60 minutes from the last time you pushed to your branch). Example: -Look at a successful job in the `wire-server-pr` pipeline from a job build matching your desired PR and commit hash. Then, find the actual docker tag used. +Look at a successful job in the `wire-server-pr` pipeline from a job bruild matching your desired PR and commit hash. Then, find the actual docker tag used. ![concourse-pr-version-circled](https://user-images.githubusercontent.com/2112744/114410146-69b34000-9bab-11eb-863c-106fb661ca82.png) ``` # PR 1438 commit 7a183b2dbcf019df1af3d3b97604edac72eca762 translates to export DOCKER_TAG=0.0.1-pr.3684 +export NAMESPACE="myname" +make kube-integration-setup ``` -#### (C) Use your local code and kind +#### 2.3 Deploy your local code to a kind cluster This can be useful to get quicker feedback while working on multi-backend code or configuration (e.g. helm charts) than to wait an hour for CI. This allows you to test code without uploading it to github and waiting an hour for CI. @@ -130,17 +122,36 @@ FUTUREWORK: this process is in development (update this section after it's confi NOTE: debug this process further as some images (e.g. nginz) are missing from the default buildah steps. * Implement re-tagging development tags as your user tag? -### (3) Run multi-backend tests +#### 2.4 Deploy your local code to a kubernetes cluster -Once you have chosen the code to test and set `DOCKER_TAG` accordingly, run the following, which will create two full installations of wire-server on the kubernetes cluster you've configured to connect to, and should take ~10 minutes. +This sections describes how partially update a release with a local build of a service, in this example `brig`. + +Start by deploying a published release (see 2.1 or 2.2). ``` +export NAMESPACE=$USER +export DOCKER_TAG=2.116.32 make kube-integration-setup ``` -Next, you can choose to either run all integration tests, which also includes running the multi-backend integration tests by default. Or you can instead choose to *only* run the multi-backend tests. +Then build and push the `brig` image by running + +``` +export DOCKER_TAG_LOCAL_BUILD=$USER +hack/bin/buildah-compile.sh +DOCKER_TAG=$DOCKER_TAG_LOCAL_BUILD EXECUTABLES=brig BUILDAH_PUSH=1 ./hack/bin/buildah-make-images.sh +``` + +To update the release with brig's local image run +``` +./hack/bin/set-chart-image-version.sh "$DOCKER_TAG_LOCAL_BUILD" brig +./hack/bin/integration-setup-federation.sh +``` + -#### Run all integration tests on kubernetes +## 3 Run multi-backend tests + +### Run all integration tests on kubernetes * takes ~10 minutes to run * test output is delayed until all tests have run. You will have to scroll the output to find the relevant multi-backend test output. @@ -151,7 +162,7 @@ Next, you can choose to either run all integration tests, which also includes ru make kube-integration-test ``` -#### Run only the multi-backend tests +### Run only the multi-backend tests * runs faster (~ half a minute) * test output is shown dynamically as tests run @@ -162,7 +173,7 @@ make kube-integration-test 3. Run the actual tests, (takes half a minute): ``` -./services/brig/federation-tests.sh test-$USER +./services/brig/federation-tests.sh "$NAMESPACE" ``` Note that this runs your *locally* compiled `brig-integration`, so this allows to easily change test code locally with the following process: @@ -170,3 +181,13 @@ Note that this runs your *locally* compiled `brig-integration`, so this allows t 1. change code under `services/brig/test/integration/Federation/` 2. recompile: `make -C services/brig fast` 3. run `./services/brig/federation-tests.sh test-$USER` again. + +## 4 Teardown + +To destroy all the resources on the kubernetes cluster that have been created run + +``` +./hack/bin/integration-teardown-federation.sh +``` + +Note: Simply deleting the namespaces is insufficient, because it leaves some resources (of kind ClusterRole, ClusterRoleBinding) that cause problems when redeploying to the same namespace via helm. diff --git a/hack/bin/set-chart-image-version.sh b/hack/bin/set-chart-image-version.sh new file mode 100755 index 00000000000..966a96c7c9d --- /dev/null +++ b/hack/bin/set-chart-image-version.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash + +USAGE="$0 ..." +docker_tag=${1?$USAGE} +charts=${@:2} + +TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" +CHARTS_DIR="$TOP_LEVEL/.local/charts" + +for chart in $charts +do +if [[ "$chart" == "nginz" ]]; then + # nginz has a different docker tag indentation + sed -i "s/ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" +else + sed -i "s/ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" +fi +done From fc9c7c19b11461f058e082f1a3f71e3bc844e8d2 Mon Sep 17 00:00:00 2001 From: zebot Date: Wed, 3 Nov 2021 21:09:11 +0100 Subject: [PATCH 66/88] chore: [charts] Update webapp version (#1897) Co-authored-by: Zebot Co-authored-by: jschaul --- changelog.d/0-release-notes/webapp-upgrade | 1 + charts/webapp/values.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/0-release-notes/webapp-upgrade diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade new file mode 100644 index 00000000000..c99f65cd9f5 --- /dev/null +++ b/changelog.d/0-release-notes/webapp-upgrade @@ -0,0 +1 @@ +Upgrade webapp version to 2021-11-01-production.0-v0.28.29-0-d919633 diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index 80def916765..169a860900a 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2021-10-28-federation-M1" + tag: "2021-11-01-production.0-v0.28.29-0-d919633" service: https: externalPort: 443 From 6ba5bec5776281b8afe15af886af1602e56667cd Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 4 Nov 2021 06:28:27 +0100 Subject: [PATCH 67/88] Galley polysemy (3/5) - Access effects (#1904) * Implement Brig, Bot and Spar intra effects * Remove placeholder Intra effect * Implement GundeckAccess effect * Implement ExternalAccess effect * Implement FederatorAccess effect * Remote obsolete remote push logic in Intra.Push --- .../5-internal/polysemy-access-effects | 1 + libs/bilge/src/Bilge/IO.hs | 2 +- libs/bilge/src/Bilge/RPC.hs | 3 + services/galley/galley.cabal | 14 +- services/galley/package.yaml | 1 + services/galley/src/Galley/API/Clients.hs | 9 +- services/galley/src/Galley/API/Create.hs | 7 +- services/galley/src/Galley/API/Federation.hs | 4 +- services/galley/src/Galley/API/Internal.hs | 3 +- services/galley/src/Galley/API/LegalHold.hs | 23 +- .../src/Galley/API/LegalHold/Conflicts.hs | 9 +- services/galley/src/Galley/API/Message.hs | 44 ++-- services/galley/src/Galley/API/Teams.hs | 72 +++--- .../galley/src/Galley/API/Teams/Features.hs | 5 +- .../src/Galley/API/Teams/Notifications.hs | 4 +- services/galley/src/Galley/API/Update.hs | 93 ++++---- services/galley/src/Galley/API/Util.hs | 106 ++------- services/galley/src/Galley/App.hs | 52 +---- services/galley/src/Galley/Data/LegalHold.hs | 2 +- services/galley/src/Galley/Effects.hs | 68 +----- .../galley/src/Galley/Effects/BotAccess.hs | 26 +++ .../galley/src/Galley/Effects/BrigAccess.hs | 113 ++++++++++ .../src/Galley/Effects/ExternalAccess.hs | 38 ++++ .../src/Galley/Effects/FederatorAccess.hs | 60 +++++ .../src/Galley/Effects/FireAndForget.hs | 4 + .../src/Galley/Effects/GundeckAccess.hs | 38 ++++ .../galley/src/Galley/Effects/SparAccess.hs | 26 +++ services/galley/src/Galley/Env.hs | 42 +++- services/galley/src/Galley/External.hs | 58 +++-- .../src/Galley/External/LegalHoldService.hs | 18 +- .../Galley/External/LegalHoldService/Types.hs | 36 +++ services/galley/src/Galley/Intra/Client.hs | 61 ++--- services/galley/src/Galley/Intra/Effects.hs | 95 ++++++++ services/galley/src/Galley/Intra/Federator.hs | 74 ++++++ .../src/Galley/Intra/Federator/Types.hs | 54 +++++ services/galley/src/Galley/Intra/Push.hs | 213 +----------------- .../galley/src/Galley/Intra/Push/Internal.hs | 168 ++++++++++++++ services/galley/src/Galley/Intra/Spar.hs | 15 +- services/galley/src/Galley/Intra/Team.hs | 11 +- services/galley/src/Galley/Intra/User.hs | 112 ++++----- services/galley/src/Galley/Intra/Util.hs | 126 ++++++++--- 41 files changed, 1182 insertions(+), 728 deletions(-) create mode 100644 changelog.d/5-internal/polysemy-access-effects create mode 100644 services/galley/src/Galley/Effects/BotAccess.hs create mode 100644 services/galley/src/Galley/Effects/BrigAccess.hs create mode 100644 services/galley/src/Galley/Effects/ExternalAccess.hs create mode 100644 services/galley/src/Galley/Effects/FederatorAccess.hs create mode 100644 services/galley/src/Galley/Effects/GundeckAccess.hs create mode 100644 services/galley/src/Galley/Effects/SparAccess.hs create mode 100644 services/galley/src/Galley/External/LegalHoldService/Types.hs create mode 100644 services/galley/src/Galley/Intra/Effects.hs create mode 100644 services/galley/src/Galley/Intra/Federator.hs create mode 100644 services/galley/src/Galley/Intra/Federator/Types.hs create mode 100644 services/galley/src/Galley/Intra/Push/Internal.hs diff --git a/changelog.d/5-internal/polysemy-access-effects b/changelog.d/5-internal/polysemy-access-effects new file mode 100644 index 00000000000..ac3addb66f7 --- /dev/null +++ b/changelog.d/5-internal/polysemy-access-effects @@ -0,0 +1 @@ +Turn placeholder access effects into actual Polysemy effects. diff --git a/libs/bilge/src/Bilge/IO.hs b/libs/bilge/src/Bilge/IO.hs index b5d12a05cb0..9166df1bd79 100644 --- a/libs/bilge/src/Bilge/IO.hs +++ b/libs/bilge/src/Bilge/IO.hs @@ -91,7 +91,7 @@ data Debug Full deriving (Eq, Ord, Show, Enum) -type Http a = HttpT IO a +type Http = HttpT IO newtype HttpT m a = HttpT { unwrap :: ReaderT Manager m a diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index 04cb232ec31..8e91f0880f4 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -45,6 +45,9 @@ import System.Logger.Class class HasRequestId m where getRequestId :: m RequestId +instance Monad m => HasRequestId (ReaderT RequestId m) where + getRequestId = ask + data RPCException = RPCException { rpceRemote :: !LText, rpceRequest :: !Request, diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 37905a23de0..9110d9df696 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 1b185cc3a9afe5d7a6c21c93d6c031963a5eb924885b6314ffc92ce96c6b545d +-- hash: aaed6006a10580d11a903fa32d0d6d09234867ab992f293833616eb68c7071bb name: galley version: 0.83.0 @@ -71,23 +71,34 @@ library Galley.Data.TeamNotifications Galley.Data.Types Galley.Effects + Galley.Effects.BotAccess + Galley.Effects.BrigAccess Galley.Effects.ClientStore Galley.Effects.CodeStore Galley.Effects.ConversationStore + Galley.Effects.ExternalAccess + Galley.Effects.FederatorAccess Galley.Effects.FireAndForget + Galley.Effects.GundeckAccess Galley.Effects.ListItems Galley.Effects.MemberStore Galley.Effects.Paging Galley.Effects.RemoteConversationListStore Galley.Effects.ServiceStore + Galley.Effects.SparAccess Galley.Effects.TeamMemberStore Galley.Effects.TeamStore Galley.Env Galley.External Galley.External.LegalHoldService + Galley.External.LegalHoldService.Types Galley.Intra.Client + Galley.Intra.Effects + Galley.Intra.Federator + Galley.Intra.Federator.Types Galley.Intra.Journal Galley.Intra.Push + Galley.Intra.Push.Internal Galley.Intra.Spar Galley.Intra.Team Galley.Intra.User @@ -163,6 +174,7 @@ library , saml2-web-sso >=0.18 , servant , servant-client + , servant-client-core , servant-server , servant-swagger , servant-swagger-ui diff --git a/services/galley/package.yaml b/services/galley/package.yaml index ebc59277a50..a46530baf04 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -76,6 +76,7 @@ library: - retry >=0.5 - safe-exceptions >=0.1 - servant + - servant-client-core - servant-server - servant-swagger - servant-swagger-ui diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 03fc8f75e16..8d209b5765f 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -26,8 +26,8 @@ import Control.Lens (view) import Data.Id import Galley.App import Galley.Effects +import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E -import qualified Galley.Intra.Client as Intra import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) import Imports @@ -49,9 +49,10 @@ getClients :: getClients usr = do isInternal <- view $ options . optSettings . setIntraListing clts <- - if isInternal - then fromUserClients <$> Intra.lookupClients [usr] - else liftSem $ E.getClients [usr] + liftSem $ + if isInternal + then fromUserClients <$> E.lookupClients [usr] + else E.getClients [usr] return $ clientIds usr clts addClientH :: diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 3bc6e8f2ddc..39f75a97334 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -44,6 +44,7 @@ import qualified Galley.Data.Conversation as Data import Galley.Data.Conversation.Types import Galley.Effects import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.TeamStore as E import Galley.Intra.Push @@ -390,7 +391,7 @@ createLegacyConnectConversation lusr conn lrecipient j = do e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) notifyCreatedConversation Nothing (tUnqualified lusr) conn c for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> - push1 $ + liftSem . E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn @@ -431,7 +432,7 @@ createLegacyConnectConversation lusr conn lrecipient j = do t <- liftIO getCurrentTime let e = Event ConvConnect qconv (qUntagged lusr) t (EdConnect j) for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> - push1 $ + liftSem . E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn @@ -469,7 +470,7 @@ notifyCreatedConversation dtime usr conn c = do -- of being added to a conversation registerRemoteConversationMemberships now localDomain c -- Notify local users - pushSome =<< mapM (toPush localDomain now) (Data.convLocalMembers c) + liftSem . E.push =<< mapM (toPush localDomain now) (Data.convLocalMembers c) where route | Data.convType c == RegularConv = RouteAny diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index c0d81ce437e..fcadd8f1711 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -41,9 +41,9 @@ import Galley.API.Util import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Effects +import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.MemberStore as E -import Galley.Intra.User (getConnections) import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) import Galley.Types.UserList import Imports @@ -216,7 +216,7 @@ addLocalUsersToRemoteConv :: [UserId] -> Galley r (Set UserId) addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do - connStatus <- getConnections localUsers (Just [qAdder]) (Just Accepted) + connStatus <- liftSem $ E.getConnections localUsers (Just [qAdder]) (Just Accepted) let localUserIdsSet = Set.fromList localUsers connected = Set.fromList $ fmap csv2From connStatus unconnected = Set.difference localUserIdsSet connected diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2c8ad18c856..efec177340c 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -57,6 +57,7 @@ import qualified Galley.Data.Conversation as Data import Galley.Effects import Galley.Effects.ClientStore import Galley.Effects.ConversationStore +import Galley.Effects.GundeckAccess import Galley.Effects.MemberStore import Galley.Effects.Paging import Galley.Effects.TeamStore @@ -556,7 +557,7 @@ rmUser user conn = do | otherwise -> return Nothing for_ (maybeList1 (catMaybes pp)) - Intra.push + (liftSem . push) leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () leaveRemoteConversations lusr cids = do diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 92ac4bd512c..2f6d2a63c70 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -58,12 +58,11 @@ import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import qualified Galley.Data.LegalHold as LegalHoldData import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects +import Galley.Effects.BrigAccess import Galley.Effects.Paging import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore import qualified Galley.External.LegalHoldService as LHService -import qualified Galley.Intra.Client as Client -import Galley.Intra.User (getConnectionsUnqualified, putConnectionInternal) import qualified Galley.Options as Opts import Galley.Types (LocalMember, lmConvRoleName, lmId) import Galley.Types.Teams as Team @@ -255,7 +254,7 @@ removeSettings' tid = removeLHForUser :: TeamMember -> Galley r () removeLHForUser member = do let uid = member ^. Team.userId - Client.removeLegalHoldClientFromUser uid + liftSem $ removeLegalHoldClientFromUser uid LHService.removeLegalHold tid uid changeLegalholdStatus tid uid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) @@ -425,7 +424,7 @@ requestDevice zusr tid uid = do -- We don't distinguish the last key here; brig will do so when the device is added LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending - Client.notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' + liftSem $ notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) requestDeviceFromService = do @@ -500,13 +499,13 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo Log.info $ Log.msg @Text "No prekeys found" throwM noLegalHoldDeviceAllocated Just keys -> pure keys - clientId <- Client.addLegalHoldClientToUser uid connId prekeys lastPrekey' + clientId <- liftSem $ addLegalHoldClientToUser uid connId prekeys lastPrekey' -- Note: teamId could be passed in the getLegalHoldAuthToken request instead of lookup up again - -- Note: both 'Client.getLegalHoldToken' and 'ensureReAuthorized' check the password - -- Note: both 'Client.getLegalHoldToken' and this function in 'assertOnTeam' above + -- Note: both 'getLegalHoldToken' and 'ensureReAuthorized' check the password + -- Note: both 'getLegalHoldToken' and this function in 'assertOnTeam' above -- checks that the user is part of a binding team -- FUTUREWORK: reduce double checks - legalHoldAuthToken <- Client.getLegalHoldAuthToken uid mPassword + legalHoldAuthToken <- liftSem $ getLegalHoldAuthToken uid mPassword LHService.confirmLegalHold clientId tid uid legalHoldAuthToken -- TODO: send event at this point (see also: -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) @@ -585,7 +584,7 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = disableLH :: UserLegalHoldStatus -> Galley r () disableLH userLHStatus = do ensureReAuthorised zusr mPassword - Client.removeLegalHoldClientFromUser uid + liftSem $ removeLegalHoldClientFromUser uid LHService.removeLegalHold tid uid -- TODO: send event at this point (see also: related TODO in this module in -- 'approveDevice' and @@ -642,7 +641,7 @@ changeLegalholdStatus tid uid old new = do UserLegalHoldNoConsent -> noop where update = LegalHoldData.setUserLegalHoldStatus tid uid new - removeblocks = void $ putConnectionInternal (RemoveLHBlocksInvolving uid) + removeblocks = void . liftSem $ putConnectionInternal (RemoveLHBlocksInvolving uid) addblocks = do blockNonConsentingConnections uid handleGroupConvPolicyConflicts uid new @@ -656,7 +655,7 @@ blockNonConsentingConnections :: UserId -> Galley r () blockNonConsentingConnections uid = do - conns <- getConnectionsUnqualified [uid] Nothing Nothing + conns <- liftSem $ getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do conflicts <- mconcat <$> findConflicts conns blockConflicts uid conflicts @@ -677,7 +676,7 @@ blockNonConsentingConnections uid = do blockConflicts :: UserId -> [UserId] -> Galley r [String] blockConflicts _ [] = pure [] blockConflicts userLegalhold othersToBlock@(_ : _) = do - status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) + status <- liftSem $ putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] setTeamLegalholdWhitelisted :: TeamId -> Galley r () diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index e780222cbeb..11995a36faf 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -30,9 +30,8 @@ import qualified Data.Set as Set import Galley.API.Util import Galley.App import Galley.Effects +import Galley.Effects.BrigAccess import Galley.Effects.TeamStore -import qualified Galley.Intra.Client as Intra -import Galley.Intra.User (getUser) import Galley.Options import Galley.Types.Teams hiding (self) import Imports @@ -90,7 +89,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do otherUids = nub $ Map.keys . userClients $ otherClients when (nub otherUids /= [self {- if all other clients belong to us, there can be no conflict -}]) $ do - allClients :: UserClientsFull <- lift $ Intra.lookupClientsFull (nub $ self : otherUids) + allClients :: UserClientsFull <- lift . liftSem $ lookupClientsFull (nub $ self : otherUids) let selfClients :: [Client.Client] = allClients @@ -126,11 +125,11 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do . Client.clientCapabilities checkConsentMissing :: Galley r Bool - checkConsentMissing = do + checkConsentMissing = liftSem $ do -- (we could also get the profile from brig. would make the code slightly more -- concise, but not really help with the rpc back-and-forth, so, like, why?) mbUser <- accountUser <$$> getUser self - mbTeamMember <- liftSem $ join <$> for (mbUser >>= userTeam) (`getTeamMember` self) + mbTeamMember <- join <$> for (mbUser >>= userTeam) (`getTeamMember` self) let lhStatus = maybe defUserLegalHoldStatus (view legalHoldStatus) mbTeamMember pure (lhStatus == UserLegalHoldNoConsent) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 4c61f562896..4bd82de30d7 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -26,11 +26,13 @@ import Galley.API.Util import Galley.App import Galley.Data.Services as Data import Galley.Effects +import Galley.Effects.BrigAccess import Galley.Effects.ClientStore import Galley.Effects.ConversationStore +import Galley.Effects.ExternalAccess +import Galley.Effects.FederatorAccess +import Galley.Effects.GundeckAccess hiding (Push) import Galley.Effects.MemberStore -import qualified Galley.External as External -import qualified Galley.Intra.Client as Intra import Galley.Intra.Push import Galley.Options (optSettings, setIntraListing) import qualified Galley.Types.Clients as Clients @@ -41,7 +43,7 @@ import qualified System.Logger.Class as Log import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError, executeFederated) +import Wire.API.Federation.Client (FederationError) import Wire.API.Federation.Error (federationErrorToWai) import Wire.API.Message import Wire.API.Team.LegalHold @@ -182,8 +184,9 @@ getRemoteClients :: Galley r (Map (Domain, UserId) (Set ClientId)) getRemoteClients remoteMembers = -- concatenating maps is correct here, because their sets of keys are disjoint - mconcat . map tUnqualified - <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain + liftSem $ + mconcat . map tUnqualified + <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain where getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap @@ -192,18 +195,18 @@ getRemoteClients remoteMembers = postRemoteOtrMessage :: Members '[ConversationStore, FederatorAccess] r => Qualified UserId -> - Qualified ConvId -> + Remote ConvId -> LByteString -> Galley r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest - { FederatedGalley.msrConvId = qUnqualified conv, + { FederatedGalley.msrConvId = tUnqualified conv, FederatedGalley.msrSender = qUnqualified sender, FederatedGalley.msrRawMessage = Base64ByteString rawMsg } rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr - FederatedGalley.msResponse <$> runFederatedGalley (qDomain conv) rpc + liftSem $ FederatedGalley.msResponse <$> runFederated conv rpc postQualifiedOtrMessage :: Members @@ -255,10 +258,10 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- get local clients localClients <- - lift $ + lift . liftSem $ if isInternal - then Clients.fromUserClients <$> Intra.lookupClients localMemberIds - else liftSem $ getClients localMemberIds + then Clients.fromUserClients <$> lookupClients localMemberIds + else getClients localMemberIds let qualifiedLocalClients = Map.mapKeys (localDomain,) . makeUserMap (Set.fromList (map lmId localMembers)) @@ -313,7 +316,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- | Send both local and remote messages, return the set of clients for which -- sending has failed. sendMessages :: - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[BotAccess, GundeckAccess, ExternalAccess, FederatorAccess] r => UTCTime -> Qualified UserId -> ClientId -> @@ -330,7 +333,8 @@ sendMessages now sender senderClient mconn conv localMemberMap metadata messages | localDomain == dom = sendLocalMessages now sender senderClient mconn (Qualified conv localDomain) localMemberMap metadata | otherwise = - sendRemoteMessages dom now sender senderClient conv metadata + sendRemoteMessages (toRemoteUnsafe dom ()) now sender senderClient conv metadata + mkQualifiedUserClientsByDomain <$> Map.traverseWithKey send messageMap where byDomain :: Map (Domain, UserId, ClientId) a -> Map Domain (Map (UserId, ClientId) a) @@ -367,7 +371,9 @@ sendLocalMessages now sender senderClient mconn conv localMemberMap metadata loc pure mempty sendRemoteMessages :: - Domain -> + forall r x. + Member FederatorAccess r => + Remote x -> UTCTime -> Qualified UserId -> ClientId -> @@ -375,7 +381,7 @@ sendRemoteMessages :: MessageMetadata -> Map (UserId, ClientId) Text -> Galley r (Set (UserId, ClientId)) -sendRemoteMessages domain now sender senderClient conv metadata messages = handle <=< runExceptT $ do +sendRemoteMessages domain now sender senderClient conv metadata messages = (handle =<<) $ do let rcpts = foldr (\((u, c), t) -> Map.insertWith (<>) u (Map.singleton c t)) @@ -397,14 +403,14 @@ sendRemoteMessages domain now sender senderClient conv metadata messages = handl -- backend has only one domain so we just pick it from the environment. originDomain <- viewFederationDomain let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes originDomain rm - executeFederated domain rpc + liftSem $ runFederatedEither domain rpc where handle :: Either FederationError a -> Galley r (Set (UserId, ClientId)) handle (Right _) = pure mempty handle (Left e) = do Log.warn $ Log.field "conversation" (toByteString' conv) - Log.~~ Log.field "domain" (toByteString' domain) + Log.~~ Log.field "domain" (toByteString' (tDomain domain)) Log.~~ Log.field "exception" (encode (federationErrorToWai e)) Log.~~ Log.msg ("Remote message sending failed" :: Text) pure (Map.keysSet messages) @@ -444,7 +450,7 @@ runMessagePush :: MessagePush -> Galley r () runMessagePush cnv mp = do - pushSome (userPushes mp) + liftSem $ push (userPushes mp) pushToBots (botPushes mp) where pushToBots :: [(BotMember, Event)] -> Galley r () @@ -453,7 +459,7 @@ runMessagePush cnv mp = do if localDomain /= qDomain cnv then unless (null pushes) $ do Log.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show cnv) - else External.deliverAndDeleteAsync (qUnqualified cnv) pushes + else liftSem $ deliverAndDeleteAsync (qUnqualified cnv) pushes newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event newMessageEvent convId sender senderClient dat time receiverClient cipherText = diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 4b899c4e36e..8c32af600cd 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -94,18 +94,18 @@ import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects +import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.ExternalAccess as E +import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.Paging as E +import qualified Galley.Effects.SparAccess as Spar import qualified Galley.Effects.TeamMemberStore as E import qualified Galley.Effects.TeamStore as E -import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push -import qualified Galley.Intra.Spar as Spar -import qualified Galley.Intra.Team as BrigTeam -import Galley.Intra.User import Galley.Options import qualified Galley.Options as Opts import qualified Galley.Queue as Q @@ -269,7 +269,7 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do -- When teams are created, they are activated immediately. In this situation, Brig will -- most likely report team size as 0 due to ES taking some time to index the team creator. -- This is also very difficult to test, so is not tested. - (TeamSize possiblyStaleSize) <- BrigTeam.getSize tid + (TeamSize possiblyStaleSize) <- liftSem $ E.getSize tid let size = if possiblyStaleSize == 0 then 1 @@ -313,7 +313,7 @@ updateTeam zusr zcon tid updateData = do memList <- getTeamMembersForFanout tid let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) - push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon + liftSem . E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: Members '[BrigAccess, TeamStore] r => @@ -379,7 +379,7 @@ uncheckedDeleteTeam :: uncheckedDeleteTeam zusr zcon tid = do team <- liftSem $ E.getTeam tid when (isJust team) $ do - Spar.deleteTeam tid + liftSem $ Spar.deleteTeam tid now <- liftIO getCurrentTime convs <- liftSem $ @@ -393,12 +393,12 @@ uncheckedDeleteTeam zusr zcon tid = do (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue - External.deliverAsync be + liftSem $ E.deliverAsync be -- TODO: we don't delete bots here, but we should do that, since -- every bot user can only be in a single conversation. Just -- deleting conversations from the database is not enough. when ((view teamBinding . tdTeam <$> team) == Just Binding) $ do - mapM_ (deleteUser . view userId) membs + liftSem $ mapM_ (E.deleteUser . view userId) membs Journal.teamDelete tid Data.unsetTeamLegalholdWhitelisted tid liftSem $ E.deleteTeam tid @@ -410,16 +410,18 @@ uncheckedDeleteTeam zusr zcon tid = do -- To avoid DoS on gundeck, send team deletion events in chunks let chunkSize = fromMaybe defConcurrentDeletionEvents (o ^. setConcurrentDeletionEvents) let chunks = List.chunksOf chunkSize (toList r) - forM_ chunks $ \chunk -> case chunk of - [] -> return () - -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the - -- push module to never fan this out to more than the limit - x : xs -> push1 (newPushLocal1 ListComplete zusr (TeamEvent e) (list1 x xs) & pushConn .~ zcon) + liftSem $ + forM_ chunks $ \chunk -> case chunk of + [] -> return () + -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the + -- push module to never fan this out to more than the limit + x : xs -> E.push1 (newPushLocal1 ListComplete zusr (TeamEvent e) (list1 x xs) & pushConn .~ zcon) -- To avoid DoS on gundeck, send conversation deletion events slowly + -- FUTUREWORK: make this behaviour part of the GundeckAccess effect let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis (o ^. setDeleteConvThrottleMillis)) forM_ ue $ \event -> do -- push ConversationDelete events - push1 event + liftSem $ E.push1 event threadDelay delay createConvDeleteEvents :: UTCTime -> @@ -509,8 +511,12 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do E.withChunks pager $ \members -> do inviters <- lookupInviterHandle members - users <- lookupUser <$> lookupActivatedUsers (fmap (view userId) members) - richInfos <- lookupRichInfo <$> getRichInfoMultiUser (fmap (view userId) members) + users <- + liftSem $ + lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) + richInfos <- + liftSem $ + lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) liftIO $ do writeString ( encodeDefaultOrderedByNameWith @@ -564,7 +570,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do let inviterIds :: [UserId] inviterIds = nub $ catMaybes $ fmap fst . view invitation <$> members - userList :: [User] <- accountUser <$$> getUsers inviterIds + userList :: [User] <- liftSem $ accountUser <$$> E.getUsers inviterIds let userMap :: M.Map UserId Handle.Handle userMap = M.fromList . catMaybes $ extract <$> userList @@ -710,7 +716,7 @@ addTeamMember zusr zcon tid nmem = do ensureNonBindingTeam tid ensureUnboundUsers [uid] ensureConnectedToLocals zusr [uid] - (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid + (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) memList <- getTeamMembersForFanout tid void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList @@ -732,7 +738,7 @@ uncheckedAddTeamMember :: Galley r () uncheckedAddTeamMember tid nmem = do mems <- getTeamMembersForFanout tid - (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid + (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem mems billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) @@ -800,7 +806,7 @@ updateTeamMember zusr zcon tid targetMember = do updateJournal :: Team -> TeamMemberList -> Galley r () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do - (TeamSize size) <- BrigTeam.getSize tid + (TeamSize size) <- liftSem $ E.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds @@ -816,7 +822,7 @@ updateTeamMember zusr zcon tid targetMember = do let ePriv = newEvent MemberUpdate tid now & eventData ?~ privilegedUpdate -- push to all members (user is privileged) let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients - for_ pushPriv $ \p -> push1 $ p & pushConn .~ Just zcon + liftSem $ for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon deleteTeamMemberH :: Members @@ -874,7 +880,7 @@ deleteTeamMember zusr zcon tid remove mBody = do then do body <- mBody & ifNothing (invalidPayload "missing request body") ensureReAuthorised zusr (body ^. tmdAuthPassword) - (TeamSize sizeBeforeDelete) <- BrigTeam.getSize tid + (TeamSize sizeBeforeDelete) <- liftSem $ E.getSize tid -- TeamSize is 'Natural' and subtracting from 0 is an error -- TeamSize could be reported as 0 if team members are added and removed very quickly, -- which happens in tests @@ -882,7 +888,7 @@ deleteTeamMember zusr zcon tid remove mBody = do if sizeBeforeDelete == 0 then 0 else sizeBeforeDelete - 1 - deleteUser remove + liftSem $ E.deleteUser remove billingUsers <- Journal.getBillingUserIds tid (Just mems) Journal.teamUpdate tid sizeAfterDelete $ filter (/= remove) billingUsers pure TeamMemberDeleteAccepted @@ -919,7 +925,8 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData ?~ EdMemberLeave remove let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) - push1 $ newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon + liftSem . E.push1 $ + newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley r () removeFromConvsAndPushConvLeaveEvent now = do @@ -946,8 +953,8 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do let x = filter (\m -> not (Conv.lmId m `Set.member` exceptTo)) users let y = Conv.Event Conv.MemberLeave qconvId qusr now edata for_ (newPushLocal (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> - push1 $ p & pushConn .~ zcon - External.deliverAsync (bots `zip` repeat y) + liftSem . E.push1 $ p & pushConn .~ zcon + liftSem $ E.deliverAsync (bots `zip` repeat y) getTeamConversations :: Member TeamStore r => @@ -1081,7 +1088,7 @@ ensureNotElevated targetPermissions member = ensureNotTooLarge :: Member BrigAccess r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options - (TeamSize size) <- BrigTeam.getSize tid + (TeamSize size) <- liftSem $ E.getSize tid unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ throwM tooManyTeamMembers return $ TeamSize size @@ -1103,7 +1110,7 @@ ensureNotTooLargeForLegalHold tid teamSize = do ensureNotTooLargeToActivateLegalHold :: Members '[BrigAccess] r => TeamId -> Galley r () ensureNotTooLargeToActivateLegalHold tid = do - (TeamSize teamSize) <- BrigTeam.getSize tid + (TeamSize teamSize) <- liftSem $ E.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do throwM cannotEnableLegalHoldServiceLargeTeam @@ -1139,7 +1146,8 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi luid <- qualifyLocal (new ^. userId) liftSem $ E.createMember lcid luid let e = newEvent MemberJoin tid now & eventData ?~ EdMemberJoin (new ^. userId) - push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn + liftSem . E.push1 $ + newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn APITeamQueue.pushTeamEvent tid e return sizeBeforeAdd where @@ -1195,7 +1203,7 @@ finishCreateTeam team owner others zcon = do now <- liftIO getCurrentTime let e = newEvent TeamCreate (team ^. teamId) now & eventData ?~ EdTeamCreate team let r = membersToRecipients Nothing others - push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon + liftSem . E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon withBindingTeam :: Member TeamStore r => UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do @@ -1226,7 +1234,7 @@ canUserJoinTeam :: Member BrigAccess r => TeamId -> Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do - (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid + (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 8122a7059db..f3dcd404483 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -63,9 +63,10 @@ import Galley.Cassandra.Paging import qualified Galley.Data.SearchVisibility as SearchVisibilityData import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects +import Galley.Effects.GundeckAccess import Galley.Effects.Paging import Galley.Effects.TeamStore -import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush, push1) +import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush) import Galley.Options import Galley.Types.Teams hiding (newTeam) import Imports @@ -459,7 +460,7 @@ pushFeatureConfigEvent tid event = do let recipients = membersToRecipients Nothing (memList ^. teamMembers) for_ (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - push1 + (liftSem . push1) -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 08edac5eb25..d37e42a64b0 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -52,7 +52,7 @@ import Galley.API.Error import Galley.App import qualified Galley.Data.TeamNotifications as DataTeamQueue import Galley.Effects -import Galley.Intra.User as Intra +import Galley.Effects.BrigAccess as Intra import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification import Imports @@ -67,7 +67,7 @@ getTeamNotifications :: Galley r QueuedNotificationList getTeamNotifications zusr since size = do tid :: TeamId <- do - mtid <- (userTeam . accountUser =<<) <$> Intra.getUser zusr + mtid <- liftSem $ (userTeam . accountUser =<<) <$> Intra.getUser zusr let err = throwM teamNotFound maybe err pure mtid page <- DataTeamQueue.fetch tid since size diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index be63e45d5ea..43190d9d830 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -98,15 +98,17 @@ import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) import Galley.Effects +import qualified Galley.Effects.BotAccess as E +import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E import qualified Galley.Effects.CodeStore as E import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.ExternalAccess as E +import qualified Galley.Effects.FederatorAccess as E +import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.TeamStore as E -import qualified Galley.External as External -import qualified Galley.Intra.Client as Intra import Galley.Intra.Push -import Galley.Intra.User (deleteBot, getContactList, lookupActivatedUsers) import Galley.Options import Galley.Types import Galley.Types.Bot hiding (addBot) @@ -301,16 +303,16 @@ performAccessUpdateAction qusr conv target = do liftSem $ E.deleteCode key ReusableCode -- Determine bots and members to be removed - let filterBotsAndMembers = filterActivated >=> (liftSem . filterTeammates) + let filterBotsAndMembers = filterActivated >=> filterTeammates let current = convBotsAndMembers conv -- initial bots and members - desired <- lift $ filterBotsAndMembers current -- desired bots and members + desired <- lift . liftSem $ filterBotsAndMembers current -- desired bots and members let toRemove = bmDiff current desired -- bots and members to be removed -- Update Cassandra lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) target lift . fireAndForget $ do -- Remove bots - traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) + traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) -- Update current bots and members let current' = current {bmBots = bmBots desired} @@ -321,12 +323,12 @@ performAccessUpdateAction qusr conv target = do void . runMaybeT $ performAction qusr conv action notifyConversationMetadataUpdate qusr Nothing lcnv current' action where - filterActivated :: BotsAndMembers -> Galley r BotsAndMembers + filterActivated :: BotsAndMembers -> Sem r BotsAndMembers filterActivated bm | ( Data.convAccessRole conv > ActivatedAccessRole && cupAccessRole target <= ActivatedAccessRole ) = do - activated <- map User.userId <$> lookupActivatedUsers (toList (bmLocals bm)) + activated <- map User.userId <$> E.lookupActivatedUsers (toList (bmLocals bm)) -- FUTUREWORK: should we also remove non-activated remote users? pure $ bm {bmLocals = Set.fromList activated} | otherwise = pure bm @@ -1028,10 +1030,10 @@ removeMemberFromRemoteConv :: Maybe ConnId -> Qualified UserId -> Galley r RemoveFromConversationResponse -removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim +removeMemberFromRemoteConv cnv lusr _ victim | qUntagged lusr == victim = do - let lc = FederatedGalley.LeaveConversationRequest (qUnqualified qcnv) (qUnqualified victim) + let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = FederatedGalley.leaveConversation FederatedGalley.clientRoutes @@ -1039,9 +1041,11 @@ removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim lc t <- liftIO getCurrentTime let successEvent = - Event MemberLeave qcnv (qUntagged lusr) t $ + Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ EdMembersLeave (QualifiedUserIdList [victim]) - mapRight (const successEvent) . FederatedGalley.leaveResponse <$> runFederated (qDomain qcnv) rpc + liftSem $ + mapRight (const successEvent) . FederatedGalley.leaveResponse + <$> E.runFederated cnv rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed performRemoveMemberAction :: @@ -1147,11 +1151,12 @@ postProteusMessage :: RawProto Public.QualifiedNewOtrMessage -> Galley r (Public.PostOtrResponse Public.MessageSendingStatus) postProteusMessage zusr zcon conv msg = do - localDomain <- viewFederationDomain - let sender = Qualified zusr localDomain - if localDomain /= qDomain conv - then postRemoteOtrMessage sender conv (rpRaw msg) - else postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) + sender <- qualifyLocal zusr + foldQualified + sender + (\c -> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) (tUnqualified c) (rpValue msg)) + (\c -> postRemoteOtrMessage (qUntagged sender) c (rpRaw msg)) + conv postOtrMessageUnqualified :: Members @@ -1252,7 +1257,7 @@ postNewOtrBroadcast usr con val msg = do now <- liftIO getCurrentTime withValidOtrBroadcastRecipients usr sender recvrs val now $ \rs -> do let (_, toUsers) = foldr (newMessage qusr con Nothing msg now) ([], []) rs - pushSome (catMaybes toUsers) + liftSem $ E.push (catMaybes toUsers) postNewOtrMessage :: Members @@ -1280,10 +1285,10 @@ postNewOtrMessage utype usr con cnv val msg = do sender = newOtrSender msg recvrs = newOtrRecipients msg now <- liftIO getCurrentTime - withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> do + withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> liftSem $ do let (toBots, toUsers) = foldr (newMessage qusr con (Just qcnv) msg now) ([], []) rs - pushSome (catMaybes toUsers) - External.deliverAndDeleteAsync cnv toBots + E.push (catMaybes toUsers) + E.deliverAndDeleteAsync cnv toBots newMessage :: Qualified UserId -> @@ -1387,9 +1392,10 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d let e = conversationActionToEvent now quid qcnv action -- notify remote participants - runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ - FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action + liftSem $ + E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ + FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action -- notify local participants and bots pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e @@ -1420,7 +1426,7 @@ isTyping zusr zcon cnv typingData = do now <- liftIO getCurrentTime let e = Event Typing qcnv qusr now (EdTyping typingData) for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> mm)) $ \p -> - push1 $ + liftSem . E.push1 $ p & pushConn ?~ zcon & pushRoute .~ RouteDirect @@ -1493,8 +1499,8 @@ addBot zusr zcon b = do ) ) for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> - push1 $ p & pushConn ?~ zcon - External.deliverAsync ((bm : bots) `zip` repeat e) + liftSem . E.push1 $ p & pushConn ?~ zcon + liftSem $ E.deliverAsync ((bm : bots) `zip` repeat e) pure e where regularConvChecks lusr c = do @@ -1541,14 +1547,15 @@ rmBot zusr zcon b = do then pure Unchanged else do t <- liftIO getCurrentTime - let evd = EdMembersLeave (QualifiedUserIdList [Qualified (botUserId (b ^. rmBotId)) localDomain]) - let e = Event MemberLeave qcnv qusr t evd - for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> - push1 $ p & pushConn .~ zcon - liftSem $ E.deleteMembers (Data.convId c) (UserList [botUserId (b ^. rmBotId)] []) - liftSem $ E.deleteClients (botUserId (b ^. rmBotId)) - External.deliverAsync (bots `zip` repeat e) - pure $ Updated e + liftSem $ do + let evd = EdMembersLeave (QualifiedUserIdList [Qualified (botUserId (b ^. rmBotId)) localDomain]) + let e = Event MemberLeave qcnv qusr t evd + for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> + E.push1 $ p & pushConn .~ zcon + E.deleteMembers (Data.convId c) (UserList [botUserId (b ^. rmBotId)] []) + E.deleteClients (botUserId (b ^. rmBotId)) + E.deliverAsync (bots `zip` repeat e) + pure $ Updated e ------------------------------------------------------------------------------- -- Helpers @@ -1601,13 +1608,14 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ fmap (view userId) <$> case val of OtrReportMissing us -> maybeFetchLimitedTeamMemberList limit tid us _ -> maybeFetchAllMembersInTeam tid - contacts <- getContactList usr + contacts <- liftSem $ E.getContactList usr let users = Set.toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) isInternal <- view $ options . optSettings . setIntraListing clts <- - if isInternal - then Clients.fromUserClients <$> Intra.lookupClients users - else liftSem $ E.getClients users + liftSem $ + if isInternal + then Clients.fromUserClients <$> E.lookupClients users + else E.getClients users let membs = newMember <$> users handleOtrResponse User usr clt rcps membs clts val now go where @@ -1647,9 +1655,10 @@ withValidOtrRecipients utype usr clt cnv rcps val now go = do let localMemberIds = lmId <$> localMembers isInternal <- view $ options . optSettings . setIntraListing clts <- - if isInternal - then Clients.fromUserClients <$> Intra.lookupClients localMemberIds - else liftSem $ E.getClients localMemberIds + liftSem $ + if isInternal + then Clients.fromUserClients <$> E.lookupClients localMemberIds + else E.getClients localMemberIds handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index a95e26c0452..17c8a474154 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. @@ -45,13 +46,15 @@ import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes import Galley.Effects +import Galley.Effects.BrigAccess import Galley.Effects.CodeStore import Galley.Effects.ConversationStore +import Galley.Effects.ExternalAccess +import Galley.Effects.FederatorAccess +import Galley.Effects.GundeckAccess import Galley.Effects.MemberStore import Galley.Effects.TeamStore -import qualified Galley.External as External import Galley.Intra.Push -import Galley.Intra.User import Galley.Options (optSettings, setFeatureFlags, setFederationDomain) import Galley.Types import Galley.Types.Conversations.Members (localMemberToOther, remoteMemberToOther) @@ -63,16 +66,11 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) import Network.Wai.Utilities -import UnliftIO.Async (concurrently, pooledForConcurrentlyN) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription -import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationClientFailure, FederatorClient, executeFederated) -import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) -import Wire.API.Federation.GRPC.Types (Component (..)) -import qualified Wire.API.User as User +import Wire.API.Federation.Error (federationNotImplemented) type JSON = Media "application" "json" @@ -83,7 +81,7 @@ ensureAccessRole role users = case role of when (any (isNothing . snd) users) $ throwErrorDescriptionType @NotATeamMember ActivatedAccessRole -> do - activated <- lookupActivatedUsers $ map fst users + activated <- liftSem $ lookupActivatedUsers $ map fst users when (length activated /= length users) $ throwErrorDescriptionType @ConvAccessDenied NonActivatedAccessRole -> return () @@ -122,23 +120,25 @@ ensureConnected self others = do ensureConnectedToLocals :: Member BrigAccess r => UserId -> [UserId] -> Galley r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = liftGalley0 $ do +ensureConnectedToLocals u uids = do (connsFrom, connsTo) <- - getConnectionsUnqualified0 [u] (Just uids) (Just Accepted) - `concurrently` getConnectionsUnqualified0 uids (Just [u]) (Just Accepted) + liftSem $ + getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ throwErrorDescriptionType @NotConnected ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () ensureConnectedToRemotes _ [] = pure () ensureConnectedToRemotes u remotes = do - acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) + acceptedConns <- + liftSem $ + getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ throwErrorDescriptionType @NotConnected ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () ensureReAuthorised u secret = do - reAuthed <- reAuthUser u (ReAuthUser secret) + reAuthed <- liftSem $ reauthUser u (ReAuthUser secret) unless reAuthed $ throwM reAuthFailed @@ -296,7 +296,7 @@ acceptOne2One usr conv conn = do conv' <- if isJust (find ((usr /=) . lmId) mems) then liftSem promote else pure conv let mems' = mems <> toList mm for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> - push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect + liftSem $ push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect return $ conv' {Data.convLocalMembers = mems'} _ -> throwM $ invalidOp "accept: invalid conversation type" where @@ -582,8 +582,8 @@ pushConversationEvent :: pushConversationEvent conn e users bots = do localDomain <- viewFederationDomain for_ (newConversationEventPush localDomain e (toList users)) $ \p -> - push1 $ p & set pushConn conn - External.deliverAsync (toList bots `zip` repeat e) + liftSem $ push1 $ p & set pushConn conn + liftSem $ deliverAsync (toList bots `zip` repeat e) verifyReusableCode :: Member CodeStore r => @@ -628,76 +628,6 @@ viewFederationDomain = view (options . optSettings . setFederationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a -checkRemoteUsersExist :: - (Member FederatorAccess r, Functor f, Foldable f) => - f (Remote UserId) -> - Galley r () -checkRemoteUsersExist = - -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain - traverse_ checkRemotesFor . bucketRemote - -checkRemotesFor :: Member FederatorAccess r => Remote [UserId] -> Galley r () -checkRemotesFor (qUntagged -> Qualified uids domain) = do - let rpc = FederatedBrig.getUsersByIds FederatedBrig.clientRoutes uids - users <- runFederatedBrig domain rpc - let uids' = - map - (qUnqualified . User.profileQualifiedId) - (filter (not . User.profileDeleted) users) - unless (Set.fromList uids == Set.fromList uids') $ - throwM unknownRemoteUser - -type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley0) a - -runFederated0 :: - forall (c :: Component) a. - Domain -> - FederatedGalleyRPC c a -> - Galley0 a -runFederated0 remoteDomain rpc = do - runExceptT (executeFederated remoteDomain rpc) - >>= either (throwM . federationErrorToWai) pure - -runFederatedGalley :: - Member FederatorAccess r => - Domain -> - FederatedGalleyRPC 'Galley a -> - Galley r a -runFederatedGalley = runFederated - -runFederatedBrig :: - Member FederatorAccess r => - Domain -> - FederatedGalleyRPC 'Brig a -> - Galley r a -runFederatedBrig = runFederated - -runFederated :: - forall (c :: Component) r a. - Member FederatorAccess r => - Domain -> - FederatedGalleyRPC c a -> - Galley r a -runFederated remoteDomain = liftGalley0 . runFederated0 remoteDomain - -runFederatedConcurrently :: - Member FederatorAccess r => - (Foldable f, Functor f) => - f (Remote a) -> - (Remote [a] -> FederatedGalleyRPC c b) -> - Galley r [Remote b] -runFederatedConcurrently xs rpc = liftGalley0 $ - pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> - qualifyAs r <$> runFederated0 (tDomain r) (rpc r) - -runFederatedConcurrently_ :: - Member FederatorAccess r => - (Foldable f, Functor f) => - f (Remote a) -> - (Remote [a] -> FederatedGalleyRPC c ()) -> - Galley r () -runFederatedConcurrently_ xs = void . runFederatedConcurrently xs - -- | Convert an internal conversation representation 'Data.Conversation' to -- 'NewRemoteConversation' to be sent over the wire to a remote backend that will -- reconstruct this into multiple public-facing @@ -807,7 +737,7 @@ registerRemoteConversationMemberships :: Domain -> Data.Conversation -> Galley r () -registerRemoteConversationMemberships now localDomain c = do +registerRemoteConversationMemberships now localDomain c = liftSem $ do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c runFederatedConcurrently_ allRemoteMembers $ \_ -> diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index ad7436253e8..cc0dfcd04b2 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -50,7 +50,6 @@ module Galley.App fromJsonBody, fromOptionalJsonBody, fromProtoBody, - initExtEnv, fanoutLimit, currentFanoutLimit, @@ -95,8 +94,12 @@ import Galley.Cassandra.ConversationList import Galley.Cassandra.Services import Galley.Cassandra.Team import Galley.Effects +import Galley.Effects.FireAndForget (interpretFireAndForget) import qualified Galley.Effects.FireAndForget as E import Galley.Env +import Galley.External +import Galley.Intra.Effects +import Galley.Intra.Federator import Galley.Options import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams @@ -110,7 +113,6 @@ import Network.Wai import Network.Wai.Utilities hiding (Error) import qualified Network.Wai.Utilities as WaiError import qualified Network.Wai.Utilities.Server as Server -import OpenSSL.EVP.Digest (getDigestByName) import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl import Polysemy @@ -169,12 +171,6 @@ instance HasFederatorConfig (Galley r) where fanoutLimit :: Galley r (Range 1 Teams.HardTruncationLimit Int32) fanoutLimit = view options >>= return . currentFanoutLimit -currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 -currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. optSettings ^. setMaxFanoutSize) - let maxTeamSize = fromIntegral (o ^. optSettings ^. setMaxTeamSize) - unsafeRange (min maxTeamSize optFanoutLimit) - -- Define some invariants for the options used validateOptions :: Logger -> Opts -> IO () validateOptions l o = do @@ -256,29 +252,6 @@ initHttpManager o = do managerIdleConnectionCount = 3 * (o ^. optSettings . setHttpPoolSize) } --- TODO: somewhat duplicates Brig.App.initExtGetManager -initExtEnv :: IO ExtEnv -initExtEnv = do - ctx <- Ssl.context - Ssl.contextSetVerificationMode ctx Ssl.VerifyNone - Ssl.contextAddOption ctx SSL_OP_NO_SSLv2 - Ssl.contextAddOption ctx SSL_OP_NO_SSLv3 - Ssl.contextAddOption ctx SSL_OP_NO_TLSv1 - Ssl.contextSetCiphers ctx rsaCiphers - Ssl.contextLoadSystemCerts ctx - mgr <- - newManager - (opensslManagerSettings (pure ctx)) - { managerResponseTimeout = responseTimeoutMicro 10000000, - managerConnCount = 100 - } - Just sha <- getDigestByName "SHA256" - return $ ExtEnv (mgr, mkVerify sha) - where - mkVerify sha fprs = - let pinset = map toByteString' fprs - in verifyRsaFingerprint sha pinset - runGalley :: Env -> Request -> Galley GalleyEffects a -> IO a runGalley e r m = let e' = reqId .~ lookupReqId r $ e @@ -306,10 +279,6 @@ evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -reqIdMsg :: RequestId -> Logger.Msg -> Logger.Msg -reqIdMsg = ("request" .=) . unRequestId -{-# INLINE reqIdMsg #-} - fromJsonBody :: FromJSON a => JsonRequest a -> Galley r a fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} @@ -370,13 +339,12 @@ interpretGalleyToGalley0 = . interpretCodeStoreToCassandra . interpretClientStoreToCassandra . interpretFireAndForget - . interpretIntra - . interpretBot - . interpretFederator - . interpretExternal - . interpretSpar - . interpretGundeck - . interpretBrig + . interpretBotAccess + . interpretFederatorAccess + . interpretExternalAccess + . interpretSparAccess + . interpretGundeckAccess + . interpretBrigAccess . unGalley ---------------------------------------------------------------------------------- diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Data/LegalHold.hs index 62171d21ed1..052bc064219 100644 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ b/services/galley/src/Galley/Data/LegalHold.hs @@ -36,10 +36,10 @@ import Cassandra import Control.Lens (unsnoc, view) import Data.Id import Data.LegalHold -import Galley.App (Env, options) import qualified Galley.Cassandra.LegalHold as C import Galley.Data.Instances () import Galley.Data.Queries as Q +import Galley.Env import qualified Galley.Options as Opts import Galley.Types.Teams (flagLegalHold) import Imports diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 4830b635e72..4058b1ea44b 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -19,37 +19,18 @@ module Galley.Effects ( -- * Effects needed in Galley GalleyEffects1, - -- * Internal services - Intra, - interpretIntra, - - -- * Brig + -- * Effects to access the Intra API + BotAccess, BrigAccess, - interpretBrig, - - -- * Federator FederatorAccess, - interpretFederator, - - -- * Spar - SparAccess, - interpretSpar, - - -- * Gundeck GundeckAccess, - interpretGundeck, + SparAccess, -- * External services ExternalAccess, - interpretExternal, - - -- * Bot API - BotAccess, - interpretBot, -- * Fire-and-forget async FireAndForget, - interpretFireAndForget, -- * Store effects ClientStore, @@ -72,53 +53,23 @@ where import Data.Id import Data.Qualified import Galley.Cassandra.Paging +import Galley.Effects.BotAccess +import Galley.Effects.BrigAccess import Galley.Effects.ClientStore import Galley.Effects.CodeStore import Galley.Effects.ConversationStore +import Galley.Effects.ExternalAccess +import Galley.Effects.FederatorAccess import Galley.Effects.FireAndForget +import Galley.Effects.GundeckAccess import Galley.Effects.ListItems import Galley.Effects.MemberStore import Galley.Effects.ServiceStore +import Galley.Effects.SparAccess import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore -import Imports import Polysemy -data Intra m a - -interpretIntra :: Sem (Intra ': r) a -> Sem r a -interpretIntra = interpret $ \case - -data BrigAccess m a - -interpretBrig :: Sem (BrigAccess ': r) a -> Sem r a -interpretBrig = interpret $ \case - -data GundeckAccess m a - -interpretGundeck :: Sem (GundeckAccess ': r) a -> Sem r a -interpretGundeck = interpret $ \case - -data ExternalAccess m a - -interpretExternal :: Sem (ExternalAccess ': r) a -> Sem r a -interpretExternal = interpret $ \case - -data FederatorAccess m a - -interpretFederator :: Sem (FederatorAccess ': r) a -> Sem r a -interpretFederator = interpret $ \case - -data SparAccess m a - -interpretSpar :: Sem (SparAccess ': r) a -> Sem r a -interpretSpar = interpret $ \case - -data BotAccess m a - -interpretBot :: Sem (BotAccess ': r) a -> Sem r a -interpretBot = interpret $ \case - -- All the possible high-level effects. type GalleyEffects1 = '[ BrigAccess, @@ -127,7 +78,6 @@ type GalleyEffects1 = ExternalAccess, FederatorAccess, BotAccess, - Intra, FireAndForget, ClientStore, CodeStore, diff --git a/services/galley/src/Galley/Effects/BotAccess.hs b/services/galley/src/Galley/Effects/BotAccess.hs new file mode 100644 index 00000000000..819fde49082 --- /dev/null +++ b/services/galley/src/Galley/Effects/BotAccess.hs @@ -0,0 +1,26 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.BotAccess where + +import Data.Id +import Polysemy + +data BotAccess m a where + DeleteBot :: ConvId -> BotId -> BotAccess m () + +makeSem ''BotAccess diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs new file mode 100644 index 00000000000..5741e3b8b15 --- /dev/null +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -0,0 +1,113 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.BrigAccess + ( -- * Brig access effect + BrigAccess (..), + + -- * Connections + getConnectionsUnqualified, + getConnectionsUnqualifiedBidi, + getConnections, + putConnectionInternal, + + -- * Users + reauthUser, + lookupActivatedUsers, + getUser, + getUsers, + deleteUser, + getContactList, + getRichInfoMultiUser, + + -- * Teams + getSize, + + -- * Clients + lookupClients, + lookupClientsFull, + notifyClientsAboutLegalHoldRequest, + getLegalHoldAuthToken, + addLegalHoldClientToUser, + removeLegalHoldClientFromUser, + ) +where + +import Brig.Types.Client +import Brig.Types.Connection +import Brig.Types.Intra +import Brig.Types.User +import Data.Id +import Data.Misc +import Data.Qualified +import Galley.External.LegalHoldService.Types +import Imports +import Network.HTTP.Types.Status +import Polysemy +import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Team.Size +import Wire.API.User.Client +import Wire.API.User.RichInfo + +data BrigAccess m a where + GetConnectionsUnqualified :: + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + BrigAccess m [ConnectionStatus] + GetConnectionsUnqualifiedBidi :: + [UserId] -> + [UserId] -> + Maybe Relation -> + Maybe Relation -> + BrigAccess m ([ConnectionStatus], [ConnectionStatus]) + GetConnections :: + [UserId] -> + Maybe [Qualified UserId] -> + Maybe Relation -> + BrigAccess m [ConnectionStatusV2] + PutConnectionInternal :: UpdateConnectionsInternal -> BrigAccess m Status + ReauthUser :: UserId -> ReAuthUser -> BrigAccess m Bool + LookupActivatedUsers :: [UserId] -> BrigAccess m [User] + GetUsers :: [UserId] -> BrigAccess m [UserAccount] + DeleteUser :: UserId -> BrigAccess m () + GetContactList :: UserId -> BrigAccess m [UserId] + GetRichInfoMultiUser :: [UserId] -> BrigAccess m [(UserId, RichInfo)] + GetSize :: TeamId -> BrigAccess m TeamSize + LookupClients :: [UserId] -> BrigAccess m UserClients + LookupClientsFull :: [UserId] -> BrigAccess m UserClientsFull + NotifyClientsAboutLegalHoldRequest :: + UserId -> + UserId -> + LastPrekey -> + BrigAccess m () + GetLegalHoldAuthToken :: + UserId -> + Maybe PlainTextPassword -> + BrigAccess m OpaqueAuthToken + AddLegalHoldClientToUser :: + UserId -> + ConnId -> + [Prekey] -> + LastPrekey -> + BrigAccess m ClientId + RemoveLegalHoldClientFromUser :: UserId -> BrigAccess m () + +makeSem ''BrigAccess + +getUser :: Member BrigAccess r => UserId -> Sem r (Maybe UserAccount) +getUser = fmap listToMaybe . getUsers . pure diff --git a/services/galley/src/Galley/Effects/ExternalAccess.hs b/services/galley/src/Galley/Effects/ExternalAccess.hs new file mode 100644 index 00000000000..81889aed8af --- /dev/null +++ b/services/galley/src/Galley/Effects/ExternalAccess.hs @@ -0,0 +1,38 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ExternalAccess + ( -- * External access effect + ExternalAccess (..), + deliver, + deliverAsync, + deliverAndDeleteAsync, + ) +where + +import Data.Id +import Galley.Data.Services +import Imports +import Polysemy +import Wire.API.Event.Conversation + +data ExternalAccess m a where + Deliver :: Foldable f => f (BotMember, Event) -> ExternalAccess m [BotMember] + DeliverAsync :: Foldable f => f (BotMember, Event) -> ExternalAccess m () + DeliverAndDeleteAsync :: Foldable f => ConvId -> f (BotMember, Event) -> ExternalAccess m () + +makeSem ''ExternalAccess diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs new file mode 100644 index 00000000000..9a31cd3e097 --- /dev/null +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -0,0 +1,60 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.FederatorAccess + ( -- * Federator access effect + FederatorAccess (..), + runFederated, + runFederatedEither, + runFederatedConcurrently, + runFederatedConcurrently_, + ) +where + +import Data.Qualified +import Galley.Intra.Federator.Types +import Imports +import Polysemy +import Wire.API.Federation.Client +import Wire.API.Federation.GRPC.Types + +data FederatorAccess m a where + RunFederated :: + forall (c :: Component) a m x. + Remote x -> + FederatedRPC c a -> + FederatorAccess m a + RunFederatedEither :: + forall (c :: Component) a m x. + Remote x -> + FederatedRPC c a -> + FederatorAccess m (Either FederationError a) + RunFederatedConcurrently :: + forall (c :: Component) f a m x. + (Foldable f, Functor f) => + f (Remote x) -> + (Remote [x] -> FederatedRPC c a) -> + FederatorAccess m [Remote a] + +makeSem ''FederatorAccess + +runFederatedConcurrently_ :: + (Foldable f, Functor f, Member FederatorAccess r) => + f (Remote a) -> + (Remote [a] -> FederatedRPC c ()) -> + Sem r () +runFederatedConcurrently_ xs = void . runFederatedConcurrently xs diff --git a/services/galley/src/Galley/Effects/FireAndForget.hs b/services/galley/src/Galley/Effects/FireAndForget.hs index 4b614862a35..73ff93d3778 100644 --- a/services/galley/src/Galley/Effects/FireAndForget.hs +++ b/services/galley/src/Galley/Effects/FireAndForget.hs @@ -37,6 +37,10 @@ makeSem ''FireAndForget fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () fireAndForget = fireAndForgetOne +-- | Run actions in separate threads and ignore results. +-- +-- /Note/: this will also ignore any state and error effects contained in the +-- 'FireAndForget' action. Use with care. interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a interpretFireAndForget = interpretFinal @IO $ \case FireAndForgetOne action -> do diff --git a/services/galley/src/Galley/Effects/GundeckAccess.hs b/services/galley/src/Galley/Effects/GundeckAccess.hs new file mode 100644 index 00000000000..1f035ff1a87 --- /dev/null +++ b/services/galley/src/Galley/Effects/GundeckAccess.hs @@ -0,0 +1,38 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.GundeckAccess + ( -- * Gundeck access effect + GundeckAccess (..), + push, + push1, + ) +where + +import qualified Galley.Intra.Push as G +import Imports +import Polysemy + +data GundeckAccess m a where + Push :: Foldable f => f G.Push -> GundeckAccess m () + +makeSem ''GundeckAccess + +-- | Asynchronously send a single push, chunking it into multiple +-- requests if there are more than 128 recipients. +push1 :: Member GundeckAccess r => G.Push -> Sem r () +push1 x = push [x] diff --git a/services/galley/src/Galley/Effects/SparAccess.hs b/services/galley/src/Galley/Effects/SparAccess.hs new file mode 100644 index 00000000000..b8479858aa7 --- /dev/null +++ b/services/galley/src/Galley/Effects/SparAccess.hs @@ -0,0 +1,26 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.SparAccess where + +import Data.Id +import Polysemy + +data SparAccess m a where + DeleteTeam :: TeamId -> SparAccess m () + +makeSem ''SparAccess diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 3be666ff2db..bff564836eb 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -18,16 +18,23 @@ module Galley.Env where import Cassandra -import Control.Lens +import Control.Lens hiding ((.=)) +import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Metrics.Middleware import Data.Misc (Fingerprint, Rsa) +import Data.Range import qualified Galley.Aws as Aws import Galley.Options import qualified Galley.Queue as Q +import qualified Galley.Types.Teams as Teams import Imports import Network.HTTP.Client +import Network.HTTP.Client.OpenSSL +import OpenSSL.EVP.Digest import OpenSSL.Session as Ssl +import qualified OpenSSL.X509.SystemStore as Ssl +import Ssl.Util import System.Logger import Util.Options @@ -58,3 +65,36 @@ data ExtEnv = ExtEnv makeLenses ''Env makeLenses ''ExtEnv + +-- TODO: somewhat duplicates Brig.App.initExtGetManager +initExtEnv :: IO ExtEnv +initExtEnv = do + ctx <- Ssl.context + Ssl.contextSetVerificationMode ctx Ssl.VerifyNone + Ssl.contextAddOption ctx SSL_OP_NO_SSLv2 + Ssl.contextAddOption ctx SSL_OP_NO_SSLv3 + Ssl.contextAddOption ctx SSL_OP_NO_TLSv1 + Ssl.contextSetCiphers ctx rsaCiphers + Ssl.contextLoadSystemCerts ctx + mgr <- + newManager + (opensslManagerSettings (pure ctx)) + { managerResponseTimeout = responseTimeoutMicro 10000000, + managerConnCount = 100 + } + Just sha <- getDigestByName "SHA256" + return $ ExtEnv (mgr, mkVerify sha) + where + mkVerify sha fprs = + let pinset = map toByteString' fprs + in verifyRsaFingerprint sha pinset + +reqIdMsg :: RequestId -> Msg -> Msg +reqIdMsg = ("request" .=) . unRequestId +{-# INLINE reqIdMsg #-} + +currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 +currentFanoutLimit o = do + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. optSettings ^. setMaxFanoutSize) + let maxTeamSize = fromIntegral (o ^. optSettings ^. setMaxTeamSize) + unsafeRange (min maxTeamSize optFanoutLimit) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index 63e1cad55b9..e325f3da587 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -15,12 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.External - ( deliver, - deliverAndDeleteAsync, - deliverAsync, - ) -where +module Galley.External (interpretExternalAccess) where import Bilge.Request import Bilge.Retry (httpHandlers) @@ -29,58 +24,59 @@ import Control.Retry import Data.ByteString.Conversion.To import Data.Id import Data.Misc -import Galley.App import Galley.Cassandra.Services import Galley.Data.Services (BotMember, botMemId, botMemService) import Galley.Effects +import Galley.Effects.ExternalAccess (ExternalAccess (..)) +import Galley.Env import Galley.Intra.User +import Galley.Intra.Util import Galley.Types (Event) import Galley.Types.Bot import Imports import qualified Network.HTTP.Client as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status (status410) +import Polysemy +import qualified Polysemy.Reader as P import Ssl.Util (withVerifiedSslConnection) import qualified System.Logger.Class as Log import System.Logger.Message (field, msg, val, (~~)) import URI.ByteString import UnliftIO (Async, async, waitCatch) +interpretExternalAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (ExternalAccess ': r) a -> + Sem r a +interpretExternalAccess = interpret $ \case + Deliver pp -> embedIntra $ deliver (toList pp) + DeliverAsync pp -> embedIntra $ deliverAsync (toList pp) + DeliverAndDeleteAsync cid pp -> embedIntra $ deliverAndDeleteAsync cid (toList pp) + -- | Like deliver, but ignore orphaned bots and return immediately. -- -- FUTUREWORK: Check if this can be removed. -deliverAsync :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r () -deliverAsync = liftGalley0 . void . forkIO . void . deliver0 +deliverAsync :: [(BotMember, Event)] -> IntraM () +deliverAsync = void . forkIO . void . deliver -- | Like deliver, but remove orphaned bots and return immediately. -deliverAndDeleteAsync :: - Members '[ExternalAccess, BotAccess] r => - ConvId -> - [(BotMember, Event)] -> - Galley r () -deliverAndDeleteAsync cnv pushes = liftGalley0 . void . forkIO $ do - gone <- liftGalley0 $ deliver0 pushes - mapM_ (deleteBot0 cnv . botMemId) gone - --- | Deliver events to external (bot) services. --- --- Returns those bots which are found to be orphaned by the external --- service, e.g. when the service tells us that it no longer knows about the --- bot. -deliver :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r [BotMember] -deliver = liftGalley0 . deliver0 +deliverAndDeleteAsync :: ConvId -> [(BotMember, Event)] -> IntraM () +deliverAndDeleteAsync cnv pushes = void . forkIO $ do + gone <- deliver pushes + mapM_ (deleteBot cnv . botMemId) gone -deliver0 :: [(BotMember, Event)] -> Galley0 [BotMember] -deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) +deliver :: [(BotMember, Event)] -> IntraM [BotMember] +deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, Event) -> Galley0 Bool + exec :: (BotMember, Event) -> IntraM Bool exec (b, e) = lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e return True - eval :: [BotMember] -> (BotMember, Async Bool) -> Galley r [BotMember] + eval :: [BotMember] -> (BotMember, Async Bool) -> IntraM [BotMember] eval gone (b, a) = do let s = botMemService b r <- waitCatch a @@ -119,7 +115,7 @@ deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: Service -> BotMember -> Event -> Galley0 () +deliver1 :: Service -> BotMember -> Event -> IntraM () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) @@ -149,7 +145,7 @@ urlPort (HttpsUrl u) = do p <- a ^. authorityPortL return (fromIntegral (p ^. portNumberL)) -sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley r () +sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> IntraM () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 133b4cf4134..ac503fc67c7 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -26,9 +24,6 @@ module Galley.External.LegalHoldService -- * helpers validateServiceKey, - - -- * types - OpaqueAuthToken (..), ) where @@ -50,6 +45,8 @@ import Data.Misc import Galley.API.Error import Galley.App import qualified Galley.Data.LegalHold as LegalHoldData +import Galley.Env +import Galley.External.LegalHoldService.Types import Imports import qualified Network.HTTP.Client as Http import Network.HTTP.Types @@ -237,14 +234,3 @@ validateServiceKey pem = (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) minRsaKeySize :: Int minRsaKeySize = 256 -- Bytes (= 2048 bits) - --- Types - --- | When receiving tokens from other services which are 'just passing through' --- it's error-prone useless extra work to parse and render them from JSON over and over again. --- We'll just wrap them with this to give some level of typesafety and a reasonable JSON --- instance -newtype OpaqueAuthToken = OpaqueAuthToken - { opaqueAuthTokenToText :: Text - } - deriving newtype (Eq, Show, FromJSON, ToJSON, ToByteString) diff --git a/services/galley/src/Galley/External/LegalHoldService/Types.hs b/services/galley/src/Galley/External/LegalHoldService/Types.hs new file mode 100644 index 00000000000..cecf37ad874 --- /dev/null +++ b/services/galley/src/Galley/External/LegalHoldService/Types.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.External.LegalHoldService.Types + ( OpaqueAuthToken (..), + ) +where + +import Data.Aeson +import Data.ByteString.Conversion.To +import Imports + +-- | When receiving tokens from other services which are 'just passing through' +-- it's error-prone useless extra work to parse and render them from JSON over and over again. +-- We'll just wrap them with this to give some level of typesafety and a reasonable JSON +-- instance +newtype OpaqueAuthToken = OpaqueAuthToken + { opaqueAuthTokenToText :: Text + } + deriving newtype (Eq, Show, FromJSON, ToJSON, ToByteString) diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index f0a941d0a39..52a783513c7 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -38,24 +38,26 @@ import Data.Misc import qualified Data.Set as Set import Data.Text.Encoding import Galley.API.Error -import Galley.App import Galley.Effects -import Galley.External.LegalHoldService +import Galley.Env +import Galley.External.LegalHoldService.Types import Galley.Intra.Util import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Polysemy +import qualified Polysemy.Reader as P +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Logger import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull) -- | Calls 'Brig.API.internalListClientsH'. -lookupClients :: Member BrigAccess r => [UserId] -> Galley r UserClients +lookupClients :: [UserId] -> IntraM UserClients lookupClients uids = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ - method POST . host brigHost . port brigPort + call Brig $ + method POST . path "/i/clients" . json (UserSet $ Set.fromList uids) . expect2xx @@ -64,14 +66,12 @@ lookupClients uids = do -- | Calls 'Brig.API.internalListClientsFullH'. lookupClientsFull :: - Member BrigAccess r => [UserId] -> - Galley r UserClientsFull + IntraM UserClientsFull lookupClientsFull uids = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ - method POST . host brigHost . port brigPort + call Brig $ + method POST . path "/i/clients/full" . json (UserSet $ Set.fromList uids) . expect2xx @@ -80,52 +80,44 @@ lookupClientsFull uids = do -- | Calls 'Brig.API.legalHoldClientRequestedH'. notifyClientsAboutLegalHoldRequest :: - Member BrigAccess r => UserId -> UserId -> LastPrekey -> - Galley r () + IntraM () notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do - (brigHost, brigPort) <- brigReq - void . callBrig $ + void . call Brig $ method POST - . host brigHost - . port brigPort . paths ["i", "clients", "legalhold", toByteString' targetUid, "request"] . json (LegalHoldClientRequest requesterUid lastPrekey') . expect2xx -- | Calls 'Brig.User.API.Auth.legalHoldLoginH'. getLegalHoldAuthToken :: - Member BrigAccess r => + Members '[Embed IO, P.TinyLog, P.Reader Env] r => UserId -> Maybe PlainTextPassword -> - Galley r OpaqueAuthToken + Sem r OpaqueAuthToken getLegalHoldAuthToken uid pw = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ + embedIntra . call Brig $ method POST - . host brigHost - . port brigPort . path "/i/legalhold-login" . queryItem "persist" "true" . json (LegalHoldLogin uid pw Nothing) . expect2xx case getCookieValue "zuid" r of Nothing -> do - Logger.warn $ Logger.msg @Text "Response from login missing auth cookie" - throwM internalError + P.warn $ Logger.msg @Text "Response from login missing auth cookie" + embed $ throwM internalError Just c -> pure . OpaqueAuthToken . decodeUtf8 $ c -- | Calls 'Brig.API.addClientInternalH'. addLegalHoldClientToUser :: - Member BrigAccess r => UserId -> ConnId -> [Prekey] -> LastPrekey -> - Galley r ClientId + IntraM ClientId addLegalHoldClientToUser uid connId prekeys lastPrekey' = do clientId <$> brigAddClient uid connId lhClient where @@ -143,28 +135,21 @@ addLegalHoldClientToUser uid connId prekeys lastPrekey' = do -- | Calls 'Brig.API.removeLegalHoldClientH'. removeLegalHoldClientFromUser :: - Member BrigAccess r => UserId -> - Galley r () + IntraM () removeLegalHoldClientFromUser targetUid = do - (brigHost, brigPort) <- brigReq - void . callBrig $ + void . call Brig $ method DELETE - . host brigHost - . port brigPort . paths ["i", "clients", "legalhold", toByteString' targetUid] . contentJson . expect2xx -- | Calls 'Brig.API.addClientInternalH'. -brigAddClient :: Member BrigAccess r => UserId -> ConnId -> NewClient -> Galley r Client +brigAddClient :: UserId -> ConnId -> NewClient -> IntraM Client brigAddClient uid connId client = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ + call Brig $ method POST - . host brigHost - . port brigPort . header "Z-Connection" (toByteString' connId) . paths ["i", "clients", toByteString' uid] . contentJson diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs new file mode 100644 index 00000000000..26191832bfa --- /dev/null +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -0,0 +1,95 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Effects + ( interpretBrigAccess, + interpretSparAccess, + interpretBotAccess, + interpretGundeckAccess, + ) +where + +import Galley.Effects.BotAccess (BotAccess (..)) +import Galley.Effects.BrigAccess (BrigAccess (..)) +import Galley.Effects.GundeckAccess (GundeckAccess (..)) +import Galley.Effects.SparAccess (SparAccess (..)) +import Galley.Env +import Galley.Intra.Client +import qualified Galley.Intra.Push.Internal as G +import Galley.Intra.Spar +import Galley.Intra.Team +import Galley.Intra.User +import Galley.Intra.Util +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import qualified Polysemy.TinyLog as P +import qualified UnliftIO + +interpretBrigAccess :: + Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Sem (BrigAccess ': r) a -> + Sem r a +interpretBrigAccess = interpret $ \case + GetConnectionsUnqualified uids muids mrel -> + embedIntra $ getConnectionsUnqualified uids muids mrel + GetConnectionsUnqualifiedBidi uids1 uids2 mrel1 mrel2 -> + embedIntra $ + UnliftIO.concurrently + (getConnectionsUnqualified uids1 (Just uids2) mrel1) + (getConnectionsUnqualified uids2 (Just uids1) mrel2) + GetConnections uids mquids mrel -> + embedIntra $ + getConnections uids mquids mrel + PutConnectionInternal uc -> embedIntra $ putConnectionInternal uc + ReauthUser uid reauth -> embedIntra $ reAuthUser uid reauth + LookupActivatedUsers uids -> embedIntra $ lookupActivatedUsers uids + GetUsers uids -> embedIntra $ getUsers uids + DeleteUser uid -> embedIntra $ deleteUser uid + GetContactList uid -> embedIntra $ getContactList uid + GetRichInfoMultiUser uids -> embedIntra $ getRichInfoMultiUser uids + GetSize tid -> embedIntra $ getSize tid + LookupClients uids -> embedIntra $ lookupClients uids + LookupClientsFull uids -> embedIntra $ lookupClientsFull uids + NotifyClientsAboutLegalHoldRequest self other pk -> + embedIntra $ notifyClientsAboutLegalHoldRequest self other pk + GetLegalHoldAuthToken uid mpwd -> getLegalHoldAuthToken uid mpwd + AddLegalHoldClientToUser uid conn pks lpk -> + embedIntra $ addLegalHoldClientToUser uid conn pks lpk + RemoveLegalHoldClientFromUser uid -> + embedIntra $ removeLegalHoldClientFromUser uid + +interpretSparAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (SparAccess ': r) a -> + Sem r a +interpretSparAccess = interpret $ \case + DeleteTeam tid -> embedIntra $ deleteTeam tid + +interpretBotAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (BotAccess ': r) a -> + Sem r a +interpretBotAccess = interpret $ \case + DeleteBot cid bid -> embedIntra $ deleteBot cid bid + +interpretGundeckAccess :: + Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Sem (GundeckAccess ': r) a -> + Sem r a +interpretGundeckAccess = interpret $ \case + Push ps -> embedIntra $ G.push ps diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs new file mode 100644 index 00000000000..cd08fb32572 --- /dev/null +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Federator (interpretFederatorAccess) where + +import Control.Monad.Except +import Data.Qualified +import Galley.Effects.FederatorAccess (FederatorAccess (..)) +import Galley.Env +import Galley.Intra.Federator.Types +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import UnliftIO +import Wire.API.Federation.Client +import Wire.API.Federation.Error + +embedFederationM :: + Members '[Embed IO, P.Reader Env] r => + FederationM a -> + Sem r a +embedFederationM action = do + env <- P.ask + embed $ runFederationM env action + +interpretFederatorAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (FederatorAccess ': r) a -> + Sem r a +interpretFederatorAccess = interpret $ \case + RunFederated dom rpc -> embedFederationM $ runFederated dom rpc + RunFederatedEither dom rpc -> embedFederationM $ runFederatedEither dom rpc + RunFederatedConcurrently rs f -> embedFederationM $ runFederatedConcurrently rs f + +runFederatedEither :: + Remote x -> + FederatedRPC c a -> + FederationM (Either FederationError a) +runFederatedEither (tDomain -> remoteDomain) rpc = do + env <- ask + liftIO $ runFederationM env (runExceptT (executeFederated remoteDomain rpc)) + +runFederated :: + Remote x -> + FederatedRPC c a -> + FederationM a +runFederated dom rpc = + runFederatedEither dom rpc + >>= either (throwIO . federationErrorToWai) pure + +runFederatedConcurrently :: + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedRPC c b) -> + FederationM [Remote b] +runFederatedConcurrently xs rpc = + pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> + qualifyAs r <$> runFederated r (rpc r) diff --git a/services/galley/src/Galley/Intra/Federator/Types.hs b/services/galley/src/Galley/Intra/Federator/Types.hs new file mode 100644 index 00000000000..44f43d5321e --- /dev/null +++ b/services/galley/src/Galley/Intra/Federator/Types.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Federator.Types + ( FederatedRPC, + FederationM, + runFederationM, + ) +where + +import Control.Lens +import Control.Monad.Except +import Galley.Env +import Galley.Options +import Imports +import Wire.API.Federation.Client +import Wire.API.Federation.GRPC.Types + +type FederatedRPC (c :: Component) = + FederatorClient c (ExceptT FederationClientFailure FederationM) + +newtype FederationM a = FederationM + {unFederationM :: ReaderT Env IO a} + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadReader Env, + MonadUnliftIO + ) + +runFederationM :: Env -> FederationM a -> IO a +runFederationM env = flip runReaderT env . unFederationM + +instance HasFederatorConfig FederationM where + federatorEndpoint = view federator + federationDomain = view (options . optSettings . setFederationDomain) diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs index 15f67076140..71292655ac5 100644 --- a/services/galley/src/Galley/Intra/Push.hs +++ b/services/galley/src/Galley/Intra/Push.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE StrictData #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -25,9 +23,6 @@ module Galley.Intra.Push newConversationEventPush, newPush1, newPushLocal1, - push, - push1, - pushSome, PushEvent (..), -- * Push Configuration @@ -51,211 +46,5 @@ module Galley.Intra.Push ) where -import Bilge hiding (options) -import Bilge.RPC -import Bilge.Retry -import Control.Lens (makeLenses, set, view, (.~), (^.)) -import Control.Monad.Catch -import Control.Retry -import Data.Aeson (Object) -import Data.Domain -import Data.Id (ConnId, UserId) -import Data.Json.Util -import Data.List.Extra (chunksOf) -import Data.List.NonEmpty (nonEmpty) -import Data.List1 -import Data.Misc -import Data.Qualified -import Data.Range -import qualified Data.Set as Set -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.Lazy as LT -import Galley.App -import Galley.Effects -import Galley.Options -import Galley.Types -import qualified Galley.Types.Teams as Teams -import Gundeck.Types.Push.V2 (RecipientClients (..)) +import Galley.Intra.Push.Internal import qualified Gundeck.Types.Push.V2 as Gundeck -import Imports hiding (forkIO) -import Network.HTTP.Types.Method -import Safe (headDef, tailDef) -import System.Logger.Class hiding (new) -import UnliftIO.Async (mapConcurrently) -import UnliftIO.Concurrent (forkIO) -import Util.Options -import qualified Wire.API.Event.FeatureConfig as FeatureConfig - -data PushEvent - = ConvEvent Event - | TeamEvent Teams.Event - | FeatureConfigEvent FeatureConfig.Event - -pushEventJson :: PushEvent -> Object -pushEventJson (ConvEvent e) = toJSONObject e -pushEventJson (TeamEvent e) = toJSONObject e -pushEventJson (FeatureConfigEvent e) = toJSONObject e - -type Recipient = RecipientBy UserId - -data RecipientBy user = Recipient - { _recipientUserId :: user, - _recipientClients :: RecipientClients - } - deriving stock (Functor, Foldable, Traversable) - -makeLenses ''RecipientBy - -recipient :: LocalMember -> Recipient -recipient = userRecipient . lmId - -userRecipient :: user -> RecipientBy user -userRecipient u = Recipient u RecipientClientsAll - -type Push = PushTo UserId - -data PushTo user = Push - { _pushConn :: Maybe ConnId, - _pushTransient :: Bool, - _pushRoute :: Gundeck.Route, - _pushNativePriority :: Maybe Gundeck.Priority, - _pushAsync :: Bool, - pushOrigin :: Maybe UserId, - _pushRecipients :: List1 (RecipientBy user), - pushJson :: Object, - pushRecipientListType :: Teams.ListType - } - deriving stock (Functor, Foldable, Traversable) - -makeLenses ''PushTo - -newPush1 :: Teams.ListType -> Maybe UserId -> PushEvent -> List1 Recipient -> Push -newPush1 recipientListType from e rr = - Push - { _pushConn = Nothing, - _pushTransient = False, - _pushRoute = Gundeck.RouteAny, - _pushNativePriority = Nothing, - _pushAsync = False, - pushRecipientListType = recipientListType, - pushJson = pushEventJson e, - pushOrigin = from, - _pushRecipients = rr - } - -newPushLocal1 :: Teams.ListType -> UserId -> PushEvent -> List1 Recipient -> Push -newPushLocal1 lt uid e rr = newPush1 lt (Just uid) e rr - -newPush :: Teams.ListType -> Maybe UserId -> PushEvent -> [Recipient] -> Maybe Push -newPush _ _ _ [] = Nothing -newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) - -newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push -newPushLocal lt uid e rr = newPush lt (Just uid) e rr - -newConversationEventPush :: Domain -> Event -> [UserId] -> Maybe Push -newConversationEventPush localDomain e users = - let musr = guard (localDomain == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) - in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient users) - --- | Asynchronously send a single push, chunking it into multiple --- requests if there are more than 128 recipients. -push1 :: Member GundeckAccess r => Push -> Galley r () -push1 p = push (list1 p []) - -pushSome :: Member GundeckAccess r => [Push] -> Galley r () -pushSome [] = return () -pushSome (x : xs) = push (list1 x xs) - -push :: Member GundeckAccess r => List1 Push -> Galley r () -push ps = do - let (localPushes, remotePushes) = foldMap (bimap toList toList . splitPush) (toList ps) - traverse_ (pushLocal . List1) (nonEmpty localPushes) - traverse_ (pushRemote . List1) (nonEmpty remotePushes) - where - splitPush :: Push -> (Maybe (PushTo UserId), Maybe (PushTo UserId)) - splitPush p = - (mkPushTo localRecipients p, mkPushTo remoteRecipients p) - where - localRecipients = toList $ _pushRecipients p - remoteRecipients = [] -- FUTUREWORK: deal with remote sending - mkPushTo :: [RecipientBy a] -> PushTo b -> Maybe (PushTo a) - mkPushTo recipients p = - nonEmpty recipients <&> \nonEmptyRecipients -> - p {_pushRecipients = List1 nonEmptyRecipients} - --- | Asynchronously send multiple pushes, aggregating them into as --- few requests as possible, such that no single request targets --- more than 128 recipients. -pushLocal :: Member GundeckAccess r => List1 (PushTo UserId) -> Galley r () -pushLocal ps = do - limit <- fanoutLimit - opts <- view options - -- Do not fan out for very large teams - let (asyncs, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) - forM_ (pushes asyncs) $ callAsync "gundeck" . gundeckReq opts - void . liftGalley0 $ mapConcurrently (call0 "gundeck" . gundeckReq opts) (pushes sync) - return () - where - pushes = fst . foldr chunk ([], 0) - chunk p (pss, !n) = - let r = recipientList p - nr = length r - in if n + nr > maxRecipients - then - let pss' = map (pure . toPush p) (chunksOf maxRecipients r) - in (pss' ++ pss, 0) - else - let hd = headDef [] pss - tl = tailDef [] pss - in ((toPush p r : hd) : tl, n + nr) - maxRecipients = 128 - recipientList p = map (toRecipient p) . toList $ _pushRecipients p - toPush p r = - let pload = Gundeck.singletonPayload (pushJson p) - in Gundeck.newPush (pushOrigin p) (unsafeRange (Set.fromList r)) pload - & Gundeck.pushOriginConnection .~ _pushConn p - & Gundeck.pushTransient .~ _pushTransient p - & maybe id (set Gundeck.pushNativePriority) (_pushNativePriority p) - toRecipient p r = - Gundeck.recipient (_recipientUserId r) (_pushRoute p) - & Gundeck.recipientClients .~ _recipientClients r - -- Ensure that under no circumstances we exceed the threshold - removeIfLargeFanout limit = - filter - ( \p -> - (pushRecipientListType p == Teams.ListComplete) - && (length (_pushRecipients p) <= (fromIntegral $ fromRange limit)) - ) - --- instead of IdMapping, we could also just take qualified IDs -pushRemote :: List1 (PushTo UserId) -> Galley r () -pushRemote _ps = do - -- FUTUREWORK(federation, #1261): send these to the other backends - pure () - ------------------------------------------------------------------------------ --- Helpers - -gundeckReq :: Opts -> [Gundeck.Push] -> Request -> Request -gundeckReq o ps = - host (encodeUtf8 $ o ^. optGundeck . epHost) - . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) - . method POST - . path "/i/push/v2" - . json ps - . expect2xx - -callAsync :: Member GundeckAccess r => LT.Text -> (Request -> Request) -> Galley r () -callAsync n r = liftGalley0 . void . forkIO $ void (call0 n r) `catches` handlers - where - handlers = - [ Handler $ \(x :: RPCException) -> err (rpcExceptionMsg x), - Handler $ \(x :: SomeException) -> err $ "remote" .= n ~~ msg (show x) - ] - -call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LByteString)) -call0 n r = recovering x3 rpcHandlers (const (rpc n r)) - -x3 :: RetryPolicy -x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs new file mode 100644 index 00000000000..6c4c7aefbca --- /dev/null +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Push.Internal where + +import Bilge hiding (options) +import Control.Lens (makeLenses, set, view, (.~)) +import Data.Aeson (Object) +import Data.Domain +import Data.Id (ConnId, UserId) +import Data.Json.Util +import Data.List.Extra (chunksOf) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List1 +import Data.Qualified +import Data.Range +import qualified Data.Set as Set +import Galley.Env +import Galley.Intra.Util +import Galley.Types +import qualified Galley.Types.Teams as Teams +import Gundeck.Types.Push.V2 (RecipientClients (..)) +import qualified Gundeck.Types.Push.V2 as Gundeck +import Imports hiding (forkIO) +import Safe (headDef, tailDef) +import UnliftIO.Async (mapConcurrently) +import qualified Wire.API.Event.FeatureConfig as FeatureConfig + +data PushEvent + = ConvEvent Event + | TeamEvent Teams.Event + | FeatureConfigEvent FeatureConfig.Event + +pushEventJson :: PushEvent -> Object +pushEventJson (ConvEvent e) = toJSONObject e +pushEventJson (TeamEvent e) = toJSONObject e +pushEventJson (FeatureConfigEvent e) = toJSONObject e + +data RecipientBy user = Recipient + { _recipientUserId :: user, + _recipientClients :: RecipientClients + } + deriving stock (Functor, Foldable, Traversable) + +makeLenses ''RecipientBy + +type Recipient = RecipientBy UserId + +data PushTo user = Push + { _pushConn :: Maybe ConnId, + _pushTransient :: Bool, + _pushRoute :: Gundeck.Route, + _pushNativePriority :: Maybe Gundeck.Priority, + _pushAsync :: Bool, + pushOrigin :: Maybe UserId, + _pushRecipients :: List1 (RecipientBy user), + pushJson :: Object, + pushRecipientListType :: Teams.ListType + } + deriving stock (Functor, Foldable, Traversable) + +makeLenses ''PushTo + +type Push = PushTo UserId + +push :: Foldable f => f Push -> IntraM () +push ps = do + let pushes = foldMap (toList . mkPushTo) ps + traverse_ pushLocal (nonEmpty pushes) + where + mkPushTo :: PushTo a -> Maybe (PushTo a) + mkPushTo p = + nonEmpty (toList (_pushRecipients p)) <&> \nonEmptyRecipients -> + p {_pushRecipients = List1 nonEmptyRecipients} + +-- | Asynchronously send multiple pushes, aggregating them into as +-- few requests as possible, such that no single request targets +-- more than 128 recipients. +pushLocal :: NonEmpty (PushTo UserId) -> IntraM () +pushLocal ps = do + opts <- view options + let limit = currentFanoutLimit opts + -- Do not fan out for very large teams + let (asyncs, syncs) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) + traverse_ (asyncCall Gundeck . json) (pushes asyncs) + void $ mapConcurrently (call Gundeck . json) (pushes syncs) + where + pushes = fst . foldr chunk ([], 0) + chunk p (pss, !n) = + let r = recipientList p + nr = length r + in if n + nr > maxRecipients + then + let pss' = map (pure . toPush p) (chunksOf maxRecipients r) + in (pss' ++ pss, 0) + else + let hd = headDef [] pss + tl = tailDef [] pss + in ((toPush p r : hd) : tl, n + nr) + maxRecipients = 128 + recipientList p = map (toRecipient p) . toList $ _pushRecipients p + toPush p r = + let pload = Gundeck.singletonPayload (pushJson p) + in Gundeck.newPush (pushOrigin p) (unsafeRange (Set.fromList r)) pload + & Gundeck.pushOriginConnection .~ _pushConn p + & Gundeck.pushTransient .~ _pushTransient p + & maybe id (set Gundeck.pushNativePriority) (_pushNativePriority p) + toRecipient p r = + Gundeck.recipient (_recipientUserId r) (_pushRoute p) + & Gundeck.recipientClients .~ _recipientClients r + -- Ensure that under no circumstances we exceed the threshold + removeIfLargeFanout limit = + filter + ( \p -> + (pushRecipientListType p == Teams.ListComplete) + && (length (_pushRecipients p) <= (fromIntegral $ fromRange limit)) + ) + +recipient :: LocalMember -> Recipient +recipient = userRecipient . lmId + +userRecipient :: user -> RecipientBy user +userRecipient u = Recipient u RecipientClientsAll + +newPush1 :: Teams.ListType -> Maybe UserId -> PushEvent -> List1 Recipient -> Push +newPush1 recipientListType from e rr = + Push + { _pushConn = Nothing, + _pushTransient = False, + _pushRoute = Gundeck.RouteAny, + _pushNativePriority = Nothing, + _pushAsync = False, + pushRecipientListType = recipientListType, + pushJson = pushEventJson e, + pushOrigin = from, + _pushRecipients = rr + } + +newPushLocal1 :: Teams.ListType -> UserId -> PushEvent -> List1 Recipient -> Push +newPushLocal1 lt uid e rr = newPush1 lt (Just uid) e rr + +newPush :: Teams.ListType -> Maybe UserId -> PushEvent -> [Recipient] -> Maybe Push +newPush _ _ _ [] = Nothing +newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) + +newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push +newPushLocal lt uid e rr = newPush lt (Just uid) e rr + +newConversationEventPush :: Domain -> Event -> [UserId] -> Maybe Push +newConversationEventPush localDomain e users = + let musr = guard (localDomain == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) + in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient users) diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index c10f3109d38..ce9f569a60d 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -23,19 +23,14 @@ where import Bilge import Data.ByteString.Conversion import Data.Id -import Galley.App -import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method -- | Notify Spar that a team is being deleted. -deleteTeam :: Member SparAccess r => TeamId -> Galley r () +deleteTeam :: TeamId -> IntraM () deleteTeam tid = do - (h, p) <- sparReq - _ <- - callSpar $ - method DELETE . host h . port p - . paths ["i", "teams", toByteString' tid] - . expect2xx - pure () + void . call Spar $ + method DELETE + . paths ["i", "teams", toByteString' tid] + . expect2xx diff --git a/services/galley/src/Galley/Intra/Team.hs b/services/galley/src/Galley/Intra/Team.hs index 50cdcdd345f..a6b8d96af1a 100644 --- a/services/galley/src/Galley/Intra/Team.hs +++ b/services/galley/src/Galley/Intra/Team.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2021 Wire Swiss GmbH -- -- This program is free software: you can redistribute it and/or modify it under -- the terms of the GNU Affero General Public License as published by the Free @@ -22,20 +22,17 @@ import Bilge.RPC import Brig.Types.Team import Data.ByteString.Conversion import Data.Id -import Galley.App -import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error -getSize :: Member BrigAccess r => TeamId -> Galley r TeamSize +getSize :: TeamId -> IntraM TeamSize getSize tid = do - (h, p) <- brigReq r <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . paths ["/i/teams", toByteString' tid, "size"] . expect2xx parseResponse (mkError status502 "server-error") r diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index faea13c43ea..0a08a634e0e 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -17,28 +17,23 @@ module Galley.Intra.User ( getConnections, - getConnectionsUnqualified0, getConnectionsUnqualified, putConnectionInternal, deleteBot, reAuthUser, lookupActivatedUsers, - getUser, getUsers, deleteUser, getContactList, chunkify, getRichInfoMultiUser, - - -- * Internal - deleteBot0, ) where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC import Brig.Types.Connection (Relation (..), UpdateConnectionsInternal (..), UserIds (..)) -import Brig.Types.Intra +import qualified Brig.Types.Intra as Brig import Brig.Types.User (User) import Control.Monad.Catch (throwM) import Data.ByteString.Char8 (pack) @@ -46,8 +41,6 @@ import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Conversion import Data.Id import Data.Qualified -import Galley.App -import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Client (HttpExceptionContent (..)) @@ -65,24 +58,14 @@ import Wire.API.User.RichInfo (RichInfo) -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatusUnqualified'. getConnectionsUnqualified :: - Member BrigAccess r => - [UserId] -> - Maybe [UserId] -> - Maybe Relation -> - Galley r [ConnectionStatus] -getConnectionsUnqualified uFrom uTo rlt = - liftGalley0 $ getConnectionsUnqualified0 uFrom uTo rlt - -getConnectionsUnqualified0 :: [UserId] -> Maybe [UserId] -> Maybe Relation -> - Galley0 [ConnectionStatus] -getConnectionsUnqualified0 uFrom uTo rlt = do - (h, p) <- brigReq + IntraM [ConnectionStatus] +getConnectionsUnqualified uFrom uTo rlt = do r <- - call0 "brig" $ - method POST . host h . port p + call Brig $ + method POST . path "/i/users/connections-status" . maybe id rfilter rlt . json ConnectionsStatusRequest {csrFrom = uFrom, csrTo = uTo} @@ -97,53 +80,57 @@ getConnectionsUnqualified0 uFrom uTo rlt = do -- -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatus'. -getConnections :: Member BrigAccess r => [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley r [ConnectionStatusV2] +getConnections :: + [UserId] -> + Maybe [Qualified UserId] -> + Maybe Relation -> + IntraM [ConnectionStatusV2] getConnections [] _ _ = pure [] getConnections uFrom uTo rlt = do - (h, p) <- brigReq r <- - callBrig $ - method POST . host h . port p + call Brig $ + method POST . path "/i/users/connections-status/v2" . json (ConnectionsStatusRequestV2 uFrom uTo rlt) . expect2xx parseResponse (mkError status502 "server-error") r -putConnectionInternal :: Member BrigAccess r => UpdateConnectionsInternal -> Galley r Status +putConnectionInternal :: + UpdateConnectionsInternal -> + IntraM Status putConnectionInternal updateConn = do - (h, p) <- brigReq response <- - callBrig $ - method PUT . host h . port p + call Brig $ + method PUT . paths ["/i/connections/connection-update"] . json updateConn pure $ responseStatus response -deleteBot0 :: ConvId -> BotId -> Galley0 () -deleteBot0 cid bot = do - (h, p) <- brigReq +deleteBot :: + ConvId -> + BotId -> + IntraM () +deleteBot cid bot = do void $ - call0 "brig" $ - method DELETE . host h . port p + call Brig $ + method DELETE . path "/bot/self" . header "Z-Type" "bot" . header "Z-Bot" (toByteString' bot) . header "Z-Conversation" (toByteString' cid) . expect2xx --- | Calls 'Brig.Provider.API.botGetSelfH'. -deleteBot :: Member BotAccess r => ConvId -> BotId -> Galley r () -deleteBot cid bot = liftGalley0 $ deleteBot0 cid bot - -- | Calls 'Brig.User.API.Auth.reAuthUserH'. -reAuthUser :: Member BrigAccess r => UserId -> ReAuthUser -> Galley r Bool +reAuthUser :: + UserId -> + Brig.ReAuthUser -> + IntraM Bool reAuthUser uid auth = do - (h, p) <- brigReq let req = - method GET . host h . port p + method GET . paths ["/i/users", toByteString' uid, "reauthenticate"] . json auth - st <- statusCode . responseStatus <$> callBrig (check [status200, status403] . req) + st <- statusCode . responseStatus <$> call Brig (check [status200, status403] . req) return $ st == 200 check :: [Status] -> Request -> Request @@ -156,13 +143,12 @@ check allowed r = } -- | Calls 'Brig.API.listActivatedAccountsH'. -lookupActivatedUsers :: Member BrigAccess r => [UserId] -> Galley r [User] +lookupActivatedUsers :: [UserId] -> IntraM [User] lookupActivatedUsers = chunkify $ \uids -> do - (h, p) <- brigReq let users = BSC.intercalate "," $ toByteString' <$> uids r <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . path "/i/users" . queryItem "ids" users . expect2xx @@ -183,49 +169,41 @@ chunkify doChunk keys = mconcat <$> (doChunk `mapM` chunks keys) chunks uids = case splitAt maxSize uids of (h, t) -> h : chunks t -- | Calls 'Brig.API.listActivatedAccountsH'. -getUser :: Member BrigAccess r => UserId -> Galley r (Maybe UserAccount) -getUser uid = listToMaybe <$> getUsers [uid] - --- | Calls 'Brig.API.listActivatedAccountsH'. -getUsers :: Member BrigAccess r => [UserId] -> Galley r [UserAccount] +getUsers :: [UserId] -> IntraM [Brig.UserAccount] getUsers = chunkify $ \uids -> do - (h, p) <- brigReq resp <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . path "/i/users" . queryItem "ids" (BSC.intercalate "," (toByteString' <$> uids)) . expect2xx pure . fromMaybe [] . responseJsonMaybe $ resp -- | Calls 'Brig.API.deleteUserNoVerifyH'. -deleteUser :: Member BrigAccess r => UserId -> Galley r () +deleteUser :: UserId -> IntraM () deleteUser uid = do - (h, p) <- brigReq void $ - callBrig $ - method DELETE . host h . port p + call Brig $ + method DELETE . paths ["/i/users", toByteString' uid] . expect2xx -- | Calls 'Brig.API.getContactListH'. -getContactList :: Member BrigAccess r => UserId -> Galley r [UserId] +getContactList :: UserId -> IntraM [UserId] getContactList uid = do - (h, p) <- brigReq r <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . paths ["/i/users", toByteString' uid, "contacts"] . expect2xx cUsers <$> parseResponse (mkError status502 "server-error") r -- | Calls 'Brig.API.Internal.getRichInfoMultiH' -getRichInfoMultiUser :: Member BrigAccess r => [UserId] -> Galley r [(UserId, RichInfo)] +getRichInfoMultiUser :: [UserId] -> IntraM [(UserId, RichInfo)] getRichInfoMultiUser = chunkify $ \uids -> do - (h, p) <- brigReq resp <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . paths ["/i/users/rich-info"] . queryItem "ids" (toByteString' (List uids)) . expect2xx diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index a9dc8ff8820..203c6ab3901 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,56 +18,120 @@ -- with this program. If not, see . module Galley.Intra.Util - ( brigReq, - sparReq, - call0, - callBrig, - callSpar, - callBot, - x1, + ( IntraComponent (..), + IntraM, + embedIntra, + call, + asyncCall, ) where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC import Bilge.Retry -import Control.Lens (view) +import Cassandra (MonadClient (..), runClient) +import Control.Lens (locally, view, (^.)) +import Control.Monad.Catch import Control.Retry import qualified Data.ByteString.Lazy as LB import Data.Misc (portNumber) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT -import Galley.App -import Galley.Effects +import Galley.Env import Galley.Options -import Imports +import Imports hiding (log) +import Network.HTTP.Types +import Polysemy +import qualified Polysemy.Reader as P +import System.Logger +import qualified System.Logger.Class as LC import Util.Options -brigReq :: Galley r (ByteString, Word16) -brigReq = do - h <- encodeUtf8 <$> view (options . optBrig . epHost) - p <- portNumber . fromIntegral <$> view (options . optBrig . epPort) - return (h, p) +data IntraComponent = Brig | Spar | Gundeck + deriving (Show) + +componentName :: IntraComponent -> String +componentName Brig = "brig" +componentName Spar = "spar" +componentName Gundeck = "gundeck" + +componentRequest :: IntraComponent -> Opts -> Request -> Request +componentRequest Brig o = + host (encodeUtf8 (o ^. optBrig . epHost)) + . port (portNumber (fromIntegral (o ^. optBrig . epPort))) +componentRequest Spar o = + host (encodeUtf8 (o ^. optSpar . epHost)) + . port (portNumber (fromIntegral (o ^. optSpar . epPort))) +componentRequest Gundeck o = + host (encodeUtf8 $ o ^. optGundeck . epHost) + . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) + . method POST + . path "/i/push/v2" + . expect2xx -sparReq :: Galley r (ByteString, Word16) -sparReq = do - h <- encodeUtf8 <$> view (options . optSpar . epHost) - p <- portNumber . fromIntegral <$> view (options . optSpar . epPort) - return (h, p) +componentRetryPolicy :: IntraComponent -> RetryPolicy +componentRetryPolicy Brig = x1 +componentRetryPolicy Spar = x1 +componentRetryPolicy Gundeck = x3 --- gundeckReq lives in Galley.Intra.Push +embedIntra :: + Members '[Embed IO, P.Reader Env] r => + IntraM a -> + Sem r a +embedIntra action = do + env <- P.ask + embed $ runHttpT (env ^. manager) (runReaderT (unIntraM action) env) -call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LB.ByteString)) -call0 n r = liftGalley0 $ recovering x1 rpcHandlers (const (rpc n r)) +newtype IntraM a = IntraM {unIntraM :: ReaderT Env Http a} + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadHttp, + MonadThrow, + MonadCatch, + MonadMask, + MonadReader Env, + MonadUnliftIO + ) -callBrig :: Member BrigAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) -callBrig r = liftGalley0 $ call0 "brig" r +instance HasRequestId IntraM where + getRequestId = IntraM $ view reqId -callSpar :: Member SparAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) -callSpar r = liftGalley0 $ call0 "spar" r +instance MonadClient IntraM where + liftClient m = do + cs <- view cstate + liftIO $ runClient cs m + localState f = locally cstate f -callBot :: Member BotAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) -callBot r = liftGalley0 $ call0 "brig" r +instance LC.MonadLogger IntraM where + log lvl m = do + env <- ask + log (env ^. applog) lvl (reqIdMsg (env ^. reqId) . m) + +call :: + IntraComponent -> + (Request -> Request) -> + IntraM (Response (Maybe LB.ByteString)) +call comp r = do + o <- view options + let r0 = componentRequest comp o + let n = LT.pack (componentName comp) + recovering (componentRetryPolicy comp) rpcHandlers (const (rpc n (r . r0))) + +asyncCall :: IntraComponent -> (Request -> Request) -> IntraM () +asyncCall comp req = void $ do + let n = LT.pack (componentName comp) + forkIO $ catches (void (call comp req)) (handlers n) + where + handlers n = + [ Handler $ \(x :: RPCException) -> LC.err (rpcExceptionMsg x), + Handler $ \(x :: SomeException) -> LC.err $ "remote" .= n ~~ msg (show x) + ] x1 :: RetryPolicy x1 = limitRetries 1 + +x3 :: RetryPolicy +x3 = limitRetries 3 <> exponentialBackoff 100000 From 030dd8165ea5b503c391cab6b368f1d62599f7f7 Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 4 Nov 2021 11:37:03 +0100 Subject: [PATCH 68/88] Cassandra: use LOCAL_QUORUM (#1884) As per https://wearezeta.atlassian.net/browse/BM-22 using LOCAL_QUORUM should: * not change anything for a single-datacentre cassandra setup (which is our case atm) * allow to make a datacentre migration that can be rolled back. --- .../0-release-notes/cassandra-local-quorum | 1 + libs/cassandra-util/src/Cassandra.hs | 5 +- libs/cassandra-util/src/Cassandra/CQL.hs | 5 +- libs/extended/extended.cabal | 4 +- libs/extended/package.yaml | 2 +- libs/extended/src/System/Logger/Extended.hs | 2 +- services/brig/brig.cabal | 3 +- services/brig/package.yaml | 1 - services/brig/src/Brig/Code.hs | 6 +- services/brig/src/Brig/Data/Activation.hs | 10 +- services/brig/src/Brig/Data/Blacklist.hs | 12 +- services/brig/src/Brig/Data/Client.hs | 32 +++--- services/brig/src/Brig/Data/Connection.hs | 50 ++++----- services/brig/src/Brig/Data/LoginCode.hs | 8 +- services/brig/src/Brig/Data/PasswordReset.hs | 10 +- services/brig/src/Brig/Data/Properties.hs | 14 +-- services/brig/src/Brig/Data/User.hs | 66 +++++------ services/brig/src/Brig/Data/UserKey.hs | 10 +- .../src/Brig/Data/UserPendingActivation.hs | 6 +- services/brig/src/Brig/Provider/DB.hs | 42 +++---- services/brig/src/Brig/Team/DB.hs | 24 ++-- services/brig/src/Brig/Unique.hs | 6 +- services/brig/src/Brig/User/Auth/DB/Cookie.hs | 10 +- services/brig/src/Brig/User/Handle.hs | 6 +- services/brig/src/Brig/User/Search/Index.hs | 2 +- .../brig/test/integration/API/Internal.hs | 2 +- .../test/integration/API/User/Connection.hs | 2 +- .../integration/API/UserPendingActivation.hs | 2 +- services/galley/galley.cabal | 3 +- .../migrate-data/src/Galley/DataMigration.hs | 4 +- .../src/V1_BackfillBillingTeamMembers.hs | 4 +- services/galley/package.yaml | 1 - .../galley/src/Galley/Cassandra/Client.hs | 6 +- services/galley/src/Galley/Cassandra/Code.hs | 6 +- .../src/Galley/Cassandra/Conversation.hs | 40 +++---- .../Galley/Cassandra/Conversation/Members.hs | 26 ++--- .../src/Galley/Cassandra/ConversationList.hs | 8 +- .../galley/src/Galley/Cassandra/LegalHold.hs | 2 +- .../galley/src/Galley/Cassandra/Services.hs | 8 +- services/galley/src/Galley/Cassandra/Team.hs | 60 +++++----- .../galley/src/Galley/Data/CustomBackend.hs | 6 +- services/galley/src/Galley/Data/LegalHold.hs | 16 +-- .../src/Galley/Data/SearchVisibility.hs | 6 +- .../galley/src/Galley/Data/TeamFeatures.hs | 12 +- .../src/Galley/Data/TeamNotifications.hs | 6 +- services/gundeck/src/Gundeck/Client.hs | 4 +- .../gundeck/src/Gundeck/Notification/Data.hs | 14 +-- services/gundeck/src/Gundeck/Push.hs | 6 +- services/gundeck/src/Gundeck/Push/Data.hs | 6 +- services/gundeck/src/Gundeck/Push/Native.hs | 2 +- services/gundeck/src/Gundeck/React.hs | 2 +- services/gundeck/test/integration/API.hs | 2 +- .../src/Spar/DataMigration/Run.hs | 4 +- .../src/Spar/DataMigration/V1_ExternalIds.hs | 6 +- .../src/Spar/DataMigration/V2_UserV2.hs | 8 +- services/spar/src/Spar/Data.hs | 94 ++++++++-------- .../test-integration/Test/Spar/APISpec.hs | 2 +- .../Test/Spar/Scim/AuthSpec.hs | 4 +- tools/db/auto-whitelist/src/Work.hs | 6 +- .../billing-team-member-backfill/src/Work.hs | 4 +- tools/db/find-undead/src/Work.hs | 2 +- tools/db/migrate-sso-feature-flag/src/Work.hs | 4 +- tools/db/move-team/move-team.cabal | 5 +- tools/db/move-team/package.yaml | 2 +- tools/db/move-team/src/Common.hs | 3 +- tools/db/move-team/src/ParseSchema.hs | 4 +- tools/db/move-team/src/Schema.hs | 104 +++++++++--------- tools/db/move-team/src/Types.hs | 1 - tools/db/repair-handles/src/Work.hs | 10 +- tools/db/service-backfill/src/Work.hs | 6 +- 70 files changed, 428 insertions(+), 434 deletions(-) create mode 100644 changelog.d/0-release-notes/cassandra-local-quorum diff --git a/changelog.d/0-release-notes/cassandra-local-quorum b/changelog.d/0-release-notes/cassandra-local-quorum new file mode 100644 index 00000000000..7fa32fb3982 --- /dev/null +++ b/changelog.d/0-release-notes/cassandra-local-quorum @@ -0,0 +1 @@ +In case you use a multi-datacentre cassandra setup (most likely you do not), be aware that now [LOCAL_QUORUM](https://docs.datastax.com/en/cassandra-oss/3.0/cassandra/dml/dmlConfigConsistency.html) is in use as a default. diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 2b166cc9b4c..cb479bf5abd 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -26,8 +26,8 @@ import Cassandra.CQL as C ( Ascii (Ascii), BatchType (BatchLogged, BatchUnLogged), Blob (Blob), - ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn), - Consistency (All, One, Quorum), + ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn, VarCharColumn), + Consistency (All, LocalQuorum, One), -- DO NOT EXPORT 'Quorum' here (until a DC migration is complete) Cql, Keyspace (Keyspace), PagingState (..), @@ -38,6 +38,7 @@ import Cassandra.CQL as C Set (Set), Tagged (Tagged), TimeUuid (TimeUuid), + Tuple (), Value (CqlAscii, CqlBigInt, CqlBlob, CqlBoolean, CqlDouble, CqlInt, CqlList, CqlText, CqlUdt), Version (V4), W, diff --git a/libs/cassandra-util/src/Cassandra/CQL.hs b/libs/cassandra-util/src/Cassandra/CQL.hs index 058b6a5bd41..c0e29560691 100644 --- a/libs/cassandra-util/src/Cassandra/CQL.hs +++ b/libs/cassandra-util/src/Cassandra/CQL.hs @@ -25,8 +25,8 @@ import Database.CQL.Protocol as C ( Ascii (Ascii), BatchType (BatchLogged, BatchUnLogged), Blob (Blob), - ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn), - Consistency (All, One, Quorum), + ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn, VarCharColumn), + Consistency (All, LocalQuorum, One), -- DO NOT EXPORT 'Quorum' here (until a DC migration is complete) Cql, Keyspace (Keyspace), PagingState (..), @@ -37,6 +37,7 @@ import Database.CQL.Protocol as C Set (Set), Tagged (Tagged), TimeUuid (TimeUuid), + Tuple (), Value (CqlAscii, CqlBigInt, CqlBlob, CqlBoolean, CqlDouble, CqlInt, CqlList, CqlText, CqlTimestamp, CqlUdt), Version (V4), W, diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index fb7d933f708..ccadad0f1b6 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 866e03ca5b340b2470e8f7b376b18824786b15873330f6fd8483de086cfae28d +-- hash: 18004f2559de4d4ac804d0a36a2d2780d0bbc10d79ebf78f337c9e6ba7a4ff3f name: extended version: 0.1.0 @@ -36,7 +36,7 @@ library aeson , base , bytestring - , cql-io + , cassandra-util , errors , exceptions , extra diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml index 4ba1de39d18..a2239b49a1d 100644 --- a/libs/extended/package.yaml +++ b/libs/extended/package.yaml @@ -21,8 +21,8 @@ dependencies: - imports - optparse-applicative - tinylog -- cql-io - exceptions +- cassandra-util # for servant's 'ReqBodyCustomError' type defined here. - errors diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index 352e344cfc3..4c9787ee26b 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -31,13 +31,13 @@ module System.Logger.Extended ) where +import Cassandra (MonadClient) import Control.Monad.Catch import Data.Aeson import Data.Aeson.Encoding (list, pair, text) import qualified Data.ByteString.Lazy.Builder as B import qualified Data.ByteString.Lazy.Char8 as L import Data.String.Conversions (cs) -import Database.CQL.IO import GHC.Generics import Imports import System.Logger as Log diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 0b10a5456a0..8544b86ac5b 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: 3f6cdbdd5b65f096b8f3e838b1009c4a1a0dd5e295304d123a4ad90ebcdf2057 +-- hash: 67fbb228d01b995595cb10594e0e80b0ca794cb9ecabcd5ed8f5a894c8881de7 name: brig version: 1.35.0 @@ -324,7 +324,6 @@ executable brig-integration , cassandra-util , containers , cookie - , cql-io , data-timeout , email-validate , exceptions diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 0fb6928ca17..14fbd8b3456 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -201,7 +201,6 @@ executables: - cassandra-util - containers - cookie - - cql-io - data-timeout - email-validate - exceptions diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs index 76475084e7f..ff4ead2ebf2 100644 --- a/services/brig/src/Brig/Code.hs +++ b/services/brig/src/Brig/Code.hs @@ -239,7 +239,7 @@ insert c = do let e = codeForEmail c let p = codeForPhone c let t = round (codeTTL c) - retry x5 (write cql (params Quorum (k, s, v, r, e, p, a, t))) + retry x5 (write cql (params LocalQuorum (k, s, v, r, e, p, a, t))) where cql :: PrepQuery W (Key, Scope, Value, Retries, Maybe Email, Maybe Phone, Maybe UUID, Int32) () cql = @@ -248,7 +248,7 @@ insert c = do -- | Lookup a pending code. lookup :: MonadClient m => Key -> Scope -> m (Maybe Code) -lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params Quorum (k, s))) +lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) where cql :: PrepQuery R (Key, Scope) (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) cql = @@ -269,7 +269,7 @@ verify k s v = lookup k s >>= maybe (return Nothing) continue -- | Delete a code associated with the given key and scope. delete :: MonadClient m => Key -> Scope -> m () -delete k s = retry x5 $ write cql (params Quorum (k, s)) +delete k s = retry x5 $ write cql (params LocalQuorum (k, s)) where cql :: PrepQuery W (Key, Scope) () cql = "DELETE FROM vcodes WHERE key = ? AND scope = ?" diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 55329cca716..8cce76a40bc 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -141,7 +141,7 @@ newActivation uk timeout u = do where insert t k c = do key <- liftIO $ mkActivationKey uk - retry x5 . write keyInsert $ params Quorum (key, t, k, c, u, maxAttempts, round timeout) + retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, maxAttempts, round timeout) return $ Activation key c genCode = ActivationCode . Ascii.unsafeFromText . pack . printf "%06d" @@ -151,7 +151,7 @@ newActivation uk timeout u = do lookupActivationCode :: UserKey -> AppIO (Maybe (Maybe UserId, ActivationCode)) lookupActivationCode k = liftIO (mkActivationKey k) - >>= retry x1 . query1 codeSelect . params Quorum . Identity + >>= retry x1 . query1 codeSelect . params LocalQuorum . Identity -- | Verify an activation code. verifyCode :: @@ -159,7 +159,7 @@ verifyCode :: ActivationCode -> ExceptT ActivationError AppIO (UserKey, Maybe UserId) verifyCode key code = do - s <- lift . retry x1 . query1 keySelect $ params Quorum (Identity key) + s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) case s of Just (ttl, Ascii t, k, c, u, r) -> if @@ -175,7 +175,7 @@ verifyCode key code = do Just p -> return (userPhoneKey p, u) Nothing -> throwE invalidCode mkScope _ _ _ = throwE invalidCode - countdown = lift . retry x5 . write keyInsert . params Quorum + countdown = lift . retry x5 . write keyInsert . params LocalQuorum revoke = lift $ deleteActivationPair key mkActivationKey :: UserKey -> IO ActivationKey @@ -186,7 +186,7 @@ mkActivationKey k = do return . ActivationKey $ Ascii.encodeBase64Url bs deleteActivationPair :: ActivationKey -> AppIO () -deleteActivationPair = write keyDelete . params Quorum . Identity +deleteActivationPair = write keyDelete . params LocalQuorum . Identity invalidUser :: ActivationError invalidUser = InvalidActivationCode "User does not exist." diff --git a/services/brig/src/Brig/Data/Blacklist.hs b/services/brig/src/Brig/Data/Blacklist.hs index 6a1325d51a7..89e571811ac 100644 --- a/services/brig/src/Brig/Data/Blacklist.hs +++ b/services/brig/src/Brig/Data/Blacklist.hs @@ -38,15 +38,15 @@ import Imports -- UserKey blacklisting insert :: MonadClient m => UserKey -> m () -insert uk = retry x5 $ write keyInsert (params Quorum (Identity $ keyText uk)) +insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ keyText uk)) exists :: MonadClient m => UserKey -> m Bool exists uk = return . isJust =<< fmap runIdentity - <$> retry x1 (query1 keySelect (params Quorum (Identity $ keyText uk))) + <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText uk))) delete :: MonadClient m => UserKey -> m () -delete uk = retry x5 $ write keyDelete (params Quorum (Identity $ keyText uk)) +delete uk = retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText uk)) keyInsert :: PrepQuery W (Identity Text) () keyInsert = "INSERT INTO blacklist (key) VALUES (?)" @@ -61,13 +61,13 @@ keyDelete = "DELETE FROM blacklist WHERE key = ?" -- Excluded phone prefixes insertPrefix :: MonadClient m => ExcludedPrefix -> m () -insertPrefix prefix = retry x5 $ write ins (params Quorum (phonePrefix prefix, comment prefix)) +insertPrefix prefix = retry x5 $ write ins (params LocalQuorum (phonePrefix prefix, comment prefix)) where ins :: PrepQuery W (PhonePrefix, Text) () ins = "INSERT INTO excluded_phones (prefix, comment) VALUES (?, ?)" deletePrefix :: MonadClient m => PhonePrefix -> m () -deletePrefix prefix = retry x5 $ write del (params Quorum (Identity prefix)) +deletePrefix prefix = retry x5 $ write del (params LocalQuorum (Identity prefix)) where del :: PrepQuery W (Identity PhonePrefix) () del = "DELETE FROM excluded_phones WHERE prefix = ?" @@ -84,7 +84,7 @@ existsAnyPrefix phone = do selectPrefixes :: MonadClient m => [Text] -> m [ExcludedPrefix] selectPrefixes prefixes = do - results <- retry x1 (query sel (params Quorum (Identity $ prefixes))) + results <- retry x1 (query sel (params LocalQuorum (Identity $ prefixes))) return $ (\(p, c) -> ExcludedPrefix p c) <$> results where sel :: PrepQuery R (Identity [Text]) (PhonePrefix, Text) diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 45b5631220e..b6a322f8877 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -130,13 +130,13 @@ addClient u newId c maxPermClients loc cps = do lon = Longitude . view longitude <$> loc mdl = newClientModel c prm = (u, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, lat, lon, mdl, C.Set . Set.toList <$> cps) - retry x5 $ write insertClient (params Quorum prm) + retry x5 $ write insertClient (params LocalQuorum prm) return $! Client newId (newClientType c) now (newClientClass c) (newClientLabel c) (newClientCookie c) loc mdl (ClientCapabilityList $ fromMaybe mempty cps) lookupClient :: MonadClient m => UserId -> ClientId -> m (Maybe Client) lookupClient u c = fmap toClient - <$> retry x1 (query1 selectClient (params Quorum (u, c))) + <$> retry x1 (query1 selectClient (params LocalQuorum (u, c))) lookupClientsBulk :: (MonadClient m) => [UserId] -> m (Map UserId (Imports.Set Client)) lookupClientsBulk uids = liftClient $ do @@ -147,7 +147,7 @@ lookupClientsBulk uids = liftClient $ do getClientSetWithUser u = (u,) . Set.fromList <$> executeQuery u executeQuery :: MonadClient m => UserId -> m [Client] - executeQuery u = toClient <$$> retry x1 (query selectClients (params Quorum (Identity u))) + executeQuery u = toClient <$$> retry x1 (query selectClients (params LocalQuorum (Identity u))) lookupPubClientsBulk :: (MonadClient m) => [UserId] -> m (UserMap (Imports.Set PubClient)) lookupPubClientsBulk uids = liftClient $ do @@ -158,17 +158,17 @@ lookupPubClientsBulk uids = liftClient $ do getClientSetWithUser u = (u,) . Set.fromList . map toPubClient <$> executeQuery u executeQuery :: MonadClient m => UserId -> m [(ClientId, Maybe ClientClass)] - executeQuery u = retry x1 (query selectPubClients (params Quorum (Identity u))) + executeQuery u = retry x1 (query selectPubClients (params LocalQuorum (Identity u))) lookupClients :: MonadClient m => UserId -> m [Client] lookupClients u = map toClient - <$> retry x1 (query selectClients (params Quorum (Identity u))) + <$> retry x1 (query selectClients (params LocalQuorum (Identity u))) lookupClientIds :: MonadClient m => UserId -> m [ClientId] lookupClientIds u = map runIdentity - <$> retry x1 (query selectClientIds (params Quorum (Identity u))) + <$> retry x1 (query selectClientIds (params LocalQuorum (Identity u))) lookupUsersClientIds :: MonadClient m => [UserId] -> m [(UserId, Set.Set ClientId)] lookupUsersClientIds us = @@ -179,22 +179,22 @@ lookupUsersClientIds us = lookupPrekeyIds :: MonadClient m => UserId -> ClientId -> m [PrekeyId] lookupPrekeyIds u c = map runIdentity - <$> retry x1 (query selectPrekeyIds (params Quorum (u, c))) + <$> retry x1 (query selectPrekeyIds (params LocalQuorum (u, c))) hasClient :: MonadClient m => UserId -> ClientId -> m Bool -hasClient u d = isJust <$> retry x1 (query1 checkClient (params Quorum (u, d))) +hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) rmClient :: UserId -> ClientId -> AppIO () rmClient u c = do - retry x5 $ write removeClient (params Quorum (u, c)) - retry x5 $ write removeClientKeys (params Quorum (u, c)) + retry x5 $ write removeClient (params LocalQuorum (u, c)) + retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) unlessM (isJust <$> view randomPrekeyLocalLock) $ deleteOptLock u c updateClientLabel :: MonadClient m => UserId -> ClientId -> Maybe Text -> m () -updateClientLabel u c l = retry x5 $ write updateClientLabelQuery (params Quorum (l, u, c)) +updateClientLabel u c l = retry x5 $ write updateClientLabelQuery (params LocalQuorum (l, u, c)) updateClientCapabilities :: MonadClient m => UserId -> ClientId -> Maybe (Imports.Set ClientCapability) -> m () -updateClientCapabilities u c fs = retry x5 $ write updateClientCapabilitiesQuery (params Quorum (C.Set . Set.toList <$> fs, u, c)) +updateClientCapabilities u c fs = retry x5 $ write updateClientCapabilitiesQuery (params LocalQuorum (C.Set . Set.toList <$> fs, u, c)) updatePrekeys :: MonadClient m => UserId -> ClientId -> [Prekey] -> ExceptT ClientDataError m () updatePrekeys u c pks = do @@ -204,7 +204,7 @@ updatePrekeys u c pks = do throwE MalformedPrekeys for_ pks $ \k -> do let args = (u, c, prekeyId k, prekeyKey k) - retry x5 $ write insertClientKey (params Quorum args) + retry x5 $ write insertClientKey (params LocalQuorum args) where check a b = do i <- CryptoBox.isPrekey b @@ -217,18 +217,18 @@ claimPrekey u c = view randomPrekeyLocalLock >>= \case -- Use random prekey selection strategy Just localLock -> withLocalLock localLock $ do - prekeys <- retry x1 $ query userPrekeys (params Quorum (u, c)) + prekeys <- retry x1 $ query userPrekeys (params LocalQuorum (u, c)) prekey <- pickRandomPrekey prekeys removeAndReturnPreKey prekey -- Use DynamoDB based optimistic locking strategy Nothing -> withOptLock u c $ do - prekey <- retry x1 $ query1 userPrekey (params Quorum (u, c)) + prekey <- retry x1 $ query1 userPrekey (params LocalQuorum (u, c)) removeAndReturnPreKey prekey where removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> AppIO (Maybe ClientPrekey) removeAndReturnPreKey (Just (i, k)) = do if i /= lastPrekeyId - then retry x1 $ write removePrekey (params Quorum (u, c, i)) + then retry x1 $ write removePrekey (params LocalQuorum (u, c, i)) else Log.debug $ field "user" (toByteString u) diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 79d69990561..5c7ccf38d7a 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -78,10 +78,10 @@ insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = write connectionInsert $ - params Quorum (tUnqualified self, ltarget, rel, now, cnv) + params LocalQuorum (tUnqualified self, ltarget, rel, now, cnv) let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionInsert $ - params Quorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + params LocalQuorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) retry x5 $ foldQualified self local remote target pure $ UserConnection @@ -107,10 +107,10 @@ updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = write connectionUpdate $ - params Quorum (status, now, tUnqualified self, ltarget) + params LocalQuorum (status, now, tUnqualified self, ltarget) let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionUpdate $ - params Quorum (status, now, tUnqualified self, domain, rtarget) + params LocalQuorum (status, now, tUnqualified self, domain, rtarget) retry x5 $ foldQualified self local remote target pure now @@ -120,12 +120,12 @@ lookupConnection self target = runMaybeT $ do let local (tUnqualified -> ltarget) = do (_, _, rel, time, mcnv) <- MaybeT . query1 connectionSelect $ - params Quorum (tUnqualified self, ltarget) + params LocalQuorum (tUnqualified self, ltarget) pure (rel, time, fmap (qUntagged . qualifyAs self) mcnv) let remote (qUntagged -> Qualified rtarget domain) = do (rel, time, cdomain, cnv) <- MaybeT . query1 remoteConnectionSelectFrom $ - params Quorum (tUnqualified self, domain, rtarget) + params LocalQuorum (tUnqualified self, domain, rtarget) pure (rel, time, Just (Qualified cnv cdomain)) (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target pure $ @@ -146,9 +146,9 @@ lookupRelationWithHistory :: AppIO (Maybe RelationWithHistory) lookupRelationWithHistory self target = do let local (tUnqualified -> ltarget) = - query1 relationSelect (params Quorum (tUnqualified self, ltarget)) + query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) let remote (qUntagged -> Qualified rtarget domain) = - query1 remoteRelationSelect (params Quorum (tUnqualified self, domain, rtarget)) + query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation @@ -163,10 +163,10 @@ lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of Just u -> retry x1 $ - paginate connectionsSelectFrom (paramsP Quorum (tUnqualified lfrom, u) (size + 1)) + paginate connectionsSelectFrom (paramsP LocalQuorum (tUnqualified lfrom, u) (size + 1)) Nothing -> retry x1 $ - paginate connectionsSelect (paramsP Quorum (Identity (tUnqualified lfrom)) (size + 1)) + paginate connectionsSelect (paramsP LocalQuorum (Identity (tUnqualified lfrom)) (size + 1)) where toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim trim p = p {result = take (fromIntegral size) (result p)} @@ -180,7 +180,7 @@ lookupLocalConnectionsPage :: Range 1 1000 Int32 -> m (PageWithState UserConnection) lookupLocalConnectionsPage self pagingState (fromRange -> size) = - fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) -- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. lookupRemoteConnectionsPage :: @@ -193,19 +193,19 @@ lookupRemoteConnectionsPage self pagingState size = fmap (toRemoteUserConnection self) <$> paginateWithState remoteConnectionSelect - (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) + (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] lookupConnectionStatus from to = map toConnectionStatus - <$> retry x1 (query connectionStatusSelect (params Quorum (from, to))) + <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus' :: [UserId] -> AppIO [ConnectionStatus] lookupConnectionStatus' from = map toConnectionStatus - <$> retry x1 (query connectionStatusSelect' (params Quorum (Identity from))) + <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> AppIO [ConnectionStatusV2] lookupLocalConnectionStatuses froms tos = do @@ -214,7 +214,7 @@ lookupLocalConnectionStatuses froms tos = do lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query relationsSelect (params Quorum (from, tUnqualified tos))) + <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> AppIO [ConnectionStatusV2] lookupRemoteConnectionStatuses froms tos = do @@ -223,7 +223,7 @@ lookupRemoteConnectionStatuses froms tos = do lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query remoteRelationsSelect (params Quorum (from, tDomain tos, tUnqualified tos))) + <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) lookupAllStatuses :: Local [UserId] -> AppIO [ConnectionStatusV2] lookupAllStatuses lfroms = do @@ -236,15 +236,15 @@ lookupAllStatuses lfroms = do lookupLocalStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupLocalStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) - <$> retry x1 (query relationsSelectAll (params Quorum (Identity from))) + <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) lookupRemoteStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupRemoteStatuses from = map (\(d, u, r) -> toConnectionStatusV2 from d u r) - <$> retry x1 (query remoteRelationsSelectAll (params Quorum (Identity from))) + <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) lookupRemoteConnectedUsersC :: forall m. (MonadClient m) => UserId -> Int32 -> ConduitT () [Remote UserId] m () lookupRemoteConnectedUsersC u maxResults = - paginateC remoteConnectionsSelectUsers (paramsP Quorum (Identity u) maxResults) x1 + paginateC remoteConnectionsSelectUsers (paramsP LocalQuorum (Identity u) maxResults) x1 .| C.map (map (uncurry toRemoteUnsafe)) -- | See 'lookupContactListWithRelation'. @@ -256,7 +256,7 @@ lookupContactList u = -- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). lookupContactListWithRelation :: UserId -> AppIO [(UserId, RelationWithHistory)] lookupContactListWithRelation u = - retry x1 (query contactsSelect (params Quorum (Identity u))) + retry x1 (query contactsSelect (params LocalQuorum (Identity u))) -- | Count the number of connections a user has in a specific relation status. -- (If you want to distinguish 'RelationWithHistory', write a new function.) @@ -280,17 +280,17 @@ countConnections u r = do deleteConnections :: UserId -> AppIO () deleteConnections u = do runConduit $ - paginateC contactsSelect (paramsP Quorum (Identity u) 100) x1 + paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 .| C.mapM_ (pooledMapConcurrentlyN_ 16 delete) - retry x1 . write connectionClear $ params Quorum (Identity u) - retry x1 . write remoteConnectionClear $ params Quorum (Identity u) + retry x1 . write connectionClear $ params LocalQuorum (Identity u) + retry x1 . write remoteConnectionClear $ params LocalQuorum (Identity u) where - delete (other, _status) = write connectionDelete $ params Quorum (other, u) + delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> AppIO () deleteRemoteConnections (qUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = pooledForConcurrentlyN_ 16 locals $ \u -> - write remoteConnectionDelete $ params Quorum (u, remoteDomain, remoteUser) + write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) -- Queries diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs index e9a2d60f4f2..5bd06b68a38 100644 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ b/services/brig/src/Brig/Data/LoginCode.hs @@ -59,7 +59,7 @@ createLoginCode u = do verifyLoginCode :: UserId -> LoginCode -> AppIO Bool verifyLoginCode u c = do - code <- retry x1 (query1 codeSelect (params Quorum (Identity u))) + code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) now <- liftIO =<< view currentTime case code of Just (c', _, t) | c == c' && t >= now -> deleteLoginCode u >> return True @@ -70,7 +70,7 @@ verifyLoginCode u c = do lookupLoginCode :: UserId -> AppIO (Maybe PendingLoginCode) lookupLoginCode u = do now <- liftIO =<< view currentTime - validate now =<< retry x1 (query1 codeSelect (params Quorum (Identity u))) + validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) where validate now (Just (c, _, t)) | now < t = return (Just (pending c now t)) validate _ _ = return Nothing @@ -78,10 +78,10 @@ lookupLoginCode u = do timeout now t = Timeout (t `diffUTCTime` now) deleteLoginCode :: UserId -> AppIO () -deleteLoginCode u = retry x5 . write codeDelete $ params Quorum (Identity u) +deleteLoginCode u = retry x5 . write codeDelete $ params LocalQuorum (Identity u) insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> AppIO () -insertLoginCode u c n t = retry x5 . write codeInsert $ params Quorum (u, c, n, t, round ttl) +insertLoginCode u c n t = retry x5 . write codeInsert $ params LocalQuorum (u, c, n, t, round ttl) -- Queries diff --git a/services/brig/src/Brig/Data/PasswordReset.hs b/services/brig/src/Brig/Data/PasswordReset.hs index 62b85323161..c486515d394 100644 --- a/services/brig/src/Brig/Data/PasswordReset.hs +++ b/services/brig/src/Brig/Data/PasswordReset.hs @@ -53,7 +53,7 @@ createPasswordResetCode u target = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime code <- liftIO $ either (const genEmailCode) (const genPhoneCode) target - retry x5 . write codeInsert $ params Quorum (key, code, u, maxAttempts, ttl `addUTCTime` now, round ttl) + retry x5 . write codeInsert $ params LocalQuorum (key, code, u, maxAttempts, ttl `addUTCTime` now, round ttl) return (key, code) where genEmailCode = PasswordResetCode . Ascii.encodeBase64Url <$> randBytes 24 @@ -65,7 +65,7 @@ lookupPasswordResetCode :: UserId -> AppIO (Maybe PasswordResetCode) lookupPasswordResetCode u = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime - validate now =<< retry x1 (query1 codeSelect (params Quorum (Identity key))) + validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity key))) where validate now (Just (c, _, _, Just t)) | t > now = return $ Just c validate _ _ = return Nothing @@ -73,7 +73,7 @@ lookupPasswordResetCode u = do verifyPasswordResetCode :: PasswordResetPair -> AppIO (Maybe UserId) verifyPasswordResetCode (k, c) = do now <- liftIO =<< view currentTime - code <- retry x1 (query1 codeSelect (params Quorum (Identity k))) + code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity k))) case code of Just (c', u, _, Just t) | c == c' && t >= now -> return (Just u) Just (c', u, Just n, Just t) | n > 1 && t > now -> do @@ -82,10 +82,10 @@ verifyPasswordResetCode (k, c) = do Just (_, _, _, _) -> deletePasswordResetCode k >> return Nothing Nothing -> return Nothing where - countdown = retry x5 . write codeInsert . params Quorum + countdown = retry x5 . write codeInsert . params LocalQuorum deletePasswordResetCode :: PasswordResetKey -> AppIO () -deletePasswordResetCode k = retry x5 . write codeDelete $ params Quorum (Identity k) +deletePasswordResetCode k = retry x5 . write codeDelete $ params LocalQuorum (Identity k) mkPasswordResetKey :: (MonadIO m) => UserId -> m PasswordResetKey mkPasswordResetKey u = do diff --git a/services/brig/src/Brig/Data/Properties.hs b/services/brig/src/Brig/Data/Properties.hs index 832e3ca23dc..18f49c7dd7e 100644 --- a/services/brig/src/Brig/Data/Properties.hs +++ b/services/brig/src/Brig/Data/Properties.hs @@ -42,31 +42,31 @@ data PropertiesDataError insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () insertProperty u k v = do - n <- lift . fmap (maybe 0 runIdentity) . retry x1 $ query1 propertyCount (params Quorum (Identity u)) + n <- lift . fmap (maybe 0 runIdentity) . retry x1 $ query1 propertyCount (params LocalQuorum (Identity u)) unless (n < maxProperties) $ throwE TooManyProperties - lift . retry x5 $ write propertyInsert (params Quorum (u, k, v)) + lift . retry x5 $ write propertyInsert (params LocalQuorum (u, k, v)) deleteProperty :: UserId -> PropertyKey -> AppIO () -deleteProperty u k = retry x5 $ write propertyDelete (params Quorum (u, k)) +deleteProperty u k = retry x5 $ write propertyDelete (params LocalQuorum (u, k)) clearProperties :: UserId -> AppIO () -clearProperties u = retry x5 $ write propertyReset (params Quorum (Identity u)) +clearProperties u = retry x5 $ write propertyReset (params LocalQuorum (Identity u)) lookupProperty :: UserId -> PropertyKey -> AppIO (Maybe PropertyValue) lookupProperty u k = fmap runIdentity - <$> retry x1 (query1 propertySelect (params Quorum (u, k))) + <$> retry x1 (query1 propertySelect (params LocalQuorum (u, k))) lookupPropertyKeys :: UserId -> AppIO [PropertyKey] lookupPropertyKeys u = map runIdentity - <$> retry x1 (query propertyKeysSelect (params Quorum (Identity u))) + <$> retry x1 (query propertyKeysSelect (params LocalQuorum (Identity u))) lookupPropertyKeysAndValues :: UserId -> AppIO PropertyKeysAndValues lookupPropertyKeysAndValues u = PropertyKeysAndValues - <$> retry x1 (query propertyKeysValuesSelect (params Quorum (Identity u))) + <$> retry x1 (query propertyKeysValuesSelect (params LocalQuorum (Identity u))) ------------------------------------------------------------------------------- -- Queries diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 8187266ceb6..eed03c3e649 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -220,7 +220,7 @@ insertAccount :: AppIO () insertAccount (UserAccount u status) mbConv password activated = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum let Locale l c = userLocale u addPrepQuery userInsert @@ -261,60 +261,60 @@ insertAccount (UserAccount u status) mbConv password activated = retry x5 . batc \VALUES (?, ?, ?, ?, ?)" updateLocale :: UserId -> Locale -> AppIO () -updateLocale u (Locale l c) = write userLocaleUpdate (params Quorum (l, c, u)) +updateLocale u (Locale l c) = write userLocaleUpdate (params LocalQuorum (l, c, u)) updateUser :: UserId -> UserUpdate -> AppIO () updateUser u UserUpdate {..} = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ uupName $ \n -> addPrepQuery userDisplayNameUpdate (n, u) for_ uupPict $ \p -> addPrepQuery userPictUpdate (p, u) for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) updateEmail :: UserId -> Email -> AppIO () -updateEmail u e = retry x5 $ write userEmailUpdate (params Quorum (e, u)) +updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) updatePhone :: UserId -> Phone -> AppIO () -updatePhone u p = retry x5 $ write userPhoneUpdate (params Quorum (p, u)) +updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) updateSSOId :: UserId -> Maybe UserSSOId -> AppIO Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u case mteamid of Just _ -> do - retry x5 $ write userSSOIdUpdate (params Quorum (ssoid, u)) + retry x5 $ write userSSOIdUpdate (params LocalQuorum (ssoid, u)) pure True Nothing -> pure False updateManagedBy :: UserId -> ManagedBy -> AppIO () -updateManagedBy u h = retry x5 $ write userManagedByUpdate (params Quorum (h, u)) +updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) updateHandle :: UserId -> Handle -> AppIO () -updateHandle u h = retry x5 $ write userHandleUpdate (params Quorum (h, u)) +updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) updatePassword :: UserId -> PlainTextPassword -> AppIO () updatePassword u t = do p <- liftIO $ mkSafePassword t - retry x5 $ write userPasswordUpdate (params Quorum (p, u)) + retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) updateRichInfo :: UserId -> RichInfoAssocList -> AppIO () -updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params Quorum (ri, u)) +updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> AppIO (Maybe ApiFt.TeamFeatureStatusNoConfig) updateFeatureConferenceCalling uid mbStatus = do let flag = ApiFt.tfwoStatus <$> mbStatus - retry x5 $ write update (params Quorum (flag, uid)) + retry x5 $ write update (params LocalQuorum (flag, uid)) pure mbStatus where update :: PrepQuery W (Maybe ApiFt.TeamFeatureStatusValue, UserId) () update = fromString $ "update user set feature_conference_calling = ? where id = ?" deleteEmail :: UserId -> AppIO () -deleteEmail u = retry x5 $ write userEmailDelete (params Quorum (Identity u)) +deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) deletePhone :: UserId -> AppIO () -deletePhone u = retry x5 $ write userPhoneDelete (params Quorum (Identity u)) +deletePhone u = retry x5 $ write userPhoneDelete (params LocalQuorum (Identity u)) deleteServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO () deleteServiceUser pid sid bid = do @@ -322,7 +322,7 @@ deleteServiceUser pid sid bid = do Nothing -> pure () Just (_, mbTid) -> retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery cql (pid, sid, bid) for_ mbTid $ \tid -> addPrepQuery cqlTeam (pid, sid, tid, bid) @@ -337,19 +337,19 @@ deleteServiceUser pid sid bid = do \WHERE provider = ? AND service = ? AND team = ? AND user = ?" updateStatus :: UserId -> AccountStatus -> AppIO () -updateStatus u s = retry x5 $ write userStatusUpdate (params Quorum (s, u)) +updateStatus u s = retry x5 $ write userStatusUpdate (params LocalQuorum (s, u)) -- | Whether the account has been activated by verifying -- an email address or phone number. isActivated :: UserId -> AppIO Bool isActivated u = (== Just (Identity True)) - <$> retry x1 (query1 activatedSelect (params Quorum (Identity u))) + <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) filterActive :: [UserId] -> AppIO [UserId] filterActive us = map (view _1) . filter isActiveUser - <$> retry x1 (query accountStateSelectAll (params Quorum (Identity us))) + <$> retry x1 (query accountStateSelectAll (params LocalQuorum (Identity us))) where isActiveUser :: (UserId, Bool, Maybe AccountStatus) -> Bool isActiveUser (_, True, Just Active) = True @@ -362,42 +362,42 @@ activateUser :: UserId -> UserIdentity -> AppIO () activateUser u ident = do let email = emailIdentity ident let phone = phoneIdentity ident - retry x5 $ write userActivatedUpdate (params Quorum (email, phone, u)) + retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) deactivateUser :: UserId -> AppIO () deactivateUser u = - retry x5 $ write userDeactivatedUpdate (params Quorum (Identity u)) + retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) lookupLocale :: UserId -> AppIO (Maybe Locale) lookupLocale u = do defLoc <- setDefaultLocale <$> view settings - fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params Quorum (Identity u))) + fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) lookupName :: UserId -> AppIO (Maybe Name) lookupName u = fmap runIdentity - <$> retry x1 (query1 nameSelect (params Quorum (Identity u))) + <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) lookupPassword :: UserId -> AppIO (Maybe Password) lookupPassword u = join . fmap runIdentity - <$> retry x1 (query1 passwordSelect (params Quorum (Identity u))) + <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) lookupStatus :: UserId -> AppIO (Maybe AccountStatus) lookupStatus u = join . fmap runIdentity - <$> retry x1 (query1 statusSelect (params Quorum (Identity u))) + <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) lookupRichInfo :: UserId -> AppIO (Maybe RichInfoAssocList) lookupRichInfo u = fmap runIdentity - <$> retry x1 (query1 richInfoSelect (params Quorum (Identity u))) + <$> retry x1 (query1 richInfoSelect (params LocalQuorum (Identity u))) -- | Returned rich infos are in the same order as users lookupRichInfoMultiUsers :: [UserId] -> AppIO [(UserId, RichInfo)] lookupRichInfoMultiUsers users = do mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) - <$> retry x1 (query richInfoSelectMulti (params Quorum (Identity users))) + <$> retry x1 (query richInfoSelectMulti (params LocalQuorum (Identity users))) -- | Lookup user (no matter what status) and return 'TeamId'. Safe to use for authorization: -- suspended / deleted / ... users can't login, so no harm done if we authorize them *after* @@ -405,10 +405,10 @@ lookupRichInfoMultiUsers users = do lookupUserTeam :: UserId -> AppIO (Maybe TeamId) lookupUserTeam u = join . fmap runIdentity - <$> retry x1 (query1 teamSelect (params Quorum (Identity u))) + <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) lookupAuth :: (MonadClient m) => UserId -> m (Maybe (Maybe Password, AccountStatus)) -lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params Quorum (Identity u))) +lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity u))) where f (pw, st) = (pw, fromMaybe Active st) @@ -419,7 +419,7 @@ lookupUsers :: HavePendingInvitations -> [UserId] -> AppIO [User] lookupUsers hpi usrs = do loc <- setDefaultLocale <$> view settings domain <- viewFederationDomain - toUsers domain loc hpi <$> retry x1 (query usersSelect (params Quorum (Identity usrs))) + toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) lookupAccount :: UserId -> AppIO (Maybe UserAccount) lookupAccount u = listToMaybe <$> lookupAccounts [u] @@ -428,10 +428,10 @@ lookupAccounts :: [UserId] -> AppIO [UserAccount] lookupAccounts usrs = do loc <- setDefaultLocale <$> view settings domain <- viewFederationDomain - fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params Quorum (Identity usrs))) + fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) lookupServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO (Maybe (ConvId, Maybe TeamId)) -lookupServiceUser pid sid bid = retry x1 (query1 cql (params Quorum (pid, sid, bid))) +lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) cql = @@ -444,7 +444,7 @@ lookupServiceUsers :: ServiceId -> ConduitM () [(BotId, ConvId, Maybe TeamId)] AppIO () lookupServiceUsers pid sid = - paginateC cql (paramsP Quorum (pid, sid) 100) x1 + paginateC cql (paramsP LocalQuorum (pid, sid) 100) x1 where cql :: PrepQuery R (ProviderId, ServiceId) (BotId, ConvId, Maybe TeamId) cql = @@ -457,7 +457,7 @@ lookupServiceUsersForTeam :: TeamId -> ConduitM () [(BotId, ConvId)] AppIO () lookupServiceUsersForTeam pid sid tid = - paginateC cql (paramsP Quorum (pid, sid, tid) 100) x1 + paginateC cql (paramsP LocalQuorum (pid, sid, tid) 100) x1 where cql :: PrepQuery R (ProviderId, ServiceId, TeamId) (BotId, ConvId) cql = @@ -466,7 +466,7 @@ lookupServiceUsersForTeam pid sid tid = lookupFeatureConferenceCalling :: MonadClient m => UserId -> m (Maybe ApiFt.TeamFeatureStatusNoConfig) lookupFeatureConferenceCalling uid = do - let q = query1 select (params Quorum (Identity uid)) + let q = query1 select (params LocalQuorum (Identity uid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q pure $ ApiFt.TeamFeatureStatusNoConfig <$> mStatusValue where diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index 408973ff0dd..12ab1e27881 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -149,20 +149,20 @@ keyAvailable k u = do lookupKey :: UserKey -> AppIO (Maybe UserId) lookupKey k = fmap runIdentity - <$> retry x1 (query1 keySelect (params Quorum (Identity $ keyText k))) + <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) insertKey :: UserId -> UserKey -> AppIO () insertKey u k = do hk <- hashKey k let kt = foldKey (\(_ :: Email) -> UKHashEmail) (\(_ :: Phone) -> UKHashPhone) k - retry x5 $ write insertHashed (params Quorum (hk, kt, u)) - retry x5 $ write keyInsert (params Quorum (keyText k, u)) + retry x5 $ write insertHashed (params LocalQuorum (hk, kt, u)) + retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) deleteKey :: UserKey -> AppIO () deleteKey k = do hk <- hashKey k - retry x5 $ write deleteHashed (params Quorum (Identity hk)) - retry x5 $ write keyDelete (params Quorum (Identity $ keyText k)) + retry x5 $ write deleteHashed (params LocalQuorum (Identity hk)) + retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) hashKey :: UserKey -> AppIO UserKeyHash hashKey uk = do diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index f56025ccd26..44283515d20 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -40,14 +40,14 @@ data UserPendingActivation = UserPendingActivation usersPendingActivationAdd :: UserPendingActivation -> AppIO () usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do - retry x5 . write insertExpiration . params Quorum $ (uid, expiresAt) + retry x5 . write insertExpiration . params LocalQuorum $ (uid, expiresAt) where insertExpiration :: PrepQuery W (UserId, UTCTime) () insertExpiration = "INSERT INTO users_pending_activation (user, expires_at) VALUES (?, ?)" usersPendingActivationList :: AppIO (Page UserPendingActivation) usersPendingActivationList = do - uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params Quorum ())) + uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params LocalQuorum ())) where selectExpired :: PrepQuery R () (UserId, UTCTime) selectExpired = @@ -58,7 +58,7 @@ usersPendingActivationRemove uid = usersPendingActivationRemoveMultiple [uid] usersPendingActivationRemoveMultiple :: [UserId] -> AppIO () usersPendingActivationRemoveMultiple uids = - retry x5 . write deleteExpired . params Quorum $ (Identity uids) + retry x5 . write deleteExpired . params LocalQuorum $ (Identity uids) where deleteExpired :: PrepQuery W (Identity [UserId]) () deleteExpired = diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index af0313ae037..35118aa13cc 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -51,7 +51,7 @@ insertAccount :: m ProviderId insertAccount name pass url descr = do pid <- randomId - retry x5 $ write cql $ params Quorum (pid, name, pass, url, descr) + retry x5 $ write cql $ params LocalQuorum (pid, name, pass, url, descr) return pid where cql :: PrepQuery W (ProviderId, Name, Password, HttpsUrl, Text) () @@ -66,7 +66,7 @@ updateAccountProfile :: m () updateAccountProfile p name url descr = retry x5 . batch $ do setType BatchUnLogged - setConsistency Quorum + setConsistency LocalQuorum for_ name $ \x -> addPrepQuery cqlName (x, p) for_ url $ \x -> addPrepQuery cqlUrl (x, p) for_ descr $ \x -> addPrepQuery cqlDescr (x, p) @@ -83,7 +83,7 @@ lookupAccountData :: MonadClient m => ProviderId -> m (Maybe (Name, Maybe Email, HttpsUrl, Text)) -lookupAccountData p = retry x1 $ query1 cql $ params Quorum (Identity p) +lookupAccountData p = retry x1 $ query1 cql $ params LocalQuorum (Identity p) where cql :: PrepQuery R (Identity ProviderId) (Name, Maybe Email, HttpsUrl, Text) cql = "SELECT name, email, url, descr FROM provider WHERE id = ?" @@ -112,7 +112,7 @@ lookupPassword p = fmap (fmap runIdentity) $ retry x1 $ query1 cql $ - params Quorum (Identity p) + params LocalQuorum (Identity p) where cql :: PrepQuery R (Identity ProviderId) (Identity Password) cql = "SELECT password FROM provider WHERE id = ?" @@ -121,7 +121,7 @@ deleteAccount :: MonadClient m => ProviderId -> m () -deleteAccount pid = retry x5 $ write cql $ params Quorum (Identity pid) +deleteAccount pid = retry x5 $ write cql $ params LocalQuorum (Identity pid) where cql :: PrepQuery W (Identity ProviderId) () cql = "DELETE FROM provider WHERE id = ?" @@ -133,7 +133,7 @@ updateAccountPassword :: m () updateAccountPassword pid pwd = do p <- liftIO $ mkSafePassword pwd - retry x5 $ write cql $ params Quorum (p, pid) + retry x5 $ write cql $ params LocalQuorum (p, pid) where cql :: PrepQuery W (Password, ProviderId) () cql = "UPDATE provider SET password = ? where id = ?" @@ -148,7 +148,7 @@ insertKey :: EmailKey -> m () insertKey p old new = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged for_ old $ \old' -> addPrepQuery cqlKeyDelete (Identity (emailKeyUniq old')) addPrepQuery cqlKeyInsert (emailKeyUniq new, p) @@ -169,13 +169,13 @@ lookupKey k = fmap (fmap runIdentity) $ retry x1 $ query1 cql $ - params Quorum (Identity (emailKeyUniq k)) + params LocalQuorum (Identity (emailKeyUniq k)) where cql :: PrepQuery R (Identity Text) (Identity ProviderId) cql = "SELECT provider FROM provider_keys WHERE key = ?" deleteKey :: MonadClient m => EmailKey -> m () -deleteKey k = retry x5 $ write cql $ params Quorum (Identity (emailKeyUniq k)) +deleteKey k = retry x5 $ write cql $ params LocalQuorum (Identity (emailKeyUniq k)) where cql :: PrepQuery W (Identity Text) () cql = "DELETE FROM provider_keys WHERE key = ?" @@ -202,7 +202,7 @@ insertService pid name summary descr url token key fprint assets tags = do retry x5 $ write cql $ params - Quorum + LocalQuorum (pid, sid, name, summary, descr, url, [token], [key], [fprint], assets, tagSet, False) return sid where @@ -237,7 +237,7 @@ lookupService pid sid = fmap (fmap mk) $ retry x1 $ query1 cql $ - params Quorum (pid, sid) + params LocalQuorum (pid, sid) where cql :: PrepQuery @@ -258,7 +258,7 @@ listServices p = fmap (map mk) $ retry x1 $ query cql $ - params Quorum (Identity p) + params LocalQuorum (Identity p) where cql :: PrepQuery @@ -286,7 +286,7 @@ updateService :: Bool -> m () updateService pid sid svcName svcTags nameChange summary descr assets tagsChange enabled = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchUnLogged -- If there is a name change, update the service name; if enabled, update indexes for_ nameChange $ \(oldName, newName) -> do @@ -331,7 +331,7 @@ deleteService pid sid name tags = do -- consumers won't be able to retry a half-done 'deleteService' call. deleteServiceWhitelist Nothing pid sid retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchUnLogged addPrepQuery cql (pid, sid) deleteServicePrefix sid name @@ -408,7 +408,7 @@ lookupServiceConn pid sid = fmap (fmap mk) $ retry x1 $ query1 cql $ - params Quorum (pid, sid) + params LocalQuorum (pid, sid) where cql :: PrepQuery R (ProviderId, ServiceId) (HttpsUrl, List1 ServiceToken, List1 (Fingerprint Rsa), Bool) cql = @@ -427,7 +427,7 @@ updateServiceConn :: Maybe Bool -> m () updateServiceConn pid sid url tokens keys enabled = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged for_ url $ \x -> addPrepQuery cqlBaseUrl (x, pid, sid) for_ tokens $ \x -> addPrepQuery cqlTokens (x, pid, sid) @@ -459,7 +459,7 @@ insertServiceIndexes :: m () insertServiceIndexes pid sid name tags = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged insertServicePrefix pid sid name insertServiceTags pid sid name tags @@ -473,7 +473,7 @@ deleteServiceIndexes :: m () deleteServiceIndexes pid sid name tags = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged deleteServicePrefix sid name deleteServiceTags pid sid name tags @@ -740,16 +740,16 @@ insertServiceWhitelist tid pid sid = deleteServiceWhitelist :: MonadClient m => Maybe TeamId -> ProviderId -> ServiceId -> m () deleteServiceWhitelist mbTid pid sid = case mbTid of Nothing -> do - teams <- retry x5 $ query lookupRev $ params Quorum (pid, sid) + teams <- retry x5 $ query lookupRev $ params LocalQuorum (pid, sid) retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery deleteAllRev (pid, sid) for_ teams $ \(Identity tid) -> addPrepQuery delete1 (tid, pid, sid) Just tid -> retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delete1 (tid, pid, sid) addPrepQuery delete1Rev (tid, pid, sid) where diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 76a472b768b..7216d751d44 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -95,7 +95,7 @@ insertInvitation iid t role (toUTCTimeMillis -> now) minviter email inviteeName let inv = Invitation t role iid now minviter email inviteeName phone retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery cqlInvitation (t, role, iid, code, email, now, minviter, inviteeName, phone, round timeout) addPrepQuery cqlInvitationInfo (code, t, iid, round timeout) addPrepQuery cqlInvitationByEmail (email, t, iid, code, round timeout) @@ -112,7 +112,7 @@ insertInvitation iid t role (toUTCTimeMillis -> now) minviter email inviteeName lookupInvitation :: MonadClient m => TeamId -> InvitationId -> m (Maybe Invitation) lookupInvitation t r = fmap toInvitation - <$> retry x1 (query1 cqlInvitation (params Quorum (t, r))) + <$> retry x1 (query1 cqlInvitation (params LocalQuorum (t, r))) where cqlInvitation :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, Email, Maybe Name, Maybe Phone) cqlInvitation = "SELECT team, role, id, created_at, created_by, email, name, phone FROM team_invitation WHERE team = ? AND id = ?" @@ -126,13 +126,13 @@ lookupInvitationByCode i = lookupInvitationCode :: MonadClient m => TeamId -> InvitationId -> m (Maybe InvitationCode) lookupInvitationCode t r = fmap runIdentity - <$> retry x1 (query1 cqlInvitationCode (params Quorum (t, r))) + <$> retry x1 (query1 cqlInvitationCode (params LocalQuorum (t, r))) where cqlInvitationCode :: PrepQuery R (TeamId, InvitationId) (Identity InvitationCode) cqlInvitationCode = "SELECT code FROM team_invitation WHERE team = ? AND id = ?" lookupInvitationCodeEmail :: MonadClient m => TeamId -> InvitationId -> m (Maybe (InvitationCode, Email)) -lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params Quorum (t, r))) +lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (t, r))) where cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, Email) cqlInvitationCodeEmail = "SELECT code, email FROM team_invitation WHERE team = ? AND id = ?" @@ -140,8 +140,8 @@ lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params lookupInvitations :: MonadClient m => TeamId -> Maybe InvitationId -> Range 1 500 Int32 -> m (ResultPage Invitation) lookupInvitations team start (fromRange -> size) = do page <- case start of - Just ref -> retry x1 $ paginate cqlSelectFrom (paramsP Quorum (team, ref) (size + 1)) - Nothing -> retry x1 $ paginate cqlSelect (paramsP Quorum (Identity team) (size + 1)) + Just ref -> retry x1 $ paginate cqlSelectFrom (paramsP LocalQuorum (team, ref) (size + 1)) + Nothing -> retry x1 $ paginate cqlSelect (paramsP LocalQuorum (Identity team) (size + 1)) return $ toResult (hasMore page) $ map toInvitation (trim page) where trim p = take (fromIntegral size) (result p) @@ -162,12 +162,12 @@ deleteInvitation t i = do case codeEmail of Just (invCode, invEmail) -> retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery cqlInvitation (t, i) addPrepQuery cqlInvitationInfo (Identity invCode) addPrepQuery cqlInvitationEmail (invEmail, t) Nothing -> - retry x5 $ write cqlInvitation (params Quorum (t, i)) + retry x5 $ write cqlInvitation (params LocalQuorum (t, i)) where cqlInvitation :: PrepQuery W (TeamId, InvitationId) () cqlInvitation = "DELETE FROM team_invitation where team = ? AND id = ?" @@ -180,7 +180,7 @@ deleteInvitations :: (MonadClient m, MonadUnliftIO m) => TeamId -> m () deleteInvitations t = liftClient $ runConduit $ - paginateC cqlSelect (paramsP Quorum (Identity t) 100) x1 + paginateC cqlSelect (paramsP LocalQuorum (Identity t) 100) x1 .| C.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitation t . runIdentity)) where cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) @@ -191,7 +191,7 @@ lookupInvitationInfo ic@(InvitationCode c) | c == mempty = return Nothing | otherwise = fmap (toInvitationInfo ic) - <$> retry x1 (query1 cqlInvitationInfo (params Quorum (Identity ic))) + <$> retry x1 (query1 cqlInvitationInfo (params LocalQuorum (Identity ic))) where toInvitationInfo i (t, r) = InvitationInfo i t r cqlInvitationInfo :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) @@ -205,7 +205,7 @@ lookupInvitationByEmail e = lookupInvitationInfoByEmail :: (Log.MonadLogger m, MonadClient m) => Email -> m InvitationByEmail lookupInvitationInfoByEmail email = do - res <- retry x1 (query cqlInvitationEmail (params Quorum (Identity email))) + res <- retry x1 (query cqlInvitationEmail (params LocalQuorum (Identity email))) case res of [] -> return InvitationByEmailNotFound (tid, invId, code) : [] -> @@ -224,7 +224,7 @@ lookupInvitationInfoByEmail email = do countInvitations :: MonadClient m => TeamId -> m Int64 countInvitations t = fromMaybe 0 . fmap runIdentity - <$> retry x1 (query1 cqlSelect (params Quorum (Identity t))) + <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity t))) where cqlSelect :: PrepQuery R (Identity TeamId) (Identity Int64) cqlSelect = "SELECT count(*) FROM team_invitation WHERE team = ?" diff --git a/services/brig/src/Brig/Unique.hs b/services/brig/src/Brig/Unique.hs index 2fc7849d22f..5c0432d172c 100644 --- a/services/brig/src/Brig/Unique.hs +++ b/services/brig/src/Brig/Unique.hs @@ -66,7 +66,7 @@ withClaim u v t io = do -- [Note: Guarantees] claim = do let ttl = max minTtl (fromIntegral (t #> Second)) - retry x5 $ write cql $ params Quorum (ttl * 2, C.Set [u], v) + retry x5 $ write cql $ params LocalQuorum (ttl * 2, C.Set [u], v) claimed <- (== [u]) <$> lookupClaims v if claimed then liftIO $ timeout (fromIntegral ttl # Second) io @@ -88,7 +88,7 @@ deleteClaim :: m () deleteClaim u v t = do let ttl = max minTtl (fromIntegral (t #> Second)) - retry x5 $ write cql $ params Quorum (ttl * 2, C.Set [u], v) + retry x5 $ write cql $ params LocalQuorum (ttl * 2, C.Set [u], v) where cql :: PrepQuery W (Int32, C.Set (Id a), Text) () cql = "UPDATE unique_claims USING TTL ? SET claims = claims - ? WHERE value = ?" @@ -99,7 +99,7 @@ lookupClaims v = fmap (maybe [] (fromSet . runIdentity)) $ retry x1 $ query1 cql $ - params Quorum (Identity v) + params LocalQuorum (Identity v) where cql :: PrepQuery R (Identity Text) (Identity (C.Set (Id a))) cql = "SELECT claims FROM unique_claims WHERE value = ?" diff --git a/services/brig/src/Brig/User/Auth/DB/Cookie.hs b/services/brig/src/Brig/User/Auth/DB/Cookie.hs index 9654883f479..7cdfcbdb964 100644 --- a/services/brig/src/Brig/User/Auth/DB/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/DB/Cookie.hs @@ -38,7 +38,7 @@ insertCookie u ck ttl = l = cookieLabel ck s = cookieSucc ck o = fromMaybe (TTL (round (diffUTCTime x c))) ttl - in retry x5 $ write cql (params Quorum (u, x, i, t, c, l, s, o)) + in retry x5 $ write cql (params LocalQuorum (u, x, i, t, c, l, s, o)) where cql :: PrepQuery W (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId, TTL) () cql = @@ -47,7 +47,7 @@ insertCookie u ck ttl = lookupCookie :: MonadClient m => UserId -> UTCTime -> CookieId -> m (Maybe (Cookie ())) lookupCookie u t c = - fmap mkCookie <$> retry x1 (query1 cql (params Quorum (u, t, c))) + fmap mkCookie <$> retry x1 (query1 cql (params LocalQuorum (u, t, c))) where mkCookie (typ, created, label, csucc) = Cookie @@ -67,7 +67,7 @@ lookupCookie u t c = listCookies :: MonadClient m => UserId -> m [Cookie ()] listCookies u = - map toCookie <$> retry x1 (query cql (params Quorum (Identity u))) + map toCookie <$> retry x1 (query cql (params LocalQuorum (Identity u))) where cql :: PrepQuery R (Identity UserId) (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) cql = @@ -90,14 +90,14 @@ listCookies u = deleteCookies :: MonadClient m => UserId -> [Cookie a] -> m () deleteCookies u cs = retry x5 . batch $ do setType BatchUnLogged - setConsistency Quorum + setConsistency LocalQuorum for_ cs $ \c -> addPrepQuery cql (u, cookieExpires c, cookieId c) where cql :: PrepQuery W (UserId, UTCTime, CookieId) () cql = "DELETE FROM user_cookies WHERE user = ? AND expires = ? AND id = ?" deleteAllCookies :: MonadClient m => UserId -> m () -deleteAllCookies u = retry x5 (write cql (params Quorum (Identity u))) +deleteAllCookies u = retry x5 (write cql (params LocalQuorum (Identity u))) where cql :: PrepQuery W (Identity UserId) () cql = "DELETE FROM user_cookies WHERE user = ?" diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 101aaf5e736..6827a41b27d 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -47,7 +47,7 @@ claimHandle uid oldHandle newHandle = runAppT env $ do -- Record ownership - retry x5 $ write handleInsert (params Quorum (newHandle, uid)) + retry x5 $ write handleInsert (params LocalQuorum (newHandle, uid)) -- Update profile result <- User.updateHandle uid newHandle -- Free old handle (if it changed) @@ -58,13 +58,13 @@ claimHandle uid oldHandle newHandle = -- | Free a 'Handle', making it available to be claimed again. freeHandle :: UserId -> Handle -> AppIO () freeHandle uid h = do - retry x5 $ write handleDelete (params Quorum (Identity h)) + retry x5 $ write handleDelete (params LocalQuorum (Identity h)) let key = "@" <> fromHandle h deleteClaim uid key (30 # Minute) -- | Lookup the current owner of a 'Handle'. lookupHandle :: Handle -> AppIO (Maybe UserId) -lookupHandle = lookupHandleWithPolicy Quorum +lookupHandle = lookupHandleWithPolicy LocalQuorum -- | A weaker version of 'lookupHandle' that trades availability -- (and potentially speed) for the possibility of returning stale data. diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index ccb2e404140..94de3110c12 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -581,7 +581,7 @@ lookupIndexUser u = lookupForIndex :: (MonadThrow m, C.MonadClient m) => UserId -> m (Maybe IndexUser) lookupForIndex u = do - result <- C.retry C.x1 (C.query1 cql (C.params C.Quorum (Identity u))) + result <- C.retry C.x1 (C.query1 cql (C.params C.LocalQuorum (Identity u))) sequence $ reindexRowToIndexUser <$> result where cql :: C.PrepQuery C.R (Identity UserId) ReindexRow diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index 2f19e86e1d1..e0b380b313d 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -8,6 +8,7 @@ import Bilge import Brig.Data.User (lookupFeatureConferenceCalling) import qualified Brig.Options as Opt import Brig.Types.User (userId) +import qualified Cassandra as Cass import Control.Exception (ErrorCall (ErrorCall), throwIO) import Control.Lens ((^.), (^?!)) import qualified Data.Aeson.Lens as Aeson @@ -15,7 +16,6 @@ import qualified Data.Aeson.Types as Aeson import Data.ByteString.Conversion (toByteString') import Data.Id import qualified Data.Set as Set -import qualified Database.CQL.IO as Cass import Imports import Test.Tasty import Test.Tasty.HUnit diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index e2678598c97..1a22019afed 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -656,7 +656,7 @@ testAllConnectionsPaging b db = do DB.retry DB.x5 $ DB.write remoteConnectionInsert $ DB.params - DB.Quorum + DB.LocalQuorum (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv) testConnectionLimit :: Brig -> ConnectionLimit -> Http () diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index c228de38bbb..9b7411bb8f3 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -132,7 +132,7 @@ waitUserExpiration opts' = do userExists :: MonadClient m => UserId -> m Bool userExists uid = do - x <- retry x1 (query1 usersSelect (params Quorum (Identity uid))) + x <- retry x1 (query1 usersSelect (params LocalQuorum (Identity uid))) pure $ case x of Nothing -> False diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 9110d9df696..fe434196d11 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: aaed6006a10580d11a903fa32d0d6d09234867ab992f293833616eb68c7071bb +-- hash: f4fae64cc086ec4a37984b47611854d490e7d34ba17147a2e53d2b11c3ca3218 name: galley version: 0.83.0 @@ -281,7 +281,6 @@ executable galley-integration , cereal , containers , cookie - , cql-io , currency-codes , data-timeout , errors diff --git a/services/galley/migrate-data/src/Galley/DataMigration.hs b/services/galley/migrate-data/src/Galley/DataMigration.hs index 8bf027be615..4e5c7752632 100644 --- a/services/galley/migrate-data/src/Galley/DataMigration.hs +++ b/services/galley/migrate-data/src/Galley/DataMigration.hs @@ -96,13 +96,13 @@ runMigration (Migration ver txt mig) = do persistVersion ver txt =<< liftIO getCurrentTime latestMigrationVersion :: MigrationActionT IO MigrationVersion -latestMigrationVersion = MigrationVersion . maybe 0 fromIntegral <$> C.query1 cql (C.params C.Quorum ()) +latestMigrationVersion = MigrationVersion . maybe 0 fromIntegral <$> C.query1 cql (C.params C.LocalQuorum ()) where cql :: C.QueryString C.R () (Identity Int32) cql = "select version from data_migration where id=1 order by version desc limit 1" persistVersion :: MigrationVersion -> Text -> UTCTime -> MigrationActionT IO () -persistVersion (MigrationVersion v) desc time = C.write cql (C.params C.Quorum (fromIntegral v, desc, time)) +persistVersion (MigrationVersion v) desc time = C.write cql (C.params C.LocalQuorum (fromIntegral v, desc, time)) where cql :: C.QueryString C.W (Int32, Text, UTCTime) () cql = "insert into data_migration (id, version, descr, date) values (1,?,?,?)" diff --git a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs index 786fe247695..09ee7cbfedd 100644 --- a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs +++ b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs @@ -57,14 +57,14 @@ pageSize = 1000 -- | Get team members from Galley getTeamMembers :: MonadClient m => ConduitM () [(TeamId, UserId, Maybe Permissions)] m () -getTeamMembers = paginateC cql (paramsP Quorum () pageSize) x5 +getTeamMembers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (TeamId, UserId, Maybe Permissions) cql = "SELECT team, user, perms FROM team_member" createBillingTeamMembers :: MonadClient m => (TeamId, UserId) -> m () createBillingTeamMembers pair = - retry x5 $ write cql (params Quorum pair) + retry x5 $ write cql (params LocalQuorum pair) where cql :: PrepQuery W (TeamId, UserId) () cql = "INSERT INTO billing_team_member (team, user) values (?, ?)" diff --git a/services/galley/package.yaml b/services/galley/package.yaml index a46530baf04..c7c5a15ff8c 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -170,7 +170,6 @@ executables: - cereal - containers - cookie - - cql-io - currency-codes - metrics-wai - data-timeout diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs index 4f01535cd68..ecf66e2f0fb 100644 --- a/services/galley/src/Galley/Cassandra/Client.hs +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -38,7 +38,7 @@ import qualified UnliftIO updateClient :: Bool -> UserId -> ClientId -> Client () updateClient add usr cls = do let q = if add then Cql.addMemberClient else Cql.rmMemberClient - retry x5 $ write (q cls) (params Quorum (Identity usr)) + retry x5 $ write (q cls) (params LocalQuorum (Identity usr)) -- Do, at most, 16 parallel lookups of up to 128 users each lookupClients :: [UserId] -> Client Clients @@ -48,10 +48,10 @@ lookupClients users = where getClients us = map (second fromSet) - <$> retry x1 (query Cql.selectClients (params Quorum (Identity us))) + <$> retry x1 (query Cql.selectClients (params LocalQuorum (Identity us))) eraseClients :: UserId -> Client () -eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user))) +eraseClients user = retry x5 (write Cql.rmClients (params LocalQuorum (Identity user))) interpretClientStoreToCassandra :: Members '[Embed IO, P.Reader ClientState] r => diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs index e03b3414a99..c41e3c09b4b 100644 --- a/services/galley/src/Galley/Cassandra/Code.hs +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -47,12 +47,12 @@ insertCode c = do let cnv = codeConversation c let t = round (codeTTL c) let s = codeScope c - retry x5 (write Cql.insertCode (params Quorum (k, v, cnv, s, t))) + retry x5 (write Cql.insertCode (params LocalQuorum (k, v, cnv, s, t))) -- | Lookup a conversation by code. lookupCode :: Key -> Scope -> Client (Maybe Code) -lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params Quorum (k, s))) +lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params LocalQuorum (k, s))) -- | Delete a code associated with the given conversation key deleteCode :: Key -> Scope -> Client () -deleteCode k s = retry x5 $ write Cql.deleteCode (params Quorum (k, s)) +deleteCode k s = retry x5 $ write Cql.deleteCode (params LocalQuorum (k, s)) diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 5cdb4bd3f5a..2522fd3ef61 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -55,10 +55,10 @@ createConversation (NewConversation ty usr acc arole name mtid mtimer recpt user conv <- Id <$> liftIO nextRandom retry x5 $ case mtid of Nothing -> - write Cql.insertConv (params Quorum (conv, ty, usr, Set (toList acc), arole, fmap fromRange name, Nothing, mtimer, recpt)) + write Cql.insertConv (params LocalQuorum (conv, ty, usr, Set (toList acc), arole, fmap fromRange name, Nothing, mtimer, recpt)) Just tid -> batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery Cql.insertConv (conv, ty, usr, Set (toList acc), arole, fmap fromRange name, Just tid, mtimer, recpt) addPrepQuery Cql.insertTeamConv (tid, conv, False) let newUsers = fmap (,role) (fromConvSize users) @@ -88,7 +88,7 @@ createConnectConversation a b name = do let conv = localOne2OneConvId a b a' = Id . U.unpack $ a retry x5 $ - write Cql.insertConv (params Quorum (conv, ConnectConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + write Cql.insertConv (params LocalQuorum (conv, ConnectConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) -- We add only one member, second one gets added later, -- when the other user accepts the connection request. (lmems, rmems) <- addMembers conv (UserList [a'] []) @@ -115,7 +115,7 @@ createConnectConversationWithRemote :: Client Conversation createConnectConversationWithRemote cid creator m = do retry x5 $ - write Cql.insertConv (params Quorum (cid, ConnectConv, creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) + write Cql.insertConv (params LocalQuorum (cid, ConnectConv, creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) -- We add only one member, second one gets added later, -- when the other user accepts the connection request. (lmems, rmems) <- addMembers cid m @@ -162,10 +162,10 @@ createOne2OneConversation :: Client Conversation createOne2OneConversation conv self other name mtid = do retry x5 $ case mtid of - Nothing -> write Cql.insertConv (params Quorum (conv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + Nothing -> write Cql.insertConv (params LocalQuorum (conv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) Just tid -> batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery Cql.insertConv (conv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) addPrepQuery Cql.insertTeamConv (tid, conv, False) (lmems, rmems) <- addMembers conv (toUserList self [qUntagged self, other]) @@ -191,7 +191,7 @@ createSelfConversation lusr name = do conv = selfConv usr lconv = qualifyAs lusr conv retry x5 $ - write Cql.insertConv (params Quorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + write Cql.insertConv (params LocalQuorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) (lmems, rmems) <- addMembers (tUnqualified lconv) (UserList [tUnqualified lusr] []) pure Conversation @@ -211,7 +211,7 @@ createSelfConversation lusr name = do deleteConversation :: ConvId -> Client () deleteConversation cid = do - retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) + retry x5 $ write Cql.markConvDeleted (params LocalQuorum (Identity cid)) localMembers <- members cid remoteMembers <- lookupRemoteMembers cid @@ -219,19 +219,19 @@ deleteConversation cid = do removeMembersFromLocalConv cid $ UserList (lmId <$> localMembers) (rmId <$> remoteMembers) - retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) + retry x5 $ write Cql.deleteConv (params LocalQuorum (Identity cid)) conversationMeta :: ConvId -> Client (Maybe ConversationMetadata) conversationMeta conv = fmap toConvMeta - <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) + <$> retry x1 (query1 Cql.selectConv (params LocalQuorum (Identity conv))) where toConvMeta (t, c, a, r, n, i, _, mt, rm) = ConversationMetadata t c (defAccess t a) (maybeRole t r) n i mt rm isConvAlive :: ConvId -> Client Bool isConvAlive cid = do - result <- retry x1 (query1 Cql.isConvDeleted (params Quorum (Identity cid))) + result <- retry x1 (query1 Cql.isConvDeleted (params LocalQuorum (Identity cid))) case runIdentity <$> result of Nothing -> pure False Just Nothing -> pure True @@ -241,25 +241,25 @@ isConvAlive cid = do updateConvType :: ConvId -> ConvType -> Client () updateConvType cid ty = retry x5 $ - write Cql.updateConvType (params Quorum (ty, cid)) + write Cql.updateConvType (params LocalQuorum (ty, cid)) updateConvName :: ConvId -> Range 1 256 Text -> Client () -updateConvName cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) +updateConvName cid name = retry x5 $ write Cql.updateConvName (params LocalQuorum (fromRange name, cid)) updateConvAccess :: ConvId -> ConversationAccessData -> Client () updateConvAccess cid (ConversationAccessData acc role) = retry x5 $ - write Cql.updateConvAccess (params Quorum (Set (toList acc), role, cid)) + write Cql.updateConvAccess (params LocalQuorum (Set (toList acc), role, cid)) updateConvReceiptMode :: ConvId -> ReceiptMode -> Client () -updateConvReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params Quorum (receiptMode, cid)) +updateConvReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params LocalQuorum (receiptMode, cid)) updateConvMessageTimer :: ConvId -> Maybe Milliseconds -> Client () -updateConvMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) +updateConvMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params LocalQuorum (mtimer, cid)) getConversation :: ConvId -> Client (Maybe Conversation) getConversation conv = do - cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) + cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params LocalQuorum (Identity conv))) remoteMems <- UnliftIO.async $ lookupRemoteMembers conv mbConv <- toConv conv @@ -296,7 +296,7 @@ localConversations ids = do foldrM flatten [] (zip ids cs) where fetchConvs = do - cs <- retry x1 $ query Cql.selectConvs (params Quorum (Identity ids)) + cs <- retry x1 $ query Cql.selectConvs (params LocalQuorum (Identity ids)) let m = Map.fromList $ map (\(c, t, u, n, a, r, i, d, mt, rm) -> (c, (t, u, n, a, r, i, d, mt, rm))) cs return $ map (`Map.lookup` m) ids flatten (i, c) cc = case c of @@ -309,7 +309,7 @@ localConversations ids = do -- user. localConversationIdsOf :: UserId -> [ConvId] -> Client [ConvId] localConversationIdsOf usr cids = do - runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) + runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params LocalQuorum (usr, cids))) -- | Takes a list of remote conversation ids and fetches member status flags -- for the given user @@ -325,7 +325,7 @@ remoteConversationStatus uid = remoteConversationStatusOnDomain :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) remoteConversationStatusOnDomain uid rconvs = Map.fromList . map toPair - <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) + <$> query Cql.selectRemoteConvMemberStatuses (params LocalQuorum (uid, tDomain rconvs, tUnqualified rconvs)) where toPair (conv, omus, omur, oar, oarr, hid, hidr) = ( qualifyAs rconvs conv, diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index a39e0f0ae25..3a69e61899c 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -72,7 +72,7 @@ addMembers conv (fmap toUserRole -> UserList lusers rusers) = do for_ (List.chunksOf 32 lusers) $ \chunk -> do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ chunk $ \(u, r) -> do -- User is local, too, so we add it to both the member and the user table addPrepQuery Cql.insertMember (conv, u, Nothing, Nothing, r) @@ -81,7 +81,7 @@ addMembers conv (fmap toUserRole -> UserList lusers rusers) = do for_ (List.chunksOf 32 rusers) $ \chunk -> do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do -- User is remote, so we only add it to the member_remote_user -- table, but the reverse mapping has to be done on the remote @@ -102,7 +102,7 @@ removeLocalMembersFromLocalConv _ [] = pure () removeLocalMembersFromLocalConv cnv victims = do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ victims $ \victim -> do addPrepQuery Cql.removeMember (cnv, victim) addPrepQuery Cql.deleteUserConv (victim, cnv) @@ -112,13 +112,13 @@ removeRemoteMembersFromLocalConv _ [] = pure () removeRemoteMembersFromLocalConv cnv victims = do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ victims $ \(qUntagged -> Qualified uid domain) -> addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) memberLists :: [ConvId] -> Client [[LocalMember]] memberLists convs = do - mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) + mems <- retry x1 $ query Cql.selectMembers (params LocalQuorum (Identity convs)) let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs where @@ -194,7 +194,7 @@ newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] remoteMemberLists convs = do - mems <- retry x1 $ query Cql.selectRemoteMembers (params Quorum (Identity convs)) + mems <- retry x1 $ query Cql.selectRemoteMembers (params LocalQuorum (Identity convs)) let convMembers = foldr (insert . mkMem) Map.empty mems return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs where @@ -212,7 +212,7 @@ member :: Client (Maybe LocalMember) member cnv usr = (toMember =<<) - <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) + <$> retry x1 (query1 Cql.selectMember (params LocalQuorum (cnv, usr))) -- | Set local users as belonging to a remote conversation. This is invoked by a -- remote galley when users from the current backend are added to conversations @@ -224,7 +224,7 @@ addLocalMembersToRemoteConv rconv users = do for_ (List.chunksOf 32 users) $ \chunk -> retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ chunk $ \u -> addPrepQuery Cql.insertUserRemoteConv @@ -251,7 +251,7 @@ updateSelfMemberLocalConv :: updateSelfMemberLocalConv lcid luid mup = do retry x5 . batch $ do setType BatchUnLogged - setConsistency Quorum + setConsistency LocalQuorum for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateOtrMemberMutedStatus @@ -273,7 +273,7 @@ updateSelfMemberRemoteConv :: updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do retry x5 . batch $ do setType BatchUnLogged - setConsistency Quorum + setConsistency LocalQuorum for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateRemoteOtrMemberMutedStatus @@ -305,7 +305,7 @@ updateOtherMemberLocalConv lcid quid omu = (r, tUnqualified lcid, qDomain quid, qUnqualified quid) retry x5 . batch $ do setType BatchUnLogged - setConsistency Quorum + setConsistency LocalQuorum traverse_ addQuery (omuConvRoleName omu) -- | Select only the members of a remote conversation from a list of users. @@ -324,7 +324,7 @@ filterRemoteConvMembers users (qUntagged -> Qualified conv dom) = filterMember user = fmap (map runIdentity) . retry x1 - $ query Cql.selectRemoteConvMembers (params Quorum (user, dom, conv)) + $ query Cql.selectRemoteConvMembers (params LocalQuorum (user, dom, conv)) removeLocalMembersFromRemoteConv :: -- | The conversation to remove members from @@ -336,7 +336,7 @@ removeLocalMembersFromRemoteConv _ [] = pure () removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) interpretMemberStoreToCassandra :: diff --git a/services/galley/src/Galley/Cassandra/ConversationList.hs b/services/galley/src/Galley/Cassandra/ConversationList.hs index 804f8278727..76d8139dabc 100644 --- a/services/galley/src/Galley/Cassandra/ConversationList.hs +++ b/services/galley/src/Galley/Cassandra/ConversationList.hs @@ -44,8 +44,8 @@ conversationIdsFrom :: Client (ResultSet ConvId) conversationIdsFrom usr start (fromRange -> max) = mkResultSet . strip . fmap runIdentity <$> case start of - Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) - Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) (max + 1)) + Just c -> paginate Cql.selectUserConvsFrom (paramsP LocalQuorum (usr, c) (max + 1)) + Nothing -> paginate Cql.selectUserConvs (paramsP LocalQuorum (Identity usr) (max + 1)) where strip p = p {result = take (fromIntegral max) (result p)} @@ -55,7 +55,7 @@ localConversationIdsPageFrom :: Range 1 1000 Int32 -> Client (PageWithState ConvId) localConversationIdsPageFrom usr pagingState (fromRange -> max) = - fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) + fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState LocalQuorum (Identity usr) max pagingState) remoteConversationIdsPageFrom :: UserId -> @@ -63,7 +63,7 @@ remoteConversationIdsPageFrom :: Int32 -> Client (PageWithState (Remote ConvId)) remoteConversationIdsPageFrom usr pagingState max = - uncurry toRemoteUnsafe <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) + uncurry toRemoteUnsafe <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState LocalQuorum (Identity usr) max pagingState) interpretConversationListToCassandra :: Members '[Embed IO, P.Reader ClientState] r => diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index d5494780773..12f687abd8a 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -27,4 +27,4 @@ isTeamLegalholdWhitelisted :: FeatureLegalHold -> TeamId -> Client Bool isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ = pure False isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid = - isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params Quorum (Identity tid)))) + isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid)))) diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs index f96fc02ae74..b6e7f7403fa 100644 --- a/services/galley/src/Galley/Cassandra/Services.hs +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -36,7 +36,7 @@ addBotMember :: ServiceRef -> BotId -> ConvId -> Client BotMember addBotMember s bot cnv = do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery insertUserConv (botUserId bot, cnv) addPrepQuery insertBot (cnv, bot, sid, pid) pure (BotMember mem) @@ -64,15 +64,15 @@ insertService s = do let url = s ^. serviceUrl let fps = Set (s ^. serviceFingerprints) let ena = s ^. serviceEnabled - retry x5 $ write insertSrv (params Quorum (pid, sid, url, tok, fps, ena)) + retry x5 $ write insertSrv (params LocalQuorum (pid, sid, url, tok, fps, ena)) lookupService :: MonadClient m => ServiceRef -> m (Maybe Service) lookupService s = fmap toService - <$> retry x1 (query1 selectSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) + <$> retry x1 (query1 selectSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) where toService (url, tok, Set fps, ena) = newService s url tok fps & set serviceEnabled ena deleteService :: MonadClient m => ServiceRef -> m () -deleteService s = retry x5 (write rmSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) +deleteService s = retry x5 (write rmSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 6369050ec74..709b236d1af 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -131,7 +131,7 @@ createTeam :: Client Team createTeam t uid (fromRange -> n) (fromRange -> i) k b = do tid <- maybe (Id <$> liftIO nextRandom) return t - retry x5 $ write Cql.insertTeam (params Quorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) + retry x5 $ write Cql.insertTeam (params LocalQuorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) where initialStatus Binding = PendingActive -- Team becomes Active after User account activation @@ -140,40 +140,40 @@ createTeam t uid (fromRange -> n) (fromRange -> i) k b = do listBillingTeamMembers :: TeamId -> Client [UserId] listBillingTeamMembers tid = fmap runIdentity - <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) + <$> retry x1 (query Cql.listBillingTeamMembers (params LocalQuorum (Identity tid))) getTeamName :: TeamId -> Client (Maybe Text) getTeamName tid = fmap runIdentity - <$> retry x1 (query1 Cql.selectTeamName (params Quorum (Identity tid))) + <$> retry x1 (query1 Cql.selectTeamName (params LocalQuorum (Identity tid))) teamConversation :: TeamId -> ConvId -> Client (Maybe TeamConversation) teamConversation t c = fmap (newTeamConversation c . runIdentity) - <$> retry x1 (query1 Cql.selectTeamConv (params Quorum (t, c))) + <$> retry x1 (query1 Cql.selectTeamConv (params LocalQuorum (t, c))) getTeamConversations :: TeamId -> Client [TeamConversation] getTeamConversations t = map (uncurry newTeamConversation) - <$> retry x1 (query Cql.selectTeamConvs (params Quorum (Identity t))) + <$> retry x1 (query Cql.selectTeamConvs (params LocalQuorum (Identity t))) teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (ResultSet TeamId) teamIdsFrom usr range (fromRange -> max) = mkResultSet . fmap runIdentity . strip <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) - Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) (max + 1)) + Just c -> paginate Cql.selectUserTeamsFrom (paramsP LocalQuorum (usr, c) (max + 1)) + Nothing -> paginate Cql.selectUserTeams (paramsP LocalQuorum (Identity usr) (max + 1)) where strip p = p {result = take (fromIntegral max) (result p)} teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (Page TeamId) teamIdsForPagination usr range (fromRange -> max) = fmap runIdentity <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) max) - Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) max) + Just c -> paginate Cql.selectUserTeamsFrom (paramsP LocalQuorum (usr, c) max) + Nothing -> paginate Cql.selectUserTeams (paramsP LocalQuorum (Identity usr) max) teamMember :: FeatureLegalHold -> TeamId -> UserId -> Client (Maybe TeamMember) teamMember lh t u = - newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params Quorum (t, u))) + newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params LocalQuorum (t, u))) where newTeamMember'' :: UserId -> @@ -187,7 +187,7 @@ addTeamMember :: TeamId -> TeamMember -> Client () addTeamMember t m = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery Cql.insertTeamMember ( t, @@ -211,7 +211,7 @@ updateTeamMember :: updateTeamMember oldPerms tid uid newPerms = do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery Cql.updatePermissions (newPerms, tid, uid) when (SetBilling `Set.member` acquiredPerms) $ @@ -228,14 +228,14 @@ removeTeamMember :: TeamId -> UserId -> Client () removeTeamMember t m = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery Cql.deleteTeamMember (t, m) addPrepQuery Cql.deleteUserTeam (m, t) addPrepQuery Cql.deleteBillingTeamMember (t, m) team :: TeamId -> Client (Maybe TeamData) team tid = - fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params Quorum (Identity tid))) + fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params LocalQuorum (Identity tid))) where toTeam (u, n, i, k, d, s, st, b) = let t = newTeam tid u n i (fromMaybe NonBinding b) & teamIconKey .~ k @@ -244,7 +244,7 @@ team tid = teamIdsOf :: UserId -> [TeamId] -> Client [TeamId] teamIdsOf usr tids = - map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params Quorum (usr, toList tids))) + map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params LocalQuorum (usr, toList tids))) teamMembersWithLimit :: FeatureLegalHold -> @@ -253,7 +253,7 @@ teamMembersWithLimit :: Client TeamMemberList teamMembersWithLimit lh t (fromRange -> limit) = do -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size - pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP Quorum (Identity t) (limit + 1))) + pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP LocalQuorum (Identity t) (limit + 1))) ms <- mapM (newTeamMember' lh t) . take (fromIntegral limit) $ result pageTuple pure $ if hasMore pageTuple @@ -279,12 +279,12 @@ teamMembersCollectedWithPagination lh tid = do teamMembersLimited :: FeatureLegalHold -> TeamId -> [UserId] -> Client [TeamMember] teamMembersLimited lh t u = mapM (newTeamMember' lh t) - =<< retry x1 (query Cql.selectTeamMembers' (params Quorum (t, u))) + =<< retry x1 (query Cql.selectTeamMembers' (params LocalQuorum (t, u))) userTeams :: UserId -> Client [TeamId] userTeams u = map runIdentity - <$> retry x1 (query Cql.selectUserTeams (params Quorum (Identity u))) + <$> retry x1 (query Cql.selectUserTeams (params LocalQuorum (Identity u))) usersTeams :: [UserId] -> Client (Map UserId TeamId) usersTeams uids = do @@ -296,12 +296,12 @@ usersTeams uids = do oneUserTeam :: UserId -> Client (Maybe TeamId) oneUserTeam u = fmap runIdentity - <$> retry x1 (query1 Cql.selectOneUserTeam (params Quorum (Identity u))) + <$> retry x1 (query1 Cql.selectOneUserTeam (params LocalQuorum (Identity u))) teamCreationTime :: TeamId -> Client (Maybe TeamCreationTime) teamCreationTime t = checkCreation . fmap runIdentity - <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params Quorum (Identity t))) + <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params LocalQuorum (Identity t))) where checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts checkCreation _ = Nothing @@ -309,7 +309,7 @@ teamCreationTime t = getTeamBinding :: TeamId -> Client (Maybe TeamBinding) getTeamBinding t = fmap (fromMaybe NonBinding . runIdentity) - <$> retry x1 (query1 Cql.selectTeamBinding (params Quorum (Identity t))) + <$> retry x1 (query1 Cql.selectTeamBinding (params LocalQuorum (Identity t))) getTeamsBindings :: [TeamId] -> Client [TeamBinding] getTeamsBindings = @@ -319,12 +319,12 @@ getTeamsBindings = deleteTeam :: TeamId -> Client () deleteTeam tid = do -- TODO: delete service_whitelist records that mention this team - retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) + retry x5 $ write Cql.markTeamDeleted (params LocalQuorum (PendingDelete, tid)) mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) removeTeamMembers mems cnvs <- teamConversationsForPagination tid Nothing (unsafeRange 2000) removeConvs cnvs - retry x5 $ write Cql.deleteTeam (params Quorum (Deleted, tid)) + retry x5 $ write Cql.deleteTeam (params LocalQuorum (Deleted, tid)) where removeConvs :: Page TeamConversation -> Client () removeConvs cnvs = do @@ -350,18 +350,18 @@ removeTeamConv :: TeamId -> ConvId -> Client () removeTeamConv tid cid = liftClient $ do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery Cql.markConvDeleted (Identity cid) addPrepQuery Cql.deleteTeamConv (tid, cid) C.deleteConversation cid updateTeamStatus :: TeamId -> TeamStatus -> Client () -updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) +updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params LocalQuorum (s, t)) updateTeam :: TeamId -> TeamUpdateData -> Client () updateTeam tid u = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ (u ^. nameUpdate) $ \n -> addPrepQuery Cql.updateTeamName (fromRange n, tid) for_ (u ^. iconUpdate) $ \i -> @@ -407,8 +407,8 @@ newTeamMember' lh tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatu teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Client (Page TeamConversation) teamConversationsForPagination tid start (fromRange -> max) = fmap (uncurry newTeamConversation) <$> case start of - Just c -> paginate Cql.selectTeamConvsFrom (paramsP Quorum (tid, c) max) - Nothing -> paginate Cql.selectTeamConvs (paramsP Quorum (Identity tid) max) + Just c -> paginate Cql.selectTeamConvsFrom (paramsP LocalQuorum (tid, c) max) + Nothing -> paginate Cql.selectTeamConvs (paramsP LocalQuorum (Identity tid) max) type RawTeamMember = (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) @@ -419,5 +419,5 @@ type RawTeamMember = (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Ma teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Client (Page RawTeamMember) teamMembersForPagination tid start (fromRange -> max) = case start of - Just u -> paginate Cql.selectTeamMembersFrom (paramsP Quorum (tid, u) max) - Nothing -> paginate Cql.selectTeamMembers (paramsP Quorum (Identity tid) max) + Just u -> paginate Cql.selectTeamMembersFrom (paramsP LocalQuorum (tid, u) max) + Nothing -> paginate Cql.selectTeamMembers (paramsP LocalQuorum (Identity tid) max) diff --git a/services/galley/src/Galley/Data/CustomBackend.hs b/services/galley/src/Galley/Data/CustomBackend.hs index 10cd979b8af..ec6955e16bd 100644 --- a/services/galley/src/Galley/Data/CustomBackend.hs +++ b/services/galley/src/Galley/Data/CustomBackend.hs @@ -34,15 +34,15 @@ import Imports getCustomBackend :: MonadClient m => Domain -> m (Maybe CustomBackend) getCustomBackend domain = fmap toCustomBackend <$> do - retry x1 $ query1 Cql.selectCustomBackend (params Quorum (Identity domain)) + retry x1 $ query1 Cql.selectCustomBackend (params LocalQuorum (Identity domain)) where toCustomBackend (backendConfigJsonUrl, backendWebappWelcomeUrl) = CustomBackend {..} setCustomBackend :: MonadClient m => Domain -> CustomBackend -> m () setCustomBackend domain CustomBackend {..} = do - retry x5 $ write Cql.updateCustomBackend (params Quorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) + retry x5 $ write Cql.updateCustomBackend (params LocalQuorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) deleteCustomBackend :: MonadClient m => Domain -> m () deleteCustomBackend domain = do - retry x5 $ write Cql.deleteCustomBackend (params Quorum (Identity domain)) + retry x5 $ write Cql.deleteCustomBackend (params LocalQuorum (Identity domain)) diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Data/LegalHold.hs index 052bc064219..716e0917dfb 100644 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ b/services/galley/src/Galley/Data/LegalHold.hs @@ -48,19 +48,19 @@ import Imports -- The Caller is responsible for checking whether legal hold is enabled for this team createSettings :: MonadClient m => LegalHoldService -> m () createSettings (LegalHoldService tid url fpr tok key) = do - retry x1 $ write insertLegalHoldSettings (params Quorum (url, fpr, tok, key, tid)) + retry x1 $ write insertLegalHoldSettings (params LocalQuorum (url, fpr, tok, key, tid)) -- | Returns 'Nothing' if no settings are saved -- The Caller is responsible for checking whether legal hold is enabled for this team getSettings :: MonadClient m => TeamId -> m (Maybe LegalHoldService) getSettings tid = fmap toLegalHoldService <$> do - retry x1 $ query1 selectLegalHoldSettings (params Quorum (Identity tid)) + retry x1 $ query1 selectLegalHoldSettings (params LocalQuorum (Identity tid)) where toLegalHoldService (httpsUrl, fingerprint, tok, key) = LegalHoldService tid httpsUrl fingerprint tok key removeSettings :: MonadClient m => TeamId -> m () -removeSettings tid = retry x5 (write removeLegalHoldSettings (params Quorum (Identity tid))) +removeSettings tid = retry x5 (write removeLegalHoldSettings (params LocalQuorum (Identity tid))) insertPendingPrekeys :: MonadClient m => UserId -> [Prekey] -> m () insertPendingPrekeys uid keys = retry x5 . batch $ @@ -73,7 +73,7 @@ insertPendingPrekeys uid keys = retry x5 . batch $ selectPendingPrekeys :: MonadClient m => UserId -> m (Maybe ([Prekey], LastPrekey)) selectPendingPrekeys uid = pickLastKey . fmap fromTuple - <$> retry x1 (query Q.selectPendingPrekeys (params Quorum (Identity uid))) + <$> retry x1 (query Q.selectPendingPrekeys (params LocalQuorum (Identity uid))) where fromTuple (keyId, key) = Prekey keyId key pickLastKey allPrekeys = @@ -82,19 +82,19 @@ selectPendingPrekeys uid = Just (keys, lst) -> pure (keys, lastPrekey . prekeyKey $ lst) dropPendingPrekeys :: MonadClient m => UserId -> m () -dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params Quorum (Identity uid))) +dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params LocalQuorum (Identity uid))) setUserLegalHoldStatus :: MonadClient m => TeamId -> UserId -> UserLegalHoldStatus -> m () setUserLegalHoldStatus tid uid status = - retry x5 (write Q.updateUserLegalHoldStatus (params Quorum (status, tid, uid))) + retry x5 (write Q.updateUserLegalHoldStatus (params LocalQuorum (status, tid, uid))) setTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () setTeamLegalholdWhitelisted tid = - retry x5 (write Q.insertLegalHoldWhitelistedTeam (params Quorum (Identity tid))) + retry x5 (write Q.insertLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) unsetTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () unsetTeamLegalholdWhitelisted tid = - retry x5 (write Q.removeLegalHoldWhitelistedTeam (params Quorum (Identity tid))) + retry x5 (write Q.removeLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) isTeamLegalholdWhitelisted :: (MonadReader Env m, MonadClient m) => TeamId -> m Bool isTeamLegalholdWhitelisted tid = do diff --git a/services/galley/src/Galley/Data/SearchVisibility.hs b/services/galley/src/Galley/Data/SearchVisibility.hs index 680a74702b0..f291fae8d1a 100644 --- a/services/galley/src/Galley/Data/SearchVisibility.hs +++ b/services/galley/src/Galley/Data/SearchVisibility.hs @@ -35,7 +35,7 @@ import Imports getSearchVisibility :: MonadClient m => TeamId -> m TeamSearchVisibility getSearchVisibility tid = toSearchVisibility <$> do - retry x1 $ query1 selectSearchVisibility (params Quorum (Identity tid)) + retry x1 $ query1 selectSearchVisibility (params LocalQuorum (Identity tid)) where -- The value is either set or we return the default toSearchVisibility :: (Maybe (Identity (Maybe TeamSearchVisibility))) -> TeamSearchVisibility @@ -45,8 +45,8 @@ getSearchVisibility tid = -- | Determines whether a given team is allowed to enable/disable sso setSearchVisibility :: MonadClient m => TeamId -> TeamSearchVisibility -> m () setSearchVisibility tid visibilityType = do - retry x5 $ write updateSearchVisibility (params Quorum (visibilityType, tid)) + retry x5 $ write updateSearchVisibility (params LocalQuorum (visibilityType, tid)) resetSearchVisibility :: MonadClient m => TeamId -> m () resetSearchVisibility tid = do - retry x5 $ write updateSearchVisibility (params Quorum (SearchVisibilityStandard, tid)) + retry x5 $ write updateSearchVisibility (params LocalQuorum (SearchVisibilityStandard, tid)) diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 3a4421177ba..a9437a3470c 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -79,7 +79,7 @@ getFeatureStatusNoConfig :: TeamId -> m (Maybe (TeamFeatureStatus a)) getFeatureStatusNoConfig tid = do - let q = query1 select (params Quorum (Identity tid)) + let q = query1 select (params LocalQuorum (Identity tid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q pure $ TeamFeatureStatusNoConfig <$> mStatusValue where @@ -97,7 +97,7 @@ setFeatureStatusNoConfig :: m (TeamFeatureStatus a) setFeatureStatusNoConfig tid status = do let flag = Public.tfwoStatus status - retry x5 $ write insert (params Quorum (tid, flag)) + retry x5 $ write insert (params LocalQuorum (tid, flag)) pure status where insert :: PrepQuery W (TeamId, TeamFeatureStatusValue) () @@ -109,7 +109,7 @@ getApplockFeatureStatus :: TeamId -> m (Maybe (TeamFeatureStatus 'Public.TeamFeatureAppLock)) getApplockFeatureStatus tid = do - let q = query1 select (params Quorum (Identity tid)) + let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q pure $ mTuple >>= \(mbStatusValue, mbEnforce, mbTimeout) -> @@ -130,7 +130,7 @@ setApplockFeatureStatus tid status = do let statusValue = Public.tfwcStatus status enforce = Public.applockEnforceAppLock . Public.tfwcConfig $ status timeout = Public.applockInactivityTimeoutSecs . Public.tfwcConfig $ status - retry x5 $ write insert (params Quorum (tid, statusValue, enforce, timeout)) + retry x5 $ write insert (params LocalQuorum (tid, statusValue, enforce, timeout)) pure status where insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Public.EnforceAppLock, Int32) () @@ -146,7 +146,7 @@ getSelfDeletingMessagesStatus :: TeamId -> m (Maybe (TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages)) getSelfDeletingMessagesStatus tid = do - let q = query1 select (params Quorum (Identity tid)) + let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q pure $ mTuple >>= \(mbStatusValue, mbTimeout) -> @@ -168,7 +168,7 @@ setSelfDeletingMessagesStatus :: setSelfDeletingMessagesStatus tid status = do let statusValue = Public.tfwcStatus status timeout = Public.sdmEnforcedTimeoutSeconds . Public.tfwcConfig $ status - retry x5 $ write insert (params Quorum (tid, statusValue, timeout)) + retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) pure status where insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Int32) () diff --git a/services/galley/src/Galley/Data/TeamNotifications.hs b/services/galley/src/Galley/Data/TeamNotifications.hs index d5c7689538f..d7b3a9003d0 100644 --- a/services/galley/src/Galley/Data/TeamNotifications.hs +++ b/services/galley/src/Galley/Data/TeamNotifications.hs @@ -57,7 +57,7 @@ add :: List1 JSON.Object -> Galley r () add tid nid (Blob . JSON.encode -> payload) = - write cqlInsert (params Quorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 + write cqlInsert (params LocalQuorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 where cqlInsert :: PrepQuery W (TeamId, NotificationId, Blob, Int32) () cqlInsert = @@ -75,8 +75,8 @@ fetch tid since (fromRange -> size) = do -- report whether there are more results. let size' = bool (+ 1) (+ 2) (isJust since) size page1 <- case TimeUuid . toUUID <$> since of - Nothing -> paginate cqlStart (paramsP Quorum (Identity tid) size') & retry x1 - Just s -> paginate cqlSince (paramsP Quorum (tid, s) size') & retry x1 + Nothing -> paginate cqlStart (paramsP LocalQuorum (Identity tid) size') & retry x1 + Just s -> paginate cqlSince (paramsP LocalQuorum (tid, s) size') & retry x1 -- Collect results, requesting more pages until we run out of data -- or have found size + 1 notifications (not including the 'since'). let isize = fromIntegral size' :: Int diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index a53643289a8..d8448dbd875 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -31,14 +31,14 @@ import Imports unregister :: UserId -> ClientId -> Gundeck () unregister uid cid = do - toks <- filter byClient <$> Push.lookup uid Push.Quorum + toks <- filter byClient <$> Push.lookup uid Push.LocalQuorum deleteTokens toks Nothing where byClient = (cid ==) . view addrClient removeUser :: UserId -> Gundeck () removeUser user = do - toks <- Push.lookup user Push.Quorum + toks <- Push.lookup user Push.LocalQuorum deleteTokens toks Nothing Push.erase user Notifications.deleteAll user diff --git a/services/gundeck/src/Gundeck/Notification/Data.hs b/services/gundeck/src/Gundeck/Notification/Data.hs index 65bd3d6f793..36becc262bf 100644 --- a/services/gundeck/src/Gundeck/Notification/Data.hs +++ b/services/gundeck/src/Gundeck/Notification/Data.hs @@ -62,7 +62,7 @@ add n tgts (Blob . JSON.encode -> p) (notificationTTLSeconds -> t) = pooledForConcurrentlyN_ 32 tgts $ \tgt -> let u = tgt ^. targetUser cs = C.Set (tgt ^. targetClients) - in write cqlInsert (params Quorum (u, n, p, cs, fromIntegral t)) & retry x5 + in write cqlInsert (params LocalQuorum (u, n, p, cs, fromIntegral t)) & retry x5 where cqlInsert :: PrepQuery W (UserId, NotificationId, Blob, C.Set ClientId, Int32) () cqlInsert = @@ -74,7 +74,7 @@ add n tgts (Blob . JSON.encode -> p) (notificationTTLSeconds -> t) = fetchId :: MonadClient m => UserId -> NotificationId -> Maybe ClientId -> m (Maybe QueuedNotification) fetchId u n c = listToMaybe . foldr' (toNotif c) [] - <$> query cqlById (params Quorum (u, n)) & retry x1 + <$> query cqlById (params LocalQuorum (u, n)) & retry x1 where cqlById :: PrepQuery R (UserId, NotificationId) (TimeUuid, Blob, Maybe (C.Set ClientId)) cqlById = @@ -84,12 +84,12 @@ fetchId u n c = fetchLast :: MonadClient m => UserId -> Maybe ClientId -> m (Maybe QueuedNotification) fetchLast u c = do - ls <- query cqlLast (params Quorum (Identity u)) & retry x1 + ls <- query cqlLast (params LocalQuorum (Identity u)) & retry x1 case ls of [] -> return Nothing ns@(n : _) -> ns `getFirstOrElse` do - p <- paginate cqlSeek (paramsP Quorum (u, n ^. _1) 100) & retry x1 + p <- paginate cqlSeek (paramsP LocalQuorum (u, n ^. _1) 100) & retry x1 seek p where seek p = @@ -120,8 +120,8 @@ fetch u c since (fromRange -> size) = do -- report whether there are more results. let size' = bool (+ 1) (+ 2) (isJust since) size page1 <- case TimeUuid . toUUID <$> since of - Nothing -> paginate cqlStart (paramsP Quorum (Identity u) size') & retry x1 - Just s -> paginate cqlSince (paramsP Quorum (u, s) size') & retry x1 + Nothing -> paginate cqlStart (paramsP LocalQuorum (Identity u) size') & retry x1 + Just s -> paginate cqlSince (paramsP LocalQuorum (u, s) size') & retry x1 -- Collect results, requesting more pages until we run out of data -- or have found size + 1 notifications (not including the 'since'). let isize = fromIntegral size' :: Int @@ -164,7 +164,7 @@ fetch u c since (fromRange -> size) = do \ORDER BY id ASC" deleteAll :: MonadClient m => UserId -> m () -deleteAll u = write cql (params Quorum (Identity u)) & retry x5 +deleteAll u = write cql (params LocalQuorum (Identity u)) & retry x5 where cql :: PrepQuery W (Identity UserId) () cql = "DELETE FROM notifications WHERE user = ?" diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index b611120fcc9..cd205b536f1 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -380,7 +380,7 @@ data AddTokenResponse addToken :: UserId -> ConnId -> PushToken -> Gundeck AddTokenResponse addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do - (cur, old) <- foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.Quorum + (cur, old) <- foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.LocalQuorum Log.info $ "user" .= UUID.toASCIIBytes (toUUID uid) ~~ "token" .= Text.take 16 (tokenText (newtok ^. token)) @@ -512,10 +512,10 @@ updateEndpoint uid t arn e = do deleteToken :: UserId -> Token -> Gundeck () deleteToken uid tok = do - as <- filter (\x -> x ^. addrToken == tok) <$> Data.lookup uid Data.Quorum + as <- filter (\x -> x ^. addrToken == tok) <$> Data.lookup uid Data.LocalQuorum when (null as) $ throwM (mkError status404 "not-found" "Push token not found") Native.deleteTokens as Nothing listTokens :: UserId -> Gundeck PushTokenList -listTokens uid = PushTokenList . map (^. addrPushToken) <$> Data.lookup uid Data.Quorum +listTokens uid = PushTokenList . map (^. addrPushToken) <$> Data.lookup uid Data.LocalQuorum diff --git a/services/gundeck/src/Gundeck/Push/Data.hs b/services/gundeck/src/Gundeck/Push/Data.hs index 73fcbb5afcf..ed07d7837b6 100644 --- a/services/gundeck/src/Gundeck/Push/Data.hs +++ b/services/gundeck/src/Gundeck/Push/Data.hs @@ -42,19 +42,19 @@ lookup u c = foldM mk [] =<< retry x1 (query q (params c (Identity u))) mk as r = maybe as (: as) <$> mkAddr r insert :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> ConnId -> ClientId -> m () -insert u t a p e o c = retry x5 $ write q (params Quorum (u, t, a, p, e, o, c)) +insert u t a p e o c = retry x5 $ write q (params LocalQuorum (u, t, a, p, e, o, c)) where q :: PrepQuery W (UserId, Transport, AppName, Token, EndpointArn, ConnId, ClientId) () q = "insert into user_push (usr, transport, app, ptoken, arn, connection, client) values (?, ?, ?, ?, ?, ?, ?)" delete :: MonadClient m => UserId -> Transport -> AppName -> Token -> m () -delete u t a p = retry x5 $ write q (params Quorum (u, t, a, p)) +delete u t a p = retry x5 $ write q (params LocalQuorum (u, t, a, p)) where q :: PrepQuery W (UserId, Transport, AppName, Token) () q = "delete from user_push where usr = ? and transport = ? and app = ? and ptoken = ?" erase :: MonadClient m => UserId -> m () -erase u = retry x5 $ write q (params Quorum (Identity u)) +erase u = retry x5 $ write q (params LocalQuorum (Identity u)) where q :: PrepQuery W (Identity UserId) () q = "delete from user_push where usr = ?" diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index 27d1234297f..3be51cae8d7 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -187,7 +187,7 @@ deleteTokens tokens new = do let oldTok = a ^. addrToken let newArn = a' ^. addrEndpoint let newTok = a' ^. addrToken - xs <- Data.lookup u Data.Quorum + xs <- Data.lookup u Data.LocalQuorum forM_ xs $ \x -> when (x ^. addrEndpoint == oldArn) $ do Data.insert diff --git a/services/gundeck/src/Gundeck/React.hs b/services/gundeck/src/Gundeck/React.hs index 6ffcc8d913f..b5340440c38 100644 --- a/services/gundeck/src/Gundeck/React.hs +++ b/services/gundeck/src/Gundeck/React.hs @@ -129,7 +129,7 @@ withEndpoint ev f = do e <- Aws.execute v (Aws.lookupEndpoint (ev ^. evEndpoint)) for_ e $ \ep -> do let us = Set.toList (ep ^. endpointUsers) - as <- concat <$> mapM (`Push.lookup` Push.Quorum) us + as <- concat <$> mapM (`Push.lookup` Push.LocalQuorum) us case filter ((== (ev ^. evEndpoint)) . view addrEndpoint) as of [] -> do logEvent ev $ diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index 2ade72f5c74..0a1b2c55ef0 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -141,7 +141,7 @@ removeUser = do deleteUser g user ntfs <- listNotifications user Nothing liftIO $ do - tokens <- Cql.runClient s (Log.runWithLogger logger $ Push.lookup user Push.Quorum) + tokens <- Cql.runClient s (Log.runWithLogger logger $ Push.lookup user Push.LocalQuorum) null tokens @?= True ntfs @?= [] diff --git a/services/spar/migrate-data/src/Spar/DataMigration/Run.hs b/services/spar/migrate-data/src/Spar/DataMigration/Run.hs index d1b565a28f1..0820d04fbc3 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/Run.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/Run.hs @@ -100,7 +100,7 @@ latestMigrationVersion Env {..} = MigrationVersion . maybe 0 fromIntegral <$> C.runClient sparCassandra - (C.query1 cql (C.params C.Quorum ())) + (C.query1 cql (C.params C.LocalQuorum ())) where cql :: C.QueryString C.R () (Identity Int32) cql = "select version from data_migration where id=1 order by version desc limit 1" @@ -108,7 +108,7 @@ latestMigrationVersion Env {..} = persistVersion :: Env -> MigrationVersion -> Text -> UTCTime -> IO () persistVersion Env {..} (MigrationVersion v) desc time = C.runClient sparCassandra $ - C.write cql (C.params C.Quorum (fromIntegral v, desc, time)) + C.write cql (C.params C.LocalQuorum (fromIntegral v, desc, time)) where cql :: C.QueryString C.W (Int32, Text, UTCTime) () cql = "insert into data_migration (id, version, descr, date) values (1,?,?,?)" diff --git a/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs b/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs index 70d5898018c..ba6b37cef11 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs @@ -142,7 +142,7 @@ readLegacyExternalIds :: (HasSpar env, HasMigEnv env) => ConduitM () [LegacyExte readLegacyExternalIds = do pSize <- lift $ pageSize <$> askMigEnv transPipe runSpar $ - paginateC select (paramsP Quorum () pSize) x5 + paginateC select (paramsP LocalQuorum () pSize) x5 where select :: PrepQuery R () LegacyExternalId select = "SELECT external, user FROM scim_external_ids" @@ -160,7 +160,7 @@ resolveTeam (page, exts) = do readUserTeam :: HasBrig env => [UserId] -> RIO env [UserTeam] readUserTeam uids = runBrig $ do - query select (params Quorum (Identity uids)) + query select (params LocalQuorum (Identity uids)) where select :: PrepQuery R (Identity [UserId]) UserTeam select = "SELECT id, team FROM user where id in ?" @@ -190,7 +190,7 @@ sink = go DryRun -> pure () NoDryRun -> runSpar $ - write insert (params Quorum (tid, extid, uid)) + write insert (params LocalQuorum (tid, extid, uid)) go insert :: PrepQuery W (TeamId, Text, UserId) () insert = "INSERT INTO scim_external (team, external_id, user) VALUES (?, ?, ?)" diff --git a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs index ddc0958026a..083b8ef5f6b 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs @@ -102,7 +102,7 @@ performMigration = do where insertNewRow :: NewRow -> EnvIO () insertNewRow newRow = do - runSpar $ write insert (params Quorum newRow) + runSpar $ write insert (params LocalQuorum newRow) where insert :: PrepQuery W NewRow () insert = "INSERT INTO user_v2 (issuer, normalized_uname_id, sso_id, uid) VALUES (?, ?, ?, ?)" @@ -138,7 +138,7 @@ collectMapping = do readOldRows = do pSize <- lift $ asks pageSize transPipe runSpar $ - paginateC select (paramsP Quorum () pSize) x5 + paginateC select (paramsP LocalQuorum () pSize) x5 where select :: PrepQuery R () OldRow select = "SELECT issuer, sso_id, uid FROM user" @@ -208,7 +208,7 @@ resolveViaActivated _ input@(List2 old1 old2 rest) = do isActivated u = runBrig $ (== Just (Identity True)) - <$> retry x1 (query1 activatedSelect (params Quorum (Identity u))) + <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool) activatedSelect = "SELECT activated FROM user WHERE id = ?" @@ -226,7 +226,7 @@ resolveViaAccessToken _ input@(List2 old1 old2 rest) = do latestCookieExpiry :: UserId -> EnvIO (Maybe UTCTime) latestCookieExpiry uid = runBrig $ - runIdentity <$$> query1 select (params Quorum (Identity uid)) + runIdentity <$$> query1 select (params LocalQuorum (Identity uid)) where select :: PrepQuery R (Identity UserId) (Identity UTCTime) select = "SELECT expires FROM user_cookies WHERE user = ? ORDER BY expires DESC LIMIT 1" diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index 96c4403ba24..aaf20ae5653 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -179,7 +179,7 @@ storeAReqID :: storeAReqID (SAML.ID rid) (SAML.Time endOfLife) = do env <- ask TTL ttl <- mkTTLAuthnRequests env endOfLife - retry x5 . write ins $ params Quorum (rid, ttl) + retry x5 . write ins $ params LocalQuorum (rid, ttl) where ins :: PrepQuery W (SAML.XmlText, Int32) () ins = "INSERT INTO authreq (req) VALUES (?) USING TTL ?" @@ -188,7 +188,7 @@ unStoreAReqID :: (HasCallStack, MonadClient m) => AReqId -> m () -unStoreAReqID (SAML.ID rid) = retry x5 . write del . params Quorum $ Identity rid +unStoreAReqID (SAML.ID rid) = retry x5 . write del . params LocalQuorum $ Identity rid where del :: PrepQuery W (Identity SAML.XmlText) () del = "DELETE FROM authreq WHERE req = ?" @@ -198,7 +198,7 @@ isAliveAReqID :: AReqId -> m Bool isAliveAReqID (SAML.ID rid) = - (==) (Just 1) <$> (retry x1 . query1 sel . params Quorum $ Identity rid) + (==) (Just 1) <$> (retry x1 . query1 sel . params LocalQuorum $ Identity rid) where sel :: PrepQuery R (Identity SAML.XmlText) (Identity Int64) sel = "SELECT COUNT(*) FROM authreq WHERE req = ?" @@ -211,7 +211,7 @@ storeAssID :: storeAssID (SAML.ID aid) (SAML.Time endOfLife) = do env <- ask TTL ttl <- mkTTLAssertions env endOfLife - retry x5 . write ins $ params Quorum (aid, ttl) + retry x5 . write ins $ params LocalQuorum (aid, ttl) where ins :: PrepQuery W (SAML.XmlText, Int32) () ins = "INSERT INTO authresp (resp) VALUES (?) USING TTL ?" @@ -220,7 +220,7 @@ unStoreAssID :: (HasCallStack, MonadClient m) => AssId -> m () -unStoreAssID (SAML.ID aid) = retry x5 . write del . params Quorum $ Identity aid +unStoreAssID (SAML.ID aid) = retry x5 . write del . params LocalQuorum $ Identity aid where del :: PrepQuery W (Identity SAML.XmlText) () del = "DELETE FROM authresp WHERE resp = ?" @@ -230,7 +230,7 @@ isAliveAssID :: AssId -> m Bool isAliveAssID (SAML.ID aid) = - (==) (Just 1) <$> (retry x1 . query1 sel . params Quorum $ Identity aid) + (==) (Just 1) <$> (retry x1 . query1 sel . params LocalQuorum $ Identity aid) where sel :: PrepQuery R (Identity SAML.XmlText) (Identity Int64) sel = "SELECT COUNT(*) FROM authresp WHERE resp = ?" @@ -249,7 +249,7 @@ storeVerdictFormat :: m () storeVerdictFormat diffTime req (fromVerdictFormat -> (fmtCon, fmtMobSucc, fmtMobErr)) = do let ttl = nominalDiffToSeconds diffTime * 2 - retry x5 . write cql $ params Quorum (req, fmtCon, fmtMobSucc, fmtMobErr, ttl) + retry x5 . write cql $ params LocalQuorum (req, fmtCon, fmtMobSucc, fmtMobErr, ttl) where cql :: PrepQuery W (AReqId, VerdictFormatCon, Maybe URI, Maybe URI, Int32) () cql = "INSERT INTO verdict (req, format_con, format_mobile_success, format_mobile_error) VALUES (?, ?, ?, ?) USING TTL ?" @@ -260,7 +260,7 @@ getVerdictFormat :: m (Maybe VerdictFormat) getVerdictFormat req = (>>= toVerdictFormat) - <$> (retry x1 . query1 cql $ params Quorum (Identity req)) + <$> (retry x1 . query1 cql $ params LocalQuorum (Identity req)) where cql :: PrepQuery R (Identity AReqId) VerdictFormatRow cql = "SELECT format_con, format_mobile_success, format_mobile_error FROM verdict WHERE req = ?" @@ -299,7 +299,7 @@ normalizeQualifiedNameId = normalizeUnqualifiedNameId . view SAML.nameID -- | Add new user. If user with this 'SAML.UserId' exists, overwrite it. insertSAMLUser :: (HasCallStack, MonadClient m) => SAML.UserRef -> UserId -> m () -insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params Quorum (tenant, normalizeQualifiedNameId subject, subject, uid) +insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params LocalQuorum (tenant, normalizeQualifiedNameId subject, subject, uid) where ins :: PrepQuery W (SAML.Issuer, NormalizedUNameID, SAML.NameID, UserId) () ins = "INSERT INTO user_v2 (issuer, normalized_uname_id, sso_id, uid) VALUES (?, ?, ?, ?)" @@ -308,7 +308,7 @@ insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params getSAMLAnyUserByIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m (Maybe UserId) getSAMLAnyUserByIssuer issuer = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (Identity issuer)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (Identity issuer)) where sel :: PrepQuery R (Identity SAML.Issuer) (Identity UserId) sel = "SELECT uid FROM user_v2 WHERE issuer = ? LIMIT 1" @@ -318,7 +318,7 @@ getSAMLAnyUserByIssuer issuer = getSAMLSomeUsersByIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m [(SAML.UserRef, UserId)] getSAMLSomeUsersByIssuer issuer = (_1 %~ SAML.UserRef issuer) - <$$> (retry x1 . query sel $ params Quorum (Identity issuer)) + <$$> (retry x1 . query sel $ params LocalQuorum (Identity issuer)) where sel :: PrepQuery R (Identity SAML.Issuer) (SAML.NameID, UserId) sel = "SELECT sso_id, uid FROM user_v2 WHERE issuer = ? LIMIT 2000" @@ -338,7 +338,7 @@ getSAMLUser uref = do getSAMLUserNew :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId) getSAMLUserNew (SAML.UserRef tenant subject) = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (tenant, normalizeQualifiedNameId subject)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (tenant, normalizeQualifiedNameId subject)) where sel :: PrepQuery R (SAML.Issuer, NormalizedUNameID) (Identity UserId) sel = "SELECT uid FROM user_v2 WHERE issuer = ? AND normalized_uname_id = ?" @@ -353,13 +353,13 @@ getSAMLUser uref = do getSAMLUserLegacy :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId) getSAMLUserLegacy (SAML.UserRef tenant subject) = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (tenant, subject)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (tenant, subject)) where sel :: PrepQuery R (SAML.Issuer, SAML.NameID) (Identity UserId) sel = "SELECT uid FROM user WHERE issuer = ? AND sso_id = ?" deleteSAMLUsersByIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m () -deleteSAMLUsersByIssuer issuer = retry x5 . write del $ params Quorum (Identity issuer) +deleteSAMLUsersByIssuer issuer = retry x5 . write del $ params LocalQuorum (Identity issuer) where del :: PrepQuery W (Identity SAML.Issuer) () del = "DELETE FROM user_v2 WHERE issuer = ?" @@ -373,12 +373,12 @@ deleteSAMLUser uid uref = do deleteSAMLUserNew uref where deleteSAMLUserNew :: (HasCallStack, MonadClient m) => SAML.UserRef -> m () - deleteSAMLUserNew (SAML.UserRef tenant subject) = retry x5 . write del $ params Quorum (tenant, normalizeQualifiedNameId subject) + deleteSAMLUserNew (SAML.UserRef tenant subject) = retry x5 . write del $ params LocalQuorum (tenant, normalizeQualifiedNameId subject) where del :: PrepQuery W (SAML.Issuer, NormalizedUNameID) () del = "DELETE FROM user_v2 WHERE issuer = ? AND normalized_uname_id = ?" deleteSAMLUserLegacy :: (HasCallStack, MonadClient m) => SAML.UserRef -> m () - deleteSAMLUserLegacy (SAML.UserRef tenant subject) = retry x5 . write del $ params Quorum (tenant, subject) + deleteSAMLUserLegacy (SAML.UserRef tenant subject) = retry x5 . write del $ params LocalQuorum (tenant, subject) where del :: PrepQuery W (SAML.Issuer, SAML.NameID) () del = "DELETE FROM user WHERE issuer = ? AND sso_id = ?" @@ -398,7 +398,7 @@ insertBindCookie cky uid ttlNDT = do env <- ask TTL ttlInt32 <- mkTTLAuthnRequestsNDT env ttlNDT let ckyval = cs . Cky.setCookieValue . SAML.fromSimpleSetCookie . getSimpleSetCookie $ cky - retry x5 . write ins $ params Quorum (ckyval, uid, ttlInt32) + retry x5 . write ins $ params LocalQuorum (ckyval, uid, ttlInt32) where ins :: PrepQuery W (ST, UserId, Int32) () ins = "INSERT INTO bind_cookie (cookie, session_owner) VALUES (?, ?) USING TTL ?" @@ -407,7 +407,7 @@ insertBindCookie cky uid ttlNDT = do lookupBindCookie :: (HasCallStack, MonadClient m) => BindCookie -> m (Maybe UserId) lookupBindCookie (cs . fromBindCookie -> ckyval :: ST) = runIdentity <$$> do - (retry x1 . query1 sel $ params Quorum (Identity ckyval)) + (retry x1 . query1 sel $ params LocalQuorum (Identity ckyval)) where sel :: PrepQuery R (Identity ST) (Identity UserId) sel = "SELECT session_owner FROM bind_cookie WHERE cookie = ?" @@ -427,7 +427,7 @@ storeIdPConfig :: m () storeIdPConfig idp = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery ins ( idp ^. SAML.idpId, @@ -470,7 +470,7 @@ setReplacedBy :: Replacing -> m () setReplacedBy (Replaced old) (Replacing new) = do - retry x5 . write ins $ params Quorum (new, old) + retry x5 . write ins $ params LocalQuorum (new, old) where ins :: PrepQuery W (SAML.IdPId, SAML.IdPId) () ins = "UPDATE idp SET replaced_by = ? WHERE idp = ?" @@ -481,7 +481,7 @@ clearReplacedBy :: Replaced -> m () clearReplacedBy (Replaced old) = do - retry x5 . write ins $ params Quorum (Identity old) + retry x5 . write ins $ params LocalQuorum (Identity old) where ins :: PrepQuery W (Identity SAML.IdPId) () ins = "UPDATE idp SET replaced_by = null WHERE idp = ?" @@ -492,7 +492,7 @@ getIdPConfig :: SAML.IdPId -> m (Maybe IdP) getIdPConfig idpid = - traverse toIdp =<< retry x1 (query1 sel $ params Quorum (Identity idpid)) + traverse toIdp =<< retry x1 (query1 sel $ params LocalQuorum (Identity idpid)) where toIdp :: IdPConfigRow -> m IdP toIdp @@ -522,9 +522,9 @@ getIdPIdByIssuerWithoutTeam :: SAML.Issuer -> m (GetIdPResult SAML.IdPId) getIdPIdByIssuerWithoutTeam issuer = do - (runIdentity <$$> retry x1 (query selv2 $ params Quorum (Identity issuer))) >>= \case + (runIdentity <$$> retry x1 (query selv2 $ params LocalQuorum (Identity issuer))) >>= \case [] -> - (runIdentity <$$> retry x1 (query1 sel $ params Quorum (Identity issuer))) >>= \case + (runIdentity <$$> retry x1 (query1 sel $ params LocalQuorum (Identity issuer))) >>= \case Just idpid -> pure $ GetIdPFound idpid Nothing -> pure GetIdPNotFound [idpid] -> @@ -544,7 +544,7 @@ getIdPIdByIssuerWithTeam :: TeamId -> m (Maybe SAML.IdPId) getIdPIdByIssuerWithTeam issuer tid = do - runIdentity <$$> retry x1 (query1 sel $ params Quorum (issuer, tid)) + runIdentity <$$> retry x1 (query1 sel $ params LocalQuorum (issuer, tid)) where sel :: PrepQuery R (SAML.Issuer, TeamId) (Identity SAML.IdPId) sel = "SELECT idp FROM issuer_idp_v2 WHERE issuer = ? and team = ?" @@ -554,7 +554,7 @@ getIdPConfigsByTeam :: TeamId -> m [IdP] getIdPConfigsByTeam team = do - idpids <- runIdentity <$$> retry x1 (query sel $ params Quorum (Identity team)) + idpids <- runIdentity <$$> retry x1 (query sel $ params LocalQuorum (Identity team)) catMaybes <$> mapM getIdPConfig idpids where sel :: PrepQuery R (Identity TeamId) (Identity SAML.IdPId) @@ -568,7 +568,7 @@ deleteIdPConfig :: m () deleteIdPConfig idp issuer team = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delDefaultIdp (Identity idp) addPrepQuery delIdp (Identity idp) addPrepQuery delIssuerIdp (Identity issuer) @@ -595,7 +595,7 @@ storeIdPRawMetadata :: SAML.IdPId -> ST -> m () -storeIdPRawMetadata idp raw = retry x5 . write ins $ params Quorum (idp, raw) +storeIdPRawMetadata idp raw = retry x5 . write ins $ params LocalQuorum (idp, raw) where ins :: PrepQuery W (SAML.IdPId, ST) () ins = "INSERT INTO idp_raw_metadata (id, metadata) VALUES (?, ?)" @@ -606,7 +606,7 @@ getIdPRawMetadata :: m (Maybe ST) getIdPRawMetadata idp = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (Identity idp)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (Identity idp)) where sel :: PrepQuery R (Identity SAML.IdPId) (Identity ST) sel = "SELECT metadata FROM idp_raw_metadata WHERE id = ?" @@ -615,7 +615,7 @@ deleteIdPRawMetadata :: (HasCallStack, MonadClient m) => SAML.IdPId -> m () -deleteIdPRawMetadata idp = retry x5 . write del $ params Quorum (Identity idp) +deleteIdPRawMetadata idp = retry x5 . write del $ params LocalQuorum (Identity idp) where del :: PrepQuery W (Identity SAML.IdPId) () del = "DELETE FROM idp_raw_metadata WHERE id = ?" @@ -632,7 +632,7 @@ getDefaultSsoCode :: m (Maybe SAML.IdPId) getDefaultSsoCode = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum ()) + <$$> (retry x1 . query1 sel $ params LocalQuorum ()) where sel :: PrepQuery R () (Identity SAML.IdPId) sel = "SELECT idp FROM default_idp WHERE partition_key_always_default = 'default' ORDER BY idp LIMIT 1" @@ -648,7 +648,7 @@ storeDefaultSsoCode idpId = do -- `ORDER BY` clause. The others will get removed by `deleteDefaultSsoCode` -- the next time this function is called (as it removes all entries). deleteDefaultSsoCode - retry x5 . write ins $ params Quorum (Identity idpId) + retry x5 . write ins $ params LocalQuorum (Identity idpId) where ins :: PrepQuery W (Identity SAML.IdPId) () ins = "INSERT INTO default_idp (partition_key_always_default, idp) VALUES ('default', ?)" @@ -656,7 +656,7 @@ storeDefaultSsoCode idpId = do deleteDefaultSsoCode :: (HasCallStack, MonadClient m) => m () -deleteDefaultSsoCode = retry x5 . write del $ params Quorum () +deleteDefaultSsoCode = retry x5 . write del $ params LocalQuorum () where del :: PrepQuery W () () del = "DELETE FROM default_idp WHERE partition_key_always_default = 'default'" @@ -684,7 +684,7 @@ insertScimToken :: m () insertScimToken token ScimTokenInfo {..} = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum let tokenHash = hashScimToken token addPrepQuery insByToken (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr) addPrepQuery insByTeam (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr) @@ -711,7 +711,7 @@ lookupScimToken :: m (Maybe ScimTokenInfo) lookupScimToken token = do let tokenHash = hashScimToken token - rows <- retry x1 . query sel $ params Quorum (tokenHash, token) + rows <- retry x1 . query sel $ params LocalQuorum (tokenHash, token) case fmap (scimTokenLookupKey &&& Prelude.id) rows of [(ScimTokenLookupKeyHashed _, row)] -> pure (Just (fromScimTokenRow row)) @@ -743,7 +743,7 @@ connvertPlaintextToken :: m () connvertPlaintextToken token ScimTokenInfo {..} = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum let tokenHash = hashScimToken token -- enter by new lookup key addPrepQuery insByToken (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr) @@ -760,7 +760,7 @@ getScimTokens :: getScimTokens team = do -- We don't need pagination here because the limit should be pretty low -- (e.g. 16). If the limit grows, we might have to introduce pagination. - rows <- retry x1 . query sel $ params Quorum (Identity team) + rows <- retry x1 . query sel $ params LocalQuorum (Identity team) pure $ sortOn stiCreatedAt $ map fromScimTokenRow rows where sel :: PrepQuery R (Identity TeamId) ScimTokenRow @@ -777,10 +777,10 @@ deleteScimToken :: ScimTokenId -> m () deleteScimToken team tokenid = do - mbToken <- retry x1 . query1 selById $ params Quorum (team, tokenid) + mbToken <- retry x1 . query1 selById $ params LocalQuorum (team, tokenid) retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delById (team, tokenid) for_ mbToken $ \(Identity key) -> addPrepQuery delByTokenLookup (Identity key) @@ -812,10 +812,10 @@ deleteTeamScimTokens :: TeamId -> m () deleteTeamScimTokens team = do - tokens <- retry x5 $ query sel $ params Quorum (Identity team) + tokens <- retry x5 $ query sel $ params LocalQuorum (Identity team) retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delByTeam (Identity team) mapM_ (addPrepQuery delByTokenLookup) tokens where @@ -834,7 +834,7 @@ writeScimUserTimes :: (HasCallStack, MonadClient m) => WithMeta (WithId UserId a writeScimUserTimes (WithMeta meta (WithId uid _)) = retry x5 . write ins $ params - Quorum + LocalQuorum ( uid, toUTCTimeMillis $ created meta, toUTCTimeMillis $ lastModified meta @@ -846,7 +846,7 @@ writeScimUserTimes (WithMeta meta (WithId uid _)) = -- | Read creation and last-update time from database for a given user id. readScimUserTimes :: (HasCallStack, MonadClient m) => UserId -> m (Maybe (UTCTimeMillis, UTCTimeMillis)) readScimUserTimes uid = do - retry x1 . query1 sel $ params Quorum (Identity uid) + retry x1 . query1 sel $ params LocalQuorum (Identity uid) where sel :: PrepQuery R (Identity UserId) (UTCTimeMillis, UTCTimeMillis) sel = "SELECT created_at, last_updated_at FROM scim_user_times WHERE uid = ?" @@ -857,7 +857,7 @@ deleteScimUserTimes :: (HasCallStack, MonadClient m) => UserId -> m () -deleteScimUserTimes uid = retry x5 . write del $ params Quorum (Identity uid) +deleteScimUserTimes uid = retry x5 . write del $ params LocalQuorum (Identity uid) where del :: PrepQuery W (Identity UserId) () del = "DELETE FROM scim_user_times WHERE uid = ?" @@ -869,14 +869,14 @@ deleteScimUserTimes uid = retry x5 . write del $ params Quorum (Identity uid) -- as a 'Text'.) insertScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> UserId -> m () insertScimExternalId tid (fromEmail -> email) uid = - retry x5 . write insert $ params Quorum (tid, email, uid) + retry x5 . write insert $ params LocalQuorum (tid, email, uid) where insert :: PrepQuery W (TeamId, Text, UserId) () insert = "INSERT INTO scim_external (team, external_id, user) VALUES (?, ?, ?)" -- | The inverse of 'insertScimExternalId'. lookupScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> m (Maybe UserId) -lookupScimExternalId tid (fromEmail -> email) = runIdentity <$$> (retry x1 . query1 sel $ params Quorum (tid, email)) +lookupScimExternalId tid (fromEmail -> email) = runIdentity <$$> (retry x1 . query1 sel $ params LocalQuorum (tid, email)) where sel :: PrepQuery R (TeamId, Text) (Identity UserId) sel = "SELECT user FROM scim_external WHERE team = ? and external_id = ?" @@ -884,7 +884,7 @@ lookupScimExternalId tid (fromEmail -> email) = runIdentity <$$> (retry x1 . que -- | The other inverse of 'insertScimExternalId' :). deleteScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> m () deleteScimExternalId tid (fromEmail -> email) = - retry x5 . write delete $ params Quorum (tid, email) + retry x5 . write delete $ params LocalQuorum (tid, email) where delete :: PrepQuery W (TeamId, Text) () delete = "DELETE FROM scim_external WHERE team = ? and external_id = ?" diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 7685df85177..980a761aa04 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -1515,7 +1515,7 @@ specSparUserMigration = do let insert :: PrepQuery W (SAML.Issuer, SAML.NameID, UserId) () insert = "INSERT INTO user (issuer, sso_id, uid) VALUES (?, ?, ?)" runClient client $ - retry x5 $ write insert (params Quorum (issuer, subject, memberUid)) + retry x5 $ write insert (params LocalQuorum (issuer, subject, memberUid)) mbUserId <- do authnreq <- negotiateAuthnRequest idp diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index 5be4bc24a2c..20c3bdc071c 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -277,7 +277,7 @@ testPlaintextTokensAreConverted = do wrapMonadClient $ do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery insByToken (ScimTokenLookupKeyPlaintext token, teamId, tokenId, now, Nothing, descr) addPrepQuery insByTeam (ScimTokenLookupKeyPlaintext token, teamId, tokenId, now, Nothing, descr) pure token @@ -299,7 +299,7 @@ testPlaintextTokensAreConverted = do countTokensInDB :: ScimTokenLookupKey -> TestSpar Int64 countTokensInDB key = wrapMonadClient $ do - count <- runIdentity <$$> (retry x1 . query1 selByKey $ params Quorum (Identity key)) + count <- runIdentity <$$> (retry x1 . query1 selByKey $ params LocalQuorum (Identity key)) pure $ fromMaybe 0 count selByKey :: PrepQuery R (Identity ScimTokenLookupKey) (Identity Int64) diff --git a/tools/db/auto-whitelist/src/Work.hs b/tools/db/auto-whitelist/src/Work.hs index b8ff4c84c50..d79832dfc6e 100644 --- a/tools/db/auto-whitelist/src/Work.hs +++ b/tools/db/auto-whitelist/src/Work.hs @@ -49,7 +49,7 @@ runCommand l brig = runClient brig $ do -- | Get all services in team conversations getServices :: Client [(ProviderId, ServiceId, TeamId)] -getServices = retry x5 $ query cql (params Quorum ()) +getServices = retry x5 $ query cql (params LocalQuorum ()) where cql :: PrepQuery R () (ProviderId, ServiceId, TeamId) cql = "SELECT provider, service, team FROM service_team" @@ -57,7 +57,7 @@ getServices = retry x5 $ query cql (params Quorum ()) -- | Check if a service exists doesServiceExist :: (ProviderId, ServiceId, a) -> Client Bool doesServiceExist (pid, sid, _) = - retry x5 $ fmap isJust $ query1 cql (params Quorum (pid, sid)) + retry x5 $ fmap isJust $ query1 cql (params LocalQuorum (pid, sid)) where cql :: PrepQuery R (ProviderId, ServiceId) (Identity ServiceId) cql = @@ -73,7 +73,7 @@ whitelistService l (pid, sid, tid) = do . Log.field "service" (show sid) . Log.field "team" (show tid) retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged addPrepQuery insert1 (tid, pid, sid) addPrepQuery insert1Rev (tid, pid, sid) diff --git a/tools/db/billing-team-member-backfill/src/Work.hs b/tools/db/billing-team-member-backfill/src/Work.hs index 318610f8bef..4d45abcc3b3 100644 --- a/tools/db/billing-team-member-backfill/src/Work.hs +++ b/tools/db/billing-team-member-backfill/src/Work.hs @@ -61,7 +61,7 @@ pageSize = 1000 -- | Get team members from Galley getTeamMembers :: ConduitM () [(TeamId, UserId, Maybe Permissions)] Client () -getTeamMembers = paginateC cql (paramsP Quorum () pageSize) x5 +getTeamMembers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (TeamId, UserId, Maybe Permissions) cql = "SELECT team, user, perms FROM team_member" @@ -70,7 +70,7 @@ createBillingTeamMembers :: [(TeamId, UserId)] -> Client () createBillingTeamMembers pairs = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum mapM_ (addPrepQuery cql) pairs where cql :: PrepQuery W (TeamId, UserId) () diff --git a/tools/db/find-undead/src/Work.hs b/tools/db/find-undead/src/Work.hs index 8a08096c335..7661bbd8fb3 100644 --- a/tools/db/find-undead/src/Work.hs +++ b/tools/db/find-undead/src/Work.hs @@ -105,7 +105,7 @@ extractScrollId :: MonadThrow m => ES.SearchResult a -> m ES.ScrollId extractScrollId res = maybe (throwM NoScrollId) pure (ES.scrollId res) usersInCassandra :: [UUID] -> Client [(UUID, Maybe AccountStatus, Maybe (Writetime ()))] -usersInCassandra users = retry x1 $ query cql (params Quorum (Identity users)) +usersInCassandra users = retry x1 $ query cql (params LocalQuorum (Identity users)) where cql :: PrepQuery R (Identity [UUID]) (UUID, Maybe AccountStatus, Maybe (Writetime ())) cql = "SELECT id, status, writetime(status) from user where id in ?" diff --git a/tools/db/migrate-sso-feature-flag/src/Work.hs b/tools/db/migrate-sso-feature-flag/src/Work.hs index a194b5c8e60..c2dc980ab77 100644 --- a/tools/db/migrate-sso-feature-flag/src/Work.hs +++ b/tools/db/migrate-sso-feature-flag/src/Work.hs @@ -57,7 +57,7 @@ pageSize :: Int32 pageSize = 1000 getSsoTeams :: ConduitM () [Identity TeamId] Client () -getSsoTeams = paginateC cql (paramsP Quorum () pageSize) x5 +getSsoTeams = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (Identity TeamId) cql = "select team from idp" @@ -67,6 +67,6 @@ writeSsoFlags = mapM_ (`setSSOTeamConfig` TeamFeatureEnabled) where setSSOTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatusValue -> m () setSSOTeamConfig tid ssoTeamConfigStatus = do - retry x5 $ write updateSSOTeamConfig (params Quorum (ssoTeamConfigStatus, tid)) + retry x5 $ write updateSSOTeamConfig (params LocalQuorum (ssoTeamConfigStatus, tid)) updateSSOTeamConfig :: PrepQuery W (TeamFeatureStatusValue, TeamId) () updateSSOTeamConfig = "update team_features set sso_status = ? where team_id = ?" diff --git a/tools/db/move-team/move-team.cabal b/tools/db/move-team/move-team.cabal index 55543fbe2be..8b3fb1e66c5 100644 --- a/tools/db/move-team/move-team.cabal +++ b/tools/db/move-team/move-team.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6c50a8e33625c79cb1b04adac7f5a9b9c337181da35f450c10ea970548a9acd4 +-- hash: 6f97fa57af68acb9606816e6048ebe009ec9c0f01a971d39ae9dbc5e2061346d name: move-team version: 1.0.0 @@ -38,7 +38,6 @@ library , cassandra-util , conduit , containers - , cql , filepath , galley , imports @@ -74,7 +73,6 @@ executable move-team , cassandra-util , conduit , containers - , cql , filepath , galley , imports @@ -111,7 +109,6 @@ executable move-team-generate , cassandra-util , conduit , containers - , cql , filepath , galley , imports diff --git a/tools/db/move-team/package.yaml b/tools/db/move-team/package.yaml index 4d01f5f4ad9..108af8a6d9c 100644 --- a/tools/db/move-team/package.yaml +++ b/tools/db/move-team/package.yaml @@ -24,7 +24,7 @@ dependencies: - cassandra-util - conduit - containers -- cql +- cassandra-util - filepath - galley - imports diff --git a/tools/db/move-team/src/Common.hs b/tools/db/move-team/src/Common.hs index 64041a43899..2d79a203fb9 100644 --- a/tools/db/move-team/src/Common.hs +++ b/tools/db/move-team/src/Common.hs @@ -22,7 +22,6 @@ import Conduit import Data.Aeson import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit.Combinators as C -import Database.CQL.Protocol (Tuple) import Imports import System.IO @@ -44,5 +43,5 @@ sinkTableRows insertQuery = go case mbTuple of Nothing -> pure () Just tuple -> do - lift $ write insertQuery (params Quorum tuple) + lift $ write insertQuery (params LocalQuorum tuple) go diff --git a/tools/db/move-team/src/ParseSchema.hs b/tools/db/move-team/src/ParseSchema.hs index f98909218d8..cae5abef31f 100644 --- a/tools/db/move-team/src/ParseSchema.hs +++ b/tools/db/move-team/src/ParseSchema.hs @@ -229,7 +229,7 @@ select{{keySpaceCaml}}{{tableNameCaml}} = "SELECT {{columns}} FROM {{tableName}} read{{keySpaceCaml}}{{tableNameCaml}}:: Env -> {{lookupKeyType}} -> ConduitM () [Row{{keySpaceCaml}}{{tableNameCaml}}] IO () read{{keySpaceCaml}}{{tableNameCaml}} Env {..} {{lookupKeyVar}} = transPipe (runClient env{{keySpaceCaml}}) $ - paginateC select{{keySpaceCaml}}{{tableNameCaml}} (paramsP Quorum (pure {{lookupKeyVar}}) envPageSize) x5 + paginateC select{{keySpaceCaml}}{{tableNameCaml}} (paramsP LocalQuorum (pure {{lookupKeyVar}}) envPageSize) x5 select{{keySpaceCaml}}{{tableNameCaml}}All :: PrepQuery R () Row{{keySpaceCaml}}{{tableNameCaml}} select{{keySpaceCaml}}{{tableNameCaml}}All = "SELECT {{columns}} FROM {{tableName}}" @@ -237,7 +237,7 @@ select{{keySpaceCaml}}{{tableNameCaml}}All = "SELECT {{columns}} FROM {{tableNam read{{keySpaceCaml}}{{tableNameCaml}}All :: Env -> ConduitM () [Row{{keySpaceCaml}}{{tableNameCaml}}] IO () read{{keySpaceCaml}}{{tableNameCaml}}All Env {..} = transPipe (runClient env{{keySpaceCaml}}) $ - paginateC select{{keySpaceCaml}}{{tableNameCaml}}All (paramsP Quorum () envPageSize) x5 + paginateC select{{keySpaceCaml}}{{tableNameCaml}}All (paramsP LocalQuorum () envPageSize) x5 export{{keySpaceCaml}}{{tableNameCaml}}Full :: Env -> FilePath -> IO () export{{keySpaceCaml}}{{tableNameCaml}}Full env@Env {..} path = do diff --git a/tools/db/move-team/src/Schema.hs b/tools/db/move-team/src/Schema.hs index 81d99692dec..56ce0a9a8da 100644 --- a/tools/db/move-team/src/Schema.hs +++ b/tools/db/move-team/src/Schema.hs @@ -46,7 +46,7 @@ selectBrigClients = "SELECT user, client, class, cookie, ip, label, lat, lon, mo readBrigClients :: Env -> [UserId] -> ConduitM () [RowBrigClients] IO () readBrigClients Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigClients (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigClients (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigClientsAll :: PrepQuery R () RowBrigClients selectBrigClientsAll = "SELECT user, client, class, cookie, ip, label, lat, lon, model, tstamp, type FROM clients" @@ -54,7 +54,7 @@ selectBrigClientsAll = "SELECT user, client, class, cookie, ip, label, lat, lon, readBrigClientsAll :: Env -> ConduitM () [RowBrigClients] IO () readBrigClientsAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigClientsAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigClientsAll (paramsP LocalQuorum () envPageSize) x5 exportBrigClientsFull :: Env -> FilePath -> IO () exportBrigClientsFull env@Env {..} path = do @@ -92,7 +92,7 @@ selectBrigConnection = "SELECT left, right, conv, last_update, message, status F readBrigConnection :: Env -> [UserId] -> ConduitM () [RowBrigConnection] IO () readBrigConnection Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigConnection (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigConnection (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigConnectionAll :: PrepQuery R () RowBrigConnection selectBrigConnectionAll = "SELECT left, right, conv, last_update, message, status FROM connection" @@ -100,7 +100,7 @@ selectBrigConnectionAll = "SELECT left, right, conv, last_update, message, statu readBrigConnectionAll :: Env -> ConduitM () [RowBrigConnection] IO () readBrigConnectionAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigConnectionAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigConnectionAll (paramsP LocalQuorum () envPageSize) x5 exportBrigConnectionFull :: Env -> FilePath -> IO () exportBrigConnectionFull env@Env {..} path = do @@ -138,7 +138,7 @@ selectBrigLoginCodes = "SELECT user, code, retries, timeout FROM login_codes WHE readBrigLoginCodes :: Env -> [UserId] -> ConduitM () [RowBrigLoginCodes] IO () readBrigLoginCodes Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigLoginCodes (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigLoginCodes (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigLoginCodesAll :: PrepQuery R () RowBrigLoginCodes selectBrigLoginCodesAll = "SELECT user, code, retries, timeout FROM login_codes" @@ -146,7 +146,7 @@ selectBrigLoginCodesAll = "SELECT user, code, retries, timeout FROM login_codes" readBrigLoginCodesAll :: Env -> ConduitM () [RowBrigLoginCodes] IO () readBrigLoginCodesAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigLoginCodesAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigLoginCodesAll (paramsP LocalQuorum () envPageSize) x5 exportBrigLoginCodesFull :: Env -> FilePath -> IO () exportBrigLoginCodesFull env@Env {..} path = do @@ -184,7 +184,7 @@ selectBrigPasswordReset = "SELECT key, code, retries, timeout, user FROM passwor readBrigPasswordReset :: Env -> [PasswordResetKey] -> ConduitM () [RowBrigPasswordReset] IO () readBrigPasswordReset Env {..} reset_keys = transPipe (runClient envBrig) $ - paginateC selectBrigPasswordReset (paramsP Quorum (pure reset_keys) envPageSize) x5 + paginateC selectBrigPasswordReset (paramsP LocalQuorum (pure reset_keys) envPageSize) x5 selectBrigPasswordResetAll :: PrepQuery R () RowBrigPasswordReset selectBrigPasswordResetAll = "SELECT key, code, retries, timeout, user FROM password_reset" @@ -192,7 +192,7 @@ selectBrigPasswordResetAll = "SELECT key, code, retries, timeout, user FROM pass readBrigPasswordResetAll :: Env -> ConduitM () [RowBrigPasswordReset] IO () readBrigPasswordResetAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigPasswordResetAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigPasswordResetAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPasswordResetFull :: Env -> FilePath -> IO () exportBrigPasswordResetFull env@Env {..} path = do @@ -230,7 +230,7 @@ selectBrigPrekeys = "SELECT user, client, key, data FROM prekeys WHERE user in ? readBrigPrekeys :: Env -> [UserId] -> ConduitM () [RowBrigPrekeys] IO () readBrigPrekeys Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigPrekeys (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigPrekeys (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigPrekeysAll :: PrepQuery R () RowBrigPrekeys selectBrigPrekeysAll = "SELECT user, client, key, data FROM prekeys" @@ -238,7 +238,7 @@ selectBrigPrekeysAll = "SELECT user, client, key, data FROM prekeys" readBrigPrekeysAll :: Env -> ConduitM () [RowBrigPrekeys] IO () readBrigPrekeysAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigPrekeysAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigPrekeysAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPrekeysFull :: Env -> FilePath -> IO () exportBrigPrekeysFull env@Env {..} path = do @@ -276,7 +276,7 @@ selectBrigProperties = "SELECT user, key, value FROM properties WHERE user in ?" readBrigProperties :: Env -> [UserId] -> ConduitM () [RowBrigProperties] IO () readBrigProperties Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigProperties (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigProperties (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigPropertiesAll :: PrepQuery R () RowBrigProperties selectBrigPropertiesAll = "SELECT user, key, value FROM properties" @@ -284,7 +284,7 @@ selectBrigPropertiesAll = "SELECT user, key, value FROM properties" readBrigPropertiesAll :: Env -> ConduitM () [RowBrigProperties] IO () readBrigPropertiesAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigPropertiesAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigPropertiesAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPropertiesFull :: Env -> FilePath -> IO () exportBrigPropertiesFull env@Env {..} path = do @@ -322,7 +322,7 @@ selectBrigRichInfo = "SELECT user, json FROM rich_info WHERE user in ?" readBrigRichInfo :: Env -> [UserId] -> ConduitM () [RowBrigRichInfo] IO () readBrigRichInfo Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigRichInfo (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigRichInfo (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigRichInfoAll :: PrepQuery R () RowBrigRichInfo selectBrigRichInfoAll = "SELECT user, json FROM rich_info" @@ -330,7 +330,7 @@ selectBrigRichInfoAll = "SELECT user, json FROM rich_info" readBrigRichInfoAll :: Env -> ConduitM () [RowBrigRichInfo] IO () readBrigRichInfoAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigRichInfoAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigRichInfoAll (paramsP LocalQuorum () envPageSize) x5 exportBrigRichInfoFull :: Env -> FilePath -> IO () exportBrigRichInfoFull env@Env {..} path = do @@ -368,7 +368,7 @@ selectBrigUser = "SELECT id, accent, accent_id, activated, assets, country, emai readBrigUser :: Env -> [UserId] -> ConduitM () [RowBrigUser] IO () readBrigUser Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigUser (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigUser (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigUserAll :: PrepQuery R () RowBrigUser selectBrigUserAll = "SELECT id, accent, accent_id, activated, assets, country, email, expires, handle, language, managed_by, name, password, phone, picture, provider, searchable, service, sso_id, status, team FROM user" @@ -376,7 +376,7 @@ selectBrigUserAll = "SELECT id, accent, accent_id, activated, assets, country, e readBrigUserAll :: Env -> ConduitM () [RowBrigUser] IO () readBrigUserAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserFull :: Env -> FilePath -> IO () exportBrigUserFull env@Env {..} path = do @@ -414,7 +414,7 @@ selectBrigUserHandle = "SELECT handle, user FROM user_handle WHERE handle in ?" readBrigUserHandle :: Env -> [Handle] -> ConduitM () [RowBrigUserHandle] IO () readBrigUserHandle Env {..} handles = transPipe (runClient envBrig) $ - paginateC selectBrigUserHandle (paramsP Quorum (pure handles) envPageSize) x5 + paginateC selectBrigUserHandle (paramsP LocalQuorum (pure handles) envPageSize) x5 selectBrigUserHandleAll :: PrepQuery R () RowBrigUserHandle selectBrigUserHandleAll = "SELECT handle, user FROM user_handle" @@ -422,7 +422,7 @@ selectBrigUserHandleAll = "SELECT handle, user FROM user_handle" readBrigUserHandleAll :: Env -> ConduitM () [RowBrigUserHandle] IO () readBrigUserHandleAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserHandleAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserHandleAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserHandleFull :: Env -> FilePath -> IO () exportBrigUserHandleFull env@Env {..} path = do @@ -460,7 +460,7 @@ selectBrigUserKeys = "SELECT key, user FROM user_keys WHERE key in ?" readBrigUserKeys :: Env -> [Int32] -> ConduitM () [RowBrigUserKeys] IO () readBrigUserKeys Env {..} keys = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeys (paramsP Quorum (pure keys) envPageSize) x5 + paginateC selectBrigUserKeys (paramsP LocalQuorum (pure keys) envPageSize) x5 selectBrigUserKeysAll :: PrepQuery R () RowBrigUserKeys selectBrigUserKeysAll = "SELECT key, user FROM user_keys" @@ -468,7 +468,7 @@ selectBrigUserKeysAll = "SELECT key, user FROM user_keys" readBrigUserKeysAll :: Env -> ConduitM () [RowBrigUserKeys] IO () readBrigUserKeysAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeysAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserKeysAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserKeysFull :: Env -> FilePath -> IO () exportBrigUserKeysFull env@Env {..} path = do @@ -506,7 +506,7 @@ selectBrigUserKeysHash = "SELECT key, key_type, user FROM user_keys_hash WHERE k readBrigUserKeysHash :: Env -> [Int32] -> ConduitM () [RowBrigUserKeysHash] IO () readBrigUserKeysHash Env {..} keys = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeysHash (paramsP Quorum (pure keys) envPageSize) x5 + paginateC selectBrigUserKeysHash (paramsP LocalQuorum (pure keys) envPageSize) x5 selectBrigUserKeysHashAll :: PrepQuery R () RowBrigUserKeysHash selectBrigUserKeysHashAll = "SELECT key, key_type, user FROM user_keys_hash" @@ -514,7 +514,7 @@ selectBrigUserKeysHashAll = "SELECT key, key_type, user FROM user_keys_hash" readBrigUserKeysHashAll :: Env -> ConduitM () [RowBrigUserKeysHash] IO () readBrigUserKeysHashAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeysHashAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserKeysHashAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserKeysHashFull :: Env -> FilePath -> IO () exportBrigUserKeysHashFull env@Env {..} path = do @@ -552,7 +552,7 @@ selectGalleyBillingTeamMember = "SELECT team, user FROM billing_team_member WHER readGalleyBillingTeamMember :: Env -> TeamId -> ConduitM () [RowGalleyBillingTeamMember] IO () readGalleyBillingTeamMember Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyBillingTeamMember (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyBillingTeamMember (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyBillingTeamMemberAll :: PrepQuery R () RowGalleyBillingTeamMember selectGalleyBillingTeamMemberAll = "SELECT team, user FROM billing_team_member" @@ -560,7 +560,7 @@ selectGalleyBillingTeamMemberAll = "SELECT team, user FROM billing_team_member" readGalleyBillingTeamMemberAll :: Env -> ConduitM () [RowGalleyBillingTeamMember] IO () readGalleyBillingTeamMemberAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyBillingTeamMemberAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyBillingTeamMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyBillingTeamMemberFull :: Env -> FilePath -> IO () exportGalleyBillingTeamMemberFull env@Env {..} path = do @@ -598,7 +598,7 @@ selectGalleyClients = "SELECT user, clients FROM clients WHERE user in ?" readGalleyClients :: Env -> [UserId] -> ConduitM () [RowGalleyClients] IO () readGalleyClients Env {..} uids = transPipe (runClient envGalley) $ - paginateC selectGalleyClients (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGalleyClients (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGalleyClientsAll :: PrepQuery R () RowGalleyClients selectGalleyClientsAll = "SELECT user, clients FROM clients" @@ -606,7 +606,7 @@ selectGalleyClientsAll = "SELECT user, clients FROM clients" readGalleyClientsAll :: Env -> ConduitM () [RowGalleyClients] IO () readGalleyClientsAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyClientsAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyClientsAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyClientsFull :: Env -> FilePath -> IO () exportGalleyClientsFull env@Env {..} path = do @@ -644,7 +644,7 @@ selectGalleyConversation = "SELECT conv, access, access_role, creator, deleted, readGalleyConversation :: Env -> [ConvId] -> ConduitM () [RowGalleyConversation] IO () readGalleyConversation Env {..} cids = transPipe (runClient envGalley) $ - paginateC selectGalleyConversation (paramsP Quorum (pure cids) envPageSize) x5 + paginateC selectGalleyConversation (paramsP LocalQuorum (pure cids) envPageSize) x5 selectGalleyConversationAll :: PrepQuery R () RowGalleyConversation selectGalleyConversationAll = "SELECT conv, access, access_role, creator, deleted, message_timer, name, receipt_mode, team, type FROM conversation" @@ -652,7 +652,7 @@ selectGalleyConversationAll = "SELECT conv, access, access_role, creator, delete readGalleyConversationAll :: Env -> ConduitM () [RowGalleyConversation] IO () readGalleyConversationAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyConversationAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyConversationAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyConversationFull :: Env -> FilePath -> IO () exportGalleyConversationFull env@Env {..} path = do @@ -690,7 +690,7 @@ selectGalleyMember = "SELECT conv, user, conversation_role, hidden, hidden_ref, readGalleyMember :: Env -> [ConvId] -> ConduitM () [RowGalleyMember] IO () readGalleyMember Env {..} cids = transPipe (runClient envGalley) $ - paginateC selectGalleyMember (paramsP Quorum (pure cids) envPageSize) x5 + paginateC selectGalleyMember (paramsP LocalQuorum (pure cids) envPageSize) x5 selectGalleyMemberAll :: PrepQuery R () RowGalleyMember selectGalleyMemberAll = "SELECT conv, user, conversation_role, hidden, hidden_ref, otr_archived, otr_archived_ref, otr_muted, otr_muted_ref, otr_muted_status, provider, service, status, user_remote_domain, user_remote_id FROM member" @@ -698,7 +698,7 @@ selectGalleyMemberAll = "SELECT conv, user, conversation_role, hidden, hidden_re readGalleyMemberAll :: Env -> ConduitM () [RowGalleyMember] IO () readGalleyMemberAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyMemberAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyMemberFull :: Env -> FilePath -> IO () exportGalleyMemberFull env@Env {..} path = do @@ -736,7 +736,7 @@ selectGalleyTeam = "SELECT team, binding, creator, deleted, icon, icon_key, name readGalleyTeam :: Env -> TeamId -> ConduitM () [RowGalleyTeam] IO () readGalleyTeam Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeam (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeam (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamAll :: PrepQuery R () RowGalleyTeam selectGalleyTeamAll = "SELECT team, binding, creator, deleted, icon, icon_key, name, search_visibility, status FROM team" @@ -744,7 +744,7 @@ selectGalleyTeamAll = "SELECT team, binding, creator, deleted, icon, icon_key, n readGalleyTeamAll :: Env -> ConduitM () [RowGalleyTeam] IO () readGalleyTeamAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamFull :: Env -> FilePath -> IO () exportGalleyTeamFull env@Env {..} path = do @@ -782,7 +782,7 @@ selectGalleyTeamConv = "SELECT team, conv, managed FROM team_conv WHERE team = ? readGalleyTeamConv :: Env -> TeamId -> ConduitM () [RowGalleyTeamConv] IO () readGalleyTeamConv Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamConv (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamConv (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamConvAll :: PrepQuery R () RowGalleyTeamConv selectGalleyTeamConvAll = "SELECT team, conv, managed FROM team_conv" @@ -790,7 +790,7 @@ selectGalleyTeamConvAll = "SELECT team, conv, managed FROM team_conv" readGalleyTeamConvAll :: Env -> ConduitM () [RowGalleyTeamConv] IO () readGalleyTeamConvAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamConvAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamConvAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamConvFull :: Env -> FilePath -> IO () exportGalleyTeamConvFull env@Env {..} path = do @@ -828,7 +828,7 @@ selectGalleyTeamFeatures = "SELECT team_id, app_lock_enforce, app_lock_inactivit readGalleyTeamFeatures :: Env -> TeamId -> ConduitM () [RowGalleyTeamFeatures] IO () readGalleyTeamFeatures Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamFeatures (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamFeatures (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamFeaturesAll :: PrepQuery R () RowGalleyTeamFeatures selectGalleyTeamFeaturesAll = "SELECT team_id, app_lock_enforce, app_lock_inactivity_timeout_secs, app_lock_status, digital_signatures, legalhold_status, search_visibility_status, sso_status, validate_saml_emails FROM team_features" @@ -836,7 +836,7 @@ selectGalleyTeamFeaturesAll = "SELECT team_id, app_lock_enforce, app_lock_inacti readGalleyTeamFeaturesAll :: Env -> ConduitM () [RowGalleyTeamFeatures] IO () readGalleyTeamFeaturesAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamFeaturesAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamFeaturesAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamFeaturesFull :: Env -> FilePath -> IO () exportGalleyTeamFeaturesFull env@Env {..} path = do @@ -874,7 +874,7 @@ selectGalleyTeamMember = "SELECT team, user, invited_at, invited_by, legalhold_s readGalleyTeamMember :: Env -> TeamId -> ConduitM () [RowGalleyTeamMember] IO () readGalleyTeamMember Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamMember (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamMember (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamMemberAll :: PrepQuery R () RowGalleyTeamMember selectGalleyTeamMemberAll = "SELECT team, user, invited_at, invited_by, legalhold_status, perms FROM team_member" @@ -882,7 +882,7 @@ selectGalleyTeamMemberAll = "SELECT team, user, invited_at, invited_by, legalhol readGalleyTeamMemberAll :: Env -> ConduitM () [RowGalleyTeamMember] IO () readGalleyTeamMemberAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamMemberAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamMemberFull :: Env -> FilePath -> IO () exportGalleyTeamMemberFull env@Env {..} path = do @@ -920,7 +920,7 @@ selectGalleyTeamNotifications = "SELECT team, id, payload FROM team_notification readGalleyTeamNotifications :: Env -> TeamId -> ConduitM () [RowGalleyTeamNotifications] IO () readGalleyTeamNotifications Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamNotifications (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamNotifications (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamNotificationsAll :: PrepQuery R () RowGalleyTeamNotifications selectGalleyTeamNotificationsAll = "SELECT team, id, payload FROM team_notifications" @@ -928,7 +928,7 @@ selectGalleyTeamNotificationsAll = "SELECT team, id, payload FROM team_notificat readGalleyTeamNotificationsAll :: Env -> ConduitM () [RowGalleyTeamNotifications] IO () readGalleyTeamNotificationsAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamNotificationsAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamNotificationsAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamNotificationsFull :: Env -> FilePath -> IO () exportGalleyTeamNotificationsFull env@Env {..} path = do @@ -966,7 +966,7 @@ selectGalleyUser = "SELECT user, conv, conv_remote_domain, conv_remote_id FROM u readGalleyUser :: Env -> [UserId] -> ConduitM () [RowGalleyUser] IO () readGalleyUser Env {..} uids = transPipe (runClient envGalley) $ - paginateC selectGalleyUser (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGalleyUser (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGalleyUserAll :: PrepQuery R () RowGalleyUser selectGalleyUserAll = "SELECT user, conv, conv_remote_domain, conv_remote_id FROM user" @@ -974,7 +974,7 @@ selectGalleyUserAll = "SELECT user, conv, conv_remote_domain, conv_remote_id FRO readGalleyUserAll :: Env -> ConduitM () [RowGalleyUser] IO () readGalleyUserAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyUserAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyUserAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyUserFull :: Env -> FilePath -> IO () exportGalleyUserFull env@Env {..} path = do @@ -1012,7 +1012,7 @@ selectGalleyUserTeam = "SELECT user, team FROM user_team WHERE user in ?" readGalleyUserTeam :: Env -> [UserId] -> ConduitM () [RowGalleyUserTeam] IO () readGalleyUserTeam Env {..} uids = transPipe (runClient envGalley) $ - paginateC selectGalleyUserTeam (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGalleyUserTeam (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGalleyUserTeamAll :: PrepQuery R () RowGalleyUserTeam selectGalleyUserTeamAll = "SELECT user, team FROM user_team" @@ -1020,7 +1020,7 @@ selectGalleyUserTeamAll = "SELECT user, team FROM user_team" readGalleyUserTeamAll :: Env -> ConduitM () [RowGalleyUserTeam] IO () readGalleyUserTeamAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyUserTeamAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyUserTeamAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyUserTeamFull :: Env -> FilePath -> IO () exportGalleyUserTeamFull env@Env {..} path = do @@ -1058,7 +1058,7 @@ selectGundeckNotifications = "SELECT user, id, clients, payload FROM notificatio readGundeckNotifications :: Env -> [UserId] -> ConduitM () [RowGundeckNotifications] IO () readGundeckNotifications Env {..} uids = transPipe (runClient envGundeck) $ - paginateC selectGundeckNotifications (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGundeckNotifications (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGundeckNotificationsAll :: PrepQuery R () RowGundeckNotifications selectGundeckNotificationsAll = "SELECT user, id, clients, payload FROM notifications" @@ -1066,7 +1066,7 @@ selectGundeckNotificationsAll = "SELECT user, id, clients, payload FROM notifica readGundeckNotificationsAll :: Env -> ConduitM () [RowGundeckNotifications] IO () readGundeckNotificationsAll Env {..} = transPipe (runClient envGundeck) $ - paginateC selectGundeckNotificationsAll (paramsP Quorum () envPageSize) x5 + paginateC selectGundeckNotificationsAll (paramsP LocalQuorum () envPageSize) x5 exportGundeckNotificationsFull :: Env -> FilePath -> IO () exportGundeckNotificationsFull env@Env {..} path = do @@ -1104,7 +1104,7 @@ selectSparScimExternal = "SELECT team, external_id, user FROM scim_external WHER readSparScimExternal :: Env -> TeamId -> ConduitM () [RowSparScimExternal] IO () readSparScimExternal Env {..} tid = transPipe (runClient envSpar) $ - paginateC selectSparScimExternal (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectSparScimExternal (paramsP LocalQuorum (pure tid) envPageSize) x5 selectSparScimExternalAll :: PrepQuery R () RowSparScimExternal selectSparScimExternalAll = "SELECT team, external_id, user FROM scim_external" @@ -1112,7 +1112,7 @@ selectSparScimExternalAll = "SELECT team, external_id, user FROM scim_external" readSparScimExternalAll :: Env -> ConduitM () [RowSparScimExternal] IO () readSparScimExternalAll Env {..} = transPipe (runClient envSpar) $ - paginateC selectSparScimExternalAll (paramsP Quorum () envPageSize) x5 + paginateC selectSparScimExternalAll (paramsP LocalQuorum () envPageSize) x5 exportSparScimExternalFull :: Env -> FilePath -> IO () exportSparScimExternalFull env@Env {..} path = do @@ -1150,7 +1150,7 @@ selectSparScimUserTimes = "SELECT uid, created_at, last_updated_at FROM scim_use readSparScimUserTimes :: Env -> [UserId] -> ConduitM () [RowSparScimUserTimes] IO () readSparScimUserTimes Env {..} uids = transPipe (runClient envSpar) $ - paginateC selectSparScimUserTimes (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectSparScimUserTimes (paramsP LocalQuorum (pure uids) envPageSize) x5 selectSparScimUserTimesAll :: PrepQuery R () RowSparScimUserTimes selectSparScimUserTimesAll = "SELECT uid, created_at, last_updated_at FROM scim_user_times" @@ -1158,7 +1158,7 @@ selectSparScimUserTimesAll = "SELECT uid, created_at, last_updated_at FROM scim_ readSparScimUserTimesAll :: Env -> ConduitM () [RowSparScimUserTimes] IO () readSparScimUserTimesAll Env {..} = transPipe (runClient envSpar) $ - paginateC selectSparScimUserTimesAll (paramsP Quorum () envPageSize) x5 + paginateC selectSparScimUserTimesAll (paramsP LocalQuorum () envPageSize) x5 exportSparScimUserTimesFull :: Env -> FilePath -> IO () exportSparScimUserTimesFull env@Env {..} path = do @@ -1196,7 +1196,7 @@ selectSparUser = "SELECT issuer, sso_id, uid FROM user WHERE issuer in ?" readSparUser :: Env -> [Text] -> ConduitM () [RowSparUser] IO () readSparUser Env {..} issuer = transPipe (runClient envSpar) $ - paginateC selectSparUser (paramsP Quorum (pure issuer) envPageSize) x5 + paginateC selectSparUser (paramsP LocalQuorum (pure issuer) envPageSize) x5 selectSparUserAll :: PrepQuery R () RowSparUser selectSparUserAll = "SELECT issuer, sso_id, uid FROM user" @@ -1204,7 +1204,7 @@ selectSparUserAll = "SELECT issuer, sso_id, uid FROM user" readSparUserAll :: Env -> ConduitM () [RowSparUser] IO () readSparUserAll Env {..} = transPipe (runClient envSpar) $ - paginateC selectSparUserAll (paramsP Quorum () envPageSize) x5 + paginateC selectSparUserAll (paramsP LocalQuorum () envPageSize) x5 exportSparUserFull :: Env -> FilePath -> IO () exportSparUserFull env@Env {..} path = do diff --git a/tools/db/move-team/src/Types.hs b/tools/db/move-team/src/Types.hs index 905dee633ed..8d079316b0b 100644 --- a/tools/db/move-team/src/Types.hs +++ b/tools/db/move-team/src/Types.hs @@ -36,7 +36,6 @@ import Data.Id import qualified Data.Text as T import Data.Text.Ascii (AsciiText, Base64, decodeBase64, encodeBase64) import qualified Data.Vector as V -import Database.CQL.Protocol (ColumnType (VarCharColumn)) import Galley.Data.Instances () import Imports import System.Logger (Logger) diff --git a/tools/db/repair-handles/src/Work.hs b/tools/db/repair-handles/src/Work.hs index d8ab725020b..3a014750375 100644 --- a/tools/db/repair-handles/src/Work.hs +++ b/tools/db/repair-handles/src/Work.hs @@ -60,7 +60,7 @@ type HandleMap = Map UserId [Handle] readHandleMap :: Env -> IO HandleMap readHandleMap Env {..} = runConduit $ - (transPipe (runClient envBrig) $ paginateC selectUserHandle (paramsP Quorum () envPageSize) x1) + (transPipe (runClient envBrig) $ paginateC selectUserHandle (paramsP LocalQuorum () envPageSize) x1) .| (C.foldM insertAndLog (Map.empty, 0) <&> fst) where selectUserHandle :: PrepQuery R () (Maybe UserId, Maybe Handle) @@ -121,7 +121,7 @@ decideAction uid (Just currentHandle) handles = sourceActions :: Env -> HandleMap -> ConduitM () ActionResult IO () sourceActions Env {..} hmap = ( transPipe (runClient envGalley) $ - paginateC selectTeam (paramsP Quorum (pure envTeam) envPageSize) x5 + paginateC selectTeam (paramsP LocalQuorum (pure envTeam) envPageSize) x5 .| C.map (fmap runIdentity) ) .| C.mapM readUsersPage @@ -137,7 +137,7 @@ sourceActions Env {..} hmap = readUsersPage :: [UserId] -> IO [(UserId, Maybe Handle)] readUsersPage uids = runClient envBrig $ - query selectUsers (params Quorum (pure uids)) + query selectUsers (params LocalQuorum (pure uids)) selectUsers :: PrepQuery R (Identity [UserId]) (UserId, Maybe Handle) selectUsers = "SELECT id, handle FROM user WHERE id in ?" @@ -154,7 +154,7 @@ executeAction env = \case setUserHandle :: Env -> UserId -> Handle -> IO () setUserHandle Env {..} uid handle = runClient envBrig $ - Cas.write updateHandle $ params Quorum (handle, uid) + Cas.write updateHandle $ params LocalQuorum (handle, uid) where updateHandle :: PrepQuery W (Handle, UserId) () updateHandle = "UPDATE user SET handle = ? WHERE id = ?" @@ -162,7 +162,7 @@ executeAction env = \case removeHandle :: Env -> Handle -> IO () removeHandle Env {..} handle = runClient envBrig $ - Cas.write deleteHandle $ params Quorum (pure handle) + Cas.write deleteHandle $ params LocalQuorum (pure handle) where deleteHandle :: PrepQuery W (Identity Handle) () deleteHandle = "DELETE FROM user_handle WHERE handle = ?" diff --git a/tools/db/service-backfill/src/Work.hs b/tools/db/service-backfill/src/Work.hs index 5b73e8d68c6..99f7b856fed 100644 --- a/tools/db/service-backfill/src/Work.hs +++ b/tools/db/service-backfill/src/Work.hs @@ -62,7 +62,7 @@ pageSize = 1000 -- | Get users from Galley getUsers :: ConduitM () [(Maybe ProviderId, Maybe ServiceId, BotId, ConvId)] Client () -getUsers = paginateC cql (paramsP Quorum () pageSize) x5 +getUsers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (Maybe ProviderId, Maybe ServiceId, BotId, ConvId) cql = "SELECT provider, service, user, conv FROM member" @@ -72,7 +72,7 @@ resolveBot :: (Maybe ProviderId, Maybe ServiceId, BotId, ConvId) -> Client (Maybe (ProviderId, ServiceId, BotId, ConvId, Maybe TeamId)) resolveBot (Just pid, Just sid, bid, cid) = do - tid <- retry x5 $ query1 teamSelect (params Quorum (Identity cid)) + tid <- retry x5 $ query1 teamSelect (params LocalQuorum (Identity cid)) pure (Just (pid, sid, bid, cid, join (fmap runIdentity tid))) where teamSelect :: PrepQuery R (Identity ConvId) (Identity (Maybe TeamId)) @@ -85,7 +85,7 @@ writeBots :: Client () writeBots [] = pure () writeBots xs = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged forM_ xs $ \(pid, sid, bid, cid, mbTid) -> do addPrepQuery writeUser (pid, sid, bid, cid, mbTid) From ea490c4c69cbef331432a485b85e1b2a4e3b3f2a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 4 Nov 2021 13:36:13 +0100 Subject: [PATCH 69/88] Close GRPC client after making a request to federator (#1873) * Close GRPCClient object in federation client code Also abstract the function that closes a GRPC client, and make it ignore errors. * Bracket uses of mkGrpcClient in tests --- changelog.d/6-federation/close-grpc-client | 1 + .../src/Wire/API/Federation/Client.hs | 17 ++++--- .../src/Wire/API/Federation/GRPC/Client.hs | 7 +++ services/federator/src/Federator/Remote.hs | 17 +------ .../integration/Test/Federator/IngressSpec.hs | 39 +++++++++------ .../test/integration/Test/Federator/Util.hs | 3 +- .../test/unit/Test/Federator/Remote.hs | 47 +++++++++---------- services/galley/src/Galley/API/Internal.hs | 5 +- .../src/Galley/Intra/Federator/Types.hs | 6 ++- 9 files changed, 77 insertions(+), 65 deletions(-) create mode 100644 changelog.d/6-federation/close-grpc-client diff --git a/changelog.d/6-federation/close-grpc-client b/changelog.d/6-federation/close-grpc-client new file mode 100644 index 00000000000..274b7be3c62 --- /dev/null +++ b/changelog.d/6-federation/close-grpc-client @@ -0,0 +1 @@ +Close GRPC client after making a request to a federator. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 423c7788a59..608fac4d389 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -20,6 +20,7 @@ module Wire.API.Federation.Client where +import Control.Monad.Catch import Control.Monad.Except (ExceptT, MonadError (..), withExceptT) import Control.Monad.State (MonadState (..), StateT, evalStateT, gets) import Data.ByteString.Builder (toLazyByteString) @@ -27,13 +28,13 @@ import qualified Data.ByteString.Lazy as LBS import Data.Domain (Domain, domainText) import qualified Data.Text as T import Imports -import Mu.GRpc.Client.TyApps (GRpcMessageProtocol (MsgProtoBuf), GRpcReply (..), GrpcClient, gRpcCall, grpcClientConfigSimple) +import Mu.GRpc.Client.TyApps import qualified Network.HTTP.Types as HTTP import Servant.Client (ResponseF (..)) import qualified Servant.Client as Servant import Servant.Client.Core (RequestBody (..), RequestF (..), RunClient (..)) import Util.Options (Endpoint (..)) -import Wire.API.Federation.GRPC.Client (createGrpcClient, reason) +import Wire.API.Federation.GRPC.Client import qualified Wire.API.Federation.GRPC.Types as Proto -- FUTUREWORK: Remove originDomain from here and make it part of all the API @@ -50,7 +51,10 @@ newtype FederatorClient (component :: Proto.Component) m a = FederatorClient {ru deriving newtype (Functor, Applicative, Monad, MonadReader FederatorClientEnv, MonadState (Maybe ByteString), MonadIO) runFederatorClientWith :: Monad m => GrpcClient -> Domain -> Domain -> FederatorClient component m a -> m a -runFederatorClientWith client targetDomain originDomain = flip evalStateT Nothing . flip runReaderT (FederatorClientEnv client targetDomain originDomain) . runFederatorClient +runFederatorClientWith client targetDomain originDomain = + flip evalStateT Nothing + . flip runReaderT (FederatorClientEnv client targetDomain originDomain) + . runFederatorClient class KnownComponent (c :: Proto.Component) where componentVal :: Proto.Component @@ -167,11 +171,12 @@ mkFederatorClient = do >>= either (throwError . FederationUnavailable . reason) pure executeFederated :: - (MonadIO m, HasFederatorConfig m) => + (MonadIO m, MonadMask m, HasFederatorConfig m) => Domain -> FederatorClient component (ExceptT FederationClientFailure m) a -> ExceptT FederationError m a executeFederated targetDomain action = do - federatorClient <- mkFederatorClient originDomain <- lift federationDomain - withExceptT FederationCallFailure (runFederatorClientWith federatorClient targetDomain originDomain action) + bracket mkFederatorClient closeGrpcClient $ \federatorClient -> + withExceptT FederationCallFailure $ + runFederatorClientWith federatorClient targetDomain originDomain action diff --git a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs index ec6a2aa44c1..5e745e85240 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs @@ -18,11 +18,13 @@ module Wire.API.Federation.GRPC.Client ( GrpcClientErr (..), createGrpcClient, + closeGrpcClient, grpcClientError, ) where import Control.Exception +import Control.Monad.Except import qualified Data.Text as T import Imports import Mu.GRpc.Client.Record (setupGrpcClient') @@ -41,6 +43,11 @@ createGrpcClient cfg = do Right (Left err) -> Left (grpcClientError (Just cfg) err) Right (Right client) -> Right client +-- | Close federator client and ignore errors, since the only possible error +-- here is EarlyEndOfStream, which should not concern us at this point. +closeGrpcClient :: MonadIO m => GrpcClient -> m () +closeGrpcClient = void . liftIO . runExceptT . close + grpcClientError :: Exception e => Maybe GrpcClientConfig -> e -> GrpcClientErr grpcClientError mcfg err = GrpcClientErr . T.pack $ diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 1fe137d8035..5324529818b 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -43,7 +43,6 @@ import Mu.GRpc.Client.Optics (GRpcReply) import Mu.GRpc.Client.Record (GRpcMessageProtocol (MsgProtoBuf)) import Mu.GRpc.Client.TyApps (gRpcCall) import Network.GRPC.Client.Helpers -import Network.HTTP2.Client.Exceptions import Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Polysemy @@ -86,7 +85,7 @@ interpretRemote = interpret $ \case target <- Polysemy.mapError (RemoteErrorDiscoveryFailure vDomain) $ discoverFederatorWithError vDomain - Polysemy.bracket (mkGrpcClient target) (closeGrpcClient target) $ \client -> + Polysemy.bracket (mkGrpcClient target) (embed @IO . closeGrpcClient) $ \client -> callInward client vRequest callInward :: MonadIO m => GrpcClient -> Request -> m (GRpcReply InwardResponse) @@ -158,20 +157,6 @@ mkGrpcClient target@(SrvTarget host port) = do . Polysemy.fromEither =<< Polysemy.fromExceptionVia (RemoteErrorTLSException target) (createGrpcClient cfg') -closeGrpcClient :: - Members '[Embed IO, Polysemy.Error RemoteError] r => - SrvTarget -> - GrpcClient -> - Sem r () -closeGrpcClient target = - Polysemy.mapError handle - . Polysemy.fromEitherM - . runExceptT - . close - where - handle :: ClientError -> RemoteError - handle = RemoteErrorClientFailure target . grpcClientError Nothing - logRemoteErrors :: Members '[Polysemy.Error RemoteError, TinyLog] r => Sem r x -> diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 8d87ff53fa5..2820598747b 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -19,6 +19,7 @@ module Test.Federator.IngressSpec where import Bilge import Control.Lens (view, (^.)) +import Control.Monad.Catch import Data.Aeson import qualified Data.ByteString.Lazy as LBS import Data.Default (def) @@ -43,7 +44,7 @@ import Test.Federator.Util import Test.Hspec import Test.Tasty.HUnit (assertFailure) import Util.Options (Endpoint (Endpoint)) -import Wire.API.Federation.GRPC.Client (createGrpcClient) +import Wire.API.Federation.GRPC.Client (closeGrpcClient, createGrpcClient) import Wire.API.Federation.GRPC.Types hiding (body, path) import qualified Wire.API.Federation.GRPC.Types as GRPC import Wire.API.User @@ -98,24 +99,34 @@ spec env = GRpcErrorString err -> err `shouldBe` "GRPC status indicates failure: status-code=INTERNAL, status-message=\"HTTP Status 400\"" _ -> assertFailure $ "Expect HTTP 400, got: " <> show grpcReply -inwardBrigCallViaIngress :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => ByteString -> LBS.ByteString -> m (GRpcReply InwardResponse) +inwardBrigCallViaIngress :: + ( MonadIO m, + MonadMask m, + MonadHttp m, + MonadReader TestEnv m, + HasCallStack + ) => + ByteString -> + LBS.ByteString -> + m (GRpcReply InwardResponse) inwardBrigCallViaIngress requestPath payload = do Endpoint ingressHost ingressPort <- cfgNginxIngress . view teTstOpts <$> ask let target = SrvTarget (cs ingressHost) ingressPort runSettings <- optSettings . view teOpts <$> ask tlsSettings <- view teTLSSettings - c <- - liftIO - . Polysemy.runM - . Polysemy.runError @RemoteError - . discardLogs - . Polysemy.runInputConst tlsSettings - . Polysemy.runReader runSettings - $ mkGrpcClient target - client <- case c of - Left clientErr -> liftIO $ assertFailure (show clientErr) - Right cli -> pure cli - inwardBrigCallViaIngressWithClient client requestPath payload + bracket + ( liftIO + . Polysemy.runM + . Polysemy.runError @RemoteError + . discardLogs + . Polysemy.runInputConst tlsSettings + . Polysemy.runReader runSettings + $ mkGrpcClient target + ) + (either (const (pure ())) closeGrpcClient) + $ \case + Left clientErr -> liftIO $ assertFailure (show clientErr) + Right client -> inwardBrigCallViaIngressWithClient client requestPath payload inwardBrigCallViaIngressWithClient :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => GrpcClient -> ByteString -> LBS.ByteString -> m (GRpcReply InwardResponse) inwardBrigCallViaIngressWithClient client requestPath payload = do diff --git a/services/federator/test/integration/Test/Federator/Util.hs b/services/federator/test/integration/Test/Federator/Util.hs index bf7835bcda2..e80da9dd1ef 100644 --- a/services/federator/test/integration/Test/Federator/Util.hs +++ b/services/federator/test/integration/Test/Federator/Util.hs @@ -69,7 +69,8 @@ newtype TestFederator m a = TestFederator {unwrapTestFederator :: ReaderT TestEn MonadReader TestEnv, MonadFail, MonadThrow, - MonadCatch + MonadCatch, + MonadMask ) instance MonadRandom m => MonadRandom (TestFederator m) where diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 3535f859d1e..61d105ed7f5 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -20,6 +20,7 @@ module Test.Federator.Remote where import Data.Streaming.Network (bindRandomPortTCP) +import Federator.Env (TLSSettings) import Federator.Options import Federator.Remote import Federator.Run (mkTLSSettingsOrThrow) @@ -31,11 +32,13 @@ import qualified Network.Wai.Handler.WarpTLS as WarpTLS import Polysemy import qualified Polysemy.Error as Polysemy import qualified Polysemy.Input as Polysemy +import qualified Polysemy.Resource as Polysemy import Test.Federator.Options (defRunSettings) import Test.Tasty import Test.Tasty.HUnit import UnliftIO (bracket, timeout) import qualified UnliftIO.Async as Async +import Wire.API.Federation.GRPC.Client import Wire.Network.DNS.SRV (SrvTarget (SrvTarget)) tests :: TestTree @@ -59,16 +62,24 @@ settings = remoteCAStore = Just "test/resources/unit/unit-ca.pem" } -assertNoError :: - forall e r x. - (Show e, Member (Embed IO) r) => - Sem (Polysemy.Error e ': r) x -> - Sem r x +assertNoError :: IO (Either RemoteError x) -> IO x assertNoError action = - Polysemy.runError action >>= \case - Left err -> embed . assertFailure $ "Unexpected error: " <> show err + action >>= \case + Left err -> assertFailure $ "Unexpected error: " <> show err Right x -> pure x +mkTestGrpcClient :: TLSSettings -> Int -> IO (Either RemoteError ()) +mkTestGrpcClient tlsSettings port = + Polysemy.runM + . Polysemy.runResource + . Polysemy.runError + . Polysemy.runInputConst tlsSettings + $ do + Polysemy.bracket + (mkGrpcClient (SrvTarget "localhost" (fromIntegral port))) + (embed @IO . closeGrpcClient) + (const (pure ())) + testValidatesCertificateSuccess :: TestTree testValidatesCertificateSuccess = testGroup @@ -76,20 +87,16 @@ testValidatesCertificateSuccess = [ testCase "when hostname=localhost and certificate-for=localhost" $ do bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost" (fromIntegral port)), + assertNoError (mkTestGrpcClient tlsSettings port), testCase "when hostname=localhost. and certificate-for=localhost" $ do bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)), + assertNoError (mkTestGrpcClient tlsSettings port), -- This is a limitation of the TLS library, this test just exists to document that. testCase "when hostname=localhost. and certificate-for=localhost." $ do bracket (startMockServer certForLocalhostDot) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- - Polysemy.runM - . Polysemy.runError @RemoteError - . Polysemy.runInputConst tlsSettings - $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + eitherClient <- mkTestGrpcClient tlsSettings port case eitherClient of Left _ -> pure () Right _ -> assertFailure "Congratulations, you fixed a known issue!" @@ -102,11 +109,7 @@ testValidatesCertificateWrongHostname = [ testCase "when the server's certificate doesn't match the hostname" $ bracket (startMockServer certForWrongDomain) (Async.cancel . fst) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- - Polysemy.runM - . Polysemy.runError - . Polysemy.runInputConst tlsSettings - $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + eitherClient <- mkTestGrpcClient tlsSettings port case eitherClient of Left (RemoteErrorTLSException _ _) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x @@ -114,11 +117,7 @@ testValidatesCertificateWrongHostname = testCase "when the server's certificate does not have the server key usage flag" $ bracket (startMockServer certWithoutServerKeyUsage) (Async.cancel . fst) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- - Polysemy.runM - . Polysemy.runError - . Polysemy.runInputConst tlsSettings - $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + eitherClient <- mkTestGrpcClient tlsSettings port case eitherClient of Left (RemoteErrorTLSException _ _) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index efec177340c..a3636b6d7bc 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -27,7 +27,6 @@ where import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) -import Control.Monad.Except (runExceptT) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) @@ -57,6 +56,7 @@ import qualified Galley.Data.Conversation as Data import Galley.Effects import Galley.Effects.ClientStore import Galley.Effects.ConversationStore +import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess import Galley.Effects.MemberStore import Galley.Effects.Paging @@ -90,7 +90,6 @@ import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.ErrorDescription (MissingLegalholdConsent) import Wire.API.Federation.API.Galley (UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley -import Wire.API.Federation.Client (executeFederated) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) import Wire.API.Routes.Public (ZOptConn, ZUser) @@ -564,7 +563,7 @@ rmUser user conn = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete - res <- runExceptT (executeFederated (tDomain remoteConvs) rpc) + res <- liftSem $ runFederatedEither remoteConvs rpc case res of -- FUTUREWORK: Add a retry mechanism if there are federation errrors. -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 diff --git a/services/galley/src/Galley/Intra/Federator/Types.hs b/services/galley/src/Galley/Intra/Federator/Types.hs index 44f43d5321e..40c0b892680 100644 --- a/services/galley/src/Galley/Intra/Federator/Types.hs +++ b/services/galley/src/Galley/Intra/Federator/Types.hs @@ -25,6 +25,7 @@ module Galley.Intra.Federator.Types where import Control.Lens +import Control.Monad.Catch import Control.Monad.Except import Galley.Env import Galley.Options @@ -43,7 +44,10 @@ newtype FederationM a = FederationM Monad, MonadIO, MonadReader Env, - MonadUnliftIO + MonadUnliftIO, + MonadThrow, + MonadCatch, + MonadMask ) runFederationM :: Env -> FederationM a -> IO a From b0a3d606deffebab7951d9709f20be41586359d1 Mon Sep 17 00:00:00 2001 From: Florian Klink Date: Thu, 4 Nov 2021 20:49:05 +0100 Subject: [PATCH 70/88] Provide ormolu via direnv, run `make formatc` in github actions (#1908) * nix: add ormolu to wire-server-direnv * direnv.nix: nixpkgs-fmt * .github/workflows: add ci.yml This builds the direnv, so it's available in the cachix binary cache. * .github/workflows/ci.yml: run make formatc This ensures the codebase is properly formatted. * tools/ormolu.sh: use utf-8 for IO Otherwise, ormolu fails with some locales on non-ASCII characters: ``` ormolu: libs/dns-util/src/Wire/Network/DNS/SRV.hs: hGetContents: invalid argument (invalid byte sequence) ``` See https://github.com/tweag/ormolu/issues/38 and https://gitlab.haskell.org/ghc/ghc/-/issues/17755 for details. * changelog: add changelog Co-authored-by: jschaul --- .github/workflows/ci.yml | 31 +++++++++++++ changelog.d/5-internal/ormolu-direnv | 1 + direnv.nix | 69 +++++++++++++++------------- tools/ormolu.sh | 12 ++--- 4 files changed, 75 insertions(+), 38 deletions(-) create mode 100644 .github/workflows/ci.yml create mode 100644 changelog.d/5-internal/ormolu-direnv diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 00000000000..ac692eec191 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,31 @@ +on: + pull_request: + push: + branches: [master] + +jobs: + build-dev-env: + name: Build dev env + strategy: + matrix: + os: + - ubuntu-latest + # This is too expensive + # - macos-latest + runs-on: ${{ matrix.os }} + steps: + - uses: actions/checkout@v2 + with: + submodules: true + - uses: cachix/install-nix-action@v14.1 + - uses: cachix/cachix-action@v10 + with: + name: wire-server + signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' + authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' + - name: Build the wire-server-direnv + run: nix-build --no-out-link direnv.nix + - name: Install the wire-server-direnv + run: nix-env -f direnv.nix -i + - name: Ensure everything is formatted + run: make formatc diff --git a/changelog.d/5-internal/ormolu-direnv b/changelog.d/5-internal/ormolu-direnv new file mode 100644 index 00000000000..ae0dddfd756 --- /dev/null +++ b/changelog.d/5-internal/ormolu-direnv @@ -0,0 +1 @@ +Add ormolu to the direnv, add a GH Action to ensure formatting diff --git a/direnv.nix b/direnv.nix index c29ac40da57..07281107a66 100644 --- a/direnv.nix +++ b/direnv.nix @@ -6,14 +6,17 @@ let src = if pkgs.stdenv.isDarwin - then pkgs.fetchurl { - url = darwinAmd64Url; - sha256 = darwinAmd64Sha256; - } - else pkgs.fetchurl { - url = linuxAmd64Url; - sha256 = linuxAmd64Sha256; - }; + then + pkgs.fetchurl + { + url = darwinAmd64Url; + sha256 = darwinAmd64Sha256; + } + else + pkgs.fetchurl { + url = linuxAmd64Url; + sha256 = linuxAmd64Sha256; + }; installPhase = '' mkdir -p $out/bin @@ -21,28 +24,31 @@ let ''; }; - staticBinary = { pname, version, linuxAmd64Url, linuxAmd64Sha256, darwinAmd64Url, darwinAmd64Sha256, binPath ? pname }: - pkgs.stdenv.mkDerivation { - inherit pname version; - - src = - if pkgs.stdenv.isDarwin - then pkgs.fetchurl { - url = darwinAmd64Url; - sha256 = darwinAmd64Sha256; - } - else pkgs.fetchurl { + staticBinary = { pname, version, linuxAmd64Url, linuxAmd64Sha256, darwinAmd64Url, darwinAmd64Sha256, binPath ? pname }: + pkgs.stdenv.mkDerivation { + inherit pname version; + + src = + if pkgs.stdenv.isDarwin + then + pkgs.fetchurl + { + url = darwinAmd64Url; + sha256 = darwinAmd64Sha256; + } + else + pkgs.fetchurl { url = linuxAmd64Url; sha256 = linuxAmd64Sha256; }; - phases = ["installPhase" "patchPhase"]; + phases = [ "installPhase" "patchPhase" ]; - installPhase = '' - mkdir -p $out/bin - cp $src $out/bin/${binPath} - chmod +x $out/bin/${binPath} - ''; - }; + installPhase = '' + mkdir -p $out/bin + cp $src $out/bin/${binPath} + chmod +x $out/bin/${binPath} + ''; + }; pinned = { stack = staticBinaryInTarball { @@ -102,17 +108,19 @@ let linuxAmd64Sha256 = "949f81b3c30ca03a3d4effdecda04f100fa3edc07a28b19400f72ede7c5f0491"; }; }; -in pkgs.buildEnv { +in +pkgs.buildEnv { name = "wire-server-direnv"; paths = [ + pkgs.cfssl pkgs.docker-compose pkgs.gnumake + pkgs.grpcurl pkgs.haskell-language-server - pkgs.telepresence pkgs.jq - pkgs.grpcurl + pkgs.ormolu + pkgs.telepresence pkgs.wget - pkgs.cfssl pkgs.yq # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf @@ -125,4 +133,3 @@ in pkgs.buildEnv { pinned.kind ]; } - diff --git a/tools/ormolu.sh b/tools/ormolu.sh index 99734e27569..e34fddf3015 100755 --- a/tools/ormolu.sh +++ b/tools/ormolu.sh @@ -4,13 +4,6 @@ set -e cd "$( dirname "${BASH_SOURCE[0]}" )/.." -command -v grep >/dev/null 2>&1 || { echo >&2 "grep is not installed, aborting."; exit 1; } -command -v sed >/dev/null 2>&1 || { echo >&2 "sed is not installed, aborting."; exit 1; } - -ORMOLU_VERSION=$(sed -n '/^extra-deps:/,$ { s/^- ormolu-//p }' < stack.yaml) -( ormolu -v 2>/dev/null | grep -q $ORMOLU_VERSION ) || ( echo "please install ormolu $ORMOLU_VERSION (eg., run 'stack install ormolu' and ensure ormolu is on your PATH.)"; exit 1 ) -echo "ormolu version: $ORMOLU_VERSION" - ARG_ALLOW_DIRTY_WC="0" ARG_ORMOLU_MODE="inplace" @@ -74,6 +67,11 @@ if [ -t 1 ]; then : ${ORMOLU_CONDENSE_OUTPUT:=1} fi +# https://github.com/tweag/ormolu/issues/38 +# https://gitlab.haskell.org/ghc/ghc/-/issues/17755 +export LANG=C.UTF-8 +export LC_ALL=C.UTF-8 + for hsfile in $(git ls-files | grep '\.hsc\?$'); do FAILED=0 From 87c27d3b0f454d9a569c80d1d953f1fbd81b6c52 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 5 Nov 2021 13:26:39 +0100 Subject: [PATCH 71/88] Implement all other store effects (#1906) * Move stuff to Cassandra hierarchy * Implement all other store effects This removes the `MonadClient` instance from `Galley`, and therefore makes all the DB-related code go through one of the store effects. * Move Cassandra conversation code out of Data * Move more Cassandra code out of Data * Move ResultSet to Cassandra hierarchy * Move queries to Cassandra hierarchy * Move Cql instances out of Data --- changelog.d/5-internal/polysemy-store | 2 +- services/galley/galley.cabal | 22 ++- services/galley/src/Galley/API/Create.hs | 48 +++++- .../galley/src/Galley/API/CustomBackend.hs | 20 ++- services/galley/src/Galley/API/Federation.hs | 1 + services/galley/src/Galley/API/LegalHold.hs | 102 +++++++----- services/galley/src/Galley/API/Query.hs | 1 - services/galley/src/Galley/API/Teams.hs | 119 ++++++++++---- .../galley/src/Galley/API/Teams/Features.hs | 118 ++++++++++---- .../src/Galley/API/Teams/Notifications.hs | 9 +- services/galley/src/Galley/API/Update.hs | 13 +- services/galley/src/Galley/API/Util.hs | 9 +- services/galley/src/Galley/App.hs | 16 +- .../src/Galley/{Data => Cassandra}/Access.hs | 27 +--- .../galley/src/Galley/Cassandra/Client.hs | 2 +- services/galley/src/Galley/Cassandra/Code.hs | 2 +- .../src/Galley/Cassandra/Conversation.hs | 24 ++- .../Galley/Cassandra/Conversation/Members.hs | 4 +- .../src/Galley/Cassandra/ConversationList.hs | 6 +- .../{Data => Cassandra}/CustomBackend.hs | 24 ++- .../Galley/{Data => Cassandra}/Instances.hs | 2 +- .../galley/src/Galley/Cassandra/LegalHold.hs | 90 ++++++++++- .../galley/src/Galley/Cassandra/Paging.hs | 8 +- .../src/Galley/{Data => Cassandra}/Queries.hs | 2 +- .../Galley/{Data => Cassandra}/ResultSet.hs | 2 +- .../{Data => Cassandra}/SearchVisibility.hs | 26 +-- .../galley/src/Galley/Cassandra/Services.hs | 2 +- services/galley/src/Galley/Cassandra/Team.hs | 5 +- .../src/Galley/Cassandra/TeamFeatures.hs | 153 ++++++++++++++++++ .../src/Galley/Cassandra/TeamNotifications.hs | 139 ++++++++++++++++ .../galley/src/Galley/Data/Conversation.hs | 46 ++++-- services/galley/src/Galley/Data/LegalHold.hs | 102 ------------ .../galley/src/Galley/Data/TeamFeatures.hs | 132 +-------------- .../src/Galley/Data/TeamNotifications.hs | 105 +----------- services/galley/src/Galley/Effects.hs | 17 +- .../src/Galley/Effects/CustomBackendStore.hs | 36 +++++ .../src/Galley/Effects/LegalHoldStore.hs | 52 ++++++ .../Galley/Effects/SearchVisibilityStore.hs | 35 ++++ .../src/Galley/Effects/TeamFeatureStore.hs | 86 ++++++++++ .../Galley/Effects/TeamNotificationStore.hs | 41 +++++ .../src/Galley/External/LegalHoldService.hs | 19 ++- .../Galley/External/LegalHoldService/Types.hs | 4 + .../test/integration/API/Teams/LegalHold.hs | 2 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 2 +- tools/db/migrate-sso-feature-flag/src/Work.hs | 2 +- tools/db/move-team/src/ParseSchema.hs | 2 +- tools/db/move-team/src/Schema.hs | 2 +- tools/db/move-team/src/Types.hs | 2 +- tools/db/move-team/src/Work.hs | 2 +- 49 files changed, 1114 insertions(+), 573 deletions(-) rename services/galley/src/Galley/{Data => Cassandra}/Access.hs (67%) rename services/galley/src/Galley/{Data => Cassandra}/CustomBackend.hs (69%) rename services/galley/src/Galley/{Data => Cassandra}/Instances.hs (99%) rename services/galley/src/Galley/{Data => Cassandra}/Queries.hs (99%) rename services/galley/src/Galley/{Data => Cassandra}/ResultSet.hs (98%) rename services/galley/src/Galley/{Data => Cassandra}/SearchVisibility.hs (71%) create mode 100644 services/galley/src/Galley/Cassandra/TeamFeatures.hs create mode 100644 services/galley/src/Galley/Cassandra/TeamNotifications.hs delete mode 100644 services/galley/src/Galley/Data/LegalHold.hs create mode 100644 services/galley/src/Galley/Effects/CustomBackendStore.hs create mode 100644 services/galley/src/Galley/Effects/LegalHoldStore.hs create mode 100644 services/galley/src/Galley/Effects/SearchVisibilityStore.hs create mode 100644 services/galley/src/Galley/Effects/TeamFeatureStore.hs create mode 100644 services/galley/src/Galley/Effects/TeamNotificationStore.hs diff --git a/changelog.d/5-internal/polysemy-store b/changelog.d/5-internal/polysemy-store index 98d604a47a4..92950ac7efe 100644 --- a/changelog.d/5-internal/polysemy-store +++ b/changelog.d/5-internal/polysemy-store @@ -1 +1 @@ -Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy. +Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy (#1890, #1906). diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index fe434196d11..2a18dcb467d 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f4fae64cc086ec4a37984b47611854d490e7d34ba17147a2e53d2b11c3ca3218 +-- hash: 07288a51b3ae662362fae1279cdd4c22977ae3c8dfb4dffe1228d0da1beba2b4 name: galley version: 0.83.0 @@ -46,26 +46,27 @@ library Galley.App Galley.Aws Galley.Cassandra + Galley.Cassandra.Access Galley.Cassandra.Client Galley.Cassandra.Code Galley.Cassandra.Conversation Galley.Cassandra.Conversation.Members Galley.Cassandra.ConversationList + Galley.Cassandra.CustomBackend Galley.Cassandra.LegalHold Galley.Cassandra.Paging + Galley.Cassandra.Queries + Galley.Cassandra.ResultSet + Galley.Cassandra.SearchVisibility Galley.Cassandra.Services Galley.Cassandra.Store Galley.Cassandra.Team - Galley.Data.Access + Galley.Cassandra.TeamFeatures + Galley.Cassandra.TeamNotifications Galley.Data.Conversation Galley.Data.Conversation.Types - Galley.Data.CustomBackend - Galley.Data.Instances - Galley.Data.LegalHold - Galley.Data.Queries - Galley.Data.ResultSet + Galley.Cassandra.Instances Galley.Data.Scope - Galley.Data.SearchVisibility Galley.Data.Services Galley.Data.TeamFeatures Galley.Data.TeamNotifications @@ -76,17 +77,22 @@ library Galley.Effects.ClientStore Galley.Effects.CodeStore Galley.Effects.ConversationStore + Galley.Effects.CustomBackendStore Galley.Effects.ExternalAccess Galley.Effects.FederatorAccess Galley.Effects.FireAndForget Galley.Effects.GundeckAccess + Galley.Effects.LegalHoldStore Galley.Effects.ListItems Galley.Effects.MemberStore Galley.Effects.Paging Galley.Effects.RemoteConversationListStore + Galley.Effects.SearchVisibilityStore Galley.Effects.ServiceStore Galley.Effects.SparAccess + Galley.Effects.TeamFeatureStore Galley.Effects.TeamMemberStore + Galley.Effects.TeamNotificationStore Galley.Effects.TeamStore Galley.Env Galley.External diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 39f75a97334..ee86e14933e 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -39,7 +39,6 @@ import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util import Galley.App -import Galley.Data.Access import qualified Galley.Data.Conversation as Data import Galley.Data.Conversation.Types import Galley.Effects @@ -73,7 +72,15 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm -- -- See Note [managed conversations]. createGroupConversation :: - Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => + Members + '[ ConversationStore, + BrigAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId -> ConnId -> Public.NewConvUnmanaged -> @@ -86,7 +93,15 @@ createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. internalCreateManagedConversationH :: - Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => + Members + '[ ConversationStore, + BrigAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do @@ -94,7 +109,15 @@ internalCreateManagedConversationH (zusr ::: zcon ::: req) = do handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv internalCreateManagedConversation :: - Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => + Members + '[ ConversationStore, + BrigAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId -> ConnId -> NewConvManaged -> @@ -105,7 +128,7 @@ internalCreateManagedConversation zusr zcon (NewConvManaged body) = do Just tinfo -> createTeamGroupConv zusr zcon tinfo body ensureNoLegalholdConflicts :: - Member TeamStore r => + Members '[LegalHoldStore, TeamStore] r => [Remote UserId] -> [UserId] -> Galley r () @@ -117,7 +140,15 @@ ensureNoLegalholdConflicts remotes locals = do -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: - Members '[ConversationStore, BrigAccess, FederatorAccess, GundeckAccess, TeamStore] r => + Members + '[ ConversationStore, + BrigAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId -> ConnId -> NewConvUnmanaged -> @@ -155,6 +186,7 @@ createTeamGroupConv :: BrigAccess, FederatorAccess, GundeckAccess, + LegalHoldStore, TeamStore ] r => @@ -497,11 +529,11 @@ toUUIDs a b = do return (a', b') accessRole :: NewConv -> AccessRole -accessRole b = fromMaybe defRole (newConvAccessRole b) +accessRole b = fromMaybe Data.defRole (newConvAccessRole b) access :: NewConv -> [Access] access a = case Set.toList (newConvAccess a) of - [] -> defRegularConvAccess + [] -> Data.defRegularConvAccess (x : xs) -> x : xs newConvMembers :: Local x -> NewConv -> UserList UserId diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index fa98803c799..9630ca6b4cb 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -27,37 +27,41 @@ import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util import Galley.App -import qualified Galley.Data.CustomBackend as Data +import Galley.Effects.CustomBackendStore import Galley.Types import Imports hiding ((\\)) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities +import Polysemy import qualified Wire.API.CustomBackend as Public -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response +getCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Domain -> Galley r Public.CustomBackend +getCustomBackendByDomain :: Member CustomBackendStore r => Domain -> Galley r Public.CustomBackend getCustomBackendByDomain domain = - Data.getCustomBackend domain >>= \case + liftSem (getCustomBackend domain) >>= \case Nothing -> throwM (customBackendNotFound domain) Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- -internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley r Response +internalPutCustomBackendByDomainH :: + Member CustomBackendStore r => + Domain ::: JsonRequest CustomBackend -> + Galley r Response internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req -- simple enough to not need a separate function - Data.setCustomBackend domain customBackend + liftSem $ setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response +internalDeleteCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Galley r Response internalDeleteCustomBackendByDomainH (domain ::: _) = do - Data.deleteCustomBackend domain + liftSem $ deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index fcadd8f1711..a6ba85d5758 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -246,6 +246,7 @@ leaveConversation :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, MemberStore, TeamStore ] diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 2f6d2a63c70..0a6015259e7 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -54,12 +54,11 @@ import Galley.API.Util import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data -import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) -import qualified Galley.Data.LegalHold as LegalHoldData -import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects import Galley.Effects.BrigAccess +import qualified Galley.Effects.LegalHoldStore as LegalHoldData import Galley.Effects.Paging +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore import qualified Galley.External.LegalHoldService as LHService @@ -80,25 +79,27 @@ import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public -assertLegalHoldEnabledForTeam :: TeamId -> Galley r () +assertLegalHoldEnabledForTeam :: Members '[LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ throwM legalHoldNotEnabled -isLegalHoldEnabledForTeam :: TeamId -> Galley r Bool +isLegalHoldEnabledForTeam :: Members '[LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do pure False FeatureLegalHoldDisabledByDefault -> do - statusValue <- Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid + statusValue <- + liftSem $ + Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid return $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False Nothing -> False FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - isTeamLegalholdWhitelisted tid + liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid createSettingsH :: - Member TeamStore r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do @@ -106,7 +107,7 @@ createSettingsH (zusr ::: tid ::: req ::: _) = do setStatus status201 . json <$> createSettings zusr tid newService createSettings :: - Member TeamStore r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => UserId -> TeamId -> Public.NewLegalHoldService -> @@ -124,18 +125,18 @@ createSettings zusr tid newService = do >>= maybe (throwM legalHoldServiceInvalidKey) pure LHService.checkLegalHoldServiceStatus fpr (newLegalHoldServiceUrl newService) let service = legalHoldService tid fpr newService key - LegalHoldData.createSettings service + liftSem $ LegalHoldData.createSettings service pure . viewLegalHoldService $ service getSettingsH :: - Member TeamStore r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid getSettings :: - Member TeamStore r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => UserId -> TeamId -> Galley r Public.ViewLegalHoldService @@ -143,7 +144,7 @@ getSettings zusr tid = do zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership isenabled <- isLegalHoldEnabledForTeam tid - mresult <- LegalHoldData.getSettings tid + mresult <- liftSem $ LegalHoldData.getSettings tid pure $ case (isenabled, mresult) of (False, _) -> Public.ViewLegalHoldServiceDisabled (True, Nothing) -> Public.ViewLegalHoldServiceNotConfigured @@ -159,9 +160,11 @@ removeSettingsH :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore, + TeamFeatureStore, TeamMemberStore InternalPaging ] r => @@ -184,8 +187,10 @@ removeSettings :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamFeatureStore, TeamStore, TeamMemberStore p ] @@ -229,6 +234,7 @@ removeSettings' :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore, @@ -260,11 +266,19 @@ removeSettings' tid = -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatusH :: Member TeamStore r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response +getUserStatusH :: + Members '[LegalHoldStore, TeamStore] r => + UserId ::: TeamId ::: UserId ::: JSON -> + Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid -getUserStatus :: Member TeamStore r => TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse +getUserStatus :: + forall r. + Members '[LegalHoldStore, TeamStore] r => + TeamId -> + UserId -> + Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do mTeamMember <- liftSem $ getTeamMember tid uid teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember @@ -278,7 +292,7 @@ getUserStatus tid uid = do where makeResponseDetails :: Galley r (Maybe LastPrekey, Maybe ClientId) makeResponseDetails = do - mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid + mLastKey <- liftSem $ fmap snd <$> LegalHoldData.selectPendingPrekeys uid lastKey <- case mLastKey of Nothing -> do Log.err . Log.msg $ @@ -303,6 +317,7 @@ grantConsentH :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore @@ -329,6 +344,7 @@ grantConsent :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore @@ -361,8 +377,10 @@ requestDeviceH :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamFeatureStore, TeamStore ] r => @@ -388,8 +406,10 @@ requestDevice :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamFeatureStore, TeamStore ] r => @@ -422,13 +442,13 @@ requestDevice zusr tid uid = do provisionLHDevice userLHStatus = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added - LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) + liftSem $ LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending liftSem $ notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) requestDeviceFromService = do - LegalHoldData.dropPendingPrekeys uid + liftSem $ LegalHoldData.dropPendingPrekeys uid lhDevice <- LHService.requestNewDevice tid uid let NewLegalHoldClient prekeys lastKey = lhDevice return (lastKey, prekeys) @@ -448,8 +468,10 @@ approveDeviceH :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamFeatureStore, TeamStore ] r => @@ -470,8 +492,10 @@ approveDevice :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamFeatureStore, TeamStore ] r => @@ -493,7 +517,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo liftSem $ maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid assertUserLHPending userLHStatus - mPreKeys <- LegalHoldData.selectPendingPrekeys uid + mPreKeys <- liftSem $ LegalHoldData.selectPendingPrekeys uid (prekeys, lastPrekey') <- case mPreKeys of Nothing -> do Log.info $ Log.msg @Text "No prekeys found" @@ -529,6 +553,7 @@ disableForUserH :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore @@ -557,6 +582,7 @@ disableForUser :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore @@ -604,6 +630,7 @@ changeLegalholdStatus :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore @@ -619,25 +646,25 @@ changeLegalholdStatus tid uid old new = do UserLegalHoldEnabled -> case new of UserLegalHoldEnabled -> noop UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> update >> removeblocks + UserLegalHoldDisabled -> liftSem update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldPending -> case new of - UserLegalHoldEnabled -> update + UserLegalHoldEnabled -> liftSem update UserLegalHoldPending -> noop - UserLegalHoldDisabled -> update >> removeblocks + UserLegalHoldDisabled -> liftSem update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldDisabled -> case new of UserLegalHoldEnabled -> illegal - UserLegalHoldPending -> addblocks >> update + UserLegalHoldPending -> addblocks >> liftSem update UserLegalHoldDisabled -> {- in case the last attempt crashed -} removeblocks UserLegalHoldNoConsent -> {- withdrawing consent is not (yet?) implemented -} illegal -- UserLegalHoldNoConsent -> case new of UserLegalHoldEnabled -> illegal UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> update + UserLegalHoldDisabled -> liftSem update UserLegalHoldNoConsent -> noop where update = LegalHoldData.setUserLegalHoldStatus tid uid new @@ -651,7 +678,7 @@ changeLegalholdStatus tid uid old new = do -- FUTUREWORK: make this async? blockNonConsentingConnections :: forall r. - Members '[BrigAccess, TeamStore] r => + Members '[BrigAccess, LegalHoldStore, TeamStore] r => UserId -> Galley r () blockNonConsentingConnections uid = do @@ -679,19 +706,21 @@ blockNonConsentingConnections uid = do status <- liftSem $ putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -setTeamLegalholdWhitelisted :: TeamId -> Galley r () -setTeamLegalholdWhitelisted tid = do - LegalHoldData.setTeamLegalholdWhitelisted tid +setTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () +setTeamLegalholdWhitelisted tid = + liftSem $ + LegalHoldData.setTeamLegalholdWhitelisted tid -setTeamLegalholdWhitelistedH :: TeamId -> Galley r Response +setTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response setTeamLegalholdWhitelistedH tid = do empty <$ setTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelisted :: TeamId -> Galley r () -unsetTeamLegalholdWhitelisted tid = do - LegalHoldData.unsetTeamLegalholdWhitelisted tid +unsetTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () +unsetTeamLegalholdWhitelisted tid = + liftSem $ + LegalHoldData.unsetTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelistedH :: TeamId -> Galley r Response +unsetTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response unsetTeamLegalholdWhitelistedH tid = do () <- error @@ -700,9 +729,9 @@ unsetTeamLegalholdWhitelistedH tid = do \before you enable the end-point." setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid -getTeamLegalholdWhitelistedH :: TeamId -> Galley r Response -getTeamLegalholdWhitelistedH tid = do - lhEnabled <- isTeamLegalholdWhitelisted tid +getTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response +getTeamLegalholdWhitelistedH tid = liftSem $ do + lhEnabled <- LegalHoldData.isTeamLegalholdWhitelisted tid pure $ if lhEnabled then setStatus status200 empty @@ -732,6 +761,7 @@ handleGroupConvPolicyConflicts :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamStore diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 6b07b1d18f6..d395b1e4246 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -52,7 +52,6 @@ import qualified Galley.API.Mapping as Mapping import Galley.API.Util import Galley.App import Galley.Cassandra.Paging -import Galley.Data.ResultSet import qualified Galley.Data.Types as Data import Galley.Effects import qualified Galley.Effects.ConversationStore as E diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 8c32af600cd..0b58052ecc5 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -88,20 +88,19 @@ import Galley.API.Util import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data -import qualified Galley.Data.LegalHold as Data -import qualified Galley.Data.ResultSet as Data -import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) -import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.ExternalAccess as E import qualified Galley.Effects.GundeckAccess as E +import qualified Galley.Effects.LegalHoldStore as Data import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.Paging as E +import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData import qualified Galley.Effects.SparAccess as Spar +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import qualified Galley.Effects.TeamMemberStore as E import qualified Galley.Effects.TeamStore as E import qualified Galley.Intra.Journal as Journal @@ -367,6 +366,7 @@ uncheckedDeleteTeam :: '[ BrigAccess, ExternalAccess, GundeckAccess, + LegalHoldStore, MemberStore, SparAccess, TeamStore @@ -400,7 +400,7 @@ uncheckedDeleteTeam zusr zcon tid = do when ((view teamBinding . tdTeam <$> team) == Just Binding) $ do liftSem $ mapM_ (E.deleteUser . view userId) membs Journal.teamDelete tid - Data.unsetTeamLegalholdWhitelisted tid + liftSem $ Data.unsetTeamLegalholdWhitelisted tid liftSem $ E.deleteTeam tid where pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () @@ -687,7 +687,16 @@ uncheckedGetTeamMembers :: uncheckedGetTeamMembers tid maxResults = liftSem $ E.getTeamMembersWithLimit tid maxResults addTeamMemberH :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => + Members + '[ BrigAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamFeatureStore, + TeamNotificationStore, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -696,7 +705,16 @@ addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty addTeamMember :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => + Members + '[ BrigAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamFeatureStore, + TeamNotificationStore, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -723,7 +741,16 @@ addTeamMember zusr zcon tid nmem = do -- This function is "unchecked" because there is no need to check for user binding (invite only). uncheckedAddTeamMemberH :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => + Members + '[ BrigAccess, + GundeckAccess, + MemberStore, + LegalHoldStore, + TeamFeatureStore, + TeamStore, + TeamNotificationStore + ] + r => TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do @@ -732,7 +759,16 @@ uncheckedAddTeamMemberH (tid ::: req ::: _) = do return empty uncheckedAddTeamMember :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => + Members + '[ BrigAccess, + GundeckAccess, + MemberStore, + LegalHoldStore, + TeamFeatureStore, + TeamStore, + TeamNotificationStore + ] + r => TeamId -> NewTeamMember -> Galley r () @@ -994,6 +1030,7 @@ deleteTeamConversation :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, MemberStore, TeamStore ] @@ -1009,7 +1046,7 @@ deleteTeamConversation zusr zcon _tid cid = do void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: - Member TeamStore r => + Members '[SearchVisibilityStore, TeamStore] r => UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do @@ -1018,7 +1055,7 @@ getSearchVisibilityH (uid ::: tid ::: _) = do json <$> getSearchVisibilityInternal tid setSearchVisibilityH :: - Member TeamStore r => + Members '[SearchVisibilityStore, TeamStore, TeamFeatureStore] r => UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do @@ -1051,10 +1088,10 @@ withTeamIds :: withTeamIds usr range size k = case range of Nothing -> do r <- liftSem $ E.listItems usr Nothing (rcast size) - k (Data.resultSetType r == Data.ResultSetTruncated) (Data.resultSetResult r) + k (resultSetType r == ResultSetTruncated) (resultSetResult r) Just (Right c) -> do r <- liftSem $ E.listItems usr (Just c) (rcast size) - k (Data.resultSetType r == Data.ResultSetTruncated) (Data.resultSetResult r) + k (resultSetType r == ResultSetTruncated) (resultSetResult r) Just (Left (fromRange -> cc)) -> do ids <- liftSem $ E.selectTeams usr (Data.ByteString.Conversion.fromList cc) k False ids @@ -1102,7 +1139,11 @@ ensureNotTooLarge tid = do -- size unlimited, because we make the assumption that these teams won't turn -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. -ensureNotTooLargeForLegalHold :: Member BrigAccess r => TeamId -> Int -> Galley r () +ensureNotTooLargeForLegalHold :: + Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Int -> + Galley r () ensureNotTooLargeForLegalHold tid teamSize = do whenM (isLegalHoldEnabledForTeam tid) $ do unlessM (teamSizeBelowLimit teamSize) $ do @@ -1126,7 +1167,7 @@ teamSizeBelowLimit teamSize = do pure True addTeamMemberInternal :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamStore] r => + Members '[BrigAccess, GundeckAccess, MemberStore, TeamNotificationStore, TeamStore] r => TeamId -> Maybe UserId -> Maybe ConnId -> @@ -1164,7 +1205,7 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi -- less warped. This is a work-around because we cannot send events to all of a large team. -- See haddocks of module "Galley.API.TeamNotifications" for details. getTeamNotificationsH :: - Member BrigAccess r => + Members '[BrigAccess, TeamNotificationStore] r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 @@ -1226,18 +1267,24 @@ getBindingTeamMembers :: Member TeamStore r => UserId -> Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> getTeamMembersForFanout tid -canUserJoinTeamH :: Member BrigAccess r => TeamId -> Galley r Response +canUserJoinTeamH :: + Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold -canUserJoinTeam :: Member BrigAccess r => TeamId -> Galley r () +canUserJoinTeam :: Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) -getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: + Member TeamFeatureStore r => + TeamId -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do @@ -1246,28 +1293,44 @@ getTeamSearchVisibilityAvailableInternal tid = do FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled - fromMaybe defConfig - <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid + liftSem $ + fromMaybe defConfig + <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) -getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley r Response +getSearchVisibilityInternalH :: + Member SearchVisibilityStore r => + TeamId ::: JSON -> + Galley r Response getSearchVisibilityInternalH (tid ::: _) = json <$> getSearchVisibilityInternal tid -getSearchVisibilityInternal :: TeamId -> Galley r TeamSearchVisibilityView -getSearchVisibilityInternal = fmap TeamSearchVisibilityView . SearchVisibilityData.getSearchVisibility - -setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response +getSearchVisibilityInternal :: + Member SearchVisibilityStore r => + TeamId -> + Galley r TeamSearchVisibilityView +getSearchVisibilityInternal = + fmap TeamSearchVisibilityView . liftSem + . SearchVisibilityData.getSearchVisibility + +setSearchVisibilityInternalH :: + Members '[SearchVisibilityStore, TeamFeatureStore] r => + TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> + Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do setSearchVisibilityInternal tid =<< fromJsonBody req pure noContent -setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley r () +setSearchVisibilityInternal :: + Members '[SearchVisibilityStore, TeamFeatureStore] r => + TeamId -> + TeamSearchVisibilityView -> + Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ throwM teamSearchVisibilityNotEnabled - SearchVisibilityData.setSearchVisibility tid searchVisibility + liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility userIsTeamOwnerH :: Member TeamStore r => TeamId ::: UserId ::: JSON -> Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index f3dcd404483..42049067478 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -60,11 +60,12 @@ import Galley.API.Teams (ensureNotTooLargeToActivateLegalHold) import Galley.API.Util import Galley.App import Galley.Cassandra.Paging -import qualified Galley.Data.SearchVisibility as SearchVisibilityData -import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Data.TeamFeatures import Galley.Effects import Galley.Effects.GundeckAccess import Galley.Effects.Paging +import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import Galley.Effects.TeamStore import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush) import Galley.Options @@ -139,7 +140,10 @@ getFeatureConfig getter zusr = do assertTeamExists tid getter (Right tid) -getAllFeatureConfigs :: Member TeamStore r => UserId -> Galley r AllFeatureConfigs +getAllFeatureConfigs :: + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + UserId -> + Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do mbTeam <- liftSem $ getOneUserTeam zusr zusrMembership <- maybe (pure Nothing) (liftSem . (flip getTeamMember zusr)) mbTeam @@ -172,11 +176,19 @@ getAllFeatureConfigs zusr = do getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] -getAllFeaturesH :: Member TeamStore r => UserId ::: TeamId ::: JSON -> Galley r Response +getAllFeaturesH :: + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + UserId ::: TeamId ::: JSON -> + Galley r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid -getAllFeatures :: forall r. Member TeamStore r => UserId -> TeamId -> Galley r Aeson.Value +getAllFeatures :: + forall r. + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + UserId -> + TeamId -> + Galley r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -206,20 +218,24 @@ getAllFeatures uid tid = do getFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => + ( Public.KnownTeamFeatureName a, + Public.FeatureHasNoConfig a, + HasStatusCol a, + Member TeamFeatureStore r + ) => Galley r Public.TeamFeatureStatusValue -> TeamId -> Galley r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault - fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid + liftSem $ fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, - TeamFeatures.HasStatusCol a, - Members '[GundeckAccess, TeamStore] r + HasStatusCol a, + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r ) => (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> TeamId -> @@ -227,7 +243,7 @@ setFeatureStatusNoConfig :: Galley r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid - newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status + newStatus <- liftSem $ TeamFeatures.setFeatureStatusNoConfig @a tid status pushFeatureConfigEvent tid $ Event.Event Event.Update (Public.knownTeamFeatureName @a) (EdFeatureWithoutConfigChanged newStatus) pure newStatus @@ -236,7 +252,10 @@ setFeatureStatusNoConfig applyState tid status = do -- the feature flag, so that we get more type safety. type GetFeatureInternalParam = Either (Maybe UserId) TeamId -getSSOStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +getSSOStatusInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -249,7 +268,7 @@ getSSOStatusInternal = FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) @@ -257,7 +276,10 @@ setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case Public.TeamFeatureDisabled -> const (throwM disableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) -getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -269,15 +291,18 @@ getTeamSearchVisibilityAvailableInternal = FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled setTeamSearchVisibilityAvailableInternal :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case - Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility + Public.TeamFeatureDisabled -> liftSem . SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) -getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +getValidateSAMLEmailsInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -289,13 +314,16 @@ getValidateSAMLEmailsInternal = getDef = pure Public.TeamFeatureDisabled setValidateSAMLEmailsInternal :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () -getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +getDigitalSignaturesInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -307,13 +335,16 @@ getDigitalSignaturesInternal = getDef = pure Public.TeamFeatureDisabled setDigitalSignaturesInternal :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () -getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +getLegalholdStatusInternal :: + Members '[LegalHoldStore, TeamFeatureStore] r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -333,8 +364,10 @@ setLegalholdStatusInternal :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamFeatureStore, TeamStore, TeamMemberStore p ] @@ -362,15 +395,18 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do Public.TeamFeatureDisabled -> removeSettings' tid Public.TeamFeatureEnabled -> do ensureNotTooLargeToActivateLegalHold tid - TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status + liftSem $ TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status -getFileSharingInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +getFileSharingInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: forall (a :: TeamFeatureName) r. - (KnownTeamFeatureName a, TeamFeatures.HasStatusCol a, FeatureHasNoConfig a) => + (KnownTeamFeatureName a, HasStatusCol a, FeatureHasNoConfig a, Member TeamFeatureStore r) => Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -385,23 +421,32 @@ getFeatureStatusWithDefaultConfig lens' = <&> Public.tfwoStatus . view unDefaults setFileSharingInternal :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () -getAppLockInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +getAppLockInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- view (options . optSettings . setFeatureFlags . flagAppLockDefaults) - status <- join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) + status <- + liftSem $ + join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) pure $ fromMaybe defaultStatus status -setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +setAppLockInternal :: + Member TeamFeatureStore r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throwM inactivityTimeoutTooLow - TeamFeatures.setApplockFeatureStatus tid status + liftSem $ TeamFeatures.setApplockFeatureStatus tid status getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do @@ -413,6 +458,7 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: + Member TeamFeatureStore r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do @@ -423,26 +469,32 @@ getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) setConferenceCallingInternal :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) -setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () +setConferenceCallingInternal = + setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () getSelfDeletingMessagesInternal :: + Member TeamFeatureStore r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) getSelfDeletingMessagesInternal = \case Left _ -> pure Public.defaultSelfDeletingMessagesStatus Right tid -> - TeamFeatures.getSelfDeletingMessagesStatus tid - <&> maybe Public.defaultSelfDeletingMessagesStatus id + liftSem $ + TeamFeatures.getSelfDeletingMessagesStatus tid + <&> maybe Public.defaultSelfDeletingMessagesStatus id setSelfDeletingMessagesInternal :: + Member TeamFeatureStore r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) -setSelfDeletingMessagesInternal = TeamFeatures.setSelfDeletingMessagesStatus +setSelfDeletingMessagesInternal tid value = + liftSem $ + TeamFeatures.setSelfDeletingMessagesStatus tid value pushFeatureConfigEvent :: Members '[GundeckAccess, TeamStore] r => diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index d37e42a64b0..8b4b0117a15 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -53,6 +53,7 @@ import Galley.App import qualified Galley.Data.TeamNotifications as DataTeamQueue import Galley.Effects import Galley.Effects.BrigAccess as Intra +import qualified Galley.Effects.TeamNotificationStore as E import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification import Imports @@ -60,7 +61,7 @@ import Network.HTTP.Types import Network.Wai.Utilities getTeamNotifications :: - Member BrigAccess r => + Members '[BrigAccess, TeamNotificationStore] r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> @@ -70,17 +71,17 @@ getTeamNotifications zusr since size = do mtid <- liftSem $ (userTeam . accountUser =<<) <$> Intra.getUser zusr let err = throwM teamNotFound maybe err pure mtid - page <- DataTeamQueue.fetch tid since size + page <- liftSem $ E.getTeamNotifications tid since size pure $ queuedNotificationList (toList (DataTeamQueue.resultSeq page)) (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: TeamId -> Event -> Galley r () +pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Galley r () pushTeamEvent tid evt = do nid <- mkNotificationId - DataTeamQueue.add tid nid (List1.singleton $ toJSONObject evt) + liftSem $ E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) -- | 'Data.UUID.V1.nextUUID' is sometimes unsuccessful, so we try a few times. mkNotificationId :: (MonadIO m, MonadThrow m) => m NotificationId diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 43190d9d830..7708afa49eb 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -92,8 +92,6 @@ import Galley.API.Mapping import Galley.API.Message import Galley.API.Util import Galley.App -import Galley.Cassandra.Services -import qualified Galley.Data.Access as Data import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) @@ -107,6 +105,7 @@ import qualified Galley.Effects.ExternalAccess as E import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.ServiceStore as E import qualified Galley.Effects.TeamStore as E import Galley.Intra.Push import Galley.Options @@ -282,6 +281,7 @@ performAccessUpdateAction :: FederatorAccess, FireAndForget, GundeckAccess, + LegalHoldStore, MemberStore, TeamStore ] @@ -457,6 +457,7 @@ type UpdateConversationActions = GundeckAccess, CodeStore, ConversationStore, + LegalHoldStore, MemberStore, TeamStore ] @@ -1432,14 +1433,14 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: JsonRequest Service -> Galley r Response +addServiceH :: Member ServiceStore r => JsonRequest Service -> Galley r Response addServiceH req = do - insertService =<< fromJsonBody req + liftSem . E.createService =<< fromJsonBody req return empty -rmServiceH :: JsonRequest ServiceRef -> Galley r Response +rmServiceH :: Member ServiceStore r => JsonRequest ServiceRef -> Galley r Response rmServiceH req = do - deleteService =<< fromJsonBody req + liftSem . E.deleteService =<< fromJsonBody req return empty addBotH :: diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 17c8a474154..5f434712e39 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -42,7 +42,6 @@ import Data.Time import Galley.API.Error import Galley.App import qualified Galley.Data.Conversation as Data -import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes import Galley.Effects @@ -52,6 +51,7 @@ import Galley.Effects.ConversationStore import Galley.Effects.ExternalAccess import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess +import Galley.Effects.LegalHoldStore import Galley.Effects.MemberStore import Galley.Effects.TeamStore import Galley.Intra.Push @@ -797,7 +797,10 @@ anyLegalholdActivated uids = do teamsOfUsers <- liftSem $ getUsersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage -allLegalholdConsentGiven :: Member TeamStore r => [UserId] -> Galley r Bool +allLegalholdConsentGiven :: + Members '[LegalHoldStore, TeamStore] r => + [UserId] -> + Galley r Bool allLegalholdConsentGiven uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -811,7 +814,7 @@ allLegalholdConsentGiven uids = do -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do teamsPage <- liftSem $ nub . Map.elems <$> getUsersTeams uidsPage - allM isTeamLegalholdWhitelisted teamsPage + allM (liftSem . isTeamLegalholdWhitelisted) teamsPage -- | Add to every uid the legalhold status getLHStatusForUsers :: diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index cc0dfcd04b2..bdb74e49923 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -91,8 +91,13 @@ import Galley.Cassandra.Code import Galley.Cassandra.Conversation import Galley.Cassandra.Conversation.Members import Galley.Cassandra.ConversationList +import Galley.Cassandra.CustomBackend +import Galley.Cassandra.LegalHold +import Galley.Cassandra.SearchVisibility import Galley.Cassandra.Services import Galley.Cassandra.Team +import Galley.Cassandra.TeamFeatures +import Galley.Cassandra.TeamNotifications import Galley.Effects import Galley.Effects.FireAndForget (interpretFireAndForget) import qualified Galley.Effects.FireAndForget as E @@ -158,12 +163,6 @@ instance MonadReader Env (Galley r) where ask = Galley $ P.ask @Env local f m = Galley $ P.local f (unGalley m) -instance MonadClient (Galley r) where - liftClient m = Galley $ do - cs <- P.ask @ClientState - embed @IO $ runClient cs m - localState f m = Galley $ P.local f (unGalley m) - instance HasFederatorConfig (Galley r) where federatorEndpoint = view federator federationDomain = view (options . optSettings . setFederationDomain) @@ -333,8 +332,13 @@ interpretGalleyToGalley0 = . interpretConversationListToCassandra . withLH interpretTeamMemberStoreToCassandra . withLH interpretTeamStoreToCassandra + . interpretTeamNotificationStoreToCassandra + . interpretTeamFeatureStoreToCassandra . interpretServiceStoreToCassandra + . interpretSearchVisibilityStoreToCassandra . interpretMemberStoreToCassandra + . withLH interpretLegalHoldStoreToCassandra + . interpretCustomBackendStoreToCassandra . interpretConversationStoreToCassandra . interpretCodeStoreToCassandra . interpretClientStoreToCassandra diff --git a/services/galley/src/Galley/Data/Access.hs b/services/galley/src/Galley/Cassandra/Access.hs similarity index 67% rename from services/galley/src/Galley/Data/Access.hs rename to services/galley/src/Galley/Cassandra/Access.hs index e2dfb0b7f5e..a2c4fb176b7 100644 --- a/services/galley/src/Galley/Data/Access.hs +++ b/services/galley/src/Galley/Cassandra/Access.hs @@ -15,11 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.Access where +module Galley.Cassandra.Access where import Cassandra -import qualified Data.Set as Set -import Galley.Data.Conversation.Types +import Galley.Data.Conversation import Imports hiding (Set) import Wire.API.Conversation hiding (Conversation) @@ -34,27 +33,5 @@ defAccess One2OneConv (Just (Set [])) = [PrivateAccess] defAccess RegularConv (Just (Set [])) = defRegularConvAccess defAccess _ (Just (Set (x : xs))) = x : xs -defRegularConvAccess :: [Access] -defRegularConvAccess = [InviteAccess] - -maybeRole :: ConvType -> Maybe AccessRole -> AccessRole -maybeRole SelfConv _ = privateRole -maybeRole ConnectConv _ = privateRole -maybeRole One2OneConv _ = privateRole -maybeRole RegularConv Nothing = defRole -maybeRole RegularConv (Just r) = r - -defRole :: AccessRole -defRole = ActivatedAccessRole - -privateRole :: AccessRole -privateRole = PrivateAccessRole - privateOnly :: Set Access privateOnly = Set [PrivateAccess] - -convAccessData :: Conversation -> ConversationAccessData -convAccessData conv = - ConversationAccessData - (Set.fromList (convAccess conv)) - (convAccessRole conv) diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs index ecf66e2f0fb..ee0f4e3bda2 100644 --- a/services/galley/src/Galley/Cassandra/Client.hs +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -25,8 +25,8 @@ import Cassandra import Control.Arrow import Data.Id import Data.List.Split (chunksOf) +import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store -import qualified Galley.Data.Queries as Cql import Galley.Effects.ClientStore (ClientStore (..)) import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs index c41e3c09b4b..ac9d03525a3 100644 --- a/services/galley/src/Galley/Cassandra/Code.hs +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -22,8 +22,8 @@ where import Brig.Types.Code import Cassandra +import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store -import qualified Galley.Data.Queries as Cql import Galley.Data.Types import Galley.Effects.CodeStore (CodeStore (..)) import Imports diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 2522fd3ef61..04822d1850c 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -22,7 +22,8 @@ module Galley.Cassandra.Conversation ) where -import Cassandra +import Cassandra hiding (Set) +import qualified Cassandra as Cql import Data.ByteString.Conversion import Data.Id import qualified Data.Map as Map @@ -31,12 +32,12 @@ import Data.Qualified import Data.Range import qualified Data.UUID.Tagged as U import Data.UUID.V4 (nextRandom) +import Galley.Cassandra.Access import Galley.Cassandra.Conversation.Members +import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store -import Galley.Data.Access import Galley.Data.Conversation import Galley.Data.Conversation.Types -import qualified Galley.Data.Queries as Cql import Galley.Effects.ConversationStore (ConversationStore (..)) import Galley.Types.Conversations.Members import Galley.Types.UserList @@ -55,11 +56,11 @@ createConversation (NewConversation ty usr acc arole name mtid mtimer recpt user conv <- Id <$> liftIO nextRandom retry x5 $ case mtid of Nothing -> - write Cql.insertConv (params LocalQuorum (conv, ty, usr, Set (toList acc), arole, fmap fromRange name, Nothing, mtimer, recpt)) + write Cql.insertConv (params LocalQuorum (conv, ty, usr, Cql.Set (toList acc), arole, fmap fromRange name, Nothing, mtimer, recpt)) Just tid -> batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.insertConv (conv, ty, usr, Set (toList acc), arole, fmap fromRange name, Just tid, mtimer, recpt) + addPrepQuery Cql.insertConv (conv, ty, usr, Cql.Set (toList acc), arole, fmap fromRange name, Just tid, mtimer, recpt) addPrepQuery Cql.insertTeamConv (tid, conv, False) let newUsers = fmap (,role) (fromConvSize users) (lmems, rmems) <- addMembers conv (ulAddLocal (usr, roleNameWireAdmin) newUsers) @@ -249,7 +250,7 @@ updateConvName cid name = retry x5 $ write Cql.updateConvName (params LocalQuoru updateConvAccess :: ConvId -> ConversationAccessData -> Client () updateConvAccess cid (ConversationAccessData acc role) = retry x5 $ - write Cql.updateConvAccess (params LocalQuorum (Set (toList acc), role, cid)) + write Cql.updateConvAccess (params LocalQuorum (Cql.Set (toList acc), role, cid)) updateConvReceiptMode :: ConvId -> ReceiptMode -> Client () updateConvReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params LocalQuorum (receiptMode, cid)) @@ -332,6 +333,17 @@ remoteConversationStatusOnDomain uid rconvs = toMemberStatus (omus, omur, oar, oarr, hid, hidr) ) +toConv :: + ConvId -> + [LocalMember] -> + [RemoteMember] -> + Maybe (ConvType, UserId, Maybe (Cql.Set Access), Maybe AccessRole, Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode) -> + Maybe Conversation +toConv cid mms remoteMems conv = + f mms <$> conv + where + f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm + interpretConversationStoreToCassandra :: Members '[Embed IO, P.Reader ClientState, TinyLog] r => Sem (ConversationStore ': r) a -> diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 3a69e61899c..039fc643428 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -34,10 +34,10 @@ import qualified Data.List.Extra as List import qualified Data.Map as Map import Data.Monoid import Data.Qualified +import Galley.Cassandra.Instances () +import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Services import Galley.Cassandra.Store -import Galley.Data.Instances () -import qualified Galley.Data.Queries as Cql import Galley.Effects.MemberStore import Galley.Types.Conversations.Members import Galley.Types.ToUserRole diff --git a/services/galley/src/Galley/Cassandra/ConversationList.hs b/services/galley/src/Galley/Cassandra/ConversationList.hs index 76d8139dabc..324b7fad34e 100644 --- a/services/galley/src/Galley/Cassandra/ConversationList.hs +++ b/services/galley/src/Galley/Cassandra/ConversationList.hs @@ -26,11 +26,11 @@ import Cassandra import Data.Id import Data.Qualified import Data.Range +import Galley.Cassandra.Instances () import Galley.Cassandra.Paging +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.ResultSet import Galley.Cassandra.Store -import Galley.Data.Instances () -import qualified Galley.Data.Queries as Cql -import Galley.Data.ResultSet import Galley.Effects.ListItems import Imports hiding (max) import Polysemy diff --git a/services/galley/src/Galley/Data/CustomBackend.hs b/services/galley/src/Galley/Cassandra/CustomBackend.hs similarity index 69% rename from services/galley/src/Galley/Data/CustomBackend.hs rename to services/galley/src/Galley/Cassandra/CustomBackend.hs index ec6955e16bd..fe757271b82 100644 --- a/services/galley/src/Galley/Data/CustomBackend.hs +++ b/services/galley/src/Galley/Cassandra/CustomBackend.hs @@ -17,19 +17,27 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.CustomBackend - ( getCustomBackend, - setCustomBackend, - deleteCustomBackend, - ) -where +module Galley.Cassandra.CustomBackend (interpretCustomBackendStoreToCassandra) where import Cassandra import Data.Domain (Domain) -import Galley.Data.Instances () -import qualified Galley.Data.Queries as Cql +import Galley.Cassandra.Instances () +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.Store +import Galley.Effects.CustomBackendStore (CustomBackendStore (..)) import Galley.Types import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretCustomBackendStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (CustomBackendStore ': r) a -> + Sem r a +interpretCustomBackendStoreToCassandra = interpret $ \case + GetCustomBackend dom -> embedClient $ getCustomBackend dom + SetCustomBackend dom b -> embedClient $ setCustomBackend dom b + DeleteCustomBackend dom -> embedClient $ deleteCustomBackend dom getCustomBackend :: MonadClient m => Domain -> m (Maybe CustomBackend) getCustomBackend domain = diff --git a/services/galley/src/Galley/Data/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs similarity index 99% rename from services/galley/src/Galley/Data/Instances.hs rename to services/galley/src/Galley/Cassandra/Instances.hs index b1d259548e4..198aa2675c0 100644 --- a/services/galley/src/Galley/Data/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.Instances +module Galley.Cassandra.Instances ( ) where diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index 12f687abd8a..87345d5c79e 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -15,13 +15,99 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Cassandra.LegalHold (isTeamLegalholdWhitelisted) where +module Galley.Cassandra.LegalHold + ( interpretLegalHoldStoreToCassandra, + isTeamLegalholdWhitelisted, + -- * Used by tests + selectPendingPrekeys, + ) +where + +import Brig.Types.Client.Prekey +import Brig.Types.Instances () +import Brig.Types.Team.LegalHold import Cassandra +import Control.Lens (unsnoc) import Data.Id -import Galley.Data.Queries as Q +import Data.LegalHold +import Galley.Cassandra.Instances () +import qualified Galley.Cassandra.Queries as Q +import Galley.Cassandra.Store +import Galley.Effects.LegalHoldStore (LegalHoldStore (..)) import Galley.Types.Teams import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretLegalHoldStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + FeatureLegalHold -> + Sem (LegalHoldStore ': r) a -> + Sem r a +interpretLegalHoldStoreToCassandra lh = interpret $ \case + CreateSettings s -> embedClient $ createSettings s + GetSettings tid -> embedClient $ getSettings tid + RemoveSettings tid -> embedClient $ removeSettings tid + InsertPendingPrekeys uid pkeys -> embedClient $ insertPendingPrekeys uid pkeys + SelectPendingPrekeys uid -> embedClient $ selectPendingPrekeys uid + DropPendingPrekeys uid -> embedClient $ dropPendingPrekeys uid + SetUserLegalHoldStatus tid uid st -> embedClient $ setUserLegalHoldStatus tid uid st + SetTeamLegalholdWhitelisted tid -> embedClient $ setTeamLegalholdWhitelisted tid + UnsetTeamLegalholdWhitelisted tid -> embedClient $ unsetTeamLegalholdWhitelisted tid + IsTeamLegalholdWhitelisted tid -> embedClient $ isTeamLegalholdWhitelisted lh tid + +-- | Returns 'False' if legal hold is not enabled for this team +-- The Caller is responsible for checking whether legal hold is enabled for this team +createSettings :: MonadClient m => LegalHoldService -> m () +createSettings (LegalHoldService tid url fpr tok key) = do + retry x1 $ write Q.insertLegalHoldSettings (params LocalQuorum (url, fpr, tok, key, tid)) + +-- | Returns 'Nothing' if no settings are saved +-- The Caller is responsible for checking whether legal hold is enabled for this team +getSettings :: MonadClient m => TeamId -> m (Maybe LegalHoldService) +getSettings tid = + fmap toLegalHoldService <$> do + retry x1 $ query1 Q.selectLegalHoldSettings (params LocalQuorum (Identity tid)) + where + toLegalHoldService (httpsUrl, fingerprint, tok, key) = LegalHoldService tid httpsUrl fingerprint tok key + +removeSettings :: MonadClient m => TeamId -> m () +removeSettings tid = retry x5 (write Q.removeLegalHoldSettings (params LocalQuorum (Identity tid))) + +insertPendingPrekeys :: MonadClient m => UserId -> [Prekey] -> m () +insertPendingPrekeys uid keys = retry x5 . batch $ + forM_ keys $ + \key -> + addPrepQuery Q.insertPendingPrekeys (toTuple key) + where + toTuple (Prekey keyId key) = (uid, keyId, key) + +selectPendingPrekeys :: MonadClient m => UserId -> m (Maybe ([Prekey], LastPrekey)) +selectPendingPrekeys uid = + pickLastKey . fmap fromTuple + <$> retry x1 (query Q.selectPendingPrekeys (params LocalQuorum (Identity uid))) + where + fromTuple (keyId, key) = Prekey keyId key + pickLastKey allPrekeys = + case unsnoc allPrekeys of + Nothing -> Nothing + Just (keys, lst) -> pure (keys, lastPrekey . prekeyKey $ lst) + +dropPendingPrekeys :: MonadClient m => UserId -> m () +dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params LocalQuorum (Identity uid))) + +setUserLegalHoldStatus :: MonadClient m => TeamId -> UserId -> UserLegalHoldStatus -> m () +setUserLegalHoldStatus tid uid status = + retry x5 (write Q.updateUserLegalHoldStatus (params LocalQuorum (status, tid, uid))) + +setTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () +setTeamLegalholdWhitelisted tid = + retry x5 (write Q.insertLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) + +unsetTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () +unsetTeamLegalholdWhitelisted tid = + retry x5 (write Q.removeLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) isTeamLegalholdWhitelisted :: FeatureLegalHold -> TeamId -> Client Bool isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False diff --git a/services/galley/src/Galley/Cassandra/Paging.hs b/services/galley/src/Galley/Cassandra/Paging.hs index d2ea8e4cd26..f4dd6a07c79 100644 --- a/services/galley/src/Galley/Cassandra/Paging.hs +++ b/services/galley/src/Galley/Cassandra/Paging.hs @@ -23,6 +23,12 @@ module Galley.Cassandra.Paging InternalPagingState (..), mkInternalPage, ipNext, + + -- * Re-exports + ResultSet, + resultSetResult, + resultSetType, + ResultSetType (..), ) where @@ -30,7 +36,7 @@ import Cassandra import Data.Id import Data.Qualified import Data.Range -import Galley.Data.ResultSet +import Galley.Cassandra.ResultSet import qualified Galley.Effects.Paging as E import Imports import Wire.API.Team.Member (HardTruncationLimit, TeamMember) diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs similarity index 99% rename from services/galley/src/Galley/Data/Queries.hs rename to services/galley/src/Galley/Cassandra/Queries.hs index fc919ac3128..641fdcbe572 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.Queries where +module Galley.Cassandra.Queries where import Brig.Types.Client.Prekey import Brig.Types.Code diff --git a/services/galley/src/Galley/Data/ResultSet.hs b/services/galley/src/Galley/Cassandra/ResultSet.hs similarity index 98% rename from services/galley/src/Galley/Data/ResultSet.hs rename to services/galley/src/Galley/Cassandra/ResultSet.hs index 78db286a0e8..441a5baa40c 100644 --- a/services/galley/src/Galley/Data/ResultSet.hs +++ b/services/galley/src/Galley/Cassandra/ResultSet.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.ResultSet where +module Galley.Cassandra.ResultSet where import Cassandra import Imports diff --git a/services/galley/src/Galley/Data/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs similarity index 71% rename from services/galley/src/Galley/Data/SearchVisibility.hs rename to services/galley/src/Galley/Cassandra/SearchVisibility.hs index f291fae8d1a..cd3905ad4ce 100644 --- a/services/galley/src/Galley/Data/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -17,19 +15,27 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.SearchVisibility - ( setSearchVisibility, - getSearchVisibility, - resetSearchVisibility, - ) -where +module Galley.Cassandra.SearchVisibility (interpretSearchVisibilityStoreToCassandra) where import Cassandra import Data.Id -import Galley.Data.Instances () -import Galley.Data.Queries +import Galley.Cassandra.Instances () +import Galley.Cassandra.Queries +import Galley.Cassandra.Store +import Galley.Effects.SearchVisibilityStore (SearchVisibilityStore (..)) import Galley.Types.Teams.SearchVisibility import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretSearchVisibilityStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (SearchVisibilityStore ': r) a -> + Sem r a +interpretSearchVisibilityStoreToCassandra = interpret $ \case + GetSearchVisibility tid -> embedClient $ getSearchVisibility tid + SetSearchVisibility tid value -> embedClient $ setSearchVisibility tid value + ResetSearchVisibility tid -> embedClient $ resetSearchVisibility tid -- | Return whether a given team is allowed to enable/disable sso getSearchVisibility :: MonadClient m => TeamId -> m TeamSearchVisibility diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs index b6e7f7403fa..724c5dab5f5 100644 --- a/services/galley/src/Galley/Cassandra/Services.hs +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -20,8 +20,8 @@ module Galley.Cassandra.Services where import Cassandra import Control.Lens import Data.Id +import Galley.Cassandra.Queries import Galley.Cassandra.Store -import Galley.Data.Queries import Galley.Data.Services import Galley.Effects.ServiceStore (ServiceStore (..)) import Galley.Types hiding (Conversation) diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 709b236d1af..9e5ece8d008 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -39,10 +39,9 @@ import Data.UUID.V4 (nextRandom) import qualified Galley.Cassandra.Conversation as C import Galley.Cassandra.LegalHold (isTeamLegalholdWhitelisted) import Galley.Cassandra.Paging +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.ResultSet import Galley.Cassandra.Store -import Galley.Data.Instances () -import qualified Galley.Data.Queries as Cql -import Galley.Data.ResultSet import Galley.Effects.ListItems import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore (TeamStore (..)) diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs new file mode 100644 index 00000000000..7ef181c87af --- /dev/null +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -0,0 +1,153 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.TeamFeatures (interpretTeamFeatureStoreToCassandra) where + +import Cassandra +import Data.Id +import Data.Proxy +import Galley.Cassandra.Instances () +import Galley.Cassandra.Store +import Galley.Data.TeamFeatures +import Galley.Effects.TeamFeatureStore (TeamFeatureStore (..)) +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import Wire.API.Team.Feature + +getFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + m (Maybe (TeamFeatureStatus a)) +getFeatureStatusNoConfig _ tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + mStatusValue <- (>>= runIdentity) <$> retry x1 q + pure $ TeamFeatureStatusNoConfig <$> mStatusValue + where + select :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatusValue)) + select = fromString $ "select " <> statusCol @a <> " from team_features where team_id = ?" + +setFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStatus a -> + m (TeamFeatureStatus a) +setFeatureStatusNoConfig _ tid status = do + let flag = tfwoStatus status + retry x5 $ write insert (params LocalQuorum (tid, flag)) + pure status + where + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue) () + insert = fromString $ "insert into team_features (team_id, " <> statusCol @a <> ") values (?, ?)" + +getApplockFeatureStatus :: + forall m. + (MonadClient m) => + TeamId -> + m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) +getApplockFeatureStatus tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + mTuple <- retry x1 q + pure $ + mTuple >>= \(mbStatusValue, mbEnforce, mbTimeout) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureAppLockConfig <$> mbEnforce <*> mbTimeout) + where + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe EnforceAppLock, Maybe Int32) + select = + fromString $ + "select " <> statusCol @'TeamFeatureAppLock <> ", app_lock_enforce, app_lock_inactivity_timeout_secs " + <> "from team_features where team_id = ?" + +setApplockFeatureStatus :: + (MonadClient m) => + TeamId -> + TeamFeatureStatus 'TeamFeatureAppLock -> + m (TeamFeatureStatus 'TeamFeatureAppLock) +setApplockFeatureStatus tid status = do + let statusValue = tfwcStatus status + enforce = applockEnforceAppLock . tfwcConfig $ status + timeout = applockInactivityTimeoutSecs . tfwcConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, enforce, timeout)) + pure status + where + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, EnforceAppLock, Int32) () + insert = + fromString $ + "insert into team_features (team_id, " + <> statusCol @'TeamFeatureAppLock + <> ", app_lock_enforce, app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" + +getSelfDeletingMessagesStatus :: + forall m. + (MonadClient m) => + TeamId -> + m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) +getSelfDeletingMessagesStatus tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + mTuple <- retry x1 q + pure $ + mTuple >>= \(mbStatusValue, mbTimeout) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout) + where + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32) + select = + fromString $ + "select " + <> statusCol @'TeamFeatureSelfDeletingMessages + <> ", self_deleting_messages_ttl " + <> "from team_features where team_id = ?" + +setSelfDeletingMessagesStatus :: + (MonadClient m) => + TeamId -> + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> + m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) +setSelfDeletingMessagesStatus tid status = do + let statusValue = tfwcStatus status + timeout = sdmEnforcedTimeoutSeconds . tfwcConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) + pure status + where + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Int32) () + insert = + fromString $ + "insert into team_features (team_id, " + <> statusCol @'TeamFeatureSelfDeletingMessages + <> ", self_deleting_messages_ttl) " + <> "values (?, ?, ?)" + +interpretTeamFeatureStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (TeamFeatureStore ': r) a -> + Sem r a +interpretTeamFeatureStoreToCassandra = interpret $ \case + GetFeatureStatusNoConfig' p tid -> embedClient $ getFeatureStatusNoConfig p tid + SetFeatureStatusNoConfig' p tid value -> embedClient $ setFeatureStatusNoConfig p tid value + GetApplockFeatureStatus tid -> embedClient $ getApplockFeatureStatus tid + SetApplockFeatureStatus tid value -> embedClient $ setApplockFeatureStatus tid value + GetSelfDeletingMessagesStatus tid -> embedClient $ getSelfDeletingMessagesStatus tid + SetSelfDeletingMessagesStatus tid value -> embedClient $ setSelfDeletingMessagesStatus tid value diff --git a/services/galley/src/Galley/Cassandra/TeamNotifications.hs b/services/galley/src/Galley/Cassandra/TeamNotifications.hs new file mode 100644 index 00000000000..2a12e347371 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/TeamNotifications.hs @@ -0,0 +1,139 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- | See also: "Galley.API.TeamNotifications". +-- +-- This module is a clone of "Gundeck.Notification.Data". +-- +-- FUTUREWORK: this is a work-around because it only solves *some* problems with team events. +-- We should really use a scalable message queue instead. +module Galley.Cassandra.TeamNotifications + ( interpretTeamNotificationStoreToCassandra, + ) +where + +import Cassandra +import qualified Data.Aeson as JSON +import Data.Id +import Data.List1 (List1) +import Data.Range (Range, fromRange) +import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) +import qualified Data.Sequence as Seq +import Galley.Cassandra.Store +import Galley.Data.TeamNotifications +import Galley.Effects.TeamNotificationStore +import Gundeck.Types.Notification +import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretTeamNotificationStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (TeamNotificationStore ': r) a -> + Sem r a +interpretTeamNotificationStoreToCassandra = interpret $ \case + CreateTeamNotification tid nid objs -> embedClient $ add tid nid objs + GetTeamNotifications tid mnid lim -> embedClient $ fetch tid mnid lim + +-- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned +add :: + TeamId -> + NotificationId -> + List1 JSON.Object -> + Client () +add tid nid (Blob . JSON.encode -> payload) = + write cqlInsert (params LocalQuorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 + where + cqlInsert :: PrepQuery W (TeamId, NotificationId, Blob, Int32) () + cqlInsert = + "INSERT INTO team_notifications \ + \(team, id, payload) VALUES \ + \(?, ?, ?) \ + \USING TTL ?" + +notificationTTLSeconds :: Int32 +notificationTTLSeconds = 24192200 + +fetch :: TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> Client ResultPage +fetch tid since (fromRange -> size) = do + -- We always need to look for one more than requested in order to correctly + -- report whether there are more results. + let size' = bool (+ 1) (+ 2) (isJust since) size + page1 <- case TimeUuid . toUUID <$> since of + Nothing -> paginate cqlStart (paramsP LocalQuorum (Identity tid) size') & retry x1 + Just s -> paginate cqlSince (paramsP LocalQuorum (tid, s) size') & retry x1 + -- Collect results, requesting more pages until we run out of data + -- or have found size + 1 notifications (not including the 'since'). + let isize = fromIntegral size' :: Int + (ns, more) <- collect Seq.empty isize page1 + -- Drop the extra element from the end as well. Keep the inclusive start + -- value in the response (if a 'since' was given and found). + -- This can probably simplified a lot further, but we need to understand + -- 'Seq' in order to do that. If you find a bug, this may be a good + -- place to start looking. + return $! case Seq.viewl (trim (isize - 1) ns) of + EmptyL -> ResultPage Seq.empty False + (x :< xs) -> ResultPage (x <| xs) more + where + collect :: + Seq QueuedNotification -> + Int -> + Page (TimeUuid, Blob) -> + Client (Seq QueuedNotification, Bool) + collect acc num page = + let ns = splitAt num $ foldr toNotif [] (result page) + nseq = Seq.fromList (fst ns) + more = hasMore page + num' = num - Seq.length nseq + acc' = acc >< nseq + in if not more || num' == 0 + then return (acc', more || not (null (snd ns))) + else liftClient (nextPage page) >>= collect acc' num' + trim :: Int -> Seq a -> Seq a + trim l ns + | Seq.length ns <= l = ns + | otherwise = case Seq.viewr ns of + EmptyR -> ns + xs :> _ -> xs + cqlStart :: PrepQuery R (Identity TeamId) (TimeUuid, Blob) + cqlStart = + "SELECT id, payload \ + \FROM team_notifications \ + \WHERE team = ? \ + \ORDER BY id ASC" + cqlSince :: PrepQuery R (TeamId, TimeUuid) (TimeUuid, Blob) + cqlSince = + "SELECT id, payload \ + \FROM team_notifications \ + \WHERE team = ? AND id >= ? \ + \ORDER BY id ASC" + +------------------------------------------------------------------------------- +-- Conversions + +toNotif :: (TimeUuid, Blob) -> [QueuedNotification] -> [QueuedNotification] +toNotif (i, b) ns = + maybe + ns + (\p1 -> queuedNotification notifId p1 : ns) + ( JSON.decode' (fromBlob b) + -- FUTUREWORK: this is from the database, so it's slightly more ok to ignore parse + -- errors than if it's data provided by a client. it would still be better to have an + -- error entry in the log file and crash, rather than ignore the error and continue. + ) + where + notifId = Id (fromTimeUuid i) diff --git a/services/galley/src/Galley/Data/Conversation.hs b/services/galley/src/Galley/Data/Conversation.hs index 725161d7f0b..b1e149b6513 100644 --- a/services/galley/src/Galley/Data/Conversation.hs +++ b/services/galley/src/Galley/Data/Conversation.hs @@ -26,20 +26,21 @@ module Galley.Data.Conversation isTeamConv, isConvDeleted, selfConv, - toConv, localOne2OneConvId, convMetadata, + convAccessData, + defRole, + maybeRole, + privateRole, + defRegularConvAccess, ) where -import Cassandra import Data.Id -import Data.Misc +import qualified Data.Set as Set import qualified Data.UUID.Tagged as U -import Galley.Data.Access +import Galley.Cassandra.Instances () import Galley.Data.Conversation.Types -import Galley.Data.Instances () -import Galley.Types.Conversations.Members import Imports hiding (Set) import Wire.API.Conversation hiding (Conversation) @@ -58,17 +59,6 @@ isConvDeleted = fromMaybe False . convDeleted selfConv :: UserId -> ConvId selfConv uid = Id (toUUID uid) -toConv :: - ConvId -> - [LocalMember] -> - [RemoteMember] -> - Maybe (ConvType, UserId, Maybe (Set Access), Maybe AccessRole, Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode) -> - Maybe Conversation -toConv cid mms remoteMems conv = - f mms <$> conv - where - f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm - -- | We deduce the conversation ID by adding the 4 components of the V4 UUID -- together pairwise, and then setting the version bits (v4) and variant bits -- (variant 2). This means that we always know what the UUID is for a @@ -87,3 +77,25 @@ convMetadata c = (convTeam c) (convMessageTimer c) (convReceiptMode c) + +convAccessData :: Conversation -> ConversationAccessData +convAccessData conv = + ConversationAccessData + (Set.fromList (convAccess conv)) + (convAccessRole conv) + +defRole :: AccessRole +defRole = ActivatedAccessRole + +maybeRole :: ConvType -> Maybe AccessRole -> AccessRole +maybeRole SelfConv _ = privateRole +maybeRole ConnectConv _ = privateRole +maybeRole One2OneConv _ = privateRole +maybeRole RegularConv Nothing = defRole +maybeRole RegularConv (Just r) = r + +privateRole :: AccessRole +privateRole = PrivateAccessRole + +defRegularConvAccess :: [Access] +defRegularConvAccess = [InviteAccess] diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Data/LegalHold.hs deleted file mode 100644 index 716e0917dfb..00000000000 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ /dev/null @@ -1,102 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Data.LegalHold - ( createSettings, - getSettings, - removeSettings, - Galley.Data.LegalHold.insertPendingPrekeys, - Galley.Data.LegalHold.selectPendingPrekeys, - Galley.Data.LegalHold.dropPendingPrekeys, - setUserLegalHoldStatus, - setTeamLegalholdWhitelisted, - isTeamLegalholdWhitelisted, - unsetTeamLegalholdWhitelisted, - ) -where - -import Brig.Types.Client.Prekey -import Brig.Types.Instances () -import Brig.Types.Team.LegalHold -import Cassandra -import Control.Lens (unsnoc, view) -import Data.Id -import Data.LegalHold -import qualified Galley.Cassandra.LegalHold as C -import Galley.Data.Instances () -import Galley.Data.Queries as Q -import Galley.Env -import qualified Galley.Options as Opts -import Galley.Types.Teams (flagLegalHold) -import Imports - --- | Returns 'False' if legal hold is not enabled for this team --- The Caller is responsible for checking whether legal hold is enabled for this team -createSettings :: MonadClient m => LegalHoldService -> m () -createSettings (LegalHoldService tid url fpr tok key) = do - retry x1 $ write insertLegalHoldSettings (params LocalQuorum (url, fpr, tok, key, tid)) - --- | Returns 'Nothing' if no settings are saved --- The Caller is responsible for checking whether legal hold is enabled for this team -getSettings :: MonadClient m => TeamId -> m (Maybe LegalHoldService) -getSettings tid = - fmap toLegalHoldService <$> do - retry x1 $ query1 selectLegalHoldSettings (params LocalQuorum (Identity tid)) - where - toLegalHoldService (httpsUrl, fingerprint, tok, key) = LegalHoldService tid httpsUrl fingerprint tok key - -removeSettings :: MonadClient m => TeamId -> m () -removeSettings tid = retry x5 (write removeLegalHoldSettings (params LocalQuorum (Identity tid))) - -insertPendingPrekeys :: MonadClient m => UserId -> [Prekey] -> m () -insertPendingPrekeys uid keys = retry x5 . batch $ - forM_ keys $ - \key -> - addPrepQuery Q.insertPendingPrekeys (toTuple key) - where - toTuple (Prekey keyId key) = (uid, keyId, key) - -selectPendingPrekeys :: MonadClient m => UserId -> m (Maybe ([Prekey], LastPrekey)) -selectPendingPrekeys uid = - pickLastKey . fmap fromTuple - <$> retry x1 (query Q.selectPendingPrekeys (params LocalQuorum (Identity uid))) - where - fromTuple (keyId, key) = Prekey keyId key - pickLastKey allPrekeys = - case unsnoc allPrekeys of - Nothing -> Nothing - Just (keys, lst) -> pure (keys, lastPrekey . prekeyKey $ lst) - -dropPendingPrekeys :: MonadClient m => UserId -> m () -dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params LocalQuorum (Identity uid))) - -setUserLegalHoldStatus :: MonadClient m => TeamId -> UserId -> UserLegalHoldStatus -> m () -setUserLegalHoldStatus tid uid status = - retry x5 (write Q.updateUserLegalHoldStatus (params LocalQuorum (status, tid, uid))) - -setTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () -setTeamLegalholdWhitelisted tid = - retry x5 (write Q.insertLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) - -unsetTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () -unsetTeamLegalholdWhitelisted tid = - retry x5 (write Q.removeLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) - -isTeamLegalholdWhitelisted :: (MonadReader Env m, MonadClient m) => TeamId -> m Bool -isTeamLegalholdWhitelisted tid = do - lhFlag <- view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) - liftClient $ C.isTeamLegalholdWhitelisted lhFlag tid diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index a9437a3470c..e7ab337d0f5 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -17,29 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.TeamFeatures - ( getFeatureStatusNoConfig, - setFeatureStatusNoConfig, - getApplockFeatureStatus, - setApplockFeatureStatus, - getSelfDeletingMessagesStatus, - setSelfDeletingMessagesStatus, - HasStatusCol (..), - ) -where +module Galley.Data.TeamFeatures (HasStatusCol (..)) where -import Cassandra -import Data.Id -import Galley.Data.Instances () import Imports import Wire.API.Team.Feature - ( TeamFeatureName (..), - TeamFeatureStatus, - TeamFeatureStatusNoConfig (..), - TeamFeatureStatusValue (..), - TeamFeatureStatusWithConfig (..), - ) -import qualified Wire.API.Team.Feature as Public -- | Because not all so called team features are actually team-level features, -- not all of them have a corresponding column in the database. Therefore, @@ -69,112 +48,3 @@ instance HasStatusCol 'TeamFeatureFileSharing where statusCol = "file_sharing" instance HasStatusCol 'TeamFeatureConferenceCalling where statusCol = "conference_calling" instance HasStatusCol 'TeamFeatureSelfDeletingMessages where statusCol = "self_deleting_messages_status" - -getFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName) m. - ( MonadClient m, - Public.FeatureHasNoConfig a, - HasStatusCol a - ) => - TeamId -> - m (Maybe (TeamFeatureStatus a)) -getFeatureStatusNoConfig tid = do - let q = query1 select (params LocalQuorum (Identity tid)) - mStatusValue <- (>>= runIdentity) <$> retry x1 q - pure $ TeamFeatureStatusNoConfig <$> mStatusValue - where - select :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatusValue)) - select = fromString $ "select " <> statusCol @a <> " from team_features where team_id = ?" - -setFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName) m. - ( MonadClient m, - Public.FeatureHasNoConfig a, - HasStatusCol a - ) => - TeamId -> - TeamFeatureStatus a -> - m (TeamFeatureStatus a) -setFeatureStatusNoConfig tid status = do - let flag = Public.tfwoStatus status - retry x5 $ write insert (params LocalQuorum (tid, flag)) - pure status - where - insert :: PrepQuery W (TeamId, TeamFeatureStatusValue) () - insert = fromString $ "insert into team_features (team_id, " <> statusCol @a <> ") values (?, ?)" - -getApplockFeatureStatus :: - forall m. - (MonadClient m) => - TeamId -> - m (Maybe (TeamFeatureStatus 'Public.TeamFeatureAppLock)) -getApplockFeatureStatus tid = do - let q = query1 select (params LocalQuorum (Identity tid)) - mTuple <- retry x1 q - pure $ - mTuple >>= \(mbStatusValue, mbEnforce, mbTimeout) -> - TeamFeatureStatusWithConfig <$> mbStatusValue <*> (Public.TeamFeatureAppLockConfig <$> mbEnforce <*> mbTimeout) - where - select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Public.EnforceAppLock, Maybe Int32) - select = - fromString $ - "select " <> statusCol @'Public.TeamFeatureAppLock <> ", app_lock_enforce, app_lock_inactivity_timeout_secs " - <> "from team_features where team_id = ?" - -setApplockFeatureStatus :: - (MonadClient m) => - TeamId -> - TeamFeatureStatus 'Public.TeamFeatureAppLock -> - m (TeamFeatureStatus 'Public.TeamFeatureAppLock) -setApplockFeatureStatus tid status = do - let statusValue = Public.tfwcStatus status - enforce = Public.applockEnforceAppLock . Public.tfwcConfig $ status - timeout = Public.applockInactivityTimeoutSecs . Public.tfwcConfig $ status - retry x5 $ write insert (params LocalQuorum (tid, statusValue, enforce, timeout)) - pure status - where - insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Public.EnforceAppLock, Int32) () - insert = - fromString $ - "insert into team_features (team_id, " - <> statusCol @'Public.TeamFeatureAppLock - <> ", app_lock_enforce, app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" - -getSelfDeletingMessagesStatus :: - forall m. - (MonadClient m) => - TeamId -> - m (Maybe (TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages)) -getSelfDeletingMessagesStatus tid = do - let q = query1 select (params LocalQuorum (Identity tid)) - mTuple <- retry x1 q - pure $ - mTuple >>= \(mbStatusValue, mbTimeout) -> - TeamFeatureStatusWithConfig <$> mbStatusValue <*> (Public.TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout) - where - select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32) - select = - fromString $ - "select " - <> statusCol @'Public.TeamFeatureSelfDeletingMessages - <> ", self_deleting_messages_ttl " - <> "from team_features where team_id = ?" - -setSelfDeletingMessagesStatus :: - (MonadClient m) => - TeamId -> - TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> - m (TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) -setSelfDeletingMessagesStatus tid status = do - let statusValue = Public.tfwcStatus status - timeout = Public.sdmEnforcedTimeoutSeconds . Public.tfwcConfig $ status - retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) - pure status - where - insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Int32) () - insert = - fromString $ - "insert into team_features (team_id, " - <> statusCol @'Public.TeamFeatureSelfDeletingMessages - <> ", self_deleting_messages_ttl) " - <> "values (?, ?, ?)" diff --git a/services/galley/src/Galley/Data/TeamNotifications.hs b/services/galley/src/Galley/Data/TeamNotifications.hs index d7b3a9003d0..faeff5edd97 100644 --- a/services/galley/src/Galley/Data/TeamNotifications.hs +++ b/services/galley/src/Galley/Data/TeamNotifications.hs @@ -23,21 +23,9 @@ -- -- FUTUREWORK: this is a work-around because it only solves *some* problems with team events. -- We should really use a scalable message queue instead. -module Galley.Data.TeamNotifications - ( ResultPage (..), - add, - fetch, - ) -where +module Galley.Data.TeamNotifications (ResultPage (..)) where -import Cassandra as C -import qualified Data.Aeson as JSON -import Data.Id -import Data.List1 (List1) -import Data.Range (Range, fromRange) -import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) -import qualified Data.Sequence as Seq -import Galley.App +import Data.Sequence (Seq) import Gundeck.Types.Notification import Imports @@ -49,92 +37,3 @@ data ResultPage = ResultPage -- last notification in 'resultSeq'. resultHasMore :: !Bool } - --- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned -add :: - TeamId -> - NotificationId -> - List1 JSON.Object -> - Galley r () -add tid nid (Blob . JSON.encode -> payload) = - write cqlInsert (params LocalQuorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 - where - cqlInsert :: PrepQuery W (TeamId, NotificationId, Blob, Int32) () - cqlInsert = - "INSERT INTO team_notifications \ - \(team, id, payload) VALUES \ - \(?, ?, ?) \ - \USING TTL ?" - -notificationTTLSeconds :: Int32 -notificationTTLSeconds = 24192200 - -fetch :: TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r ResultPage -fetch tid since (fromRange -> size) = do - -- We always need to look for one more than requested in order to correctly - -- report whether there are more results. - let size' = bool (+ 1) (+ 2) (isJust since) size - page1 <- case TimeUuid . toUUID <$> since of - Nothing -> paginate cqlStart (paramsP LocalQuorum (Identity tid) size') & retry x1 - Just s -> paginate cqlSince (paramsP LocalQuorum (tid, s) size') & retry x1 - -- Collect results, requesting more pages until we run out of data - -- or have found size + 1 notifications (not including the 'since'). - let isize = fromIntegral size' :: Int - (ns, more) <- collect Seq.empty isize page1 - -- Drop the extra element from the end as well. Keep the inclusive start - -- value in the response (if a 'since' was given and found). - -- This can probably simplified a lot further, but we need to understand - -- 'Seq' in order to do that. If you find a bug, this may be a good - -- place to start looking. - return $! case Seq.viewl (trim (isize - 1) ns) of - EmptyL -> ResultPage Seq.empty False - (x :< xs) -> ResultPage (x <| xs) more - where - collect :: - Seq QueuedNotification -> - Int -> - Page (TimeUuid, Blob) -> - Galley r (Seq QueuedNotification, Bool) - collect acc num page = - let ns = splitAt num $ foldr toNotif [] (result page) - nseq = Seq.fromList (fst ns) - more = hasMore page - num' = num - Seq.length nseq - acc' = acc >< nseq - in if not more || num' == 0 - then return (acc', more || not (null (snd ns))) - else liftClient (nextPage page) >>= collect acc' num' - trim :: Int -> Seq a -> Seq a - trim l ns - | Seq.length ns <= l = ns - | otherwise = case Seq.viewr ns of - EmptyR -> ns - xs :> _ -> xs - cqlStart :: PrepQuery R (Identity TeamId) (TimeUuid, Blob) - cqlStart = - "SELECT id, payload \ - \FROM team_notifications \ - \WHERE team = ? \ - \ORDER BY id ASC" - cqlSince :: PrepQuery R (TeamId, TimeUuid) (TimeUuid, Blob) - cqlSince = - "SELECT id, payload \ - \FROM team_notifications \ - \WHERE team = ? AND id >= ? \ - \ORDER BY id ASC" - -------------------------------------------------------------------------------- --- Conversions - -toNotif :: (TimeUuid, Blob) -> [QueuedNotification] -> [QueuedNotification] -toNotif (i, b) ns = - maybe - ns - (\p1 -> queuedNotification notifId p1 : ns) - ( JSON.decode' (fromBlob b) - -- FUTUREWORK: this is from the database, so it's slightly more ok to ignore parse - -- errors than if it's data provided by a client. it would still be better to have an - -- error entry in the log file and crash, rather than ignore the error and continue. - ) - where - notifId = Id (fromTimeUuid i) diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 4058b1ea44b..e2f26dea92f 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -36,10 +36,15 @@ module Galley.Effects ClientStore, CodeStore, ConversationStore, + CustomBackendStore, + LegalHoldStore, MemberStore, + SearchVisibilityStore, ServiceStore, - TeamStore, + TeamFeatureStore, TeamMemberStore, + TeamNotificationStore, + TeamStore, -- * Paging effects ListItems, @@ -58,15 +63,20 @@ import Galley.Effects.BrigAccess import Galley.Effects.ClientStore import Galley.Effects.CodeStore import Galley.Effects.ConversationStore +import Galley.Effects.CustomBackendStore import Galley.Effects.ExternalAccess import Galley.Effects.FederatorAccess import Galley.Effects.FireAndForget import Galley.Effects.GundeckAccess +import Galley.Effects.LegalHoldStore import Galley.Effects.ListItems import Galley.Effects.MemberStore +import Galley.Effects.SearchVisibilityStore import Galley.Effects.ServiceStore import Galley.Effects.SparAccess +import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamMemberStore +import Galley.Effects.TeamNotificationStore import Galley.Effects.TeamStore import Polysemy @@ -82,8 +92,13 @@ type GalleyEffects1 = ClientStore, CodeStore, ConversationStore, + CustomBackendStore, + LegalHoldStore, MemberStore, + SearchVisibilityStore, ServiceStore, + TeamFeatureStore, + TeamNotificationStore, TeamStore, TeamMemberStore InternalPaging, ListItems CassandraPaging ConvId, diff --git a/services/galley/src/Galley/Effects/CustomBackendStore.hs b/services/galley/src/Galley/Effects/CustomBackendStore.hs new file mode 100644 index 00000000000..cd3fc723009 --- /dev/null +++ b/services/galley/src/Galley/Effects/CustomBackendStore.hs @@ -0,0 +1,36 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.CustomBackendStore + ( CustomBackendStore (..), + getCustomBackend, + setCustomBackend, + deleteCustomBackend, + ) +where + +import Data.Domain (Domain) +import Galley.Types +import Imports +import Polysemy + +data CustomBackendStore m a where + GetCustomBackend :: Domain -> CustomBackendStore m (Maybe CustomBackend) + SetCustomBackend :: Domain -> CustomBackend -> CustomBackendStore m () + DeleteCustomBackend :: Domain -> CustomBackendStore m () + +makeSem ''CustomBackendStore diff --git a/services/galley/src/Galley/Effects/LegalHoldStore.hs b/services/galley/src/Galley/Effects/LegalHoldStore.hs new file mode 100644 index 00000000000..28b70fcf1f8 --- /dev/null +++ b/services/galley/src/Galley/Effects/LegalHoldStore.hs @@ -0,0 +1,52 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.LegalHoldStore + ( LegalHoldStore (..), + createSettings, + getSettings, + removeSettings, + insertPendingPrekeys, + selectPendingPrekeys, + dropPendingPrekeys, + setUserLegalHoldStatus, + setTeamLegalholdWhitelisted, + unsetTeamLegalholdWhitelisted, + isTeamLegalholdWhitelisted, + ) +where + +import Data.Id +import Data.LegalHold +import Galley.External.LegalHoldService.Types +import Imports +import Polysemy +import Wire.API.User.Client.Prekey + +data LegalHoldStore m a where + CreateSettings :: LegalHoldService -> LegalHoldStore m () + GetSettings :: TeamId -> LegalHoldStore m (Maybe LegalHoldService) + RemoveSettings :: TeamId -> LegalHoldStore m () + InsertPendingPrekeys :: UserId -> [Prekey] -> LegalHoldStore m () + SelectPendingPrekeys :: UserId -> LegalHoldStore m (Maybe ([Prekey], LastPrekey)) + DropPendingPrekeys :: UserId -> LegalHoldStore m () + SetUserLegalHoldStatus :: TeamId -> UserId -> UserLegalHoldStatus -> LegalHoldStore m () + SetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () + UnsetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () + IsTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m Bool + +makeSem ''LegalHoldStore diff --git a/services/galley/src/Galley/Effects/SearchVisibilityStore.hs b/services/galley/src/Galley/Effects/SearchVisibilityStore.hs new file mode 100644 index 00000000000..28a9b394c32 --- /dev/null +++ b/services/galley/src/Galley/Effects/SearchVisibilityStore.hs @@ -0,0 +1,35 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.SearchVisibilityStore + ( SearchVisibilityStore (..), + getSearchVisibility, + setSearchVisibility, + resetSearchVisibility, + ) +where + +import Data.Id +import Galley.Types.Teams.SearchVisibility +import Polysemy + +data SearchVisibilityStore m a where + GetSearchVisibility :: TeamId -> SearchVisibilityStore m TeamSearchVisibility + SetSearchVisibility :: TeamId -> TeamSearchVisibility -> SearchVisibilityStore m () + ResetSearchVisibility :: TeamId -> SearchVisibilityStore m () + +makeSem ''SearchVisibilityStore diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs new file mode 100644 index 00000000000..d2910980f20 --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -0,0 +1,86 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamFeatureStore + ( TeamFeatureStore (..), + getFeatureStatusNoConfig, + setFeatureStatusNoConfig, + getApplockFeatureStatus, + setApplockFeatureStatus, + getSelfDeletingMessagesStatus, + setSelfDeletingMessagesStatus, + ) +where + +import Data.Id +import Data.Proxy +import Galley.Data.TeamFeatures +import Imports +import Polysemy +import Wire.API.Team.Feature + +data TeamFeatureStore m a where + -- the proxy argument makes sure that makeSem below generates type-inference-friendly code + GetFeatureStatusNoConfig' :: + forall (a :: TeamFeatureName) m. + ( FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStore m (Maybe (TeamFeatureStatus a)) + -- the proxy argument makes sure that makeSem below generates type-inference-friendly code + SetFeatureStatusNoConfig' :: + forall (a :: TeamFeatureName) m. + ( FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStatus a -> + TeamFeatureStore m (TeamFeatureStatus a) + GetApplockFeatureStatus :: + TeamId -> + TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) + SetApplockFeatureStatus :: + TeamId -> + TeamFeatureStatus 'TeamFeatureAppLock -> + TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureAppLock) + GetSelfDeletingMessagesStatus :: + TeamId -> + TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + SetSelfDeletingMessagesStatus :: + TeamId -> + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> + TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) + +makeSem ''TeamFeatureStore + +getFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + TeamId -> + Sem r (Maybe (TeamFeatureStatus a)) +getFeatureStatusNoConfig = getFeatureStatusNoConfig' (Proxy @a) + +setFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + TeamId -> + TeamFeatureStatus a -> + Sem r (TeamFeatureStatus a) +setFeatureStatusNoConfig = setFeatureStatusNoConfig' (Proxy @a) diff --git a/services/galley/src/Galley/Effects/TeamNotificationStore.hs b/services/galley/src/Galley/Effects/TeamNotificationStore.hs new file mode 100644 index 00000000000..5e553315d44 --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamNotificationStore.hs @@ -0,0 +1,41 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamNotificationStore where + +import qualified Data.Aeson as JSON +import Data.Id +import Data.List1 (List1) +import Data.Range +import Galley.Data.TeamNotifications +import Gundeck.Types.Notification +import Imports +import Polysemy + +data TeamNotificationStore m a where + CreateTeamNotification :: + TeamId -> + NotificationId -> + List1 JSON.Object -> + TeamNotificationStore m () + GetTeamNotifications :: + TeamId -> + Maybe NotificationId -> + Range 1 10000 Int32 -> + TeamNotificationStore m ResultPage + +makeSem ''TeamNotificationStore diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index ac503fc67c7..1c4a3038ecb 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -44,7 +44,7 @@ import Data.Id import Data.Misc import Galley.API.Error import Galley.App -import qualified Galley.Data.LegalHold as LegalHoldData +import Galley.Effects.LegalHoldStore as LegalHoldData import Galley.Env import Galley.External.LegalHoldService.Types import Imports @@ -55,6 +55,7 @@ import qualified OpenSSL.EVP.PKey as SSL import qualified OpenSSL.PEM as SSL import qualified OpenSSL.RSA as SSL import qualified OpenSSL.Session as SSL +import Polysemy import Ssl.Util import qualified Ssl.Util as SSL import qualified System.Logger.Class as Log @@ -80,7 +81,11 @@ checkLegalHoldServiceStatus fpr url = do . Bilge.expect2xx -- | @POST /initiate@. -requestNewDevice :: TeamId -> UserId -> Galley r NewLegalHoldClient +requestNewDevice :: + Member LegalHoldStore r => + TeamId -> + UserId -> + Galley r NewLegalHoldClient requestNewDevice tid uid = do resp <- makeLegalHoldServiceRequest tid reqParams case eitherDecode (responseBody resp) of @@ -99,6 +104,7 @@ requestNewDevice tid uid = do -- | @POST /confirm@ -- Confirm that a device has been linked to a user and provide an authorization token confirmLegalHold :: + Member LegalHoldStore r => ClientId -> TeamId -> UserId -> @@ -118,6 +124,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do -- | @POST /remove@ -- Inform the LegalHold Service that a user's legalhold has been disabled. removeLegalHold :: + Member LegalHoldStore r => TeamId -> UserId -> Galley r () @@ -137,9 +144,13 @@ removeLegalHold tid uid = do -- | Lookup legal hold service settings for a team and make a request to the service. Pins -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. -makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) +makeLegalHoldServiceRequest :: + Member LegalHoldStore r => + TeamId -> + (Http.Request -> Http.Request) -> + Galley r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do - maybeLHSettings <- LegalHoldData.getSettings tid + maybeLHSettings <- liftSem $ LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of Nothing -> throwM legalHoldServiceNotRegistered Just lhSettings -> pure lhSettings diff --git a/services/galley/src/Galley/External/LegalHoldService/Types.hs b/services/galley/src/Galley/External/LegalHoldService/Types.hs index cecf37ad874..8a3f671bcf5 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Types.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Types.hs @@ -19,9 +19,13 @@ module Galley.External.LegalHoldService.Types ( OpaqueAuthToken (..), + + -- * Re-exports + LegalHoldService, ) where +import Brig.Types.Team.LegalHold import Data.Aeson import Data.ByteString.Conversion.To import Imports diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 2f16338b5af..b5d4cd24deb 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -66,7 +66,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Time.Clock as Time import qualified Galley.App as Galley import Galley.Cassandra.Client -import qualified Galley.Data.LegalHold as LegalHoldData +import qualified Galley.Cassandra.LegalHold as LegalHoldData import Galley.External.LegalHoldService (validateServiceKey) import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index c9ee4e914a4..f7ce8108228 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -60,7 +60,7 @@ import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) import qualified Galley.App as Galley import Galley.Cassandra.Client -import qualified Galley.Data.LegalHold as LegalHoldData +import qualified Galley.Cassandra.LegalHold as LegalHoldData import Galley.External.LegalHoldService (validateServiceKey) import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients diff --git a/tools/db/migrate-sso-feature-flag/src/Work.hs b/tools/db/migrate-sso-feature-flag/src/Work.hs index c2dc980ab77..582f2fdf3bd 100644 --- a/tools/db/migrate-sso-feature-flag/src/Work.hs +++ b/tools/db/migrate-sso-feature-flag/src/Work.hs @@ -31,7 +31,7 @@ import Data.Conduit.Internal (zipSources) import qualified Data.Conduit.List as C import Data.Id import Data.Misc -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import System.Logger (Logger) import qualified System.Logger as Log diff --git a/tools/db/move-team/src/ParseSchema.hs b/tools/db/move-team/src/ParseSchema.hs index cae5abef31f..7d4299a8b2f 100644 --- a/tools/db/move-team/src/ParseSchema.hs +++ b/tools/db/move-team/src/ParseSchema.hs @@ -205,7 +205,7 @@ import Data.Conduit import Data.Id import Data.Time import Data.UUID -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import Types import Wire.API.Team.Permission diff --git a/tools/db/move-team/src/Schema.hs b/tools/db/move-team/src/Schema.hs index 56ce0a9a8da..1958fb705b1 100644 --- a/tools/db/move-team/src/Schema.hs +++ b/tools/db/move-team/src/Schema.hs @@ -27,7 +27,7 @@ import Data.IP (IP) import Data.Id import Data.Time import Data.UUID -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import System.FilePath.Posix (()) import Types diff --git a/tools/db/move-team/src/Types.hs b/tools/db/move-team/src/Types.hs index 8d079316b0b..e103908cb73 100644 --- a/tools/db/move-team/src/Types.hs +++ b/tools/db/move-team/src/Types.hs @@ -36,7 +36,7 @@ import Data.Id import qualified Data.Text as T import Data.Text.Ascii (AsciiText, Base64, decodeBase64, encodeBase64) import qualified Data.Vector as V -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import System.Logger (Logger) import Wire.API.User.Password (PasswordResetKey (..)) diff --git a/tools/db/move-team/src/Work.hs b/tools/db/move-team/src/Work.hs index 7d9e8207aef..cab4883b389 100644 --- a/tools/db/move-team/src/Work.hs +++ b/tools/db/move-team/src/Work.hs @@ -38,7 +38,7 @@ import qualified Data.Conduit.List as CL import Data.Id import qualified Data.Set as Set import Data.UUID -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import Schema import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitWith) From 21c0eac05189f8886fa91a5090047aedc6634f6e Mon Sep 17 00:00:00 2001 From: fisx Date: Fri, 5 Nov 2021 17:27:02 +0100 Subject: [PATCH 72/88] Fix: push events when AppLock or SelfDeletingMessages config change. (#1901) * Fix: push events when AppLock or SelfDeletingMessages config change. Remove unused feature config change event. Revert "Remove unused feature config change event." This reverts commit ad0aaa75511c4b03a25cb783e1b386d4b228e046. fixed compile error formatting * Changelog. --- changelog.d/3-bug-fixes/pr-1901 | 1 + .../galley/src/Galley/API/Teams/Features.hs | 25 +++++++++++++------ 2 files changed, 19 insertions(+), 7 deletions(-) create mode 100644 changelog.d/3-bug-fixes/pr-1901 diff --git a/changelog.d/3-bug-fixes/pr-1901 b/changelog.d/3-bug-fixes/pr-1901 new file mode 100644 index 00000000000..177e67f63ab --- /dev/null +++ b/changelog.d/3-bug-fixes/pr-1901 @@ -0,0 +1 @@ +Push events when AppLock or SelfDeletingMessages config change. diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 42049067478..d4a2a076b72 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -79,7 +79,13 @@ import Servant.API ((:<|>) ((:<|>))) import qualified Servant.Client as Client import qualified System.Logger.Class as Log import Util.Options (Endpoint, epHost, epPort) -import Wire.API.Event.FeatureConfig (EventData (EdFeatureWithoutConfigChanged)) +import Wire.API.Event.FeatureConfig + ( EventData + ( EdFeatureApplockChanged, + EdFeatureSelfDeletingMessagesChanged, + EdFeatureWithoutConfigChanged + ), + ) import qualified Wire.API.Event.FeatureConfig as Event import qualified Wire.API.Routes.Internal.Brig as IAPI import Wire.API.Team.Feature (AllFeatureConfigs (..), FeatureHasNoConfig, KnownTeamFeatureName, TeamFeatureName) @@ -439,14 +445,17 @@ getAppLockInternal mbtid = do pure $ fromMaybe defaultStatus status setAppLockInternal :: - Member TeamFeatureStore r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throwM inactivityTimeoutTooLow - liftSem $ TeamFeatures.setApplockFeatureStatus tid status + let pushEvent = + pushFeatureConfigEvent tid $ + Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) + (liftSem $ TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do @@ -488,13 +497,15 @@ getSelfDeletingMessagesInternal = \case <&> maybe Public.defaultSelfDeletingMessagesStatus id setSelfDeletingMessagesInternal :: - Member TeamFeatureStore r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) -setSelfDeletingMessagesInternal tid value = - liftSem $ - TeamFeatures.setSelfDeletingMessagesStatus tid value +setSelfDeletingMessagesInternal tid st = do + let pushEvent = + pushFeatureConfigEvent tid $ + Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) + (liftSem $ TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent pushFeatureConfigEvent :: Members '[GundeckAccess, TeamStore] r => From 1db0235b19bf61fb006b9493ba5a05a2cb300bbc Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 8 Nov 2021 10:01:27 +0100 Subject: [PATCH 73/88] regenerate galley.cabal (#1911) --- services/galley/galley.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 2a18dcb467d..3efbf509124 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 07288a51b3ae662362fae1279cdd4c22977ae3c8dfb4dffe1228d0da1beba2b4 +-- hash: 7c30fbe05e0beac371abdaab802319d909686c98a1b133508c984e021b2999ba name: galley version: 0.83.0 @@ -53,6 +53,7 @@ library Galley.Cassandra.Conversation.Members Galley.Cassandra.ConversationList Galley.Cassandra.CustomBackend + Galley.Cassandra.Instances Galley.Cassandra.LegalHold Galley.Cassandra.Paging Galley.Cassandra.Queries @@ -65,7 +66,6 @@ library Galley.Cassandra.TeamNotifications Galley.Data.Conversation Galley.Data.Conversation.Types - Galley.Cassandra.Instances Galley.Data.Scope Galley.Data.Services Galley.Data.TeamFeatures From 4dbd1a584bd0d64412ef4bd049aa10fd8781d213 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 8 Nov 2021 12:08:00 +0100 Subject: [PATCH 74/88] Federation: Notify remote participants when a user leaves a conversation because they were deleted (#1891) Also add End2end test for deleting a user --- Makefile | 4 ++ changelog.d/6-federation/notify-remotes | 1 + services/brig/federation-tests.sh | 12 +++- .../brig/test/integration/API/User/Util.hs | 14 ++++ .../test/integration/Federation/End2end.hs | 28 +++++++- services/galley/src/Galley/API/Internal.hs | 66 +++++++++++++------ services/galley/test/integration/API.hs | 52 ++++++++++++--- services/galley/test/integration/API/Util.hs | 5 ++ 8 files changed, 150 insertions(+), 32 deletions(-) create mode 100644 changelog.d/6-federation/notify-remotes diff --git a/Makefile b/Makefile index bcb634ff73e..0fc43d27ad4 100644 --- a/Makefile +++ b/Makefile @@ -277,6 +277,10 @@ kube-integration-test: kube-integration-teardown: export NAMESPACE=$(NAMESPACE); ./hack/bin/integration-teardown-federation.sh +.PHONY: kube-integration-e2e-telepresence +kube-integration-e2e-telepresence: + ./services/brig/federation-tests.sh $(NAMESPACE) + .PHONY: kube-integration-setup-sans-federation kube-integration-setup-sans-federation: guard-tag charts-integration # by default "test- is used as namespace diff --git a/changelog.d/6-federation/notify-remotes b/changelog.d/6-federation/notify-remotes new file mode 100644 index 00000000000..0aeaa8c457f --- /dev/null +++ b/changelog.d/6-federation/notify-remotes @@ -0,0 +1 @@ +Notify remote participants when a user leaves a conversation because they were deleted diff --git a/services/brig/federation-tests.sh b/services/brig/federation-tests.sh index 8c1732bd9aa..76acd31691e 100755 --- a/services/brig/federation-tests.sh +++ b/services/brig/federation-tests.sh @@ -27,4 +27,14 @@ kubectl -n "$NAMESPACE" get configmap brig -o jsonpath='{.data.brig\.yaml}' >b.y sed -i "s=privateKeys: /etc/wire/brig/secrets/secretkey.txt=privateKeys: test/resources/zauth/privkeys.txt=g" b.yaml sed -i "s=publicKeys: /etc/wire/brig/secrets/publickey.txt=publicKeys: test/resources/zauth/pubkeys.txt=g" b.yaml -telepresence --namespace "$NAMESPACE" --also-proxy cassandra-ephemeral --run bash -c "export INTEGRATION_FEDERATION_TESTS=1; ./dist/brig-integration -p federation-end2end-user -i i.yaml -s b.yaml" +# We need to pass --also-proxy to cannon pod IPs, as for some reason (maybe due +# to calico) the pod IPs in some clusters are not within the podCIDR range +# defined on the nodes and cannons need to be accessed directly (without using +# the kubernetes services) +declare -a alsoProxyOptions +while read -r ip; do + alsoProxyOptions+=("--also-proxy=${ip}") +done < <(kubectl get pods -n "$NAMESPACE" -l wireService=cannon -o json | jq -r '.items[].status.podIPs[].ip') + +# shellcheck disable=SC2086 +telepresence --namespace "$NAMESPACE" --also-proxy=cassandra-ephemeral ${alsoProxyOptions[*]} --run bash -c "export INTEGRATION_FEDERATION_TESTS=1; ./dist/brig-integration -p federation-end2end-user -i i.yaml -s b.yaml" diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 6ee884a3dc0..a3024bde91c 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -50,8 +50,10 @@ import qualified Data.Vector as Vec import Federation.Util (withTempMockFederator) import Gundeck.Types (Notification (..)) import Imports +import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import Util +import qualified Wire.API.Event.Conversation as Conv import qualified Wire.API.Federation.API.Brig as F import Wire.API.Federation.GRPC.Types hiding (body, path) import qualified Wire.API.Federation.GRPC.Types as F @@ -462,3 +464,15 @@ matchDeleteUserNotification quid n = do etype @?= Just "user.delete" eUnqualifiedId @?= Just (qUnqualified quid) eQualifiedId @?= Just quid + +matchConvLeaveNotification :: Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> Notification -> IO () +matchConvLeaveNotification conv remover removeds n = do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + Conv.evtConv e @?= conv + Conv.evtType e @?= Conv.MemberLeave + Conv.evtFrom e @?= remover + sorted (Conv.evtData e) @?= sorted (Conv.EdMembersLeave (Conv.QualifiedUserIdList removeds)) + where + sorted (Conv.EdMembersLeave (Conv.QualifiedUserIdList m)) = Conv.EdMembersLeave (Conv.QualifiedUserIdList (sort m)) + sorted x = x diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index d197a6b3c8f..445fa1ab7c8 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -18,7 +18,7 @@ module Federation.End2end where import API.Search.Util -import API.User.Util (getUserClientsQualified) +import API.User.Util import Bilge import Bilge.Assert ((!!!), ( Brig -> Galley -> Galley -> Cannon -> Http () +testDeleteUser brig1 brig2 galley1 galley2 cannon1 = do + alice <- userQualifiedId <$> randomUser brig1 + bobDel <- userQualifiedId <$> randomUser brig2 + + connectUsersEnd2End brig1 brig2 alice bobDel + + conv1 <- + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (qUnqualified alice) [bobDel] + do + deleteUser (qUnqualified bobDel) (Just defPassword) brig2 !!! const 200 === statusCode + WS.assertMatch_ (5 # Second) wsAlice $ matchDeleteUserNotification bobDel + WS.assertMatch_ (5 # Second) wsAlice $ matchConvLeaveNotification conv1 bobDel [bobDel] + WS.assertMatch_ (5 # Second) wsAlice $ matchConvLeaveNotification conv2 bobDel [bobDel] diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index a3636b6d7bc..bb7ce82c268 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -33,7 +33,6 @@ import Data.List1 (maybeList1) import Data.Qualified import Data.Range import Data.String.Conversions (cs) -import qualified Data.Text as T import Data.Time import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients @@ -87,9 +86,11 @@ import Servant.Server.Generic (genericServerT) import System.Logger.Class hiding (Path, name) import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) +import Wire.API.Conversation.Action (ConversationAction (ConversationActionRemoveMembers)) import Wire.API.ErrorDescription (MissingLegalholdConsent) -import Wire.API.Federation.API.Galley (UserDeletedConversationsNotification (UserDeletedConversationsNotification)) +import Wire.API.Federation.API.Galley (ConversationUpdate (..), UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley +import Wire.API.Federation.Client (FederationError) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) import Wire.API.Routes.Public (ZOptConn, ZUser) @@ -533,7 +534,9 @@ rmUser user conn = do leaveLocalConversations :: Member MemberStore r => [ConvId] -> Galley r () leaveLocalConversations ids = do localDomain <- viewFederationDomain + let qUser = Qualified user localDomain cc <- liftSem $ getConversations ids + now <- liftIO getCurrentTime pp <- for cc $ \c -> case Data.convType c of SelfConv -> return Nothing One2OneConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing @@ -541,42 +544,67 @@ rmUser user conn = do RegularConv | user `isMember` Data.convLocalMembers c -> do liftSem $ deleteMembers (Data.convId c) (UserList [user] []) - now <- liftIO getCurrentTime let e = Event MemberLeave (Qualified (Data.convId c) localDomain) (Qualified user localDomain) now - (EdMembersLeave (QualifiedUserIdList [Qualified user localDomain])) - return $ + (EdMembersLeave (QualifiedUserIdList [qUser])) + for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) + pure $ Intra.newPushLocal ListComplete user (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) <&> set Intra.pushConn conn . set Intra.pushRoute Intra.RouteDirect | otherwise -> return Nothing + for_ (maybeList1 (catMaybes pp)) (liftSem . push) + -- FUTUREWORK: This could be optimized to reduce the number of RPCs + -- made. When a team is deleted the burst of RPCs created here could + -- lead to performance issues. We should cover this in a performance + -- test. + notifyRemoteMembers :: UTCTime -> Qualified UserId -> ConvId -> Remote [UserId] -> Galley r () + notifyRemoteMembers now qUser cid remotes = do + localDomain <- viewFederationDomain + let convUpdate = + ConversationUpdate + { cuTime = now, + cuOrigUserId = qUser, + cuConvId = cid, + cuAlreadyPresentUsers = tUnqualified remotes, + cuAction = ConversationActionRemoveMembers (pure qUser) + } + let rpc = FedGalley.onConversationUpdated FedGalley.clientRoutes localDomain convUpdate + liftSem (runFederatedEither remotes rpc) + >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) + leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () leaveRemoteConversations lusr cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete - res <- liftSem $ runFederatedEither remoteConvs rpc - case res of - -- FUTUREWORK: Add a retry mechanism if there are federation errrors. - -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 - Left federationError -> do - Log.err $ - Log.msg $ - T.unwords - [ "Federation error while notifying remote backends of a user deletion (Galley).", - "user_id: " <> (cs . show) lusr, - "details: " <> (cs . show) federationError - ] - pure () - Right _ -> pure () + liftSem (runFederatedEither remoteConvs rpc) + >>= logAndIgnoreError "Error in onUserDeleted call" (tUnqualified lusr) + + -- FUTUREWORK: Add a retry mechanism if there are federation errrors. + -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 + logAndIgnoreError :: Text -> UserId -> Either FederationError a -> Galley r () + logAndIgnoreError message usr res = do + case res of + Left federationError -> do + Log.err + ( Log.msg + ( "Federation error while notifying remote backends of a user deletion (Galley). " + <> message + <> " " + <> (cs . show $ federationError) + ) + . Log.field "user" (show usr) + ) + Right _ -> pure () deleteLoop :: Galley r () deleteLoop = liftGalley0 $ do diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 8999fb3bb08..b199d4c0f06 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -87,7 +87,7 @@ import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley ( Api (onConversationUpdated), - ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuOrigUserId), + ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuConvId, cuOrigUserId), GetConversationsResponse (..), RemoteConvMembers (..), RemoteConversation (..), @@ -3200,17 +3200,19 @@ removeUser = do let [alice', alexDel', amy'] = qUnqualified <$> [alice, alexDel, amy] let bDomain = Domain "b.example.com" bart <- randomQualifiedId bDomain + berta <- randomQualifiedId bDomain let cDomain = Domain "c.example.com" carl <- randomQualifiedId cDomain connectUsers alice' (list1 alexDel' [amy']) connectWithRemoteUser alice' bart + connectWithRemoteUser alice' berta connectWithRemoteUser alexDel' bart connectWithRemoteUser alice' carl connectWithRemoteUser alexDel' carl convA1 <- decodeConvId <$> postConv alice' [alexDel'] (Just "gossip") [] Nothing Nothing - convA2 <- decodeConvId <$> postConv alice' [alexDel', amy'] (Just "gossip2") [] Nothing Nothing + convA2 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, amy, berta]} convA3 <- decodeConvId <$> postConv alice' [amy'] (Just "gossip3") [] Nothing Nothing convA4 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, bart, carl]} convB1 <- randomId -- a remote conversation at 'bDomain' that Alice, AlexDel and Bart will be in @@ -3238,35 +3240,65 @@ removeUser = do FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB2 bart [alexDel] FederatedGalley.onConversationCreated fedGalleyClient cDomain $ nc convC1 carl [alexDel] + localDomain <- viewFederationDomain + WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do + let galleyApi _domain = + emptyFederatedGalley + { FederatedGalley.leaveConversation = \_domain _update -> + pure (FederatedGalley.LeaveConversationResponse (Right ())), + FederatedGalley.onConversationUpdated = \_domain _convUpdate -> + pure () + } (_, fedRequests) <- - withTempMockFederator (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ + withTempServantMockFederator (const emptyFederatedBrig) galleyApi localDomain $ deleteUser alexDel' !!! const 200 === statusCode - -- FUTUTREWORK: There should be 4 requests, one to each domain for telling - -- them that alex left the conversation hosted locally. Add assertions for - -- that and implement it. liftIO $ do - assertEqual ("expect exactly 2 federated requests in : " <> show fedRequests) 2 (length fedRequests) - bReq <- assertOne $ filter (\req -> F.domain req == domainText bDomain) fedRequests - cReq <- assertOne $ filter (\req -> F.domain req == domainText cDomain) fedRequests + assertEqual ("expect exactly 5 federated requests in : " <> show fedRequests) 5 (length fedRequests) + liftIO $ do + bReq <- assertOne $ filter (matchFedRequest bDomain "/federation/on-user-deleted/conversations") fedRequests fmap F.component (F.request bReq) @?= Just F.Galley fmap F.path (F.request bReq) @?= Just "/federation/on-user-deleted/conversations" Just (Right udcnB) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request bReq) sort (fromRange (FederatedGalley.udcnConversations udcnB)) @?= sort [convB1, convB2] FederatedGalley.udcnUser udcnB @?= qUnqualified alexDel - fmap F.component (F.request bReq) @?= Just F.Galley + liftIO $ do + cReq <- assertOne $ filter (matchFedRequest cDomain "/federation/on-user-deleted/conversations") fedRequests + fmap F.component (F.request cReq) @?= Just F.Galley fmap F.path (F.request cReq) @?= Just "/federation/on-user-deleted/conversations" Just (Right udcnC) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cReq) sort (fromRange (FederatedGalley.udcnConversations udcnC)) @?= sort [convC1] FederatedGalley.udcnUser udcnC @?= qUnqualified alexDel + liftIO $ do WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ wsAssertMembersLeave qconvA1 alexDel [alexDel] WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel, wsAmy] $ wsAssertMembersLeave qconvA2 alexDel [alexDel] + + liftIO $ do + let bConvUpdateRPCs = filter (matchFedRequest bDomain "/federation/on-conversation-updated") fedRequests + bConvUpdatesEither :: [Either String ConversationUpdate] <- eitherDecode . LBS.fromStrict . F.body <$$> mapM (assertJust . F.request) bConvUpdateRPCs + bConvUpdates <- mapM assertRight bConvUpdatesEither + + bConvUpdatesA2 <- assertOne $ filter (\cu -> cuConvId cu == convA2) bConvUpdates + cuAction bConvUpdatesA2 @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers bConvUpdatesA2 @?= [qUnqualified berta] + + bConvUpdatesA4 <- assertOne $ filter (\cu -> cuConvId cu == convA4) bConvUpdates + cuAction bConvUpdatesA4 @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers bConvUpdatesA4 @?= [qUnqualified bart] + + liftIO $ do + cConvUpdateRPC <- assertOne $ filter (matchFedRequest cDomain "/federation/on-conversation-updated") fedRequests + Just (Right convUpdate) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cConvUpdateRPC) + cuConvId convUpdate @?= convA4 + cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers convUpdate @?= [qUnqualified carl] + -- Check memberships mems1 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA1 mems2 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA2 diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 22bf552f9da..2f7c43f6814 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -2512,3 +2512,8 @@ generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId = do if shouldBeLocal == isLocal then pure (qTagUnsafe other, convId) else generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId + +matchFedRequest :: Domain -> ByteString -> FederatedRequest -> Bool +matchFedRequest domain reqpath req = + F.domain req == domainText domain + && fmap F.path (F.request req) == Just reqpath From f3e45afd1417da3974f35b51f950853129f0eb61 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 8 Nov 2021 18:18:13 +0100 Subject: [PATCH 75/88] Use cabal to build wire-server (opt-in) (#1853) * Update multiple files (squashed) * Use cabal-plan and bash instead of cabal test or cabal install Both `cabal test` and `cabal install` "change configuration" so next time `cabal build` is run, cabal goes over all the packages to make sure nothing needs compilation which is a significant slowdown. This way we don't have to go through that slowdown. * Ensure `make c` works for all packages * Add usage instructions for `make c` and `make ci` * Update tools/convert-to-cabal/README.md * Simplify running tests with cabal * Gitignore .envrc.local and cabal.project.local Co-authored-by: Akshay Mankar --- .envrc | 2 +- .gitignore | 4 + Makefile | 38 +- cabal.project | 280 ++ cabal.project.freeze | 2528 +++++++++++++++++ changelog.d/5-internal/use-cabal | 1 + direnv.nix | 30 + hack/bin/cabal-install-all-artefacts.sh | 11 + hack/bin/cabal-install-artefacts.sh | 9 + hack/bin/cabal-project-local-template.sh | 16 + hack/bin/cabal-run-all-tests.sh | 12 + hack/bin/cabal-run-tests.sh | 14 + hack/bin/nix-hls.sh | 6 +- libs/types-common-journal/package.yaml | 40 - .../types-common-journal.cabal | 11 +- libs/wire-message-proto-lens/package.yaml | 30 - .../wire-message-proto-lens.cabal | 6 +- stack.yaml | 5 +- stack.yaml.lock | 80 +- tools/convert-to-cabal/README.md | 85 + tools/convert-to-cabal/generate.sh | 11 + tools/convert-to-cabal/shell.nix | 28 + 22 files changed, 3114 insertions(+), 133 deletions(-) create mode 100644 cabal.project create mode 100644 cabal.project.freeze create mode 100644 changelog.d/5-internal/use-cabal create mode 100755 hack/bin/cabal-install-all-artefacts.sh create mode 100755 hack/bin/cabal-install-artefacts.sh create mode 100755 hack/bin/cabal-project-local-template.sh create mode 100755 hack/bin/cabal-run-all-tests.sh create mode 100755 hack/bin/cabal-run-tests.sh delete mode 100644 libs/types-common-journal/package.yaml delete mode 100644 libs/wire-message-proto-lens/package.yaml create mode 100644 tools/convert-to-cabal/README.md create mode 100755 tools/convert-to-cabal/generate.sh create mode 100644 tools/convert-to-cabal/shell.nix diff --git a/.envrc b/.envrc index 45436364165..1526ad22269 100644 --- a/.envrc +++ b/.envrc @@ -1,5 +1,5 @@ env=$(nix-build --no-out-link "$PWD/direnv.nix") -PATH_add "${env}/bin" +load_prefix "${env}" # allow local .envrc overrides [[ -f .envrc.local ]] && source_env .envrc.local diff --git a/.gitignore b/.gitignore index 8e9a7a3b4c7..d1c8a56e869 100644 --- a/.gitignore +++ b/.gitignore @@ -99,3 +99,7 @@ b.yaml telepresence.log /.ghci + +# local config +.envrc.local +cabal.project.local \ No newline at end of file diff --git a/Makefile b/Makefile index 0fc43d27ad4..bcedd573e34 100644 --- a/Makefile +++ b/Makefile @@ -39,12 +39,37 @@ init: # Build all Haskell services and executables, run unit tests .PHONY: install install: init +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + cabal build all + ./hack/bin/cabal-run-all-tests.sh + ./hack/bin/cabal-install-all-artefacts.sh +else stack install --pedantic --test --bench --no-run-benchmarks --local-bin-path=dist +endif # Build all Haskell services and executables with -O0, run unit tests .PHONY: fast fast: init +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + make install +else stack install --pedantic --test --bench --no-run-benchmarks --local-bin-path=dist --fast $(WIRE_STACK_OPTIONS) +endif + +# Usage: make c package=brig test=1 +.PHONY: c +c: + cabal build $(WIRE_CABAL_BUILD_OPTIONS) $(package) +ifeq ($(test), 1) + ./hack/bin/cabal-run-tests.sh $(package) +endif + ./hack/bin/cabal-install-artefacts.sh $(package) + +# ci here doesn't refer to continuous integration, but to cabal-integration +# Usage: make ci package=brig test=1 +.PHONY: ci +ci: c + make -C services/$(package) i-$(pattern) # Build everything (Haskell services and nginz) .PHONY: services @@ -232,14 +257,15 @@ libzauth: # # Run this again after changes to libraries or dependencies. .PHONY: hie.yaml -hie.yaml: stack-dev.yaml - stack build implicit-hie - stack exec gen-hie | yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml - -.PHONY: stack-dev.yaml -stack-dev.yaml: +hie.yaml: +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + echo -e 'cradle:\n cabal: {}' > hie.yaml +else cp stack.yaml stack-dev.yaml echo -e '\n\nghc-options:\n "$$locals": -O0 -Wall -Werror' >> stack-dev.yaml + stack build implicit-hie + stack exec gen-hie | yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml +endif ##################################### # Today we pretend to be CI and run integration tests on kubernetes diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000000..ef0d913ebad --- /dev/null +++ b/cabal.project @@ -0,0 +1,280 @@ +-- Generated by stackage-to-hackage + +with-compiler: ghc-8.8.4 + +packages: + libs/api-bot/ + , libs/api-client/ + , libs/bilge/ + , libs/brig-types/ + , libs/cargohold-types/ + , libs/cassandra-util/ + , libs/extended/ + , libs/dns-util/ + , libs/deriving-swagger2/ + , libs/galley-types/ + , libs/gundeck-types/ + , libs/hscim/ + , libs/imports/ + , libs/metrics-core/ + , libs/metrics-wai/ + , libs/polysemy-wire-zoo/ + , libs/ropes/ + , libs/schema-profunctor/ + , libs/sodium-crypto-sign/ + , libs/ssl-util/ + , libs/tasty-cannon/ + , libs/types-common/ + , libs/types-common-aws/ + , libs/types-common-journal/ + , libs/wai-utilities/ + , libs/wire-api/ + , libs/wire-api-federation/ + , libs/wire-message-proto-lens/ + , libs/zauth/ + , services/brig/ + , services/cannon/ + , services/cargohold/ + , services/federator/ + , services/galley/ + , services/gundeck/ + , services/proxy/ + , services/spar/ + , tools/api-simulations/ + , tools/bonanza/ + , tools/db/auto-whitelist/ + , tools/db/migrate-sso-feature-flag/ + , tools/db/service-backfill/ + , tools/db/billing-team-member-backfill/ + , tools/db/find-undead/ + , tools/db/move-team/ + , tools/db/repair-handles/ + , tools/makedeb/ + , tools/rex/ + , tools/stern/ + +source-repository-package + type: git + location: https://github.com/dpwright/HaskellNet-SSL + tag: ca84ef29a93eaef7673fa58056cdd8dae1568d2d + +source-repository-package + type: git + location: https://github.com/fimad/prometheus-haskell + tag: 2e3282e5fb27ba8d989c271a0a989823fad7ec43 + subdir: wai-middleware-prometheus + +source-repository-package + type: git + location: https://github.com/haskell-servant/servant-swagger + tag: bb0a84faa073fa9530f60337610d7da3d5b9393c + +source-repository-package + type: git + location: https://github.com/kim/hs-collectd + tag: 885da222be2375f78c7be36127620ed772b677c9 + +source-repository-package + type: git + location: https://github.com/kim/snappy-framing + tag: d99f702c0086729efd6848dea8a01e5266c3a61c + +source-repository-package + type: git + location: https://github.com/lucasdicioccio/http2-client + tag: 73f5975e18eda9d071aa5548fcea6b5a51e61769 + +source-repository-package + type: git + location: https://github.com/vincenthz/hs-certificate + tag: a899bda3d7666d25143be7be8f3105fc076703d9 + subdir: x509-store + +source-repository-package + type: git + location: https://github.com/wireapp/amazonka + tag: 412172d8c28906591f01576a78792de7c34cc3eb + subdir: amazonka + amazonka-cloudfront + amazonka-dynamodb + amazonka-s3 + amazonka-ses + amazonka-sns + amazonka-sqs + core + +source-repository-package + type: git + location: https://github.com/wireapp/bloodhound + tag: 92de9aa632d590f288a353d03591c38ba72b3cb3 + +source-repository-package + type: git + location: https://github.com/wireapp/cryptobox-haskell + tag: 7546a1a25635ef65183e3d44c1052285e8401608 + +source-repository-package + type: git + location: https://github.com/wireapp/haskell-multihash.git + tag: 300a6f46384bfca33e545c8bab52ef3717452d12 + +source-repository-package + type: git + location: https://github.com/wireapp/hsaml2 + tag: b652ec6e69d1647e827cbee0fa290605ac09dc63 + +source-repository-package + type: git + location: https://github.com/wireapp/hspec-wai + tag: 0a5142cd3ba48116ff059c041348b817fb7bdb25 + +source-repository-package + type: git + location: https://github.com/wireapp/http-client + tag: 9100baeddbd15d93dc58a826ae812dafff29d5fd + subdir: http-client + http-client-openssl + http-client-tls + http-conduit + +source-repository-package + type: git + location: https://github.com/wireapp/http2 + tag: 7c465be1201e0945b106f7cc6176ac1b1193be13 + +source-repository-package + type: git + location: https://github.com/wireapp/http2-grpc-haskell + tag: eea98418672626eafbace3181ca34bf44bee91c0 + subdir: http2-client-grpc + +source-repository-package + type: git + location: https://github.com/wireapp/saml2-web-sso + tag: 60398f375987b74d6b855b5d225e45dc3a96ac06 + +source-repository-package + type: git + location: https://github.com/wireapp/servant.git + tag: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + subdir: servant + servant-client + servant-client-core + servant-server + +source-repository-package + type: git + location: https://github.com/wireapp/snappy + tag: b0e5c08af48911caecffa4fa6a3e74872018b258 + +source-repository-package + type: git + location: https://gitlab.com/twittner/wai-routing + tag: 7e996a93fec5901767f845a50316b3c18e51a61d + +allow-older: * +allow-newer: * + +-- Changes by ./tools/convert-to-cabal/generate.sh + +tests: True + + +package api-bot + ghc-options: -Werror +package api-client + ghc-options: -Werror +package api-simulations + ghc-options: -Werror +package auto-whitelist + ghc-options: -Werror +package bilge + ghc-options: -Werror +package billing-team-member-backfill + ghc-options: -Werror +package bonanza + ghc-options: -Werror +package brig + ghc-options: -Werror +package brig-types + ghc-options: -Werror +package cannon + ghc-options: -Werror +package cargohold + ghc-options: -Werror +package cargohold-types + ghc-options: -Werror +package cassandra-util + ghc-options: -Werror +package deriving-swagger2 + ghc-options: -Werror +package dns-util + ghc-options: -Werror +package extended + ghc-options: -Werror +package federator + ghc-options: -Werror +package find-undead + ghc-options: -Werror +package galley + ghc-options: -Werror +package galley-types + ghc-options: -Werror +package gundeck + ghc-options: -Werror +package gundeck-types + ghc-options: -Werror +package hscim + ghc-options: -Werror +package imports + ghc-options: -Werror +package makedeb + ghc-options: -Werror +package metrics-core + ghc-options: -Werror +package metrics-wai + ghc-options: -Werror +package migrate-sso-feature-flag + ghc-options: -Werror +package move-team + ghc-options: -Werror +package polysemy-wire-zoo + ghc-options: -Werror +package proxy + ghc-options: -Werror +package repair-handles + ghc-options: -Werror +package rex + ghc-options: -Werror +package ropes + ghc-options: -Werror +package schema-profunctor + ghc-options: -Werror +package service-backfill + ghc-options: -Werror +package sodium-crypto-sign + ghc-options: -Werror +package spar + ghc-options: -Werror +package ssl-util + ghc-options: -Werror +package stern + ghc-options: -Werror +package tasty-cannon + ghc-options: -Werror +package types-common + ghc-options: -Werror +package types-common-aws + ghc-options: -Werror +package types-common-journal + ghc-options: -Werror +package wai-utilities + ghc-options: -Werror +package wire-api + ghc-options: -Werror +package wire-api-federation + ghc-options: -Werror +package wire-message-proto-lens + ghc-options: -Werror +package zauth + ghc-options: -Werror diff --git a/cabal.project.freeze b/cabal.project.freeze new file mode 100644 index 00000000000..71ff635e0b6 --- /dev/null +++ b/cabal.project.freeze @@ -0,0 +1,2528 @@ +constraints: any.AC-Angle ==1.0, + any.ALUT ==2.4.0.3, + any.ANum ==0.2.0.2, + any.Allure ==0.9.5.0, + any.Boolean ==0.2.4, + any.BoundedChan ==1.0.3.0, + any.ChannelT ==0.0.0.7, + any.Chart ==1.9.3, + any.Chart-diagrams ==1.9.3, + any.ChasingBottoms ==1.3.1.9, + any.Clipboard ==2.3.2.0, + any.ClustalParser ==1.3.0, + any.Color ==0.1.4, + any.ConfigFile ==1.1.4, + any.DAV ==1.3.4, + any.DBFunctor ==0.1.1.1, + any.Decimal ==0.5.1, + any.Diff ==0.4.0, + any.ENIG ==0.0.1.0, + any.Earley ==0.13.0.1, + any.Ebnf2ps ==1.0.15, + any.FenwickTree ==0.1.2.1, + any.FindBin ==0.0.5, + any.FloatingHex ==0.4, + any.FontyFruity ==0.5.3.5, + any.ForestStructures ==0.0.1.0, + any.GLFW-b ==3.3.0.0, + any.GLURaw ==2.0.0.4, + any.GLUT ==2.7.0.15, + any.GenericPretty ==1.2.2, + any.Glob ==0.10.1, + any.HCodecs ==0.5.2, + any.HDBC ==2.4.0.3, + any.HDBC-session ==0.1.2.0, + any.HSlippyMap ==3.0.1, + any.HStringTemplate ==0.8.7, + any.HSvm ==0.1.1.3.22, + any.HTF ==0.14.0.3, + any.HTTP ==4000.3.15, + any.HUnit ==1.6.0.0, + any.HUnit-approx ==1.1.1.1, + any.HaTeX ==3.22.2.0, + any.HaXml ==1.25.5, + any.HandsomeSoup ==0.4.2, + any.HasBigDecimal ==0.1.1, + any.HaskellNet ==0.5.2, + HsOpenSSL -fast-bignum, + any.HsOpenSSL ==0.11.4.19, + any.HsOpenSSL-x509-system ==0.1.0.3, + any.HsYAML ==0.2.1.0, + any.HsYAML-aeson ==0.2.0.0, + any.IPv6Addr ==1.1.5, + any.Imlib ==0.1.2, + any.IntervalMap ==0.6.1.2, + any.JuicyPixels ==3.3.5, + any.JuicyPixels-blurhash ==0.1.0.3, + any.JuicyPixels-extra ==0.4.1, + any.JuicyPixels-scale-dct ==0.1.2, + any.LambdaHack ==0.9.5.0, + any.LibZip ==1.0.1, + any.List ==0.6.2, + any.ListLike ==4.7.2, + any.ListTree ==0.2.3, + any.MemoTrie ==0.6.10, + any.MissingH ==1.4.3.0, + any.MonadPrompt ==1.0.0.5, + any.MonadRandom ==0.5.2, + any.MusicBrainz ==0.4.1, + NineP -bytestring-in-base, + any.NineP ==0.0.2.1, + any.NumInstances ==1.4, + any.ObjectName ==1.1.0.1, + any.OneTuple ==0.2.2.1, + any.Only ==0.1, + any.OpenAL ==1.7.0.5, + any.OpenGL ==3.0.3.0, + any.OpenGLRaw ==3.3.4.0, + any.ParsecTools ==0.0.2.0, + any.PyF ==0.9.0.2, + any.QuasiText ==0.1.2.6, + any.QuickCheck ==2.14, + any.RSA ==2.4.1, + any.Ranged-sets ==0.4.0, + any.Rasterific ==0.7.5.2, + any.RefSerialize ==0.4.0, + any.SHA ==1.6.4.4, + any.SVGFonts ==1.7.0.1, + any.SafeSemaphore ==0.10.1, + any.ShellCheck ==0.7.1, + any.Spintax ==0.3.5, + any.StateVar ==1.2, + any.TCache ==0.12.1, + any.Taxonomy ==2.1.0, + any.TypeCompose ==0.9.14, + any.ViennaRNAParser ==1.3.3, + any.Win32 ==2.6.1.0, + any.Win32-notify ==0.3.0.3, + any.X11 ==1.9.2, + any.X11-xft ==0.3.1, + any.Xauth ==0.1, + any.abstract-deque ==0.3, + any.abstract-par ==0.3.3, + any.accuerr ==0.2.0.2, + any.ace ==0.6, + any.action-permutations ==0.0.0.1, + any.active ==0.2.0.14, + any.ad ==4.4, + any.adjunctions ==4.4, + any.adler32 ==0.1.2.0, + any.advent-of-code-api ==0.2.7.0, + any.aeson ==1.4.7.1, + any.aeson-attoparsec ==0.0.0, + any.aeson-better-errors ==0.9.1.0, + any.aeson-casing ==0.2.0.0, + any.aeson-combinators ==0.0.2.1, + any.aeson-compat ==0.3.9, + any.aeson-default ==0.9.1.0, + any.aeson-diff ==1.1.0.9, + any.aeson-generic-compat ==0.0.1.3, + any.aeson-lens ==0.5.0.0, + any.aeson-optics ==1.1.0.1, + any.aeson-picker ==0.1.0.5, + any.aeson-pretty ==0.8.8, + any.aeson-qq ==0.8.3, + any.aeson-schemas ==1.2.0, + any.aeson-utils ==0.3.0.2, + any.aeson-yak ==0.1.1.3, + any.aeson-yaml ==1.0.6.0, + any.al ==0.1.4.2, + any.alarmclock ==0.7.0.5, + any.alerts ==0.1.2.0, + any.alex ==3.2.5, + any.alg ==0.2.13.1, + any.algebraic-graphs ==0.5, + any.almost-fix ==0.0.2, + any.alsa-core ==0.5.0.1, + any.alsa-mixer ==0.3.0, + any.alsa-pcm ==0.6.1.1, + any.alsa-seq ==0.6.0.7, + any.alternative-vector ==0.0.0, + any.amazonka-apigateway ==1.6.1, + any.amazonka-application-autoscaling ==1.6.1, + any.amazonka-appstream ==1.6.1, + any.amazonka-athena ==1.6.1, + any.amazonka-autoscaling ==1.6.1, + any.amazonka-budgets ==1.6.1, + any.amazonka-certificatemanager ==1.6.1, + any.amazonka-cloudformation ==1.6.1, + any.amazonka-cloudhsm ==1.6.1, + any.amazonka-cloudsearch ==1.6.1, + any.amazonka-cloudsearch-domains ==1.6.1, + any.amazonka-cloudtrail ==1.6.1, + any.amazonka-cloudwatch ==1.6.1, + any.amazonka-cloudwatch-events ==1.6.1, + any.amazonka-cloudwatch-logs ==1.6.1, + any.amazonka-codebuild ==1.6.1, + any.amazonka-codecommit ==1.6.1, + any.amazonka-codedeploy ==1.6.1, + any.amazonka-codepipeline ==1.6.1, + any.amazonka-cognito-identity ==1.6.1, + any.amazonka-cognito-idp ==1.6.1, + any.amazonka-cognito-sync ==1.6.1, + any.amazonka-config ==1.6.1, + any.amazonka-datapipeline ==1.6.1, + any.amazonka-devicefarm ==1.6.1, + any.amazonka-directconnect ==1.6.1, + any.amazonka-discovery ==1.6.1, + any.amazonka-dms ==1.6.1, + any.amazonka-ds ==1.6.1, + any.amazonka-dynamodb-streams ==1.6.1, + any.amazonka-ecr ==1.6.1, + any.amazonka-ecs ==1.6.1, + any.amazonka-efs ==1.6.1, + any.amazonka-elasticache ==1.6.1, + any.amazonka-elasticbeanstalk ==1.6.1, + any.amazonka-elasticsearch ==1.6.1, + any.amazonka-elastictranscoder ==1.6.1, + any.amazonka-elb ==1.6.1, + any.amazonka-elbv2 ==1.6.1, + any.amazonka-emr ==1.6.1, + any.amazonka-gamelift ==1.6.1, + any.amazonka-glacier ==1.6.1, + any.amazonka-glue ==1.6.1, + any.amazonka-health ==1.6.1, + any.amazonka-iam ==1.6.1, + any.amazonka-importexport ==1.6.1, + any.amazonka-inspector ==1.6.1, + any.amazonka-iot ==1.6.1, + any.amazonka-iot-dataplane ==1.6.1, + any.amazonka-kinesis ==1.6.1, + any.amazonka-kinesis-analytics ==1.6.1, + any.amazonka-kinesis-firehose ==1.6.1, + any.amazonka-kms ==1.6.1, + any.amazonka-lambda ==1.6.1, + any.amazonka-lightsail ==1.6.1, + any.amazonka-marketplace-analytics ==1.6.1, + any.amazonka-marketplace-metering ==1.6.1, + any.amazonka-ml ==1.6.1, + any.amazonka-opsworks ==1.6.1, + any.amazonka-opsworks-cm ==1.6.1, + any.amazonka-pinpoint ==1.6.1, + any.amazonka-polly ==1.6.1, + any.amazonka-rds ==1.6.1, + any.amazonka-redshift ==1.6.1, + any.amazonka-rekognition ==1.6.1, + any.amazonka-route53 ==1.6.1, + any.amazonka-route53-domains ==1.6.1, + any.amazonka-sdb ==1.6.1, + any.amazonka-servicecatalog ==1.6.1, + any.amazonka-shield ==1.6.1, + any.amazonka-sms ==1.6.1, + any.amazonka-snowball ==1.6.1, + any.amazonka-ssm ==1.6.1, + any.amazonka-stepfunctions ==1.6.1, + any.amazonka-storagegateway ==1.6.1, + any.amazonka-sts ==1.6.1, + any.amazonka-support ==1.6.1, + any.amazonka-swf ==1.6.1, + any.amazonka-test ==1.6.1, + any.amazonka-waf ==1.6.1, + any.amazonka-workspaces ==1.6.1, + any.amazonka-xray ==1.6.1, + any.amqp ==0.20.0, + any.amqp-utils ==0.4.4.1, + any.annotated-wl-pprint ==0.7.0, + any.ansi-terminal ==0.10.3, + any.ansi-wl-pprint ==0.6.9, + any.antiope-core ==7.5.1, + any.antiope-dynamodb ==7.5.1, + any.antiope-messages ==7.5.1, + any.antiope-s3 ==7.5.1, + any.antiope-sns ==7.5.1, + any.antiope-sqs ==7.5.1, + any.apecs ==0.9.2, + any.apecs-gloss ==0.2.4, + any.apecs-physics ==0.4.4, + any.api-field-json-th ==0.1.0.2, + any.app-settings ==0.2.0.12, + any.appar ==0.1.8, + any.appendmap ==0.1.5, + any.apportionment ==0.0.0.3, + any.approximate ==0.3.2, + any.arbor-lru-cache ==0.1.1.1, + any.arithmoi ==0.10.0.0, + any.array-memoize ==0.6.0, + any.arrow-extras ==0.1.0.1, + any.ascii ==1.0.0.2, + any.ascii-case ==1.0.0.2, + any.ascii-char ==1.0.0.2, + any.ascii-group ==1.0.0.2, + any.ascii-predicates ==1.0.0.2, + any.ascii-progress ==0.3.3.0, + any.ascii-superset ==1.0.0.2, + any.ascii-th ==1.0.0.2, + any.asciidiagram ==1.3.3.3, + any.asn1-encoding ==0.9.6, + any.asn1-parse ==0.9.5, + any.asn1-types ==0.3.4, + any.assert-failure ==0.1.2.5, + any.assoc ==1.0.2, + any.astro ==0.4.2.1, + any.async ==2.2.2, + any.async-extra ==0.2.0.0, + any.async-refresh ==0.3.0.0, + any.async-refresh-tokens ==0.4.0.0, + any.async-timer ==0.2.0.0, + any.atom-basic ==0.2.5, + any.atomic-primops ==0.8.3, + any.atomic-write ==0.2.0.7, + any.attoparsec ==0.13.2.4, + any.attoparsec-base64 ==0.0.0, + any.attoparsec-binary ==0.2, + any.attoparsec-expr ==0.1.1.2, + any.attoparsec-iso8601 ==1.0.1.0, + any.attoparsec-path ==0.0.0.1, + any.audacity ==0.0.2, + any.aur ==7.0.4, + any.aura ==3.1.9, + any.authenticate ==1.3.5, + any.authenticate-oauth ==1.6.0.1, + any.auto ==0.4.3.1, + any.auto-update ==0.1.6, + any.autoexporter ==1.1.18, + any.avers ==0.0.17.1, + any.avro ==0.5.2.0, + any.aws-cloudfront-signed-cookies ==0.2.0.6, + any.bank-holidays-england ==0.2.0.5, + any.base-compat ==0.11.1, + any.base-compat-batteries ==0.11.1, + any.base-noprelude ==4.13.0.0, + any.base-orphans ==0.8.2, + any.base-prelude ==1.3, + any.base-unicode-symbols ==0.2.4.2, + any.base16 ==0.2.1.0, + any.base16-bytestring ==0.1.1.7, + any.base16-lens ==0.1.2.0, + any.base32 ==0.1.1.2, + any.base32-lens ==0.1.0.0, + any.base32string ==0.9.1, + any.base58-bytestring ==0.1.0, + any.base58string ==0.10.0, + any.base64 ==0.4.2.2, + any.base64-bytestring ==1.0.0.3, + any.base64-bytestring-type ==1.0.1, + any.base64-lens ==0.3.0, + any.base64-string ==0.2, + any.basement ==0.0.11, + any.basic-prelude ==0.7.0, + any.bazel-runfiles ==0.12, + any.bbdb ==0.8, + any.bcrypt ==0.0.11, + any.bech32 ==1.0.2, + any.bech32-th ==1.0.2, + any.bench ==1.0.12, + any.benchpress ==0.2.2.14, + any.between ==0.11.0.0, + any.bibtex ==0.1.0.6, + any.bifunctors ==5.5.7, + any.bimap ==0.4.0, + any.bimap-server ==0.1.0.1, + any.bimaps ==0.1.0.2, + any.bin ==0.1, + any.binary-conduit ==1.3.1, + any.binary-ext ==2.0.4, + any.binary-ieee754 ==0.1.0.0, + any.binary-list ==1.1.1.2, + any.binary-orphans ==1.0.1, + any.binary-parser ==0.5.6, + any.binary-parsers ==0.2.4.0, + any.binary-search ==1.0.0.3, + any.binary-shared ==0.8.3, + any.binary-tagged ==0.3, + any.bindings-DSL ==1.0.25, + any.bindings-GLFW ==3.3.2.0, + any.bindings-libzip ==1.0.1, + any.bindings-uname ==0.1, + any.bins ==0.1.2.0, + any.bitarray ==0.0.1.1, + any.bits ==0.5.2, + any.bits-extra ==0.0.2.0, + any.bitset-word8 ==0.1.1.2, + any.bitvec ==1.0.3.0, + any.blake2 ==0.3.0, + any.blanks ==0.3.0, + any.blas-carray ==0.1.0.1, + any.blas-comfort-array ==0.0.0.2, + any.blas-ffi ==0.1, + any.blaze-bootstrap ==0.1.0.1, + any.blaze-builder ==0.4.1.0, + any.blaze-html ==0.9.1.2, + any.blaze-markup ==0.8.2.7, + any.blaze-svg ==0.3.6.1, + any.blaze-textual ==0.2.1.0, + any.bmp ==1.2.6.3, + any.boltzmann-samplers ==0.1.1.0, + any.boolean-like ==0.1.1.0, + any.boolean-normal-forms ==0.0.1.1, + any.boolsimplifier ==0.1.8, + any.boots ==0.2.0.1, + any.bordacount ==0.1.0.0, + any.boring ==0.1.3, + any.both ==0.1.1.1, + any.bound ==2.0.1, + any.bounded-queue ==1.0.0, + any.boundingboxes ==0.2.3, + any.bower-json ==1.0.0.1, + any.boxes ==0.1.5, + brick +demos, + any.brick ==0.52.1, + any.brittany ==0.12.1.1, + any.broadcast-chan ==0.2.1.1, + any.bsb-http-chunked ==0.0.0.4, + bson -_old-network, + any.bson ==0.4.0.1, + any.btrfs ==0.2.0.0, + any.buffer-builder ==0.2.4.7, + any.buffer-pipe ==0.0, + any.bugsnag-hs ==0.1.0.3, + any.butcher ==1.3.3.2, + any.bv ==0.5, + any.bv-little ==1.1.1, + any.byte-count-reader ==0.10.1.1, + any.byte-order ==0.1.2.0, + any.byteable ==0.1.1, + any.bytedump ==1.0, + any.byteorder ==1.0.4, + any.bytes ==0.17, + any.byteset ==0.1.1.0, + any.bytestring-builder ==0.10.8.2.0, + any.bytestring-conversion ==0.3.1, + any.bytestring-lexing ==0.5.0.2, + any.bytestring-mmap ==0.2.2, + any.bytestring-strict-builder ==0.4.5.3, + any.bytestring-to-vector ==0.3.0.1, + any.bytestring-tree-builder ==0.2.7.3, + any.bz2 ==1.0.0.1, + any.bzlib-conduit ==0.3.0.2, + any.c2hs ==0.28.6, + any.ca-province-codes ==1.0.0.0, + any.cabal-appimage ==0.3.0.0, + any.cabal-debian ==5.0.3, + any.cabal-doctest ==1.0.8, + cabal-rpm -old-locale, + any.cabal-rpm ==2.0.6, + any.cabal2nix ==2.15.1, + any.cabal2spec ==2.5, + any.cache ==0.1.3.0, + any.cacophony ==0.10.1, + any.calendar-recycling ==0.0.0.1, + any.call-stack ==0.2.0, + any.can-i-haz ==0.3.1.0, + any.cardano-coin-selection ==1.0.1, + any.carray ==0.1.6.8, + any.casa-client ==0.0.1, + any.casa-types ==0.0.1, + any.case-insensitive ==1.2.1.0, + any.cased ==0.1.0.0, + any.cases ==0.1.4, + any.casing ==0.1.4.1, + cassava -bytestring--lt-0_10_4, + any.cassava ==0.5.2.0, + any.cassava-conduit ==0.5.1, + any.cassava-megaparsec ==2.0.2, + any.cast ==0.1.0.2, + any.category ==0.2.5.0, + any.cayley-client ==0.4.13, + any.cborg ==0.2.4.0, + any.cborg-json ==0.2.2.0, + any.cereal ==0.5.8.1, + any.cereal-conduit ==0.8.0, + any.cereal-text ==0.1.0.2, + any.cereal-vector ==0.2.0.1, + any.cfenv ==0.1.0.0, + any.chan ==0.0.4.1, + any.character-cases ==0.1.0.4, + any.charset ==0.3.7.1, + any.charsetdetect-ae ==1.1.0.4, + any.chaselev-deque ==0.5.0.5, + any.cheapskate ==0.1.1.2, + any.cheapskate-highlight ==0.1.0.0, + any.cheapskate-lucid ==0.1.0.0, + any.checkers ==0.5.6, + any.checksum ==0.0, + any.chimera ==0.3.1.0, + any.chiphunk ==0.1.2.1, + any.choice ==0.2.2, + any.chronologique ==0.3.1.3, + any.chronos ==1.1.1, + any.chronos-bench ==0.2.0.2, + any.chunked-data ==0.3.1, + any.cipher-aes ==0.2.11, + any.cipher-camellia ==0.0.2, + any.cipher-des ==0.0.6, + any.cipher-rc4 ==0.1.4, + any.circle-packing ==0.1.0.6, + any.clash-ghc ==1.2.4, + any.clash-lib ==1.2.4, + any.clash-prelude ==1.2.4, + any.classy-prelude ==1.5.0, + any.classy-prelude-conduit ==1.5.0, + any.classy-prelude-yesod ==1.5.0, + any.clay ==0.13.3, + any.clientsession ==0.9.1.2, + any.climb ==0.3.3, + any.clock ==0.8, + any.clock-extras ==0.1.0.2, + any.clumpiness ==0.17.0.2, + any.cmark ==0.6, + any.cmark-gfm ==0.2.1, + any.cmark-lucid ==0.1.0.0, + any.cmdargs ==0.10.20, + any.co-log ==0.4.0.1, + any.co-log-concurrent ==0.5.0.0, + any.co-log-core ==0.2.1.1, + any.co-log-polysemy ==0.0.1.2, + any.code-page ==0.2, + any.codec-beam ==0.2.0, + any.codec-rpm ==0.2.2, + any.coercible-utils ==0.1.0, + any.colorful-monoids ==0.2.1.3, + any.colorize-haskell ==1.0.1, + any.colour ==2.3.5, + any.colourista ==0.1.0.0, + any.combinatorial ==0.1.0.1, + any.comfort-array ==0.4, + any.comfort-graph ==0.0.3.1, + any.commutative ==0.0.2, + any.comonad ==5.0.6, + any.compactmap ==0.1.4.2.1, + any.compendium-client ==0.2.1.1, + any.compensated ==0.8.1, + any.compiler-warnings ==0.1.0, + any.composable-associations ==0.1.0.0, + any.composable-associations-aeson ==0.1.0.0, + any.composition ==1.0.2.1, + any.composition-extra ==2.0.0, + any.concise ==0.1.0.1, + any.concurrency ==1.11.0.0, + any.concurrent-extra ==0.7.0.12, + any.concurrent-output ==1.10.12, + any.concurrent-split ==0.0.1.1, + any.concurrent-supply ==0.1.8, + any.cond ==0.4.1.1, + any.conduit ==1.3.2.1, + any.conduit-algorithms ==0.0.11.0, + any.conduit-combinators ==1.3.0, + any.conduit-concurrent-map ==0.1.1, + any.conduit-extra ==1.3.5, + any.conduit-parse ==0.2.1.0, + any.conduit-zstd ==0.0.2.0, + any.conferer ==0.4.1.1, + any.conferer-hspec ==0.4.0.1, + any.conferer-source-json ==0.4.0.1, + any.conferer-warp ==0.4.0.1, + any.config-ini ==0.2.4.0, + any.configurator ==0.3.0.0, + any.configurator-export ==0.1.0.1, + any.configurator-pg ==0.2.4, + any.connection ==0.3.1, + any.connection-pool ==0.2.2, + any.console-style ==0.0.2.1, + any.constraint ==0.1.4.0, + any.constraint-tuples ==0.1.2, + any.constraints ==0.12, + any.contravariant ==1.5.2, + any.contravariant-extras ==0.3.5.2, + any.control-bool ==0.2.1, + any.control-monad-free ==0.6.2, + any.control-monad-omega ==0.3.2, + any.convertible ==1.1.1.0, + any.cookie ==0.4.5, + any.core-data ==0.2.1.8, + any.core-program ==0.2.4.5, + any.core-text ==0.2.3.6, + any.countable ==1.0, + any.cpio-conduit ==0.7.0, + any.cpphs ==1.20.9.1, + any.cprng-aes ==0.6.1, + any.cpu ==0.1.2, + any.cpuinfo ==0.1.0.1, + any.cql ==4.0.2, + any.cql-io ==1.1.1, + any.cql-io-tinylog ==0.1.0, + any.crackNum ==2.3, + any.crc32c ==0.0.0, + any.credential-store ==0.1.2, + any.criterion ==1.5.6.2, + any.criterion-measurement ==0.1.2.0, + any.cron ==0.7.0, + any.crypt-sha512 ==0, + any.crypto-api ==0.13.3, + any.crypto-cipher-types ==0.0.9, + any.crypto-enigma ==0.1.1.6, + any.crypto-numbers ==0.2.7, + any.crypto-pubkey ==0.2.8, + any.crypto-pubkey-types ==0.4.3, + any.crypto-random ==0.0.9, + any.crypto-random-api ==0.2.0, + any.cryptocompare ==0.1.1, + any.cryptohash ==0.11.9, + any.cryptohash-cryptoapi ==0.1.4, + any.cryptohash-md5 ==0.11.100.1, + any.cryptohash-sha1 ==0.11.100.1, + any.cryptohash-sha256 ==0.11.101.0, + any.cryptohash-sha512 ==0.11.100.1, + any.cryptonite ==0.28, + any.cryptonite-conduit ==0.2.2, + any.cryptonite-openssl ==0.7, + any.csp ==1.4.0, + any.css-syntax ==0.1.0.0, + any.css-text ==0.1.3.0, + any.csv ==0.1.2, + any.csv-conduit ==0.7.1.0, + any.ctrie ==0.2, + any.cubicbezier ==0.6.0.6, + any.cubicspline ==0.1.2, + any.cuckoo-filter ==0.2.0.2, + any.cue-sheet ==2.0.1, + curl +new-base, + any.curl ==1.3.8, + any.currencies ==0.2.0.0, + any.currency ==0.2.0.0, + any.currency-codes ==3.0.0.1, + any.cursor ==0.3.0.0, + any.cursor-brick ==0.1.0.0, + any.cursor-fuzzy-time ==0.0.0.0, + any.cursor-gen ==0.3.0.0, + any.cutter ==0.0, + any.cyclotomic ==1.1.1, + any.czipwith ==1.0.1.3, + any.d10 ==0.2.1.6, + any.data-accessor ==0.2.3, + any.data-accessor-mtl ==0.2.0.4, + any.data-accessor-transformers ==0.2.1.7, + any.data-ascii ==1.0.0.2, + any.data-binary-ieee754 ==0.4.4, + any.data-bword ==0.1.0.1, + any.data-checked ==0.3, + any.data-clist ==0.1.2.3, + any.data-compat ==0.1.0.2, + any.data-default ==0.7.1.1, + any.data-default-class ==0.1.2.0, + any.data-default-instances-containers ==0.0.1, + any.data-default-instances-dlist ==0.0.1, + any.data-default-instances-old-locale ==0.0.1, + any.data-diverse ==4.7.0.0, + any.data-dword ==0.3.2, + any.data-endian ==0.1.1, + any.data-fix ==0.2.1, + any.data-forest ==0.1.0.8, + any.data-has ==0.3.0.0, + any.data-interval ==2.0.1, + any.data-inttrie ==0.1.4, + any.data-lens-light ==0.1.2.2, + any.data-memocombinators ==0.5.1, + any.data-msgpack ==0.0.13, + any.data-msgpack-types ==0.0.3, + any.data-or ==1.0.0.5, + any.data-ordlist ==0.4.7.0, + any.data-ref ==0.0.2, + any.data-reify ==0.6.1, + any.data-serializer ==0.3.4.1, + any.data-textual ==0.3.0.3, + any.data-timeout ==0.3.1, + any.data-tree-print ==0.1.0.2, + any.datadog ==0.2.5.0, + any.dataurl ==0.1.0.0, + any.dbus ==1.2.16, + any.dbus-hslogger ==0.1.0.1, + any.debian ==4.0.2, + any.debian-build ==0.10.2.0, + any.debug-trace-var ==0.2.0, + any.dec ==0.0.3, + any.declarative ==0.5.3, + any.deepseq-generics ==0.2.0.0, + any.deepseq-instances ==0.1.0.1, + any.deferred-folds ==0.9.10.1, + any.dejafu ==2.3.0.1, + any.dense-linear-algebra ==0.1.0.0, + any.depq ==0.4.1.0, + any.deque ==0.4.3, + any.deriveJsonNoPrefix ==0.1.0.1, + any.deriving-aeson ==0.2.5, + any.deriving-compat ==0.5.9, + any.derulo ==1.0.9, + any.detour-via-sci ==1.0.0, + any.dhall ==1.32.0, + any.dhall-bash ==1.0.30, + any.dhall-json ==1.6.4, + any.dhall-lsp-server ==1.0.8, + any.dhall-yaml ==1.1.0, + any.di-core ==1.0.4, + any.di-monad ==1.3.1, + any.diagrams ==1.4, + any.diagrams-contrib ==1.4.4, + any.diagrams-core ==1.4.2, + any.diagrams-lib ==1.4.3, + any.diagrams-postscript ==1.5, + any.diagrams-rasterific ==1.4.2, + any.diagrams-solve ==0.1.2, + any.diagrams-svg ==1.4.3, + any.dialogflow-fulfillment ==0.1.1.3, + any.dictionary-sharing ==0.1.0.0, + any.digest ==0.0.1.2, + any.digits ==0.3.1, + any.dimensional ==1.3, + any.directory-tree ==0.12.1, + any.discount ==0.1.1, + any.disk-free-space ==0.1.0.1, + any.distributed-closure ==0.4.2.0, + any.distribution-nixpkgs ==1.3.1, + any.distribution-opensuse ==1.1.1, + any.distributive ==0.6.2, + any.dl-fedora ==0.7.5, + any.dlist ==0.8.0.8, + any.dlist-instances ==0.1.1.1, + any.dlist-nonempty ==0.1.1, + any.dns ==4.0.1, + any.do-list ==1.0.1, + any.do-notation ==0.1.0.2, + any.dockerfile ==0.2.0, + any.doclayout ==0.3, + any.doctemplates ==0.8.2, + any.doctest ==0.16.3, + any.doctest-discover ==0.2.0.0, + any.doctest-driver-gen ==0.3.0.2, + any.doldol ==0.4.1.2, + any.dotenv ==0.8.0.7, + any.dotgen ==0.4.3, + any.dotnet-timespan ==0.0.1.0, + any.double-conversion ==2.0.2.0, + any.download ==0.3.2.7, + any.drinkery ==0.4, + any.dsp ==0.2.5.1, + any.dual ==0.1.1.1, + any.dual-tree ==0.2.2.1, + any.dublincore-xml-conduit ==0.1.0.2, + any.dunai ==0.7.0, + any.duration ==0.1.0.0, + any.dvorak ==0.1.0.0, + any.dynamic-state ==0.3.1, + any.dyre ==0.8.12, + any.eap ==0.9.0.2, + any.earcut ==0.1.0.4, + any.easy-file ==0.2.2, + any.echo ==0.1.3, + any.ecstasy ==0.2.1.0, + any.ed25519 ==0.0.5.0, + any.edit-distance ==0.2.2.1, + any.edit-distance-vector ==1.0.0.4, + any.editor-open ==0.6.0.0, + any.egison ==4.0.3, + any.egison-pattern-src ==0.2.1.0, + any.egison-pattern-src-th-mode ==0.2.1.1, + any.either ==5.0.1.1, + any.either-both ==0.1.1.1, + any.either-unwrap ==1.1, + any.ekg ==0.4.0.15, + any.ekg-core ==0.1.1.7, + any.ekg-json ==0.1.0.6, + any.ekg-statsd ==0.2.5.0, + any.elerea ==2.9.0, + any.elf ==0.30, + any.eliminators ==0.6, + any.elm-bridge ==0.6.1, + any.elm-core-sources ==1.0.0, + any.elm-export ==0.6.0.1, + any.elm2nix ==0.2, + any.emacs-module ==0.1.1, + any.email-validate ==2.3.2.13, + any.emojis ==0.1, + any.enclosed-exceptions ==1.0.3, + any.entropy ==0.4.1.6, + any.enum-subset-generate ==0.1.0.0, + any.enummapset ==0.6.0.3, + any.enumset ==0.0.5, + any.envelope ==0.2.2.0, + any.envy ==2.1.0.0, + any.epub-metadata ==4.5, + any.eq ==4.2, + any.equal-files ==0.0.5.3, + any.equational-reasoning ==0.6.0.3, + any.erf ==2.0.0.0, + any.errors ==2.3.0, + any.errors-ext ==0.4.2, + any.ersatz ==0.4.8, + any.esqueleto ==3.3.3.3, + any.essence-of-live-coding ==0.1.0.3, + any.essence-of-live-coding-gloss ==0.1.0.3, + any.essence-of-live-coding-pulse ==0.1.0.3, + any.essence-of-live-coding-quickcheck ==0.1.0.3, + any.etc ==0.4.1.0, + any.event-list ==0.1.2, + any.eventful-core ==0.2.0, + any.eventful-test-helpers ==0.2.0, + any.eventstore ==1.4.1, + any.every ==0.0.1, + any.exact-combinatorics ==0.2.0.9, + any.exact-pi ==0.5.0.1, + any.exception-hierarchy ==0.1.0.3, + any.exception-mtl ==0.4.0.1, + any.exception-transformers ==0.4.0.9, + any.exceptions ==0.10.4, + any.executable-path ==0.0.3.1, + any.exit-codes ==1.0.0, + any.exomizer ==1.0.0, + any.exp-pairs ==0.2.0.0, + any.expiring-cache-map ==0.0.6.1, + any.explicit-exception ==0.1.10, + any.express ==0.1.3, + any.extended-reals ==0.2.4.0, + any.extensible-effects ==5.0.0.1, + any.extensible-exceptions ==0.1.1.4, + any.extra ==1.7.8, + any.extractable-singleton ==0.0.1, + any.extrapolate ==0.4.2, + any.fail ==4.9.0.0, + any.failable ==1.2.4.0, + any.fakedata ==0.6.1, + any.farmhash ==0.1.0.5, + any.fast-digits ==0.3.0.0, + any.fast-logger ==3.0.1, + any.fast-math ==1.0.2, + any.fb ==2.1.1, + any.feature-flags ==0.1.0.1, + any.fedora-dists ==1.1.2, + any.fedora-haskell-tools ==0.9, + any.feed ==1.3.0.1, + any.fft ==0.1.8.6, + any.fgl ==5.7.0.3, + any.file-embed ==0.0.11.2, + any.file-embed-lzma ==0, + any.file-modules ==0.1.2.4, + any.file-path-th ==0.1.0.0, + any.filecache ==0.4.1, + any.filelock ==0.1.1.5, + any.filemanip ==0.3.6.3, + any.filepattern ==0.1.2, + any.fileplow ==0.1.0.0, + any.filtrable ==0.1.4.0, + any.fin ==0.1.1, + any.fingertree ==0.1.4.2, + any.finite-typelits ==0.1.4.2, + any.first-class-families ==0.8.0.0, + any.first-class-patterns ==0.3.2.5, + any.fitspec ==0.4.8, + any.fixed ==0.3, + any.fixed-length ==0.2.2, + any.fixed-vector ==1.2.0.0, + any.fixed-vector-hetero ==0.6.0.0, + any.flac ==0.2.0, + any.flac-picture ==0.1.2, + any.flags-applicative ==0.1.0.2, + any.flat ==0.4.4, + any.flat-mcmc ==1.5.1, + any.floatshow ==0.2.4, + any.flow ==1.0.21, + any.flush-queue ==1.0.0, + any.fmlist ==0.9.4, + any.fmt ==0.6.1.2, + any.fn ==0.3.0.2, + any.focus ==1.0.1.3, + any.focuslist ==0.1.0.2, + any.fold-debounce ==0.2.0.9, + any.fold-debounce-conduit ==0.2.0.5, + any.foldable1 ==0.1.0.0, + any.foldl ==1.4.6, + any.folds ==0.7.5, + any.follow-file ==0.0.3, + any.force-layout ==0.4.0.6, + any.foreign-store ==0.2, + any.forkable-monad ==0.2.0.3, + any.forma ==1.1.3, + any.format-numbers ==0.1.0.1, + any.formatting ==6.3.7, + any.foundation ==0.0.25, + any.free ==5.1.3, + any.free-categories ==0.2.0.0, + any.free-vl ==0.1.4, + any.freenect ==1.2.1, + any.freer-simple ==1.2.1.1, + any.freetype2 ==0.2.0, + any.friendly-time ==0.4.1, + any.from-sum ==0.2.3.0, + any.frontmatter ==0.1.0.2, + any.fsnotify ==0.3.0.1, + any.fsnotify-conduit ==0.1.1.1, + any.ftp-client ==0.5.1.4, + any.ftp-client-conduit ==0.5.0.5, + any.funcmp ==1.9, + any.function-builder ==0.3.0.1, + functor-classes-compat +containers, + any.functor-classes-compat ==1, + any.fused-effects ==1.0.2.2, + any.fusion-plugin ==0.2.1, + any.fusion-plugin-types ==0.1.0, + any.fuzzcheck ==0.1.1, + any.fuzzy ==0.1.0.0, + any.fuzzy-dates ==0.1.1.2, + any.fuzzy-time ==0.1.0.0, + any.fuzzyset ==0.2.0, + any.gauge ==0.2.5, + any.gd ==3000.7.3, + any.gdp ==0.0.3.0, + any.general-games ==1.1.1, + any.generic-arbitrary ==0.1.0, + any.generic-constraints ==1.1.1.1, + any.generic-data ==0.8.3.0, + any.generic-deriving ==1.13.1, + any.generic-lens ==2.0.0.0, + any.generic-lens-core ==2.0.0.0, + any.generic-monoid ==0.1.0.1, + any.generic-optics ==2.0.0.0, + any.generic-random ==1.3.0.1, + any.generics-sop ==0.5.1.0, + any.generics-sop-lens ==0.2.0.1, + any.genvalidity ==0.11.0.0, + any.genvalidity-aeson ==0.3.0.0, + any.genvalidity-bytestring ==0.6.0.0, + any.genvalidity-containers ==0.8.0.2, + any.genvalidity-criterion ==0.2.0.0, + any.genvalidity-hspec ==0.7.0.4, + any.genvalidity-hspec-aeson ==0.3.1.1, + any.genvalidity-hspec-binary ==0.2.0.4, + any.genvalidity-hspec-cereal ==0.2.0.4, + any.genvalidity-hspec-hashable ==0.2.0.5, + any.genvalidity-hspec-optics ==0.1.1.2, + any.genvalidity-hspec-persistent ==0.0.0.1, + any.genvalidity-mergeful ==0.2.0.0, + any.genvalidity-mergeless ==0.2.0.0, + any.genvalidity-path ==0.3.0.4, + any.genvalidity-property ==0.5.0.1, + any.genvalidity-scientific ==0.2.1.1, + any.genvalidity-text ==0.7.0.2, + any.genvalidity-time ==0.3.0.0, + any.genvalidity-typed-uuid ==0.0.0.2, + any.genvalidity-unordered-containers ==0.3.0.1, + any.genvalidity-uuid ==0.1.0.4, + any.genvalidity-vector ==0.3.0.1, + any.geoip2 ==0.4.0.1, + any.geojson ==4.0.2, + any.getopt-generics ==0.13.0.4, + any.ghc-byteorder ==4.11.0.0.10, + any.ghc-check ==0.5.0.1, + any.ghc-compact ==0.1.0.0, + any.ghc-core ==0.5.6, + any.ghc-events ==0.13.0, + any.ghc-exactprint ==0.6.2, + any.ghc-lib ==8.10.2.20200808, + any.ghc-lib-parser ==8.10.1.20200412, + any.ghc-lib-parser-ex ==8.10.0.16, + any.ghc-parser ==0.2.2.0, + any.ghc-paths ==0.1.0.12, + any.ghc-prof ==1.4.1.7, + any.ghc-source-gen ==0.4.0.0, + any.ghc-syntax-highlighter ==0.0.6.0, + any.ghc-tcplugins-extra ==0.4, + any.ghc-typelits-extra ==0.4, + any.ghc-typelits-knownnat ==0.7.3, + any.ghc-typelits-natnormalise ==0.7.2, + any.ghc-typelits-presburger ==0.3.0.1, + any.ghci-hexcalc ==0.1.1.0, + any.ghcid ==0.8.7, + any.ghcjs-codemirror ==0.0.0.2, + any.ghost-buster ==0.1.1.0, + any.gi-atk ==2.0.21, + any.gi-cairo ==1.0.23, + any.gi-cairo-connector ==0.0.1, + any.gi-cairo-render ==0.0.1, + any.gi-dbusmenu ==0.4.7, + any.gi-dbusmenugtk3 ==0.4.8, + any.gi-gdk ==3.0.22, + any.gi-gdkpixbuf ==2.0.23, + any.gi-gdkx11 ==3.0.9, + any.gi-gio ==2.0.26, + any.gi-glib ==2.0.23, + any.gi-gobject ==2.0.22, + any.gi-graphene ==1.0.1, + any.gi-gtk ==3.0.33, + any.gi-gtk-hs ==0.3.8.1, + any.gi-pango ==1.0.22, + any.gi-xlib ==2.0.8, + any.ginger ==0.10.1.0, + any.gingersnap ==0.3.1.0, + any.giphy-api ==0.7.0.0, + any.githash ==0.1.4.0, + any.github-rest ==1.0.3, + any.github-types ==0.2.1, + any.gitlab-haskell ==0.1.8, + any.gitrev ==1.3.1, + any.gl ==0.9, + any.glabrous ==2.0.2, + any.gloss ==1.13.1.2, + any.gloss-rendering ==1.13.1.1, + any.gluturtle ==0.0.58.1, + any.gnuplot ==0.5.6.1, + any.google-isbn ==1.0.3, + any.gothic ==0.1.5, + any.gpolyline ==0.1.0.1, + any.graph-core ==0.3.0.0, + any.graph-wrapper ==0.2.6.0, + any.graphite ==0.10.0.1, + any.graphs ==0.7.1, + any.graphviz ==2999.20.1.0, + any.gravatar ==0.8.0, + greskell -hint-test, + any.greskell ==1.1.0.3, + any.greskell-core ==0.1.3.5, + any.greskell-websocket ==0.1.2.4, + any.groom ==0.1.2.1, + any.group-by-date ==0.1.0.3, + any.groups ==0.4.1.0, + any.gtk-sni-tray ==0.1.6.0, + any.gtk-strut ==0.1.3.0, + any.guarded-allocation ==0.0.1, + any.hOpenPGP ==2.9.4, + any.hackage-db ==2.1.0, + any.hackage-security ==0.6.0.1, + any.haddock-library ==1.8.0, + any.hadolint ==1.18.0, + any.hadoop-streaming ==0.2.0.3, + any.hakyll ==4.13.4.0, + any.half ==0.3, + any.hall-symbols ==0.1.0.6, + any.hamtsolo ==1.0.3, + any.hapistrano ==0.4.1.2, + any.happstack-server ==7.6.1, + any.happy ==1.19.12, + any.hasbolt ==0.1.4.3, + any.hashable ==1.3.0.0, + any.hashable-time ==0.2.0.2, + any.hashids ==1.0.2.4, + any.hashmap ==1.3.3, + any.hashtables ==1.2.4.1, + any.haskeline ==0.7.5.0, + any.haskell-gi ==0.23.1, + any.haskell-gi-base ==0.23.0, + any.haskell-gi-overloading ==1.0, + any.haskell-igraph ==0.8.0, + any.haskell-import-graph ==1.0.4, + any.haskell-lexer ==1.1, + any.haskell-lsp ==0.22.0.0, + any.haskell-lsp-types ==0.22.0.0, + any.haskell-names ==0.9.9, + any.haskell-src ==1.0.3.1, + any.haskell-src-exts ==1.23.1, + any.haskell-src-exts-util ==0.2.5, + any.haskell-src-meta ==0.8.5, + any.haskey-btree ==0.3.0.1, + any.haskoin-core ==0.13.4, + any.haskoin-node ==0.13.0, + any.hasql ==1.4.3, + any.hasql-optparse-applicative ==0.3.0.6, + any.hasql-pool ==0.5.2, + any.hasql-transaction ==1.0.0.1, + any.hasty-hamiltonian ==1.3.3, + any.haxr ==3000.11.4.1, + any.hdaemonize ==0.5.6, + any.headroom ==0.2.1.0, + any.heap ==1.0.4, + any.heaps ==0.3.6.1, + any.hebrew-time ==0.1.2, + any.hedgehog ==1.0.3, + any.hedgehog-corpus ==0.2.0, + any.hedgehog-fakedata ==0.0.1.3, + any.hedgehog-fn ==1.0, + any.hedgehog-quickcheck ==0.1.1, + any.hedis ==0.12.14, + any.here ==1.2.13, + any.heredoc ==0.2.0.0, + any.heterocephalus ==1.0.5.3, + any.hex ==0.2.0, + any.hexml ==0.3.4, + any.hexml-lens ==0.2.1, + any.hexpat ==0.20.13, + any.hexstring ==0.11.1, + any.hformat ==0.3.3.1, + any.hfsevents ==0.1.6, + any.hi-file-parser ==0.1.0.0, + any.hidapi ==0.1.5, + any.hie-bios ==0.5.1, + any.higher-leveldb ==0.5.0.2, + any.highlighting-kate ==0.6.4, + any.hinfo ==0.0.3.0, + any.hinotify ==0.4, + any.hint ==0.9.0.3, + any.hjsmin ==0.2.0.4, + any.hkd-default ==1.1.0.0, + any.hkgr ==0.2.6.1, + any.hledger ==1.18.1, + any.hledger-iadd ==1.3.12, + any.hledger-lib ==1.18.1, + any.hledger-stockquotes ==0.1.0.0, + any.hledger-ui ==1.18.1, + any.hledger-web ==1.18.1, + any.hlibcpuid ==0.2.0, + any.hlibgit2 ==0.18.0.16, + any.hlint ==3.1.6, + any.hmatrix ==0.20.0.0, + any.hmatrix-gsl ==0.19.0.1, + any.hmatrix-gsl-stats ==0.4.1.8, + any.hmatrix-morpheus ==0.1.1.2, + any.hmatrix-vector-sized ==0.1.3.0, + any.hmpfr ==0.4.4, + any.hnock ==0.4.0, + any.hoauth2 ==1.14.0, + any.hopenpgp-tools ==0.23.1, + any.hopenssl ==2.2.4, + any.hopfli ==0.2.2.1, + any.hosc ==0.17, + any.hostname ==1.0, + any.hostname-validate ==1.0.0, + any.hourglass ==0.2.12, + any.hourglass-orphans ==0.1.0.0, + any.hp2pretty ==0.9, + any.hpack ==0.34.2, + any.hpack-dhall ==0.5.2, + any.hpc-codecov ==0.2.0.0, + any.hpc-lcov ==1.0.1, + any.hreader ==1.1.0, + any.hreader-lens ==0.1.3.0, + any.hruby ==0.3.8, + any.hs-GeoIP ==0.3, + any.hs-bibutils ==6.10.0.0, + any.hs-functors ==0.1.7.1, + any.hs-php-session ==0.0.9.3, + any.hsc2hs ==0.68.7, + any.hscolour ==1.24.4, + any.hsdns ==1.8, + any.hsebaysdk ==0.4.1.0, + any.hsemail ==2.2.0, + any.hset ==2.2.0, + any.hsini ==0.5.1.2, + any.hsinstall ==2.6, + any.hslogger ==1.3.1.0, + any.hslua ==1.0.3.2, + any.hslua-aeson ==1.0.3, + any.hslua-module-doclayout ==0.1.0, + any.hslua-module-system ==0.2.2, + any.hslua-module-text ==0.2.1, + any.hsp ==0.10.0, + any.hspec ==2.7.4, + any.hspec-attoparsec ==0.1.0.2, + any.hspec-checkers ==0.1.0.2, + any.hspec-contrib ==0.5.1, + any.hspec-core ==2.7.4, + any.hspec-discover ==2.7.4, + any.hspec-expectations ==0.8.2, + any.hspec-expectations-lifted ==0.10.0, + any.hspec-expectations-pretty-diff ==0.7.2.5, + any.hspec-golden ==0.1.0.3, + any.hspec-golden-aeson ==0.7.0.0, + any.hspec-hedgehog ==0.0.1.2, + any.hspec-leancheck ==0.0.4, + any.hspec-megaparsec ==2.1.0, + any.hspec-meta ==2.6.0, + any.hspec-need-env ==0.1.0.5, + any.hspec-parsec ==0, + any.hspec-smallcheck ==0.5.2, + any.hspec-tables ==0.0.1, + any.hspec-wai-json ==0.10.1, + any.hsshellscript ==3.4.5, + any.hsyslog ==5.0.2, + any.htaglib ==1.2.0, + any.html ==1.0.1.2, + any.html-conduit ==1.3.2.1, + any.html-entities ==1.1.4.3, + any.html-entity-map ==0.1.0.0, + any.htoml ==1.0.0.3, + any.http-api-data ==0.4.1.1, + any.http-client-overrides ==0.1.1.0, + any.http-common ==0.8.2.1, + any.http-date ==0.0.8, + any.http-directory ==0.1.8, + any.http-download ==0.2.0.0, + any.http-link-header ==1.0.3.1, + any.http-media ==0.8.0.0, + any.http-reverse-proxy ==0.6.0, + any.http-streams ==0.8.7.2, + any.http-types ==0.12.3, + any.http2-grpc-proto3-wire ==0.1.0.0, + any.http2-grpc-types ==0.5.0.0, + any.httpd-shed ==0.4.1.1, + any.human-readable-duration ==0.2.1.4, + any.hunit-dejafu ==2.0.0.4, + any.hvect ==0.4.0.0, + any.hvega ==0.9.1.0, + any.hw-balancedparens ==0.4.1.0, + any.hw-bits ==0.7.2.1, + any.hw-conduit ==0.2.1.0, + any.hw-conduit-merges ==0.2.1.0, + any.hw-diagnostics ==0.0.1.0, + any.hw-excess ==0.2.3.0, + any.hw-fingertree ==0.1.2.0, + any.hw-fingertree-strict ==0.1.2.0, + any.hw-hedgehog ==0.1.1.0, + any.hw-hspec-hedgehog ==0.1.1.0, + any.hw-int ==0.0.2.0, + any.hw-json-simd ==0.1.1.0, + any.hw-mquery ==0.2.1.0, + any.hw-parser ==0.1.1.0, + any.hw-prim ==0.6.3.0, + any.hw-rankselect-base ==0.3.4.1, + any.hw-streams ==0.0.1.0, + any.hw-string-parse ==0.0.0.4, + any.hweblib ==0.6.3, + hxt +network-uri, + any.hxt ==9.3.1.18, + any.hxt-charproperties ==9.4.0.0, + any.hxt-css ==0.1.0.3, + any.hxt-curl ==9.1.1.1, + any.hxt-expat ==9.1.1, + hxt-http +network-uri, + any.hxt-http ==9.1.5.2, + any.hxt-regex-xmlschema ==9.2.0.3, + any.hxt-tagsoup ==9.1.4, + any.hxt-unicode ==9.0.2.4, + any.hybrid-vectors ==0.2.2, + any.hyperloglog ==0.4.3, + any.hyphenation ==0.8, + any.hyraxAbif ==0.2.3.21, + any.iconv ==0.4.1.3, + any.identicon ==0.2.2, + any.ieee754 ==0.8.0, + any.if ==0.1.0.0, + any.iff ==0.0.6, + any.ihaskell ==0.10.1.2, + any.ihs ==0.1.0.3, + any.ilist ==0.4.0.1, + any.imagesize-conduit ==1.1, + any.immortal ==0.3, + any.immortal-queue ==0.1.0.1, + any.implicit-hie ==0.1.2.5, + any.include-file ==0.1.0.4, + any.incremental-parser ==0.4.0.2, + any.indents ==0.5.0.1, + any.indexed ==0.1.3, + any.indexed-containers ==0.1.0.2, + any.indexed-list-literals ==0.2.1.3, + any.indexed-profunctors ==0.1, + any.infer-license ==0.2.0, + any.inflections ==0.4.0.6, + any.influxdb ==1.7.1.6, + any.ini ==0.4.1, + any.inj ==1.0, + any.inline-c ==0.9.1.0, + any.inline-c-cpp ==0.4.0.2, + any.inliterate ==0.1.0, + any.insert-ordered-containers ==0.2.3.1, + any.inspection-testing ==0.4.2.4, + any.instance-control ==0.1.2.0, + any.int-cast ==0.2.0.0, + any.integer-logarithms ==1.0.3, + any.integer-roots ==1.0, + any.integration ==0.2.1, + any.intern ==0.9.2, + any.interpolate ==0.2.1, + any.interpolatedstring-perl6 ==1.0.2, + any.interpolation ==0.1.1.1, + any.interpolator ==1.0.0, + any.intervals ==0.9.1, + any.intro ==0.7.0.0, + any.intset-imperative ==0.1.0.0, + any.invariant ==0.5.3, + any.invertible ==0.2.0.7, + any.invertible-grammar ==0.1.3, + any.invertible-hxt ==0.1, + any.io-machine ==0.2.0.0, + any.io-manager ==0.1.0.3, + any.io-memoize ==1.1.1.0, + any.io-region ==0.1.1, + any.io-storage ==0.3, + any.io-streams ==1.5.2.0, + any.io-streams-haproxy ==1.0.1.0, + any.ip6addr ==1.0.1, + any.iproute ==1.7.9, + any.ipynb ==0.1.0.1, + any.ipython-kernel ==0.10.2.1, + any.irc ==0.6.1.0, + any.irc-client ==1.1.1.1, + any.irc-conduit ==0.3.0.4, + any.irc-ctcp ==0.1.3.0, + any.isbn ==1.0.0.0, + any.islink ==0.1.0.0, + any.iso3166-country-codes ==0.20140203.8, + any.iso639 ==0.1.0.3, + any.iso8601-time ==0.1.5, + any.it-has ==0.2.0.0, + any.iterable ==3.0, + any.ix-shapable ==0.1.0, + any.ixset-typed ==0.5, + any.jack ==0.7.1.4, + any.jailbreak-cabal ==1.3.5, + any.jira-wiki-markup ==1.1.4, + any.jose ==0.8.3.1, + any.jose-jwt ==0.8.0, + any.js-dgtable ==0.5.2, + any.js-flot ==0.8.3, + any.js-jquery ==3.3.1, + any.json-alt ==1.0.0, + any.json-feed ==1.0.11, + any.json-rpc ==1.0.3, + any.json-rpc-generic ==0.2.1.5, + any.jsonpath ==0.2.0.0, + any.junit-xml ==0.1.0.1, + any.justified-containers ==0.3.0.0, + any.jwt ==0.10.0, + any.kan-extensions ==5.2, + any.kanji ==3.4.1, + any.katip ==0.8.5.0, + any.kawhi ==0.3.0, + any.kazura-queue ==0.1.0.4, + any.kdt ==0.2.4, + any.keycode ==0.2.2, + any.keys ==3.12.3, + any.kind-apply ==0.3.2.0, + any.kind-generics ==0.4.1.0, + any.kind-generics-th ==0.2.2.0, + any.kmeans ==0.1.3, + any.koofr-client ==1.0.0.3, + any.krank ==0.2.2, + any.kubernetes-webhook-haskell ==0.2.0.3, + any.l10n ==0.1.0.1, + any.labels ==0.3.3, + any.lackey ==1.0.13, + any.lame ==0.2.0, + any.language-avro ==0.1.3.1, + any.language-bash ==0.9.2, + any.language-c ==0.8.3, + any.language-c-quote ==0.12.2.1, + any.language-docker ==9.1.1, + any.language-haskell-extract ==0.2.4, + any.language-java ==0.2.9, + any.language-javascript ==0.7.1.0, + any.language-nix ==2.2.0, + any.language-protobuf ==1.0.1, + any.language-puppet ==1.4.6.5, + any.lapack-carray ==0.0.3, + any.lapack-comfort-array ==0.0.0.1, + any.lapack-ffi ==0.0.2, + any.lapack-ffi-tools ==0.1.2.1, + any.largeword ==1.2.5, + any.latex ==0.1.0.4, + any.lattices ==2.0.2, + any.lawful ==0.1.0.0, + any.lazy-csv ==0.5.1, + any.lazyio ==0.1.0.4, + any.lca ==0.3.1, + any.leancheck ==0.9.3, + any.leancheck-instances ==0.0.4, + any.leapseconds-announced ==2017.1.0.1, + any.learn-physics ==0.6.5, + any.lens ==4.18.1, + any.lens-action ==0.2.4, + any.lens-aeson ==1.1, + any.lens-datetime ==0.3, + any.lens-family ==2.0.0, + any.lens-family-core ==2.0.0, + any.lens-family-th ==0.5.1.0, + any.lens-misc ==0.0.2.0, + any.lens-properties ==4.11.1, + any.lens-regex ==0.1.1, + any.lenz ==0.4.2.0, + any.leveldb-haskell ==0.6.5, + any.libffi ==0.1, + any.libgit ==0.3.1, + any.libgraph ==1.14, + any.libmpd ==0.9.1.0, + any.libyaml ==0.1.2, + any.life-sync ==1.1.1.0, + any.lift-generics ==0.1.3, + any.lifted-async ==0.10.1.2, + any.lifted-base ==0.2.3.12, + any.line ==4.0.1, + any.linear ==1.21.1, + any.linenoise ==0.3.2, + any.linux-file-extents ==0.2.0.0, + any.linux-namespaces ==0.1.3.0, + any.list-predicate ==0.1.0.1, + any.list-singleton ==1.0.0.4, + any.list-t ==1.0.4, + any.listsafe ==0.1.0.1, + any.little-logger ==0.1.0, + any.little-rio ==0.1.1, + any.llvm-hs ==9.0.1, + any.llvm-hs-pure ==9.0.0, + any.lmdb ==0.2.5, + any.load-env ==0.2.1.0, + any.loc ==0.1.3.8, + any.loch-th ==0.2.2, + any.lockfree-queue ==0.2.3.1, + any.log-base ==0.8.0.1, + any.log-domain ==0.13, + any.logfloat ==0.13.3.3, + any.logging ==3.0.5, + any.logging-facade ==0.3.0, + any.logging-facade-syslog ==1, + any.logict ==0.7.0.3, + any.loop ==0.3.0, + any.loopbreaker ==0.1.1.1, + any.lrucache ==1.2.0.1, + any.lrucaching ==0.3.3, + any.lsp-test ==0.10.3.0, + any.lucid ==2.9.12, + any.lucid-extras ==0.2.2, + any.lukko ==0.1.1.2, + any.lzma ==0.0.0.3, + any.lzma-conduit ==1.2.1, + any.machines ==0.7, + any.magic ==1.1, + any.main-tester ==0.2.0.1, + any.mainland-pretty ==0.7.0.1, + any.makefile ==1.1.0.0, + any.managed ==1.0.8, + any.markdown ==0.1.17.4, + any.markdown-unlit ==0.5.0, + any.markov-chain ==0.0.3.4, + any.markov-chain-usage-model ==0.0.0, + any.massiv ==0.5.4.0, + any.massiv-io ==0.2.1.0, + any.massiv-test ==0.1.4, + any.math-extras ==0.1.1.0, + any.math-functions ==0.3.4.1, + any.mathexpr ==0.3.0.0, + any.matplotlib ==0.7.5, + any.matrices ==0.5.0, + any.matrix ==0.3.6.1, + any.matrix-as-xyz ==0.1.2.2, + any.matrix-market-attoparsec ==0.1.1.3, + any.matrix-static ==0.3, + any.maximal-cliques ==0.1.1, + any.mbox ==0.3.4, + any.mbox-utility ==0.0.3.1, + any.mcmc-types ==1.0.3, + any.medea ==1.1.2, + any.median-stream ==0.7.0.0, + any.megaparsec ==8.0.0, + any.megaparsec-tests ==8.0.0, + any.membrain ==0.0.0.2, + any.memory ==0.15.0, + any.mercury-api ==0.1.0.2, + any.mergeful ==0.2.0.0, + any.mergeless ==0.3.0.0, + mersenne-random-pure64 -small_base, + any.mersenne-random-pure64 ==0.2.2.0, + any.messagepack ==0.5.4, + any.metrics ==0.4.1.1, + any.mfsolve ==0.3.2.0, + any.microlens ==0.4.11.2, + any.microlens-aeson ==2.3.1, + any.microlens-contra ==0.1.0.2, + any.microlens-ghc ==0.4.12, + any.microlens-mtl ==0.2.0.1, + any.microlens-platform ==0.4.1, + any.microlens-process ==0.2.0.2, + any.microlens-th ==0.4.3.5, + any.microspec ==0.2.1.3, + any.microstache ==1.0.1.1, + any.midair ==0.2.0.1, + any.midi ==0.2.2.2, + any.mighty-metropolis ==2.0.0, + any.mime ==0.4.0.2, + any.mime-mail ==0.5.0, + any.mime-mail-ses ==0.4.3, + any.mime-types ==0.1.0.9, + any.min-max-pqueue ==0.1.0.2, + any.mini-egison ==1.0.0, + any.minimal-configuration ==0.1.4, + any.minimorph ==0.2.2.0, + any.minio-hs ==1.5.2, + any.miniutter ==0.5.1.0, + mintty +win32-2-5-3, + any.mintty ==0.1.2, + any.miso ==1.6.0.0, + any.missing-foreign ==0.1.1, + any.mixed-types-num ==0.4.0.2, + any.mixpanel-client ==0.2.1, + any.mltool ==0.2.0.1, + any.mmap ==0.5.9, + any.mmark ==0.0.7.2, + any.mmark-cli ==0.0.5.0, + any.mmark-ext ==0.2.1.2, + any.mmorph ==1.1.3, + any.mnist-idx ==0.1.2.8, + any.mockery ==0.3.5, + any.mod ==0.1.2.0, + any.model ==0.5, + any.modern-uri ==0.3.2.0, + any.modular ==0.1.0.8, + any.monad-bayes ==0.1.1.0, + any.monad-control ==1.0.2.3, + any.monad-control-aligned ==0.0.1.1, + any.monad-coroutine ==0.9.0.4, + any.monad-extras ==0.6.0, + any.monad-journal ==0.8.1, + any.monad-logger ==0.3.35, + any.monad-logger-json ==0.1.0.0, + any.monad-logger-prefix ==0.1.11, + any.monad-loops ==0.4.3, + any.monad-memo ==0.5.1, + any.monad-metrics ==0.2.1.4, + any.monad-par ==0.3.5, + any.monad-par-extras ==0.3.3, + any.monad-parallel ==0.7.2.3, + any.monad-peel ==0.2.1.2, + any.monad-products ==4.0.1, + any.monad-resumption ==0.1.4.0, + any.monad-skeleton ==0.1.5, + any.monad-st ==0.2.4.1, + any.monad-time ==0.3.1.0, + any.monad-unlift ==0.2.0, + any.monad-unlift-ref ==0.2.1, + any.monadic-arrays ==0.2.2, + any.monads-tf ==0.1.0.3, + mongoDB -_old-network, + any.mongoDB ==2.7.0.0, + any.mono-traversable ==1.0.15.1, + any.mono-traversable-instances ==0.1.1.0, + any.mono-traversable-keys ==0.1.0, + any.monoid-extras ==0.5.1, + any.monoid-subclasses ==1.0.1, + any.monoid-transformer ==0.0.4, + any.more-containers ==0.2.2.0, + any.morpheus-graphql ==0.12.0, + any.morpheus-graphql-core ==0.12.0, + any.mountpoints ==1.0.2, + any.mpi-hs ==0.7.2.0, + any.mpi-hs-binary ==0.1.1.0, + any.mpi-hs-cereal ==0.1.0.0, + any.mtl-compat ==0.2.2, + any.mtl-prelude ==2.0.3.1, + any.mu-avro ==0.4.0.4, + any.mu-grpc-client ==0.4.0.1, + any.mu-grpc-common ==0.4.0.0, + any.mu-grpc-server ==0.4.0.0, + any.mu-optics ==0.3.0.1, + any.mu-protobuf ==0.4.2.0, + any.mu-rpc ==0.4.0.1, + any.mu-schema ==0.3.1.2, + any.multi-containers ==0.1.1, + any.multiarg ==0.30.0.10, + any.multimap ==1.2.1, + any.multiset ==0.3.4.3, + any.multistate ==0.8.0.3, + any.murmur-hash ==0.1.0.9, + any.murmur3 ==1.0.4, + any.mustache ==2.3.1, + any.mutable-containers ==0.3.4, + any.mwc-probability ==2.3.1, + any.mwc-random ==0.14.0.0, + any.mx-state-codes ==1.0.0.0, + any.mysql ==0.1.7, + any.mysql-simple ==0.4.5, + any.n2o ==0.11.1, + any.nagios-check ==0.3.2, + any.names-th ==0.3.0.1, + any.nano-erl ==0.1.0.1, + any.nanospec ==0.2.2, + any.nats ==1.1.2, + any.natural-induction ==0.2.0.0, + any.natural-sort ==0.1.2, + any.natural-transformation ==0.4, + any.ndjson-conduit ==0.1.0.5, + any.neat-interpolation ==0.3.2.6, + any.netlib-carray ==0.1, + any.netlib-comfort-array ==0.0.0.1, + any.netlib-ffi ==0.1.1, + any.netpbm ==1.0.3, + any.netrc ==0.2.0.0, + any.nettle ==0.3.0, + any.netwire ==5.0.3, + any.netwire-input ==0.0.7, + any.netwire-input-glfw ==0.0.11, + any.network ==3.1.1.1, + any.network-bsd ==2.8.1.0, + any.network-byte-order ==0.1.5, + any.network-conduit-tls ==1.3.2, + any.network-info ==0.2.0.10, + any.network-ip ==0.3.0.3, + any.network-messagepack-rpc ==0.1.2.0, + any.network-messagepack-rpc-websocket ==0.1.1.1, + any.network-simple ==0.4.5, + any.network-simple-tls ==0.4, + any.network-transport ==0.5.4, + any.network-transport-composed ==0.2.1, + any.network-uri ==2.6.3.0, + any.newtype ==0.2.2.0, + any.newtype-generics ==0.5.4, + any.nicify-lib ==1.0.1, + nix-paths +allow-relative-paths, + any.nix-paths ==1.0.1, + any.no-value ==1.0.0.0, + any.non-empty ==0.3.2, + any.non-empty-sequence ==0.2.0.4, + any.non-negative ==0.1.2, + any.nonce ==1.0.7, + any.nondeterminism ==1.4, + any.nonempty-containers ==0.3.4.1, + any.nonempty-vector ==0.2.0.2, + any.nonemptymap ==0.0.6.0, + any.not-gloss ==0.7.7.0, + any.nowdoc ==0.1.1.0, + any.nqe ==0.6.3, + any.nsis ==0.3.3, + any.numbers ==3000.2.0.2, + any.numeric-extras ==0.1, + any.numeric-prelude ==0.4.3.2, + any.numhask ==0.4.0, + any.numtype-dk ==0.5.0.2, + any.nuxeo ==0.3.2, + any.o-clock ==1.1.0, + any.oauthenticated ==0.2.1.0, + any.odbc ==0.2.2, + any.oeis2 ==1.0.4, + any.ofx ==0.4.4.0, + any.old-locale ==1.0.0.7, + any.old-time ==1.1.0.3, + any.once ==0.4, + any.one-liner ==1.0, + any.one-liner-instances ==0.1.2.1, + any.oo-prototypes ==0.1.0.0, + any.opaleye ==0.6.7006.1, + any.open-browser ==0.2.1.0, + any.openexr-write ==0.1.0.2, + any.openpgp-asciiarmor ==0.1.2, + any.opensource ==0.1.1.0, + any.openssl-streams ==1.2.3.0, + any.opentelemetry ==0.4.2, + any.opentelemetry-extra ==0.4.2, + any.opentelemetry-lightstep ==0.4.2, + any.opentelemetry-wai ==0.4.2, + any.operational ==0.2.3.5, + any.operational-class ==0.3.0.0, + any.optics ==0.2, + any.optics-core ==0.2, + any.optics-extra ==0.2, + any.optics-th ==0.2, + any.optics-vl ==0.2, + any.optional-args ==1.0.2, + any.options ==1.2.1.1, + any.optparse-applicative ==0.15.1.0, + any.optparse-generic ==1.3.1, + any.optparse-simple ==0.1.1.3, + any.optparse-text ==0.1.1.0, + any.ordered-containers ==0.2.2, + any.ormolu ==0.1.4.1, + any.overhang ==1.0.0, + any.packcheck ==0.5.1, + any.pager ==0.1.1.0, + any.pagination ==0.2.1, + any.pagure-cli ==0.2, + any.pandoc ==2.9.2.1, + any.pandoc-citeproc ==0.17.0.1, + any.pandoc-csv2table ==1.0.8, + any.pandoc-plot ==0.6.1.0, + any.pandoc-pyplot ==2.3.0.1, + any.pandoc-types ==1.20, + any.pantry ==0.4.0.2, + any.papillon ==0.1.1.1, + any.parallel ==3.2.2.0, + any.parallel-io ==0.3.3, + any.parameterized ==0.5.0.0, + any.paripari ==0.6.0.1, + any.parseargs ==0.2.0.9, + any.parsec-class ==1.0.0.0, + any.parsec-numbers ==0.1.0, + any.parsec-numeric ==0.1.0.0, + any.parser-combinators ==1.2.1, + any.parser-combinators-tests ==1.2.1, + any.parsers ==0.12.10, + any.partial-handler ==1.0.3, + any.partial-isomorphisms ==0.2.2.1, + any.partial-semigroup ==0.5.1.8, + any.password ==2.0.1.1, + any.password-instances ==2.0.0.1, + any.path ==0.7.0, + any.path-extra ==0.2.0, + any.path-io ==1.6.0, + any.path-pieces ==0.2.1, + any.path-text-utf8 ==0.0.1.6, + pathtype -old-time, + any.pathtype ==0.8.1.1, + any.pathwalk ==0.3.1.2, + any.pattern-arrows ==0.0.2, + any.pattern-trie ==0.1.0, + any.pcg-random ==0.1.3.6, + any.pcre-heavy ==1.0.0.2, + any.pcre-light ==0.4.1.0, + any.pcre-utils ==0.1.8.1.1, + any.pdfinfo ==1.5.4, + any.peano ==0.1.0.1, + any.pem ==0.2.4, + any.percent-format ==0.0.1, + any.perfect-hash-generator ==0.2.0.6, + any.perfect-vector-shuffle ==0.1.1.1, + any.persist ==0.1.1.5, + any.persistable-record ==0.6.0.5, + any.persistable-types-HDBC-pg ==0.0.3.5, + any.persistent ==2.10.5.2, + any.persistent-mysql ==2.10.2.3, + any.persistent-pagination ==0.1.1.1, + any.persistent-postgresql ==2.10.1.2, + any.persistent-qq ==2.9.1.1, + any.persistent-sqlite ==2.10.6.2, + any.persistent-template ==2.8.2.3, + any.persistent-test ==2.0.3.1, + any.persistent-typed-db ==0.1.0.1, + any.pg-harness-client ==0.6.0, + any.pg-transact ==0.3.1.1, + any.pgp-wordlist ==0.1.0.3, + any.phantom-state ==0.2.1.2, + any.pid1 ==0.1.2.0, + any.pipes ==4.3.14, + any.pipes-aeson ==0.4.1.8, + any.pipes-attoparsec ==0.5.1.5, + any.pipes-binary ==0.4.2, + any.pipes-bytestring ==2.1.6, + any.pipes-concurrency ==2.0.12, + any.pipes-csv ==1.4.3, + any.pipes-extras ==1.0.15, + any.pipes-fastx ==0.3.0.0, + any.pipes-group ==1.0.12, + any.pipes-http ==1.0.6, + any.pipes-network ==0.6.5, + any.pipes-network-tls ==0.4, + any.pipes-ordered-zip ==1.1.0, + any.pipes-parse ==3.0.8, + any.pipes-random ==1.0.0.5, + any.pipes-safe ==2.3.2, + any.pipes-wai ==3.2.0, + any.pkcs10 ==0.2.0.0, + any.placeholders ==0.1, + any.plaid ==0.1.0.4, + any.planb-token-introspection ==0.1.4.0, + any.plotlyhs ==0.2.1, + any.pointed ==5.0.1, + any.pointedlist ==0.6.1, + any.pointless-fun ==1.1.0.6, + any.poll ==0.0.0.1, + any.poly ==0.4.0.0, + any.poly-arity ==0.1.0, + any.polynomials-bernstein ==1.1.2, + any.polyparse ==1.13, + any.polysemy ==1.6.0.0, + any.polysemy-mocks ==0.1.0.0, + any.polysemy-plugin ==0.2.5.2, + any.pooled-io ==0.0.2.2, + any.port-utils ==0.2.1.0, + any.posix-paths ==0.2.1.6, + any.possibly ==1.0.0.0, + any.post-mess-age ==0.2.1.0, + any.postgres-options ==0.2.0.0, + any.postgresql-binary ==0.12.2, + any.postgresql-libpq ==0.9.4.2, + any.postgresql-orm ==0.5.1, + any.postgresql-simple ==0.6.2, + any.postgrest ==7.0.0, + any.pptable ==0.3.0.0, + any.pqueue ==1.4.1.3, + any.prefix-units ==0.2.0, + any.prelude-compat ==0.0.0.2, + any.prelude-safeenum ==0.1.1.2, + any.pretty-class ==1.0.1.1, + any.pretty-hex ==1.1, + any.pretty-relative-time ==0.2.0.0, + any.pretty-show ==1.10, + any.pretty-simple ==3.2.3.0, + any.pretty-sop ==0.2.0.3, + any.pretty-terminal ==0.1.0.0, + any.pretty-types ==0.3.0.1, + any.prettyclass ==1.0.0.0, + any.prettyprinter ==1.6.2, + any.prettyprinter-ansi-terminal ==1.1.2, + any.prettyprinter-compat-annotated-wl-pprint ==1, + any.prettyprinter-compat-ansi-wl-pprint ==1.0.1, + any.prettyprinter-compat-wl-pprint ==1.0.0.1, + any.prettyprinter-convert-ansi-wl-pprint ==1.1.1, + any.primes ==0.2.1.0, + any.primitive ==0.7.0.1, + any.primitive-addr ==0.1.0.2, + any.primitive-extras ==0.8, + any.primitive-unaligned ==0.1.1.1, + any.primitive-unlifted ==0.1.2.0, + any.print-console-colors ==0.1.0.0, + any.process-extras ==0.7.4, + any.product-isomorphic ==0.0.3.3, + any.product-profunctors ==0.10.0.1, + any.profiterole ==0.1, + any.profunctors ==5.5.2, + any.project-template ==0.2.1.0, + any.projectroot ==0.2.0.1, + any.prometheus ==2.2.2, + any.prometheus-client ==1.0.1, + any.promises ==0.3, + any.prompt ==0.1.1.2, + any.prospect ==0.1.0.0, + any.proto-lens ==0.7.0.0, + any.proto-lens-arbitrary ==0.1.2.9, + any.proto-lens-optparse ==0.1.1.7, + any.proto-lens-protobuf-types ==0.7.0.0, + any.proto-lens-protoc ==0.7.0.0, + any.proto-lens-runtime ==0.7.0.0, + any.proto-lens-setup ==0.4.0.4, + any.proto3-wire ==1.2.0, + any.protobuf ==0.2.1.3, + any.protobuf-simple ==0.1.1.0, + any.protocol-radius ==0.0.1.1, + any.protocol-radius-test ==0.1.0.1, + any.protolude ==0.2.4, + any.proxied ==0.3.1, + any.psqueues ==0.2.7.2, + any.publicsuffix ==0.20200526, + any.pulse-simple ==0.1.14, + any.pureMD5 ==2.1.3, + any.purescript-bridge ==0.14.0.0, + any.pushbullet-types ==0.4.1.0, + any.pusher-http-haskell ==1.5.1.14, + any.pvar ==0.2.0.0, + any.qchas ==1.1.0.1, + any.qm-interpolated-string ==0.3.0.0, + any.qrcode-core ==0.9.4, + any.qrcode-juicypixels ==0.8.2, + any.quadratic-irrational ==0.1.1, + any.quickcheck-arbitrary-adt ==0.3.1.0, + any.quickcheck-assertions ==0.3.0, + any.quickcheck-classes ==0.6.4.0, + any.quickcheck-classes-base ==0.6.1.0, + any.quickcheck-instances ==0.3.23, + any.quickcheck-io ==0.2.0, + any.quickcheck-simple ==0.1.1.1, + any.quickcheck-special ==0.1.0.6, + any.quickcheck-state-machine ==0.6.0, + any.quickcheck-text ==0.1.2.1, + any.quickcheck-transformer ==0.3.1.1, + any.quickcheck-unicode ==1.0.1.0, + any.quiet ==0.2, + any.radius ==0.6.1.0, + any.rainbow ==0.34.2.2, + any.rainbox ==0.26.0.0, + any.ral ==0.1, + any.ramus ==0.1.2, + any.rando ==0.0.0.4, + any.random ==1.1, + any.random-bytestring ==0.1.3.2, + any.random-shuffle ==0.0.4, + any.random-tree ==0.6.0.5, + any.range ==0.3.0.2, + any.range-set-list ==0.1.3.1, + any.rank1dynamic ==0.4.0, + any.rank2classes ==1.3.2.1, + any.rasterific-svg ==0.3.3.2, + any.rate-limit ==1.4.2, + any.ratel ==1.0.12, + any.ratel-wai ==1.1.3, + any.raw-strings-qq ==1.1, + any.rawfilepath ==0.2.4, + any.rawstring-qm ==0.2.3.0, + any.rcu ==0.2.4, + any.rdf ==0.1.0.4, + any.rdtsc ==1.3.0.1, + any.re2 ==0.3, + any.read-editor ==0.1.0.2, + any.read-env-var ==1.0.0.0, + any.readable ==0.3.1, + any.reanimate ==0.3.3.0, + any.reanimate-svg ==0.9.8.0, + any.rebase ==1.6.1, + any.record-dot-preprocessor ==0.2.6, + any.record-hasfield ==1.0, + any.records-sop ==0.1.0.3, + any.recursion-schemes ==5.1.3, + any.redis-io ==1.1.0, + any.redis-resp ==1.0.0, + any.reducers ==3.12.3, + any.ref-fd ==0.4.0.2, + any.refact ==0.3.0.2, + any.reflection ==2.1.6, + any.reform ==0.2.7.4, + any.reform-blaze ==0.2.4.3, + any.reform-hamlet ==0.0.5.3, + any.reform-happstack ==0.2.5.3, + any.regex ==1.1.0.0, + any.regex-applicative ==0.3.3.1, + any.regex-applicative-text ==0.1.0.1, + any.regex-base ==0.94.0.0, + any.regex-compat ==0.95.2.0, + any.regex-compat-tdfa ==0.95.1.4, + any.regex-pcre ==0.95.0.0, + any.regex-pcre-builtin ==0.95.1.2.8.43, + any.regex-posix ==0.96.0.0, + any.regex-tdfa ==1.3.1.0, + any.regex-with-pcre ==1.1.0.0, + any.registry ==0.1.9.3, + any.reinterpret-cast ==0.1.0, + any.relapse ==1.0.0.0, + any.relational-query ==0.12.2.3, + any.relational-query-HDBC ==0.7.2.0, + any.relational-record ==0.2.2.0, + any.relational-schemas ==0.1.8.0, + any.relude ==0.7.0.0, + any.renderable ==0.2.0.1, + any.replace-attoparsec ==1.4.1.0, + any.replace-megaparsec ==1.4.2.0, + any.repline ==0.2.2.0, + any.req ==3.2.0, + any.req-conduit ==1.0.0, + any.rerebase ==1.6.1, + any.resolv ==0.1.2.0, + any.resource-pool ==0.2.3.2, + any.resourcet ==1.2.4.2, + any.result ==0.2.6.0, + any.rethinkdb-client-driver ==0.0.25, + any.retry ==0.8.1.2, + any.rev-state ==0.1.2, + any.rfc1751 ==0.1.3, + any.rfc5051 ==0.1.0.4, + any.rhine ==0.6.0, + any.rhine-gloss ==0.6.0.1, + any.rigel-viz ==0.2.0.0, + any.rio ==0.1.18.0, + any.rio-orphans ==0.1.1.0, + any.rio-prettyprint ==0.1.1.0, + any.roc-id ==0.1.0.0, + any.rocksdb-haskell ==1.0.1, + any.rocksdb-query ==0.3.2, + any.roles ==0.2.0.0, + any.rope-utf16-splay ==0.3.1.0, + any.rosezipper ==0.2, + any.rot13 ==0.2.0.1, + any.rpmbuild-order ==0.3.1, + any.runmemo ==1.0.0.1, + any.safe ==0.3.19, + any.safe-decimal ==0.2.0.0, + any.safe-exceptions ==0.1.7.1, + any.safe-exceptions-checked ==0.1.0, + any.safe-foldable ==0.1.0.0, + any.safe-json ==1.1.1, + any.safe-money ==0.9, + any.safecopy ==0.10.3, + any.safeio ==0.0.5.0, + any.salak ==0.3.6, + any.salak-yaml ==0.3.5.3, + any.saltine ==0.1.1.0, + any.salve ==1.0.10, + any.sample-frame ==0.0.3, + any.sample-frame-np ==0.0.4.1, + any.sampling ==0.3.5, + any.say ==0.1.0.1, + any.sbp ==2.6.3, + any.scalpel ==0.6.2, + any.scalpel-core ==0.6.2, + any.scanf ==0.1.0.0, + any.scanner ==0.3.1, + any.scheduler ==1.4.2.3, + any.scientific ==0.3.6.2, + any.scotty ==0.11.6, + any.scrypt ==0.5.0, + any.sdl2 ==2.5.2.0, + any.sdl2-gfx ==0.2, + any.sdl2-image ==2.0.0, + any.sdl2-mixer ==1.1.0, + any.sdl2-ttf ==2.1.1, + any.search-algorithms ==0.3.1, + any.secp256k1-haskell ==0.2.5, + any.securemem ==0.1.10, + any.selda ==0.5.1.0, + any.selda-json ==0.1.1.0, + any.selective ==0.4.1.1, + any.semialign ==1.1.0.1, + any.semialign-indexed ==1.1, + any.semialign-optics ==1.1, + any.semigroupoid-extras ==5, + any.semigroupoids ==5.3.4, + any.semigroups ==0.19.1, + any.semiring-simple ==1.0.0.1, + any.semirings ==0.5.4, + any.semver ==0.3.4, + any.sendfile ==0.7.11.1, + any.seqalign ==0.2.0.4, + any.sequence-formats ==1.4.1, + any.sequenceTools ==1.4.0.5, + any.serf ==0.1.1.0, + any.serialise ==0.2.3.0, + any.servant-JuicyPixels ==0.3.0.5, + any.servant-auth ==0.3.2.0, + any.servant-auth-docs ==0.2.10.0, + any.servant-auth-server ==0.4.5.1, + any.servant-auth-swagger ==0.2.10.0, + any.servant-blaze ==0.9, + any.servant-cassava ==0.10, + any.servant-checked-exceptions ==2.2.0.0, + any.servant-checked-exceptions-core ==2.2.0.0, + any.servant-conduit ==0.15.1, + any.servant-docs ==0.11.4, + any.servant-docs-simple ==0.2.0.1, + any.servant-elm ==0.7.2, + any.servant-errors ==0.1.6.0, + any.servant-foreign ==0.15, + any.servant-js ==0.9.4.2, + any.servant-lucid ==0.9, + any.servant-machines ==0.15.1, + any.servant-mock ==0.8.7, + any.servant-multipart ==0.11.5, + any.servant-pipes ==0.15.2, + any.servant-purescript ==0.10.0.0, + any.servant-rawm ==0.3.2.0, + any.servant-static-th ==0.2.4.0, + any.servant-subscriber ==0.7.0.0, + any.servant-swagger-ui ==0.3.4.3.36.1, + any.servant-swagger-ui-core ==0.3.3, + any.servant-swagger-ui-redoc ==0.3.3.1.22.3, + any.servant-websockets ==2.0.0, + any.servant-yaml ==0.1.0.1, + any.serverless-haskell ==0.11.3, + any.serversession ==1.0.1, + any.serversession-frontend-wai ==1.0, + any.ses-html ==0.4.0.0, + any.set-cover ==0.1.1, + any.setenv ==0.1.1.3, + any.setlocale ==1.0.0.9, + any.sexp-grammar ==2.1.0, + any.shake ==0.19.1, + any.shake-plus ==0.1.10.0, + any.shakespeare ==2.0.25, + any.shared-memory ==0.2.0.0, + any.shell-conduit ==4.7.0, + any.shell-escape ==0.2.0, + any.shell-utility ==0.1, + any.shellmet ==0.0.3.1, + any.shelltestrunner ==1.9, + any.shelly ==1.9.0, + any.should-not-typecheck ==2.1.0, + any.show-combinators ==0.2.0.0, + any.siggy-chardust ==1.0.0, + any.signal ==0.1.0.4, + any.silently ==1.2.5.1, + any.simple-affine-space ==0.1.1, + any.simple-cabal ==0.1.2, + any.simple-cmd ==0.2.2, + any.simple-cmd-args ==0.1.6, + any.simple-log ==0.9.12, + any.simple-reflect ==0.3.3, + any.simple-sendfile ==0.2.30, + any.simple-templates ==1.0.0, + any.simple-vec3 ==0.6.0.1, + any.simplest-sqlite ==0.1.0.2, + any.simplistic-generics ==2.0.0, + any.since ==0.0.0, + any.singleton-bool ==0.1.5, + any.singleton-nats ==0.4.5, + any.singletons ==2.6, + any.singletons-presburger ==0.3.0.1, + any.siphash ==1.0.3, + any.sitemap-gen ==0.1.0.0, + any.size-based ==0.1.2.0, + any.sized ==0.4.0.0, + any.skein ==1.0.9.4, + any.skews ==0.1.0.3, + any.skip-var ==0.1.1.0, + any.skylighting ==0.8.5, + any.skylighting-core ==0.8.5, + any.slack-api ==0.12, + any.slist ==0.1.1.0, + any.smallcheck ==1.1.7, + any.smash ==0.1.1.0, + any.smash-aeson ==0.1.0.0, + any.smash-lens ==0.1.0.0, + any.smash-microlens ==0.1.0.0, + any.smoothie ==0.4.2.11, + any.smtp-mail ==0.2.0.0, + any.snap-blaze ==0.2.1.5, + any.snap-core ==1.0.4.2, + any.snap-server ==1.1.1.2, + any.snowflake ==0.1.1.1, + any.soap ==0.2.3.6, + any.soap-tls ==0.1.1.4, + any.socks ==0.6.1, + any.some ==1.0.1, + any.sop-core ==0.5.0.1, + any.sort ==1.0.0.0, + any.sorted-list ==0.2.1.0, + any.sourcemap ==0.1.6, + any.sox ==0.2.3.1, + any.soxlib ==0.0.3.1, + any.sparse-linear-algebra ==0.3.1, + any.sparse-tensor ==0.2.1.4, + any.spatial-math ==0.5.0.1, + any.special-values ==0.1.0.0, + any.speculate ==0.4.2, + any.speedy-slice ==0.3.1, + any.splice ==0.6.1.1, + any.split ==0.2.3.4, + any.splitmix ==0.0.4, + any.spoon ==0.3.1, + any.spreadsheet ==0.1.3.8, + any.sql-words ==0.1.6.4, + any.sqlcli ==0.2.2.0, + any.sqlcli-odbc ==0.2.0.1, + any.squeather ==0.4.0.0, + any.srcloc ==0.5.1.2, + any.stache ==2.1.1, + any.stack ==2.3.3, + any.stack-templatizer ==0.1.0.2, + any.stackcollapse-ghc ==0.0.1.2, + any.starter ==0.3.0, + any.stateref ==0.3, + any.statestack ==0.3, + any.static-text ==0.2.0.6, + any.statistics ==0.15.2.0, + any.status-notifier-item ==0.3.0.5, + any.stb-image-redux ==0.2.1.3, + any.step-function ==0.2, + any.stm-chans ==3.0.0.4, + any.stm-conduit ==4.0.1, + any.stm-containers ==1.1.0.4, + any.stm-delay ==0.1.1.1, + any.stm-extras ==0.1.0.3, + any.stm-hamt ==1.2.0.4, + any.stm-split ==0.0.2.1, + any.stomp-queue ==0.3.1, + any.stompl ==0.5.0, + any.stopwatch ==0.1.0.6, + any.storable-complex ==0.2.3.0, + any.storable-record ==0.0.5, + any.storable-tuple ==0.0.3.3, + any.storablevector ==0.2.13.1, + any.stratosphere ==0.53.0, + any.streaming ==0.2.3.0, + any.streaming-bytestring ==0.1.6, + any.streaming-commons ==0.2.2.1, + any.streamly ==0.7.2, + any.streamly-bytestring ==0.1.2, + any.streams ==3.3, + any.strict ==0.3.2, + any.strict-base-types ==0.6.1, + any.strict-concurrency ==0.2.4.3, + any.strict-list ==0.1.5, + any.strict-tuple ==0.1.3, + any.strict-tuple-lens ==0.1.0.1, + any.string-class ==0.1.7.0, + any.string-combinators ==0.6.0.5, + any.string-conv ==0.1.2, + any.string-conversions ==0.4.0.1, + any.string-interpolate ==0.2.1.0, + any.string-qq ==0.0.4, + any.string-transform ==1.1.1, + any.stringbuilder ==0.5.1, + any.stringsearch ==0.3.6.6, + any.stripe-concepts ==1.0.2.4, + any.stripe-signature ==1.0.0.6, + any.strive ==5.0.12, + any.structs ==0.1.3, + any.structured ==0.1, + any.structured-cli ==2.5.2.0, + any.stylish-haskell ==0.11.0.3, + any.sum-type-boilerplate ==0.1.1, + any.summoner ==2.0.1.1, + any.summoner-tui ==2.0.1.1, + any.sundown ==0.6, + any.superbuffer ==0.3.1.1, + any.svg-builder ==0.1.1, + any.svg-tree ==0.6.2.4, + any.swagger ==0.3.0, + any.swagger2 ==2.5, + any.swish ==0.10.0.4, + any.syb ==0.7.1, + any.symbol ==0.2.4, + any.symengine ==0.1.2.0, + any.symmetry-operations-symbols ==0.0.2.1, + any.sysinfo ==0.1.1, + any.system-argv0 ==0.1.1, + any.system-fileio ==0.3.16.4, + any.system-filepath ==0.4.14, + any.system-info ==0.5.1, + any.systemd ==2.3.0, + any.tabular ==0.2.2.8, + any.taffybar ==3.2.2, + any.tagchup ==0.4.1.1, + any.tagged ==0.8.6, + any.tagged-binary ==0.2.0.1, + any.tagged-identity ==0.1.3, + any.tagged-transformer ==0.8.1, + any.tagshare ==0.0, + any.tagsoup ==0.14.8, + any.tao ==1.0.0, + any.tao-example ==1.0.0, + tar -old-time, + any.tar ==0.5.1.1, + any.tar-conduit ==0.3.2, + any.tardis ==0.4.1.0, + any.tasty ==1.2.3, + any.tasty-ant-xml ==1.1.6, + any.tasty-dejafu ==2.0.0.6, + any.tasty-discover ==4.2.1, + any.tasty-expected-failure ==0.11.1.2, + any.tasty-golden ==2.3.3.2, + any.tasty-hedgehog ==1.0.0.2, + any.tasty-hspec ==1.1.5.1, + any.tasty-hunit ==0.10.0.2, + any.tasty-kat ==0.0.3, + any.tasty-leancheck ==0.0.1, + any.tasty-lua ==0.2.3, + any.tasty-program ==1.0.5, + any.tasty-quickcheck ==0.10.1.1, + any.tasty-rerun ==1.1.17, + any.tasty-silver ==3.1.15, + any.tasty-smallcheck ==0.8.1, + any.tasty-th ==0.1.7, + any.tasty-wai ==0.1.1.0, + any.tce-conf ==1.3, + any.tdigest ==0.2.1, + any.template ==0.2.0.10, + any.template-haskell-compat-v0208 ==0.1.5, + any.temporary ==1.3, + any.temporary-rc ==1.2.0.3, + any.temporary-resourcet ==0.1.0.1, + any.tensorflow-test ==0.1.0.0, + any.tensors ==0.1.4, + any.terminal-progress-bar ==0.4.1, + any.terminal-size ==0.3.2.1, + any.test-framework ==0.8.2.0, + any.test-framework-hunit ==0.3.0.2, + any.test-framework-leancheck ==0.0.1, + any.test-framework-quickcheck2 ==0.3.0.5, + any.test-framework-smallcheck ==0.2, + any.test-framework-th ==0.2.4, + any.testing-feat ==1.1.0.0, + any.testing-type-modifiers ==0.1.0.1, + any.texmath ==0.12.0.2, + any.text-binary ==0.2.1.1, + any.text-builder ==0.6.6.1, + any.text-conversions ==0.3.0, + any.text-format ==0.3.2, + any.text-icu ==0.7.0.1, + any.text-icu-translit ==0.1.0.7, + any.text-latin1 ==0.3.1, + any.text-ldap ==0.1.1.13, + any.text-manipulate ==0.2.0.1, + any.text-metrics ==0.3.0, + any.text-postgresql ==0.0.3.1, + any.text-printer ==0.5.0.1, + any.text-region ==0.3.1.0, + any.text-short ==0.1.3, + any.text-show ==3.8.5, + any.text-show-instances ==3.8.3, + any.text-zipper ==0.10.1, + any.textlocal ==0.1.0.5, + any.tf-random ==0.5, + any.tfp ==1.0.1.1, + any.th-abstraction ==0.3.2.0, + any.th-bang-compat ==0.0.1.0, + any.th-constraint-compat ==0.0.1.0, + any.th-data-compat ==0.1.0.0, + any.th-desugar ==1.10, + any.th-env ==0.1.0.2, + any.th-expand-syns ==0.4.6.0, + any.th-extras ==0.0.0.4, + any.th-lift ==0.8.1, + any.th-lift-instances ==0.1.17, + any.th-nowq ==0.1.0.5, + any.th-orphans ==0.13.10, + any.th-printf ==0.7, + any.th-reify-compat ==0.0.1.5, + any.th-reify-many ==0.1.9, + any.th-strict-compat ==0.1.0.1, + any.th-test-utils ==1.0.2, + any.these ==1.1.1.1, + any.these-lens ==1.0.0.1, + any.these-optics ==1, + any.thread-hierarchy ==0.3.0.2, + any.thread-local-storage ==0.2, + any.thread-supervisor ==0.1.0.1, + any.threads ==0.5.1.6, + any.threepenny-gui ==0.9.0.0, + any.throttle-io-stream ==0.2.0.1, + any.through-text ==0.1.0.0, + any.throwable-exceptions ==0.1.0.9, + any.thyme ==0.3.5.5, + any.tidal ==1.5.2, + any.tile ==0.3.0.0, + any.time-compat ==1.9.3, + any.time-lens ==0.4.0.2, + time-locale-compat -old-locale, + any.time-locale-compat ==0.1.1.5, + any.time-locale-vietnamese ==1.0.0.0, + any.time-manager ==0.0.0, + any.time-parsers ==0.1.2.1, + any.time-units ==1.0.0, + any.timeit ==2.0, + any.timelens ==0.2.0.2, + any.timerep ==2.0.0.2, + any.timezone-olson ==0.2.0, + any.timezone-series ==0.1.9, + any.tinylog ==0.15.0, + any.titlecase ==1.0.1, + any.tldr ==0.6.4, + any.tls ==1.5.5, + any.tls-debug ==0.4.8, + any.tls-session-manager ==0.0.4, + any.tmapchan ==0.0.3, + any.tmapmvar ==0.0.4, + any.tmp-postgres ==1.34.1.0, + any.tomland ==1.3.0.0, + any.tonalude ==0.1.1.0, + any.topograph ==1.0.0.1, + any.torsor ==0.1, + any.tostring ==0.2.1.1, + any.tracing ==0.0.5.1, + any.transaction ==0.1.1.3, + any.transformers-base ==0.4.5.2, + any.transformers-bifunctors ==0.1, + transformers-compat +five-three, + any.transformers-compat ==0.6.5, + any.transformers-fix ==1.0, + any.traverse-with-class ==1.0.1.0, + any.tree-diff ==0.1, + any.tree-fun ==0.8.1.0, + any.trifecta ==2.1, + any.triplesec ==0.2.2.1, + any.trivial-constraint ==0.6.0.0, + any.tsv2csv ==0.1.0.2, + any.ttc ==0.2.2.0, + any.ttl-hashtables ==1.4.1.0, + any.ttrie ==0.1.2.1, + any.tuple ==0.3.0.2, + any.tuple-sop ==0.3.1.0, + any.tuple-th ==0.2.5, + any.tuples-homogenous-h98 ==0.1.1.0, + any.turtle ==1.5.20, + any.type-equality ==1, + any.type-errors ==0.2.0.0, + any.type-errors-pretty ==0.0.1.1, + any.type-fun ==0.1.1, + any.type-hint ==0.1, + any.type-level-integers ==0.0.1, + any.type-level-kv-list ==1.1.0, + any.type-level-numbers ==0.1.1.1, + any.type-map ==0.1.6.0, + any.type-natural ==0.8.3.1, + any.type-of-html ==1.5.1.0, + any.type-of-html-static ==0.1.0.2, + any.type-operators ==0.2.0.0, + any.type-spec ==0.4.0.0, + any.typed-process ==0.2.6.0, + any.typed-uuid ==0.0.0.2, + any.typenums ==0.1.2.1, + any.typerep-map ==0.3.3.0, + any.tzdata ==0.1.20190911.0, + any.ua-parser ==0.7.5.1, + any.uglymemo ==0.1.0.1, + any.ulid ==0.3.0.0, + any.unagi-chan ==0.4.1.3, + any.unbounded-delays ==0.1.1.0, + any.unboxed-ref ==0.4.0.0, + any.unboxing-vector ==0.1.1.0, + any.uncertain ==0.3.1.0, + any.unconstrained ==0.1.0.2, + any.unexceptionalio ==0.5.1, + any.unexceptionalio-trans ==0.5.1, + any.unicode ==0.0.1.1, + any.unicode-show ==0.1.0.4, + any.unicode-transforms ==0.3.7, + any.unification-fd ==0.10.0.1, + any.union-find ==0.2, + any.uniplate ==1.6.12, + any.uniprot-kb ==0.1.2.0, + any.uniq-deep ==1.2.0, + any.unique ==0, + any.unique-logic ==0.4, + any.unique-logic-tf ==0.5.1, + any.unit-constraint ==0.0.0, + any.universe ==1.2, + any.universe-base ==1.1.1, + any.universe-instances-base ==1.1, + any.universe-instances-extended ==1.1.1, + any.universe-instances-trans ==1.1, + any.universe-reverse-instances ==1.1, + any.universe-some ==1.2, + any.universum ==1.6.1, + any.unix-bytestring ==0.3.7.3, + any.unix-compat ==0.5.2, + any.unix-time ==0.4.7, + any.unliftio ==0.2.13, + any.unliftio-core ==0.1.2.0, + any.unliftio-pool ==0.2.1.1, + any.unlit ==0.4.0.0, + any.unordered-containers ==0.2.10.0, + any.unordered-intmap ==0.1.1, + any.unsafe ==0.0, + any.urbit-hob ==0.3.3, + any.uri-bytestring ==0.3.2.2, + any.uri-bytestring-aeson ==0.1.0.8, + any.uri-encode ==1.5.0.6, + any.url ==2.1.3, + any.users ==0.5.0.0, + any.utf8-conversions ==0.1.0.4, + any.utf8-light ==0.4.2, + any.utf8-string ==1.0.1.1, + any.util ==0.1.17.1, + any.utility-ht ==0.0.15, + any.uuid ==1.3.13, + any.uuid-types ==1.0.3, + any.validation ==1.1, + any.validation-selective ==0.1.0.0, + any.validity ==0.11.0.0, + any.validity-aeson ==0.2.0.4, + any.validity-bytestring ==0.4.1.1, + any.validity-containers ==0.5.0.4, + any.validity-path ==0.4.0.1, + any.validity-primitive ==0.0.0.1, + any.validity-scientific ==0.2.0.3, + any.validity-text ==0.3.1.1, + any.validity-time ==0.3.0.0, + any.validity-unordered-containers ==0.2.0.3, + any.validity-uuid ==0.1.0.3, + any.validity-vector ==0.2.0.3, + any.valor ==0.1.0.0, + any.vault ==0.3.1.4, + any.vec ==0.3, + any.vector ==0.12.1.2, + any.vector-algorithms ==0.8.0.3, + any.vector-binary-instances ==0.2.5.1, + any.vector-buffer ==0.4.1, + any.vector-builder ==0.3.8, + any.vector-bytes-instances ==0.1.1, + any.vector-instances ==3.4, + any.vector-mmap ==0.0.3, + any.vector-rotcev ==0.1.0.0, + any.vector-sized ==1.4.2, + any.vector-space ==0.16, + any.vector-split ==1.0.0.2, + any.vector-th-unbox ==0.2.1.7, + any.verbosity ==0.4.0.0, + any.versions ==3.5.4, + any.vformat ==0.14.1.0, + any.vformat-aeson ==0.1.0.1, + any.vformat-time ==0.1.0.0, + any.void ==0.7.3, + any.vty ==5.28.2, + any.wai ==3.2.2.1, + any.wai-app-static ==3.1.7.2, + any.wai-conduit ==3.0.0.4, + any.wai-cors ==0.2.7, + any.wai-enforce-https ==0.0.2.1, + any.wai-eventsource ==3.0.0, + any.wai-extra ==3.0.29.2, + any.wai-handler-launch ==3.0.3.1, + any.wai-logger ==2.3.6, + any.wai-middleware-caching ==0.1.0.2, + any.wai-middleware-clacks ==0.1.0.1, + any.wai-middleware-gunzip ==0.0.2, + any.wai-middleware-static ==0.8.3, + any.wai-predicates ==1.0.0, + any.wai-route ==0.4.0, + any.wai-session ==0.3.3, + any.wai-slack-middleware ==0.2.0, + any.wai-websockets ==3.0.1.2, + any.warp ==3.3.13, + any.warp-grpc ==0.4.0.1, + any.warp-tls ==3.2.12, + any.warp-tls-uid ==0.2.0.6, + any.wave ==0.2.0, + any.wcwidth ==0.0.2, + any.webdriver ==0.9.0.1, + any.webex-teams-api ==0.2.0.1, + any.webex-teams-conduit ==0.2.0.1, + any.webex-teams-pipes ==0.2.0.1, + any.webrtc-vad ==0.1.0.3, + any.websockets ==0.12.7.1, + any.websockets-snap ==0.10.3.1, + any.weigh ==0.0.16, + any.wide-word ==0.1.1.1, + any.wikicfp-scraper ==0.1.0.11, + any.wild-bind ==0.1.2.6, + any.wild-bind-x11 ==0.2.0.10, + windns +allow-non-windows, + any.windns ==0.1.0.1, + any.with-location ==0.1.0, + any.with-utf8 ==1.0.2.1, + any.witherable-class ==0, + any.within ==0.1.1.0, + any.witness ==0.4, + any.wizards ==1.0.3, + any.wl-pprint-annotated ==0.1.0.1, + any.wl-pprint-console ==0.1.0.2, + any.wl-pprint-text ==1.2.0.1, + any.word-trie ==0.3.0, + any.word-wrap ==0.4.1, + any.word24 ==2.0.1, + any.word8 ==0.1.3, + any.world-peace ==1.0.2.0, + any.wrap ==0.0.0, + any.wreq ==0.5.3.2, + any.writer-cps-exceptions ==0.1.0.1, + any.writer-cps-mtl ==0.1.1.6, + any.writer-cps-transformers ==0.5.6.1, + any.wss-client ==0.3.0.0, + any.wuss ==1.1.17, + any.x11-xim ==0.0.9.0, + any.x509 ==1.7.5, + any.x509-system ==1.6.6, + any.x509-validation ==1.6.11, + any.xdg-basedir ==0.2.2, + any.xdg-desktop-entry ==0.1.1.1, + any.xdg-userdirs ==0.1.0.2, + any.xeno ==0.4.2, + any.xls ==0.1.3, + any.xlsx ==0.8.1, + any.xlsx-tabular ==0.2.2.1, + any.xml ==1.3.14, + any.xml-basic ==0.1.3.1, + any.xml-conduit ==1.9.0.0, + any.xml-conduit-writer ==0.1.1.2, + any.xml-hamlet ==0.5.0.1, + any.xml-helpers ==1.0.0, + any.xml-html-qq ==0.1.0.1, + any.xml-indexed-cursor ==0.1.1.0, + any.xml-lens ==0.2, + any.xml-picklers ==0.3.6, + any.xml-to-json ==2.0.1, + any.xml-to-json-fast ==2.0.0, + any.xml-types ==0.3.8, + any.xmlgen ==0.6.2.2, + any.xmonad ==0.15, + any.xmonad-contrib ==0.16, + any.xmonad-extras ==0.15.2, + any.xss-sanitize ==0.3.6, + any.xturtle ==0.2.0.0, + any.xxhash-ffi ==0.2.0.0, + any.yaml ==0.11.5.0, + any.yamlparse-applicative ==0.1.0.1, + any.yes-precure5-command ==5.5.3, + any.yesod ==1.6.1.0, + any.yesod-auth ==1.6.10, + any.yesod-auth-fb ==1.10.1, + any.yesod-auth-hashdb ==1.7.1.2, + any.yesod-bin ==1.6.0.6, + any.yesod-core ==1.6.18, + any.yesod-fb ==0.6.1, + any.yesod-form ==1.6.7, + any.yesod-form-bootstrap4 ==3.0.0, + any.yesod-gitrev ==0.2.1, + any.yesod-newsfeed ==1.7.0.0, + any.yesod-persistent ==1.6.0.4, + any.yesod-recaptcha2 ==1.0.1, + any.yesod-sitemap ==1.6.0, + any.yesod-static ==1.6.1.0, + any.yesod-test ==1.6.10, + any.yesod-websockets ==0.3.0.2, + any.yi-rope ==0.11, + any.yjsvg ==0.2.0.1, + any.yjtools ==0.9.18, + any.yoga ==0.0.0.5, + any.youtube ==0.2.1.1, + any.zasni-gerna ==0.0.7.1, + any.zero ==0.1.5, + any.zeromq4-haskell ==0.8.0, + any.zeromq4-patterns ==0.3.1.0, + any.zim-parser ==0.2.1.0, + any.zip ==1.5.0, + any.zip-archive ==0.4.1, + any.zip-stream ==0.2.0.1, + any.zippers ==0.3, + any.zlib ==0.6.2.2, + any.zlib-bindings ==0.1.1.5, + any.zlib-lens ==0.1.2.1, + any.zot ==0.0.3, + any.zstd ==0.1.2.0 diff --git a/changelog.d/5-internal/use-cabal b/changelog.d/5-internal/use-cabal new file mode 100644 index 00000000000..2f8378eadcb --- /dev/null +++ b/changelog.d/5-internal/use-cabal @@ -0,0 +1 @@ +Use cabal to build wire-server (opt-in) diff --git a/direnv.nix b/direnv.nix index 07281107a66..6a336217404 100644 --- a/direnv.nix +++ b/direnv.nix @@ -122,6 +122,7 @@ pkgs.buildEnv { pkgs.telepresence pkgs.wget pkgs.yq + pkgs.rsync # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf pkgs.buildah @@ -131,5 +132,34 @@ pkgs.buildEnv { pinned.helmfile pinned.kubectl pinned.kind + + # For cabal-migration + pkgs.haskell.compiler.ghc884 + + pkgs.cabal-install + pkgs.haskellPackages.cabal-plan + pkgs.pkgconfig + pkgs.protobuf + + pkgs.cryptobox + pkgs.geoip + pkgs.icu.dev + pkgs.icu.out + pkgs.libsodium.dev + pkgs.libsodium.out + pkgs.libxml2.dev + pkgs.libxml2.out + pkgs.ncurses.dev + pkgs.ncurses.out + pkgs.openssl.dev + pkgs.openssl.out + pkgs.pcre.dev + pkgs.pcre.out + pkgs.snappy.dev + pkgs.snappy.out + pkgs.zlib.dev + pkgs.zlib.out + pkgs.lzma.dev + pkgs.lzma.out ]; } diff --git a/hack/bin/cabal-install-all-artefacts.sh b/hack/bin/cabal-install-all-artefacts.sh new file mode 100755 index 00000000000..2087b655b32 --- /dev/null +++ b/hack/bin/cabal-install-all-artefacts.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +for d in $(find "$TOP_LEVEL" -name '*.cabal' | grep -v dist-newstyle | xargs -n 1 dirname); do + cd "$d" + "$DIR/cabal-install-artefacts.sh" "$(basename "$d")" +done diff --git a/hack/bin/cabal-install-artefacts.sh b/hack/bin/cabal-install-artefacts.sh new file mode 100755 index 00000000000..215f7f868bf --- /dev/null +++ b/hack/bin/cabal-install-artefacts.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +DIST="$TOP_LEVEL/dist" + +cabal-plan list-bins "$1"':exe:*' | awk '{print $2}' | xargs -I '{}' rsync -a {} "$DIST" diff --git a/hack/bin/cabal-project-local-template.sh b/hack/bin/cabal-project-local-template.sh new file mode 100755 index 00000000000..de45ddfd694 --- /dev/null +++ b/hack/bin/cabal-project-local-template.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +cd "$TOP_LEVEL" + +package_options=$1 + +local_projects=$(find . -name '*.cabal' | grep -v dist-newstyle | xargs -n 1 basename | sed 's|.cabal||g' | sort) + +for project in $local_projects; do + echo "package $project + $package_options" +done diff --git a/hack/bin/cabal-run-all-tests.sh b/hack/bin/cabal-run-all-tests.sh new file mode 100755 index 00000000000..7d84637417f --- /dev/null +++ b/hack/bin/cabal-run-all-tests.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +find "$TOP_LEVEL" -name '*.cabal' | + grep -v dist-newstyle | + xargs -n 1 dirname | + xargs -n 1 basename | + xargs -n 1 "$DIR/cabal-run-tests.sh" diff --git a/hack/bin/cabal-run-tests.sh b/hack/bin/cabal-run-tests.sh new file mode 100755 index 00000000000..7364ea40fa2 --- /dev/null +++ b/hack/bin/cabal-run-tests.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +pkgName=${1:-Please specify package name} + +# This is required because some tests (e.g. golden tests) depend on the path +# where they are run from. +pkgDir=$(find "$TOP_LEVEL" -name "$pkgName.cabal" | grep -v dist-newstyle | head -1 | xargs -n 1 dirname) +cd "$pkgDir" + +cabal-plan list-bins "$pkgName"':test:*' | awk '{print $2}' | xargs --no-run-if-empty -n 1 bash -c diff --git a/hack/bin/nix-hls.sh b/hack/bin/nix-hls.sh index 488cc122e6e..9b633f5e460 100755 --- a/hack/bin/nix-hls.sh +++ b/hack/bin/nix-hls.sh @@ -5,6 +5,8 @@ set -euo pipefail DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" TOP_LEVEL="$(cd "$DIR/../.." && pwd)" -env=$(nix-build --no-out-link "$PWD/direnv.nix") -export PATH="$env/bin:$PATH" +env=$(nix-build --no-out-link "$TOP_LEVEL/direnv.nix") +eval "$(direnv stdlib)" +load_prefix "$env" + haskell-language-server-wrapper "$@" diff --git a/libs/types-common-journal/package.yaml b/libs/types-common-journal/package.yaml deleted file mode 100644 index f6d0f4d1309..00000000000 --- a/libs/types-common-journal/package.yaml +++ /dev/null @@ -1,40 +0,0 @@ -defaults: - local: ../../package-defaults.yaml -name: types-common-journal -version: '0.1.0' -synopsis: Shared protobuf type definitions. -description: Shared protobuf type definitions for journaling. -category: System -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 -extra-source-files: -- proto/TeamEvents.proto -- proto/UserEvents.proto -ghc-options: -- -fno-warn-redundant-constraints -dependencies: -- base ==4.* -- bytestring -- imports -- proto-lens-runtime -- time -- types-common -- uuid -library: - source-dirs: src - ghc-prof-options: -fprof-auto-exported - exposed-modules: - # do not remove this list! stack won't be able to generate it from the protobuf source files! - - Data.Proto - - Data.Proto.Id - - Proto.TeamEvents - - Proto.TeamEvents_Fields - - Proto.UserEvents - - Proto.UserEvents_Fields -custom-setup: - dependencies: - - base - - Cabal - - proto-lens-setup diff --git a/libs/types-common-journal/types-common-journal.cabal b/libs/types-common-journal/types-common-journal.cabal index 8f0490851d6..f804fd9991d 100644 --- a/libs/types-common-journal/types-common-journal.cabal +++ b/libs/types-common-journal/types-common-journal.cabal @@ -1,10 +1,10 @@ -cabal-version: 1.24 +cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: e1935f392440ca2f304ef17fbfe551f6cda9b616b15272792df66ed83e01123b +-- hash: 00a76393f405b068d1b0ffe0c3d0f59370b3ad9ac10a9c0bc08f5abe721bc351 name: types-common-journal version: 0.1.0 @@ -42,6 +42,8 @@ library default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fno-warn-redundant-constraints ghc-prof-options: -fprof-auto-exported + build-tool-depends: + proto-lens-protoc:proto-lens-protoc build-depends: base ==4.* , bytestring @@ -51,3 +53,8 @@ library , types-common , uuid default-language: Haskell2010 + autogen-modules: + Proto.TeamEvents + Proto.TeamEvents_Fields + Proto.UserEvents + Proto.UserEvents_Fields diff --git a/libs/wire-message-proto-lens/package.yaml b/libs/wire-message-proto-lens/package.yaml deleted file mode 100644 index 54bfe246ea7..00000000000 --- a/libs/wire-message-proto-lens/package.yaml +++ /dev/null @@ -1,30 +0,0 @@ -defaults: - local: ../../package-defaults.yaml -name: wire-message-proto-lens -version: '0.1.0' -synopsis: Shared protobuf type definitions for Wire Messaging. -description: Shared protobuf type definitions for Wire Messaging. -category: System -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2021 Wire Swiss GmbH -license: AGPL-3 -extra-source-files: -- generic-message-proto/proto/otr.proto -ghc-options: -- -fno-warn-redundant-constraints -dependencies: -- base -- proto-lens-runtime -library: - source-dirs: . - ghc-prof-options: -fprof-auto-exported - exposed-modules: - # do not remove this list! stack won't be able to generate it from the protobuf source files! - - Proto.Otr - - Proto.Otr_Fields -custom-setup: - dependencies: - - base - - Cabal - - proto-lens-setup diff --git a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal index a4e5644e15b..cb9e559b95c 100644 --- a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal +++ b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.24 +cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.33.0. -- @@ -39,4 +39,8 @@ library build-depends: base , proto-lens-runtime + build-tool-depends: proto-lens-protoc:proto-lens-protoc default-language: Haskell2010 + autogen-modules: + Proto.Otr + Proto.Otr_Fields diff --git a/stack.yaml b/stack.yaml index b816f92c3c4..2795b2949e1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -104,9 +104,8 @@ extra-deps: # Therefore we pin an unreleased commit directly. # # Once the fix has been merged (and released on hackage), we can pin that instead. -- archive: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 - size: 11158334 +- git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb subdirs: - amazonka - amazonka-cloudfront diff --git a/stack.yaml.lock b/stack.yaml.lock index a8910cfe1db..abe6af55450 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -109,125 +109,109 @@ packages: original: hackage: aeson-1.4.7.1@sha256:6d8d2fd959b7122a1df9389cf4eca30420a053d67289f92cdc0dbc0dab3530ba,7098 - completed: - size: 11158334 subdir: amazonka - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 1038 sha256: 59c7840fe6c9609d1d5022149010e72db5778e4978b9384b6dee8a4a207c96b3 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-cloudfront - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-cloudfront version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 12839 sha256: f0f27588c628d9996c298ab035b19999572ad8432ea05526497b608b009b1258 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-cloudfront - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-dynamodb - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-dynamodb version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 8379 sha256: d513775676879e3b2ff8393528882df1670a79110120b65ce6c68765581a2473 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-dynamodb - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-s3 - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-s3 version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 18431 sha256: a19d02da301bbcad502e6092d7418a59543747c8bb6f12932bcbc4606f7814ab + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-s3 - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-ses - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-ses version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 18197 sha256: cd9b02c30d7571dc87868b054ed3826d5b8d26b717f3158da6443377e8dfd563 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-ses - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-sns - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-sns version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 7905 sha256: e5a6d407b92e423ccf58d784fe42d4a0598204f65c0e7753569c130428bfb5eb + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-sns - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-sqs - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-sqs version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 5351 sha256: 990b7e4467d557e43959483063f7229f5039857a8cd67decb53f9a5c513db7f8 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-sqs - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: core - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-core version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 3484 sha256: d4e427a362d66c9ee0dc0de810015633e43e3953944a84b24cfa2e71bcf0ed4d + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: core - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: name: cryptobox-haskell version: 0.1.1 diff --git a/tools/convert-to-cabal/README.md b/tools/convert-to-cabal/README.md new file mode 100644 index 00000000000..c3f4e780814 --- /dev/null +++ b/tools/convert-to-cabal/README.md @@ -0,0 +1,85 @@ +# How to convert the project to cabal + +1. Run + + ```bash + ./tools/convert-to-cabal/generate.sh + ``` + + This will generate these files + - `cabal.project.freeze` + - `cabal.project` + +2. Create a `cabal.project.local` file with + + ``` + optimization: False + ``` + + This configures that local builds fast without optimization. + + To make sure Haskell Language Server also builds all projects without optimization run this: + + ```bash + ./hack/bin/cabal-project-local-template.sh "ghc-options: -O0" >> ./cabal.project.local + ``` + + Note: cabal v2-repl (which is run by hie-bios (HLS)) seem to be ignoring "optimization" flag for local dependencies, this is why we need to specify `ghc-options` explicitely. + + +# How to use the project with cabal + +1. Update your environment. + ```bash + cabal update + ``` + + Add this to your .envrc.local + ```bash + export WIRE_BUILD_WITH_CABAL=1 + ``` + + You should be able to build wire-server with cabal now: + + ```bash + make install # using cabal + make c package=brig # to build and install all of brig's executables + make c package=brig test=1 # also run unit tests + make ci package=brig pattern="delete" # build and run brig's integration tests + ``` + +2. For Haskell Language Server change `hie.yaml` to use cabal + ```bash + WIRE_BUILD_WITH_CABAL=1 make hie.yaml + ``` + + + +## Notes + +- `cabal v2-repl` (used by hie-bios) seem to be ignoring "optimization" flag for local dependencies. However it respects ghc-options + +``` +package foo + ghc-options: -O0 +``` + +- With new cabal build there doesn't seem to be any way of running tests as part of a build. You have to run the tests manually. + https://github.com/haskell/cabal/issues/7267 + +- Nix integration (`nix: True` in `~/.cabal/config`) is not supported in new-build. + https://github.com/haskell/cabal/issues/4646 + That's why you have to enter the environment defined by `direnv.nix` manually (or via direnv) to use cabal. + +- cabal oddity? Specifying `--ghc-options` twice yields different result + + if run + ``` + cabal build --ghc-options "-O0" exe:brig + ``` + + and then + ``` + cabal build --ghc-options "-O0" --ghc-options "-O0" exe:brig + ``` + Cabal will retry to build brig and _all_ of its dependencies diff --git a/tools/convert-to-cabal/generate.sh b/tools/convert-to-cabal/generate.sh new file mode 100755 index 00000000000..cd240702381 --- /dev/null +++ b/tools/convert-to-cabal/generate.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash +set -euo pipefail + +TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" + +cd "$TOP_LEVEL" + +{ + echo -e "\n-- Changes by ./tools/convert-to-cabal/generate.sh \n\ntests: True\n\n" + ./hack/bin/cabal-project-local-template.sh "ghc-options: -Werror" >> ./cabal.project +} >> ./cabal.project diff --git a/tools/convert-to-cabal/shell.nix b/tools/convert-to-cabal/shell.nix new file mode 100644 index 00000000000..87266663a03 --- /dev/null +++ b/tools/convert-to-cabal/shell.nix @@ -0,0 +1,28 @@ +{ pkgs ? import ../../nix }: +let + pinned = { + stack2cabal = + let source = pkgs.fetchFromGitHub { + owner = "hasufell"; + repo = "stack2cabal"; + rev = "afa113beb77569ff21f03fade6ce39edc109598d"; + sha256 = "1zwg1xkqxn5b9mmqafg87rmgln47zsmpgdkly165xdzg38smhmng"; + }; + + overlay = self: super: { + "stack2cabal" = super.callCabal2nix "stack2cabal" source { }; + }; + + haskellPackages = pkgs.haskell.packages.ghc884.override { + overrides = overlay; + }; + + in pkgs.haskell.lib.doJailbreak haskellPackages.stack2cabal; + + }; +in pkgs.mkShell { + name = "shell"; + buildInputs = [ + pinned.stack2cabal + ]; +} From 9eb681091699b07e3ad07e2c496f6e7435c241dc Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 9 Nov 2021 09:45:02 +0100 Subject: [PATCH 76/88] fix generate.sh (#1913) --- tools/convert-to-cabal/generate.sh | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tools/convert-to-cabal/generate.sh b/tools/convert-to-cabal/generate.sh index cd240702381..3a0e8c5f421 100755 --- a/tools/convert-to-cabal/generate.sh +++ b/tools/convert-to-cabal/generate.sh @@ -5,7 +5,9 @@ TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" cd "$TOP_LEVEL" +nix-shell ./tools/convert-to-cabal/shell.nix --command "stack2cabal --no-run-hpack" + { - echo -e "\n-- Changes by ./tools/convert-to-cabal/generate.sh \n\ntests: True\n\n" - ./hack/bin/cabal-project-local-template.sh "ghc-options: -Werror" >> ./cabal.project + echo -e "\n-- Changes by ./tools/convert-to-cabal/generate.sh \n\ntests: True\n\n"; + ./hack/bin/cabal-project-local-template.sh "ghc-options: -Werror" } >> ./cabal.project From 73713902fbe2abbffd74b76af4488002bcaa7813 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 9 Nov 2021 12:32:08 +0100 Subject: [PATCH 77/88] Do not fail user deletion when a remote notification fails (#1912) * Refactor: withMockedFederatorAndGalley * brig: ignore when remote notifications fail * extend test case with a domain that is unvailable * Remove FUTUREWORK, done in #1891 * Add changelog entry * Refactor: Changes from review --- ...dont-fail-user-deletion-unavailble-remotes | 1 + services/brig/src/Brig/IO/Intra.hs | 12 ++-- .../brig/test/integration/API/User/Account.hs | 53 ++++++++++++++++- services/brig/test/integration/Util.hs | 6 +- services/galley/src/Galley/API/Internal.hs | 1 - services/galley/test/integration/API.hs | 59 +++++++++++++++---- 6 files changed, 107 insertions(+), 25 deletions(-) create mode 100644 changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes diff --git a/changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes b/changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes new file mode 100644 index 00000000000..0b55867b7c8 --- /dev/null +++ b/changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes @@ -0,0 +1 @@ +Do not fail user deletion when a remote notification fails diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 6ceed1c77fa..df063cbdd0d 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -93,6 +93,7 @@ import Data.Coerce (coerce) import qualified Data.Conduit.List as C import qualified Data.Currency as Currency import Data.Domain +import Data.Either.Combinators (whenLeft) import qualified Data.HashMap.Strict as M import Data.Id import Data.Json.Util (UTCTimeMillis, (#)) @@ -118,7 +119,7 @@ import qualified Network.Wai.Utilities.Error as Wai import System.Logger.Class as Log hiding (name, (.=)) import Wire.API.Federation.API.Brig import Wire.API.Federation.Client -import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) +import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Message (UserClients) import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) @@ -275,13 +276,8 @@ notifyUserDeletionRemotes deleted = do Just rangedUids -> do luidDeleted <- qualifyLocal deleted eitherFErr <- runExceptT (notifyUserDeleted luidDeleted (qualifyAs uids rangedUids)) - case eitherFErr of - Left fErr -> do - logFederationError (tDomain uids) fErr - -- FUTUTREWORK: Do something better here? - -- FUTUREWORK: Write test that this happens - throwM $ federationErrorToWai fErr - Right () -> pure () + whenLeft eitherFErr $ + logFederationError (tDomain uids) logFederationError :: Domain -> FederationError -> AppT IO () logFederationError domain fErr = diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index fcc529fd2da..78dd97bda49 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -136,6 +136,7 @@ tests _ at opts p b c ch g aws = test' aws p "delete /i/users/:uid - 202" $ testDeleteInternal b c aws, test' aws p "delete with profile pic" $ testDeleteWithProfilePic b ch, test' aws p "delete with connected remote users" $ testDeleteWithRemotes opts b, + test' aws p "delete with connected remote users and failed remote notifcations" $ testDeleteWithRemotesAndFailedNotifications opts b c, test' aws p "put /i/users/:uid/sso-id" $ testUpdateSSOId b g, testGroup "temporary customer extensions" @@ -1224,7 +1225,7 @@ testDeleteWithRemotes opts brig = do sendConnectionAction brig opts (userId localUser) remote2UserBlocked (Just FedBrig.RemoteConnect) Accepted void $ putConnectionQualified brig (userId localUser) remote2UserBlocked Blocked - let fedMockResponse = OutwardResponseBody (cs $ Aeson.encode EmptyResponse) + let fedMockResponse = const (OutwardResponseBody (cs $ Aeson.encode EmptyResponse)) let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = case (requestMethod, requestPath) of @@ -1257,6 +1258,56 @@ testDeleteWithRemotes opts brig = do (eitherDecode . cs) (F.body r) Nothing -> Left "No request" +testDeleteWithRemotesAndFailedNotifications :: Opt.Opts -> Brig -> Cannon -> Http () +testDeleteWithRemotesAndFailedNotifications opts brig cannon = do + alice <- randomUser brig + alex <- randomUser brig + let localDomain = qDomain (userQualifiedId alice) + + let bDomain = Domain "b.example.com" + cDomain = Domain "c.example.com" + bob <- Qualified <$> randomId <*> pure bDomain + carl <- Qualified <$> randomId <*> pure cDomain + + postConnection brig (userId alice) (userId alex) !!! const 201 === statusCode + putConnection brig (userId alex) (userId alice) Accepted !!! const 200 === statusCode + sendConnectionAction brig opts (userId alice) bob (Just FedBrig.RemoteConnect) Accepted + sendConnectionAction brig opts (userId alice) carl (Just FedBrig.RemoteConnect) Accepted + + let fedMockResponse req = + if Domain (F.domain req) == bDomain + then F.OutwardResponseError (F.OutwardError F.ConnectionRefused "mocked connection problem with b domain") + else OutwardResponseBody (cs $ Aeson.encode EmptyResponse) + + let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response + galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = + case (Http.parseMethod requestMethod, requestPath) of + (Right Http.DELETE, ["i", "user"]) -> do + let response = Wai.responseLBS Http.status200 [(Http.hContentType, "application/json")] (cs $ Aeson.encode EmptyResponse) + pure response + _ -> error "not mocked" + + (_, rpcCalls, _galleyCalls) <- WS.bracketR cannon (userId alex) $ \wsAlex -> do + let action = withMockedFederatorAndGalley opts localDomain fedMockResponse galleyHandler $ do + deleteUser (userId alice) (Just defPassword) brig !!! do + const 200 === statusCode + liftIO action <* do + void . liftIO . WS.assertMatch (5 # Second) wsAlex $ matchDeleteUserNotification (userQualifiedId alice) + + liftIO $ do + rRpc <- assertOne $ filter (\c -> F.domain c == domainText cDomain) rpcCalls + cUdn <- assertRight $ parseFedRequest rRpc + udcnUser cUdn @?= userId alice + sort (fromRange (udcnConnections cUdn)) + @?= sort (map qUnqualified [carl]) + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a + parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + testUpdateSSOId :: Brig -> Galley -> Http () testUpdateSSOId brig galley = do noSuchUserId <- Id <$> liftIO UUID.nextRandom diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index b6ad08f42d3..5a3ca0781b4 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -89,7 +89,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.Federation.API.Brig as FedBrig import qualified Wire.API.Federation.API.Galley as FedGalley -import Wire.API.Federation.GRPC.Types (OutwardResponse) +import Wire.API.Federation.GRPC.Types (FederatedRequest, OutwardResponse) import qualified Wire.API.Federation.Mock as Mock import Wire.API.Routes.MultiTablePaging @@ -1039,14 +1039,14 @@ withMockedGalley opts handler action = withMockedFederatorAndGalley :: Opt.Opts -> Domain -> - OutwardResponse -> + (FederatedRequest -> OutwardResponse) -> (ReceivedRequest -> MockT IO Wai.Response) -> Session a -> IO (a, Mock.ReceivedRequests, [ReceivedRequest]) withMockedFederatorAndGalley opts domain fedResp galleyHandler action = do result <- assertRight <=< runExceptT $ withTempMockedService initState galleyHandler $ \galleyMockState -> - Mock.withTempMockFederator (Mock.initState domain) (const (pure fedResp)) $ \fedMockState -> do + Mock.withTempMockFederator (Mock.initState domain) (pure . fedResp) $ \fedMockState -> do let opts' = opts { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)), diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index bb7ce82c268..5e510f293b9 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -530,7 +530,6 @@ rmUser user conn = do page' <- liftSem $ listTeams user (Just (pageState page)) maxBound leaveTeams page' - -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity leaveLocalConversations :: Member MemberStore r => [ConvId] -> Galley r () leaveLocalConversations ids = do localDomain <- viewFederationDomain diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index b199d4c0f06..3bdb964a400 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -3198,26 +3198,35 @@ removeUser = do c <- view tsCannon [alice, alexDel, amy] <- replicateM 3 randomQualifiedUser let [alice', alexDel', amy'] = qUnqualified <$> [alice, alexDel, amy] + let bDomain = Domain "b.example.com" bart <- randomQualifiedId bDomain berta <- randomQualifiedId bDomain + let cDomain = Domain "c.example.com" carl <- randomQualifiedId cDomain + let dDomain = Domain "d.example.com" + dwight <- randomQualifiedId dDomain + dory <- randomQualifiedId dDomain + connectUsers alice' (list1 alexDel' [amy']) connectWithRemoteUser alice' bart connectWithRemoteUser alice' berta connectWithRemoteUser alexDel' bart connectWithRemoteUser alice' carl connectWithRemoteUser alexDel' carl + connectWithRemoteUser alice' dwight + connectWithRemoteUser alexDel' dory convA1 <- decodeConvId <$> postConv alice' [alexDel'] (Just "gossip") [] Nothing Nothing - convA2 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, amy, berta]} + convA2 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, amy, berta, dwight]} convA3 <- decodeConvId <$> postConv alice' [amy'] (Just "gossip3") [] Nothing Nothing convA4 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, bart, carl]} convB1 <- randomId -- a remote conversation at 'bDomain' that Alice, AlexDel and Bart will be in convB2 <- randomId -- a remote conversation at 'bDomain' that AlexDel and Bart will be in convC1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Carl will be in + convD1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Dory will be in let qconvA1 = Qualified convA1 (qDomain alexDel) qconvA2 = Qualified convA2 (qDomain alexDel) @@ -3239,23 +3248,34 @@ removeUser = do FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB2 bart [alexDel] FederatedGalley.onConversationCreated fedGalleyClient cDomain $ nc convC1 carl [alexDel] - - localDomain <- viewFederationDomain + FederatedGalley.onConversationCreated fedGalleyClient dDomain $ nc convD1 dory [alexDel] WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do - let galleyApi _domain = - emptyFederatedGalley - { FederatedGalley.leaveConversation = \_domain _update -> - pure (FederatedGalley.LeaveConversationResponse (Right ())), - FederatedGalley.onConversationUpdated = \_domain _convUpdate -> - pure () - } + let handler :: F.FederatedRequest -> IO F.OutwardResponse + handler freq@(Domain . F.domain -> domain) + | domain == dDomain = + pure + ( F.OutwardResponseError + ( F.OutwardError + F.ConnectionRefused + "mocked: dDomain is unavailable" + ) + ) + | domain `elem` [bDomain, cDomain] = + case F.path <$> F.request freq of + (Just "/federation/leave-conversation") -> + pure (F.OutwardResponseBody (cs (encode (FederatedGalley.LeaveConversationResponse (Right ()))))) + (Just "federation/on-conversation-updated") -> + pure (F.OutwardResponseBody (cs (encode ()))) + other -> error $ "unmocked path " <> show other + | otherwise = error "unmocked domain" + (_, fedRequests) <- - withTempServantMockFederator (const emptyFederatedBrig) galleyApi localDomain $ + withTempMockFederator' handler $ deleteUser alexDel' !!! const 200 === statusCode liftIO $ do - assertEqual ("expect exactly 5 federated requests in : " <> show fedRequests) 5 (length fedRequests) + assertEqual ("expect exactly 7 federated requests in : " <> show fedRequests) 7 (length fedRequests) liftIO $ do bReq <- assertOne $ filter (matchFedRequest bDomain "/federation/on-user-deleted/conversations") fedRequests @@ -3273,6 +3293,14 @@ removeUser = do sort (fromRange (FederatedGalley.udcnConversations udcnC)) @?= sort [convC1] FederatedGalley.udcnUser udcnC @?= qUnqualified alexDel + liftIO $ do + dReq <- assertOne $ filter (matchFedRequest dDomain "/federation/on-user-deleted/conversations") fedRequests + fmap F.component (F.request dReq) @?= Just F.Galley + fmap F.path (F.request dReq) @?= Just "/federation/on-user-deleted/conversations" + Just (Right udcnD) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dReq) + sort (fromRange (FederatedGalley.udcnConversations udcnD)) @?= sort [convD1] + FederatedGalley.udcnUser udcnD @?= qUnqualified alexDel + liftIO $ do WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ wsAssertMembersLeave qconvA1 alexDel [alexDel] @@ -3299,6 +3327,13 @@ removeUser = do cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel) cuAlreadyPresentUsers convUpdate @?= [qUnqualified carl] + liftIO $ do + dConvUpdateRPC <- assertOne $ filter (matchFedRequest dDomain "/federation/on-conversation-updated") fedRequests + Just (Right convUpdate) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dConvUpdateRPC) + cuConvId convUpdate @?= convA2 + cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers convUpdate @?= [qUnqualified dwight] + -- Check memberships mems1 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA1 mems2 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA2 From 08362c884e63c7b514eda3fffe095a9fe1e4a8b7 Mon Sep 17 00:00:00 2001 From: Molly Miller <33266253+sysvinit@users.noreply.github.com> Date: Tue, 9 Nov 2021 17:23:22 +0100 Subject: [PATCH 78/88] Fix LD_LIBRARY_PATH usage in direnv build environment (#1918) * Only set LD_LIBRARY_PATH for cabal in direnv build environment. The .envrc used direnv's load_prefix function to make all the required tools and dependency libraries visible within the development environment, which sets a couple of environment variables in the dev shell including PATH and LD_LIBRARY_PATH. The latter is required so that cabal can find non-Haskell dependencies such as zlib and cryptobox. However, adding paths inside the Nix store to LD_LIBRARY_PATH can interfere with tools in the host system, especially on non-NixOS systems, as the dynamic loader will attempt to load dynamic libraries from the Nix store before those of the host system, which in some cases will cause some programs to fail to run due to dynamic symbol mismatches. This commit refactors the direnv build environment, splitting everything but cabal into a separate environment, and exposing cabal through a wrapper script which sets LD_LIBRARY_PATH appropriately only for cabal. Instead of load_prefix, the .envrc reverts to using PATH_add, to avoid introducing LD_LIBRARY_PATH into dev shell environments. Co-authored-by: Akshay Mankar Co-authored-by: Stefan Matting --- .envrc | 2 +- direnv.nix | 74 ++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 48 insertions(+), 28 deletions(-) diff --git a/.envrc b/.envrc index 1526ad22269..45436364165 100644 --- a/.envrc +++ b/.envrc @@ -1,5 +1,5 @@ env=$(nix-build --no-out-link "$PWD/direnv.nix") -load_prefix "${env}" +PATH_add "${env}/bin" # allow local .envrc overrides [[ -f .envrc.local ]] && source_env .envrc.local diff --git a/direnv.nix b/direnv.nix index 6a336217404..e91f6a7f5c5 100644 --- a/direnv.nix +++ b/direnv.nix @@ -108,8 +108,49 @@ let linuxAmd64Sha256 = "949f81b3c30ca03a3d4effdecda04f100fa3edc07a28b19400f72ede7c5f0491"; }; }; -in -pkgs.buildEnv { + + compile-deps = pkgs.buildEnv { + name = "wire-server-compile-deps"; + paths = [ + pkgs.pkgconfig + pkgs.protobuf + + pkgs.cryptobox + pkgs.geoip + pkgs.icu.dev + pkgs.icu.out + pkgs.libsodium.dev + pkgs.libsodium.out + pkgs.libxml2.dev + pkgs.libxml2.out + pkgs.ncurses.dev + pkgs.ncurses.out + pkgs.openssl.dev + pkgs.openssl.out + pkgs.pcre.dev + pkgs.pcre.out + pkgs.snappy.dev + pkgs.snappy.out + pkgs.zlib.dev + pkgs.zlib.out + pkgs.lzma.dev + pkgs.lzma.out + ]; + }; + + # This performs roughly the same setup as direnv's load_prefix function, but + # only when invoking cabal. This means that we can set LD_LIBRARY_PATH just + # for cabal, as setting it in direnv can interfere with programs in the host + # system, especially for non-NixOS users. + cabal-wrapper = pkgs.writeShellScriptBin "cabal" '' + export CPATH="${compile-deps}/include:$CPATH" + export LD_LIBRARY_PATH="${compile-deps}/lib:$LD_LIBRARY_PATH" + export LIBRARY_PATH="${compile-deps}/lib:$LIBRARY_PATH" + export PKG_CONFIG_PATH="${compile-deps}/lib/pkgconfig:$PKG_CONFIG_PATH" + export PATH="${compile-deps}/bin:$PATH" + exec "${pkgs.cabal-install}/bin/cabal" "$@" + ''; +in pkgs.buildEnv { name = "wire-server-direnv"; paths = [ pkgs.cfssl @@ -135,31 +176,10 @@ pkgs.buildEnv { # For cabal-migration pkgs.haskell.compiler.ghc884 - - pkgs.cabal-install pkgs.haskellPackages.cabal-plan - pkgs.pkgconfig - pkgs.protobuf - - pkgs.cryptobox - pkgs.geoip - pkgs.icu.dev - pkgs.icu.out - pkgs.libsodium.dev - pkgs.libsodium.out - pkgs.libxml2.dev - pkgs.libxml2.out - pkgs.ncurses.dev - pkgs.ncurses.out - pkgs.openssl.dev - pkgs.openssl.out - pkgs.pcre.dev - pkgs.pcre.out - pkgs.snappy.dev - pkgs.snappy.out - pkgs.zlib.dev - pkgs.zlib.out - pkgs.lzma.dev - pkgs.lzma.out + + # We don't use pkgs.cabal-install here, as we invoke it with a wrapper + # which sets LD_LIBRARY_PATH and others correctly. + cabal-wrapper ]; } From 6c3e5330ce4a57bddfeab70d2e307cb760ba17cc Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 9 Nov 2021 13:56:01 -0800 Subject: [PATCH 79/88] polysemy-check laws for IdP effect (#1863) Fix a bug in the IdP.Mem interpreter, and added law tests for IdP --- changelog.d/5-internal/polysemy-check-spar | 1 + services/spar/package.yaml | 1 + services/spar/spar.cabal | 4 +- services/spar/src/Spar/API.hs | 2 +- services/spar/src/Spar/App.hs | 5 +- services/spar/src/Spar/Sem/IdP.hs | 11 +- services/spar/src/Spar/Sem/IdP/Cassandra.hs | 9 +- services/spar/src/Spar/Sem/IdP/Mem.hs | 40 ++--- .../test-integration/Test/Spar/DataSpec.hs | 2 +- services/spar/test/Arbitrary.hs | 32 +++- services/spar/test/Test/Spar/Sem/IdPSpec.hs | 158 ++++++++++++++++++ stack.yaml | 3 + stack.yaml.lock | 7 + 13 files changed, 241 insertions(+), 34 deletions(-) create mode 100644 changelog.d/5-internal/polysemy-check-spar create mode 100644 services/spar/test/Test/Spar/Sem/IdPSpec.hs diff --git a/changelog.d/5-internal/polysemy-check-spar b/changelog.d/5-internal/polysemy-check-spar new file mode 100644 index 00000000000..bd9600b4fd7 --- /dev/null +++ b/changelog.d/5-internal/polysemy-check-spar @@ -0,0 +1 @@ +Fix a bug in the IdP.Mem interpreter, and added law tests for IdP diff --git a/services/spar/package.yaml b/services/spar/package.yaml index 312376a6ae5..fc27e3fb8a1 100644 --- a/services/spar/package.yaml +++ b/services/spar/package.yaml @@ -99,6 +99,7 @@ tests: - QuickCheck - spar - uri-bytestring + - polysemy-check executables: spar: diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index e23c70faad2..546c6c75f32 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e1e1abfd9d2fd00bd96a693a9466a13e0b7aef15677f0506941f662094a340a1 +-- hash: a0e25b55baaade0d8e5c5317b255ef5191d861abfde4369ef34ffb6d77bc8e0d name: spar version: 0.1 @@ -499,6 +499,7 @@ test-suite spec Test.Spar.Intra.BrigSpec Test.Spar.Roundtrip.ByteString Test.Spar.ScimSpec + Test.Spar.Sem.IdPSpec Test.Spar.TypesSpec Paths_spar hs-source-dirs: @@ -547,6 +548,7 @@ test-suite spec , network-uri , optparse-applicative , polysemy + , polysemy-check , polysemy-plugin , raw-strings-qq , retry diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index dddd5b8c653..9b2adccefe6 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -461,7 +461,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons when (stiIdP == Just idpid) $ ScimTokenStore.delete team stiId -- Delete IdP config do - IdPEffect.deleteConfig idpid issuer team + IdPEffect.deleteConfig idp IdPEffect.deleteRawMetadata idpid return NoContent where diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 87daf33352f..926c466e366 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -763,10 +763,9 @@ deleteTeam team = do -- used by the team, and remove everything related to those IdPs, too. idps <- IdPEffect.getConfigsByTeam team for_ idps $ \idp -> do - let idpid = idp ^. SAML.idpId - issuer = idp ^. SAML.idpMetadata . SAML.edIssuer + let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer SAMLUserStore.deleteByIssuer issuer - IdPEffect.deleteConfig idpid issuer team + IdPEffect.deleteConfig idp sparToServerErrorWithLogging :: Member Reporter r => SparError -> Sem r ServerError sparToServerErrorWithLogging err = do diff --git a/services/spar/src/Spar/Sem/IdP.hs b/services/spar/src/Spar/Sem/IdP.hs index 946561fe7a3..f9889e5fc03 100644 --- a/services/spar/src/Spar/Sem/IdP.hs +++ b/services/spar/src/Spar/Sem/IdP.hs @@ -18,11 +18,13 @@ data GetIdPResult a | -- | An IdP was found, but it lives in another team than the one you were looking for. -- This should be handled similarly to NotFound in most cases. GetIdPWrongTeam SAML.IdPId - deriving (Eq, Show) + deriving (Eq, Show, Generic) newtype Replaced = Replaced SAML.IdPId + deriving (Eq, Ord, Show) newtype Replacing = Replacing SAML.IdPId + deriving (Eq, Ord, Show) data IdP m a where StoreConfig :: IP.IdP -> IdP m () @@ -30,14 +32,17 @@ data IdP m a where GetIdByIssuerWithoutTeam :: SAML.Issuer -> IdP m (GetIdPResult SAML.IdPId) GetIdByIssuerWithTeam :: SAML.Issuer -> TeamId -> IdP m (Maybe SAML.IdPId) GetConfigsByTeam :: TeamId -> IdP m [IP.IdP] - DeleteConfig :: SAML.IdPId -> SAML.Issuer -> TeamId -> IdP m () + DeleteConfig :: IP.IdP -> IdP m () + -- affects _wiReplacedBy in GetConfig SetReplacedBy :: Replaced -> Replacing -> IdP m () ClearReplacedBy :: Replaced -> IdP m () -- TODO(sandy): maybe this wants to be a separate effect - -- data Metadata m a wher e + -- data Metadata m a where StoreRawMetadata :: SAML.IdPId -> Text -> IdP m () GetRawMetadata :: SAML.IdPId -> IdP m (Maybe Text) DeleteRawMetadata :: SAML.IdPId -> IdP m () +deriving stock instance Show (IdP m a) + -- TODO(sandy): Inline this definition --- no TH makeSem ''IdP diff --git a/services/spar/src/Spar/Sem/IdP/Cassandra.hs b/services/spar/src/Spar/Sem/IdP/Cassandra.hs index 286eb2301ee..14e2a8d526b 100644 --- a/services/spar/src/Spar/Sem/IdP/Cassandra.hs +++ b/services/spar/src/Spar/Sem/IdP/Cassandra.hs @@ -1,10 +1,13 @@ module Spar.Sem.IdP.Cassandra where import Cassandra +import Control.Lens ((^.)) import Imports import Polysemy +import qualified SAML2.WebSSO.Types as SAML import qualified Spar.Data as Data import Spar.Sem.IdP +import Wire.API.User.IdentityProvider (wiTeam) idPToCassandra :: forall m r a. @@ -19,7 +22,11 @@ idPToCassandra = GetIdByIssuerWithoutTeam i -> Data.getIdPIdByIssuerWithoutTeam i GetIdByIssuerWithTeam i t -> Data.getIdPIdByIssuerWithTeam i t GetConfigsByTeam itlt -> Data.getIdPConfigsByTeam itlt - DeleteConfig i i11 itlt -> Data.deleteIdPConfig i i11 itlt + DeleteConfig idp -> + let idpid = idp ^. SAML.idpId + issuer = idp ^. SAML.idpMetadata . SAML.edIssuer + team = idp ^. SAML.idpExtraInfo . wiTeam + in Data.deleteIdPConfig idpid issuer team SetReplacedBy r r11 -> Data.setReplacedBy r r11 ClearReplacedBy r -> Data.clearReplacedBy r StoreRawMetadata i t -> Data.storeIdPRawMetadata i t diff --git a/services/spar/src/Spar/Sem/IdP/Mem.hs b/services/spar/src/Spar/Sem/IdP/Mem.hs index 154bdda142d..600fb03d4cb 100644 --- a/services/spar/src/Spar/Sem/IdP/Mem.hs +++ b/services/spar/src/Spar/Sem/IdP/Mem.hs @@ -1,8 +1,7 @@ {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -module Spar.Sem.IdP.Mem (idPToMem) where +module Spar.Sem.IdP.Mem (idPToMem, IS) where -import Control.Exception (assert) import Control.Lens ((%~), (.~), (^.), _1, _2) import Data.Id (TeamId) import qualified Data.Map as M @@ -22,11 +21,11 @@ type RawState = Map SAML.IdPId Text idPToMem :: forall r a. Sem (Eff.IdP ': r) a -> - Sem r a + Sem r (IS, a) idPToMem = evState . evEff where - evState :: Sem (State IS : r) a -> Sem r a - evState = evalState mempty + evState :: Sem (State IS : r) a -> Sem r (IS, a) + evState = runState mempty evEff :: Sem (Eff.IdP ': r) a -> Sem (State IS ': r) a evEff = reinterpret @_ @(State IS) $ \case @@ -40,8 +39,8 @@ idPToMem = evState . evEff gets (getIdByIssuerWithTeam iss team . (^. _1)) Eff.GetConfigsByTeam team -> gets (getConfigsByTeam team . (^. _1)) - Eff.DeleteConfig i iss team -> - modify' (_1 %~ deleteConfig i iss team) + Eff.DeleteConfig idp -> + modify' (_1 %~ deleteConfig idp) Eff.SetReplacedBy (Eff.Replaced replaced) (Eff.Replacing replacing) -> modify' (_1 %~ ((updateReplacedBy (Just replacing) replaced) <$>)) Eff.ClearReplacedBy (Eff.Replaced replaced) -> @@ -55,14 +54,14 @@ idPToMem = evState . evEff storeConfig :: IP.IdP -> TypedState -> TypedState storeConfig iw = - M.filter - ( \iw' -> - or - [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer, - iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam - ] - ) - . M.insert (iw ^. SAML.idpId) iw + M.insert (iw ^. SAML.idpId) iw + . M.filter + ( \iw' -> + or + [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer, + iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam + ] + ) getConfig :: SAML.IdPId -> TypedState -> Maybe IP.IdP getConfig = M.lookup @@ -95,17 +94,12 @@ getConfigsByTeam team = fl :: IP.IdP -> Bool fl idp = idp ^. SAML.idpExtraInfo . IP.wiTeam == team -deleteConfig :: SAML.IdPId -> SAML.Issuer -> TeamId -> TypedState -> TypedState -deleteConfig i iss team = +deleteConfig :: IP.IdP -> TypedState -> TypedState +deleteConfig idp = M.filter fl where fl :: IP.IdP -> Bool - fl idp = - assert -- calling this function with inconsistent values will crash hard. - ( idp ^. SAML.idpMetadata . SAML.edIssuer == iss - && idp ^. SAML.idpExtraInfo . IP.wiTeam == team - ) - (idp ^. SAML.idpId /= i) + fl idp' = idp' ^. SAML.idpId /= idp ^. SAML.idpId updateReplacedBy :: Maybe SAML.IdPId -> SAML.IdPId -> IP.IdP -> IP.IdP updateReplacedBy mbReplacing replaced idp = diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 2c66752773d..4bd1547b385 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -200,7 +200,7 @@ spec = do do midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Just idp - () <- runSpar $ IdPEffect.deleteConfig (idp ^. idpId) (idp ^. idpMetadata . edIssuer) teamid + () <- runSpar $ IdPEffect.deleteConfig idp do midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Nothing diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index f48e5722fc5..bc7ca9fae4e 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -23,15 +23,18 @@ module Arbitrary where import Data.Aeson -import Data.Id () +import Data.Id (TeamId) import Data.Proxy import Data.String.Conversions (cs) import Data.Swagger hiding (Header (..)) import Imports import SAML2.WebSSO.Test.Arbitrary () +import SAML2.WebSSO.Types import Servant.API.ContentTypes import Spar.Scim +import qualified Spar.Sem.IdP as E import Test.QuickCheck +import URI.ByteString import Wire.API.User.IdentityProvider import Wire.API.User.Saml @@ -85,3 +88,30 @@ instance ToJSON NoContent where instance ToSchema NoContent where declareNamedSchema _ = declareNamedSchema (Proxy @String) + +instance Arbitrary E.Replacing where + arbitrary = E.Replacing <$> arbitrary + +instance Arbitrary E.Replaced where + arbitrary = E.Replaced <$> arbitrary + +instance CoArbitrary a => CoArbitrary (E.GetIdPResult a) + +instance CoArbitrary IdPId + +instance CoArbitrary WireIdP + +instance CoArbitrary WireIdPAPIVersion + +instance CoArbitrary TeamId + +instance CoArbitrary Issuer where + coarbitrary (Issuer ur) = coarbitrary $ show ur + +instance CoArbitrary a => CoArbitrary (URIRef a) where + coarbitrary = coarbitrary . show + +instance CoArbitrary (IdPConfig WireIdP) + +instance CoArbitrary IdPMetadata where + coarbitrary = coarbitrary . show diff --git a/services/spar/test/Test/Spar/Sem/IdPSpec.hs b/services/spar/test/Test/Spar/Sem/IdPSpec.hs new file mode 100644 index 00000000000..de09081dab1 --- /dev/null +++ b/services/spar/test/Test/Spar/Sem/IdPSpec.hs @@ -0,0 +1,158 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Test.Spar.Sem.IdPSpec where + +import Arbitrary () +import Control.Lens +import Imports +import Polysemy +import Polysemy.Check +import qualified SAML2.WebSSO as SAML +import SAML2.WebSSO.Types +import qualified Spar.Sem.IdP as E +import Spar.Sem.IdP.Mem +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import qualified Wire.API.User.IdentityProvider as IdP + +deriveGenericK ''E.IdP + +prop_storeGet :: + Member E.IdP r => + (forall a. Sem r a -> IO (IS, a)) -> + Property +prop_storeGet x = + prepropLaw @'[E.IdP] + ( do + s <- arbitrary + pure + ( do + E.storeConfig s + E.getConfig $ s ^. idpId, + do + E.storeConfig s + pure (Just s) + ) + ) + x + +prop_storeGetRaw :: + Member E.IdP r => + (forall a. Sem r a -> IO (IS, a)) -> + Property +prop_storeGetRaw x = + prepropLaw @'[E.IdP] + ( do + idpid <- arbitrary + t <- arbitrary + pure + ( do + E.storeRawMetadata idpid t + E.getRawMetadata idpid, + do + E.storeRawMetadata idpid t + pure (Just t) + ) + ) + x + +prop_storeStoreRaw :: + Member E.IdP r => + (forall a. Sem r a -> IO (IS, a)) -> + Property +prop_storeStoreRaw x = + prepropLaw @'[E.IdP] + ( do + idpid <- arbitrary + t1 <- arbitrary + t2 <- arbitrary + pure + ( do + E.storeRawMetadata idpid t1 + E.storeRawMetadata idpid t2, + do + E.storeRawMetadata idpid t2 + ) + ) + x + +prop_storeDeleteRaw :: + Member E.IdP r => + (forall a. Sem r a -> IO (IS, a)) -> + Property +prop_storeDeleteRaw x = + prepropLaw @'[E.IdP] + ( do + idpid <- arbitrary + t <- arbitrary + pure + ( do + E.storeRawMetadata idpid t + E.deleteRawMetadata idpid, + do + E.deleteRawMetadata idpid + ) + ) + x + +prop_deleteGetRaw :: + Member E.IdP r => + (forall a. Sem r a -> IO (IS, a)) -> + Property +prop_deleteGetRaw x = + prepropLaw @'[E.IdP] + ( do + idpid <- arbitrary + pure + ( do + E.deleteRawMetadata idpid + E.getRawMetadata idpid, + do + E.deleteRawMetadata idpid + pure Nothing + ) + ) + x + +prop_storeGetByIssuer :: + Member E.IdP r => + (forall a. Sem r a -> IO (IS, a)) -> + Property +prop_storeGetByIssuer x = + prepropLaw @'[E.IdP] + ( do + s <- arbitrary + pure + ( do + E.storeConfig s + E.getIdByIssuerWithoutTeam $ s ^. idpMetadata . edIssuer, + do + E.storeConfig s + pure $ E.GetIdPFound $ s ^. idpId + ) + ) + x + +testInterpreter :: Sem '[E.IdP] a -> IO ((Map SAML.IdPId IdP.IdP, Map SAML.IdPId Text), a) +testInterpreter = pure . run . idPToMem + +propsForInterpreter :: + Member E.IdP r => + (forall a. Sem r a -> IO (IS, a)) -> + Spec +propsForInterpreter lower = do + describe "Config Actions" $ do + prop "storeConfig/getConfig" $ prop_storeGet lower + prop "storeConfig/getIdByIssuerWithoutTeam" $ prop_storeGetByIssuer lower + + describe "Raw Metadata Actions" $ do + prop "storeRawMetadata/storeRawMetadata" $ prop_storeStoreRaw lower + prop "storeRawMetadata/getRawMetadata" $ prop_storeGetRaw lower + prop "storeRawMetadata/deleteRawMetadata" $ prop_storeDeleteRaw lower + prop "deleteRawMetadata/getRawMetadata" $ prop_deleteGetRaw lower + +spec :: Spec +spec = modifyMaxSuccess (const 1000) $ do + propsForInterpreter testInterpreter diff --git a/stack.yaml b/stack.yaml index 2795b2949e1..28cd4ee7aa4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -254,6 +254,9 @@ extra-deps: subdirs: - x509-store +# Not on stackage yet +- polysemy-check-0.8.1.0 + ############################################################ # Development tools ############################################################ diff --git a/stack.yaml.lock b/stack.yaml.lock index abe6af55450..9c6dd2b653f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -804,6 +804,13 @@ packages: subdir: x509-store git: https://github.com/vincenthz/hs-certificate commit: a899bda3d7666d25143be7be8f3105fc076703d9 +- completed: + hackage: polysemy-check-0.8.1.0@sha256:5cce3ae162d2f8d8f629397daa28ec5e425f72d357afeb4fe994e102425f2383,2648 + pantry-tree: + size: 1027 + sha256: bc880fb3405307ed251c02358d604979d8014040b78c2ffe6319076431f93509 + original: + hackage: polysemy-check-0.8.1.0 - completed: hackage: ormolu-0.1.4.1@sha256:ed404eac6e4eb64da1ca5fb749e0f99907431a9633e6ba34e44d260e7d7728ba,6499 pantry-tree: From 488f8b5e1baf6b3625750ebc2b02d68b8ce301f8 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 10 Nov 2021 06:49:14 +0100 Subject: [PATCH 80/88] Galley polysemy (4/5) - Error effects (#1907) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Remove MonadThrow instance of Galley Most instance of throwing in the IO monad have now been replaced by the use of an explicit `Error` effect. Note, however, that some interpretation code is still throwing exceptions. * Throw error descriptions into Sem monad * Refactor ensureConnectedOrSameTeam * Introduce some fine-grained error effects * Split ConversationAction into several action types * Replace Wai.Error with fine-grained error types * Separate out NotATeamMember error * Add CHANGELOG entry * Remove an unnecessary ActionError data constructor * Update services/galley/src/Galley/API/Query.hs Remove a commented out function signature Co-authored-by: Marko Dimjašević --- changelog.d/5-internal/polysemy-errors | 1 + .../src/Wire/API/Federation/Client.hs | 1 + .../src/Wire/API/Federation/Error.hs | 1 + .../src/Wire/API/Conversation/Action.hs | 3 +- .../wire-api/src/Wire/API/ErrorDescription.hs | 9 +- services/galley/galley.cabal | 3 +- services/galley/src/Galley/API/Action.hs | 519 ++++++++ services/galley/src/Galley/API/Create.hs | 180 ++- .../galley/src/Galley/API/CustomBackend.hs | 29 +- services/galley/src/Galley/API/Error.hs | 267 +++- services/galley/src/Galley/API/Federation.hs | 177 +-- services/galley/src/Galley/API/Internal.hs | 39 +- services/galley/src/Galley/API/LegalHold.hs | 218 +++- services/galley/src/Galley/API/Mapping.hs | 22 +- services/galley/src/Galley/API/Query.hs | 71 +- services/galley/src/Galley/API/Teams.hs | 535 +++++--- .../galley/src/Galley/API/Teams/Features.hs | 115 +- .../src/Galley/API/Teams/Notifications.hs | 14 +- services/galley/src/Galley/API/Update.hs | 1096 ++++++++++------- services/galley/src/Galley/API/Util.hs | 373 +++--- services/galley/src/Galley/App.hs | 48 +- services/galley/src/Galley/Cassandra/Code.hs | 3 + services/galley/src/Galley/Effects.hs | 13 +- .../galley/src/Galley/Effects/CodeStore.hs | 11 +- .../src/Galley/External/LegalHoldService.hs | 21 +- services/galley/src/Galley/Validation.hs | 22 +- 26 files changed, 2650 insertions(+), 1141 deletions(-) create mode 100644 changelog.d/5-internal/polysemy-errors create mode 100644 services/galley/src/Galley/API/Action.hs diff --git a/changelog.d/5-internal/polysemy-errors b/changelog.d/5-internal/polysemy-errors new file mode 100644 index 00000000000..b7b8060ebf0 --- /dev/null +++ b/changelog.d/5-internal/polysemy-errors @@ -0,0 +1 @@ +Introduce fine-grained error types and polysemy error effects in Galley. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 608fac4d389..cb2cfc2522f 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -127,6 +127,7 @@ data FederationError | FederationNotImplemented | FederationNotConfigured | FederationCallFailure FederationClientFailure + | FederationUnexpectedBody Text deriving (Show, Eq, Typeable) instance Exception FederationError diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index 6aa875b608a..8b363936164 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -76,6 +76,7 @@ federationErrorToWai (FederationCallFailure failure) = addErrorData $ Wai.federrPath = T.decodeUtf8 (fedFailPath failure) } } +federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s noFederationStatus :: Status noFederationStatus = status403 diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index a7bf22c23b2..9080c867328 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -34,8 +34,7 @@ import Wire.API.Conversation.Role import Wire.API.Event.Conversation import Wire.API.Util.Aeson (CustomEncoded (..)) --- | An update to a conversation, including addition and removal of members. --- Used to send notifications to users and to remote backends. +-- | A sum type consisting of all possible conversation actions. data ConversationAction = ConversationActionAddMembers (NonEmpty (Qualified UserId)) RoleName | ConversationActionRemoveMembers (NonEmpty (Qualified UserId)) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 11f28240723..42363dc0e8c 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -226,10 +226,13 @@ noIdentity n = ErrorDescription (Text.pack (symbolVal (Proxy @desc)) <> " (code type OperationDenied = ErrorDescription 403 "operation-denied" "Insufficient permissions" -operationDenied :: Show perm => perm -> OperationDenied -operationDenied p = +operationDeniedSpecialized :: String -> OperationDenied +operationDeniedSpecialized p = ErrorDescription $ - "Insufficient permissions (missing " <> Text.pack (show p) <> ")" + "Insufficient permissions (missing " <> Text.pack p <> ")" + +operationDenied :: Show perm => perm -> OperationDenied +operationDenied = operationDeniedSpecialized . show type NotATeamMember = ErrorDescription 403 "no-team-member" "Requesting user is not a team member" diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 3efbf509124..7eeb2c3d6b9 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7c30fbe05e0beac371abdaab802319d909686c98a1b133508c984e021b2999ba +-- hash: 6f378c75d7938aa5f221f136049c8ca98f63e7ae682e0035fb912f3917cfd1b1 name: galley version: 0.83.0 @@ -25,6 +25,7 @@ flag static library exposed-modules: Galley.API + Galley.API.Action Galley.API.Clients Galley.API.Create Galley.API.CustomBackend diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs new file mode 100644 index 00000000000..4f3e508b11e --- /dev/null +++ b/services/galley/src/Galley/API/Action.hs @@ -0,0 +1,519 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.Action + ( -- * Conversation action class + IsConversationAction (..), + + -- * Conversation action types + ConversationDelete (..), + ConversationJoin (..), + ConversationLeave (..), + ConversationMemberUpdate (..), + + -- * Performing actions + updateLocalConversation, + + -- * Utilities + ensureConversationActionAllowed, + addMembersToLocalConversation, + notifyConversationAction, + ) +where + +import qualified Brig.Types.User as User +import Control.Lens +import Control.Monad.Trans.Maybe +import Data.Id +import Data.Kind +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Misc +import Data.Qualified +import qualified Data.Set as Set +import Data.Time.Clock +import Galley.API.Error +import Galley.API.Util +import Galley.App +import Galley.Data.Conversation +import Galley.Data.Services +import Galley.Data.Types +import Galley.Effects +import qualified Galley.Effects.BotAccess as E +import qualified Galley.Effects.BrigAccess as E +import qualified Galley.Effects.CodeStore as E +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.FederatorAccess as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.TeamStore as E +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Galley.Validation +import Imports +import Polysemy +import Polysemy.Error +import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation.Action +import Wire.API.Conversation.Role +import Wire.API.ErrorDescription +import Wire.API.Event.Conversation hiding (Conversation) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Client +import Wire.API.Team.LegalHold +import Wire.API.Team.Member + +-- | An update to a conversation, including addition and removal of members. +-- Used to send notifications to users and to remote backends. +class IsConversationAction a where + type HasConversationActionEffects a (r :: EffectRow) :: Constraint + + conversationAction :: a -> ConversationAction + ensureAllowed :: + (IsConvMember mem, HasConversationActionEffects a r) => + Local x -> + a -> + Conversation -> + mem -> + Galley r () + ensureAllowed _ _ _ _ = pure () + conversationActionTag' :: Qualified UserId -> a -> Action + performAction :: + ( HasConversationActionEffects a r, + Members '[ConversationStore] r + ) => + Qualified UserId -> + Local ConvId -> + Conversation -> + a -> + MaybeT (Galley r) (BotsAndMembers, a) + +-- | The action of some users joining a conversation. +data ConversationJoin = ConversationJoin + { cjUsers :: NonEmpty (Qualified UserId), + cjRole :: RoleName + } + +-- | The action of some users leaving a conversation. +newtype ConversationLeave = ConversationLeave + {clUsers :: NonEmpty (Qualified UserId)} + +-- | The action of promoting/demoting a member of a conversation. +data ConversationMemberUpdate = ConversationMemberUpdate + { cmuTarget :: Qualified UserId, + cmuUpdate :: OtherMemberUpdate + } + +-- | The action of deleting a conversation. +data ConversationDelete = ConversationDelete + +instance IsConversationAction ConversationJoin where + type + HasConversationActionEffects ConversationJoin r = + Members + '[ BrigAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r + + conversationAction cj = ConversationActionAddMembers (cjUsers cj) (cjRole cj) + ensureAllowed _ cj _ self = ensureConvRoleNotElevated self (cjRole cj) + conversationActionTag' _ _ = AddConversationMember + performAction qusr lcnv conv (ConversationJoin invited role) = do + let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited + + lift $ do + lusr <- liftSem $ ensureLocal lcnv qusr + ensureMemberLimit (toList (convLocalMembers conv)) newMembers + liftSem $ ensureAccess conv InviteAccess + checkLocals lusr (convTeam conv) (ulLocals newMembers) + checkRemotes lusr (ulRemotes newMembers) + checkLHPolicyConflictsLocal (ulLocals newMembers) + checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) + + addMembersToLocalConversation lcnv newMembers role + where + userIsMember u = (^. userId . to (== u)) + + checkLocals :: + Members + '[ BrigAccess, + Error ActionError, + Error ConversationError, + Error NotATeamMember, + TeamStore + ] + r => + Local UserId -> + Maybe TeamId -> + [UserId] -> + Galley r () + checkLocals lusr (Just tid) newUsers = do + tms <- liftSem $ E.selectTeamMembers tid newUsers + let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers + ensureAccessRole (convAccessRole conv) userMembershipMap + ensureConnectedOrSameTeam lusr newUsers + checkLocals lusr Nothing newUsers = do + ensureAccessRole (convAccessRole conv) (zip newUsers $ repeat Nothing) + ensureConnectedOrSameTeam lusr newUsers + + checkRemotes :: + Members '[BrigAccess, Error ActionError, Error FederationError, TeamStore] r => + Local UserId -> + [Remote UserId] -> + Galley r () + checkRemotes lusr remotes = do + -- if federator is not configured, we fail early, so we avoid adding + -- remote members to the database + unless (null remotes) $ do + endpoint <- federatorEndpoint + liftSem . when (isNothing endpoint) $ + throw FederationNotConfigured + ensureConnectedToRemotes lusr remotes + + checkLHPolicyConflictsLocal :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => + [UserId] -> + Galley r () + checkLHPolicyConflictsLocal newUsers = do + let convUsers = convLocalMembers conv + + allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers + + whenM (anyLegalholdActivated (lmId <$> convUsers)) $ + unless allNewUsersGaveConsent $ + liftSem $ throw MissingLegalholdConsent + + whenM (anyLegalholdActivated newUsers) $ do + unless allNewUsersGaveConsent $ + liftSem $ throw MissingLegalholdConsent + + convUsersLHStatus <- do + uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) + pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus + + if any + ( \(mem, status) -> + lmConvRoleName mem == roleNameWireAdmin + && consentGiven status == ConsentGiven + ) + convUsersLHStatus + then do + for_ convUsersLHStatus $ \(mem, status) -> + when (consentGiven status == ConsentNotGiven) $ do + qvictim <- qUntagged <$> qualifyLocal (lmId mem) + void . runMaybeT $ + updateLocalConversation lcnv qvictim Nothing $ + ConversationLeave (pure qvictim) + else liftSem $ throw MissingLegalholdConsent + + checkLHPolicyConflictsRemote :: + FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> + Galley r () + checkLHPolicyConflictsRemote _remotes = pure () + +instance IsConversationAction ConversationLeave where + type + HasConversationActionEffects ConversationLeave r = + (Members '[MemberStore] r) + conversationAction cl = ConversationActionRemoveMembers (clUsers cl) + conversationActionTag' qusr a + | pure qusr == clUsers a = LeaveConversation + | otherwise = RemoveConversationMember + performAction _qusr lcnv conv action = do + let presentVictims = filter (isConvMember lcnv conv) (toList (clUsers action)) + guard . not . null $ presentVictims + lift . liftSem $ E.deleteMembers (convId conv) (toUserList lcnv presentVictims) + pure (mempty, action) -- FUTUREWORK: should we return the filtered action here? + +instance IsConversationAction ConversationMemberUpdate where + type + HasConversationActionEffects ConversationMemberUpdate r = + (Members '[MemberStore, Error ConversationError] r) + conversationAction cmu = ConversationActionMemberUpdate (cmuTarget cmu) (cmuUpdate cmu) + conversationActionTag' _ _ = ModifyOtherConversationMember + performAction _qusr lcnv conv action = lift . liftSem $ do + void $ ensureOtherMember lcnv (cmuTarget action) conv + E.setOtherMember lcnv (cmuTarget action) (cmuUpdate action) + pure (mempty, action) + +instance IsConversationAction ConversationDelete where + type + HasConversationActionEffects ConversationDelete r = + Members '[Error FederationError, Error NotATeamMember, CodeStore, TeamStore] r + conversationAction ConversationDelete = ConversationActionDelete + ensureAllowed loc ConversationDelete conv self = + liftSem . for_ (convTeam conv) $ \tid -> do + lusr <- ensureLocal loc (convMemberId loc self) + void $ E.getTeamMember tid (tUnqualified lusr) >>= noteED @NotATeamMember + conversationActionTag' _ _ = DeleteConversation + performAction _ lcnv conv action = lift . liftSem $ do + key <- E.makeKey (tUnqualified lcnv) + E.deleteCode key ReusableCode + case convTeam conv of + Nothing -> E.deleteConversation (tUnqualified lcnv) + Just tid -> E.deleteTeamConversation tid (tUnqualified lcnv) + pure (mempty, action) + +instance IsConversationAction ConversationRename where + type + HasConversationActionEffects ConversationRename r = + Members '[Error ActionError, Error InvalidInput] r + + conversationAction = ConversationActionRename + conversationActionTag' _ _ = ModifyConversationName + performAction _ lcnv _ action = lift . liftSem $ do + cn <- rangeChecked (cupName action) + E.setConversationName (tUnqualified lcnv) cn + pure (mempty, action) + +instance IsConversationAction ConversationMessageTimerUpdate where + type HasConversationActionEffects ConversationMessageTimerUpdate r = () + conversationAction = ConversationActionMessageTimerUpdate + conversationActionTag' _ _ = ModifyConversationMessageTimer + performAction _ lcnv conv action = do + guard $ convMessageTimer conv /= cupMessageTimer action + lift . liftSem $ E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) + pure (mempty, action) + +instance IsConversationAction ConversationReceiptModeUpdate where + type HasConversationActionEffects ConversationReceiptModeUpdate r = () + conversationAction = ConversationActionReceiptModeUpdate + conversationActionTag' _ _ = ModifyConversationReceiptMode + performAction _ lcnv conv action = do + guard $ convReceiptMode conv /= Just (cruReceiptMode action) + lift . liftSem $ E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) + pure (mempty, action) + +instance IsConversationAction ConversationAccessData where + type + HasConversationActionEffects ConversationAccessData r = + Members + '[ BotAccess, + BrigAccess, + CodeStore, + Error ActionError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r + conversationAction = ConversationActionAccessUpdate + ensureAllowed _ target conv self = do + -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and + -- so on; users are not supposed to be able to make other conversations + -- have 'PrivateAccessRole' + liftSem $ + when + ( PrivateAccess `elem` cupAccess target + || PrivateAccessRole == cupAccessRole target + ) + $ throw InvalidTargetAccess + -- Team conversations incur another round of checks + case convTeam conv of + Just _ -> do + -- Access mode change might result in members being removed from the + -- conversation, so the user must have the necessary permission flag + ensureActionAllowed RemoveConversationMember self + Nothing -> + liftSem $ + when (cupAccessRole target == TeamAccessRole) $ + throw InvalidTargetAccess + conversationActionTag' _ _ = ModifyConversationAccess + performAction qusr lcnv conv action = do + guard $ convAccessData conv /= action + -- Remove conversation codes if CodeAccess is revoked + when + ( CodeAccess `elem` convAccess conv + && CodeAccess `notElem` cupAccess action + ) + $ lift $ do + key <- mkKey (tUnqualified lcnv) + liftSem $ E.deleteCode key ReusableCode + + -- Determine bots and members to be removed + let filterBotsAndMembers = filterActivated >=> filterTeammates + let current = convBotsAndMembers conv -- initial bots and members + desired <- lift . liftSem $ filterBotsAndMembers current -- desired bots and members + let toRemove = bmDiff current desired -- bots and members to be removed + + -- Update Cassandra + lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) action + lift . fireAndForget $ do + -- Remove bots + traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) + + -- Update current bots and members + let current' = current {bmBots = bmBots desired} + + -- Remove users and notify everyone + void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do + let rAction = ConversationLeave usersToRemove + void . runMaybeT $ performAction qusr lcnv conv rAction + notifyConversationAction qusr Nothing lcnv current' (conversationAction rAction) + pure (mempty, action) + where + filterActivated :: Member BrigAccess r => BotsAndMembers -> Sem r BotsAndMembers + filterActivated bm + | convAccessRole conv > ActivatedAccessRole + && cupAccessRole action <= ActivatedAccessRole = do + activated <- map User.userId <$> E.lookupActivatedUsers (toList (bmLocals bm)) + -- FUTUREWORK: should we also remove non-activated remote users? + pure $ bm {bmLocals = Set.fromList activated} + | otherwise = pure bm + + filterTeammates :: Member TeamStore r => BotsAndMembers -> Sem r BotsAndMembers + filterTeammates bm = do + -- In a team-only conversation we also want to remove bots and guests + case (cupAccessRole action, convTeam conv) of + (TeamAccessRole, Just tid) -> do + onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> + isJust <$> E.getTeamMember tid user + pure $ + BotsAndMembers + { bmLocals = Set.fromList onlyTeamUsers, + bmBots = mempty, + bmRemotes = mempty + } + _ -> pure bm + +-- | Update a local conversation, and notify all local and remote members. +updateLocalConversation :: + ( IsConversationAction a, + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r, + HasConversationActionEffects a r + ) => + Local ConvId -> + Qualified UserId -> + Maybe ConnId -> + a -> + MaybeT (Galley r) Event +updateLocalConversation lcnv qusr con action = do + -- retrieve conversation + (conv, self) <- + lift $ + getConversationAndMemberWithError ConvNotFound qusr (tUnqualified lcnv) + + -- perform checks + lift $ ensureConversationActionAllowed lcnv action conv self + + -- perform action + (extraTargets, action') <- performAction qusr lcnv conv action + + -- send notifications to both local and remote users + lift $ + notifyConversationAction + qusr + con + lcnv + (convBotsAndMembers conv <> extraTargets) + (conversationAction action') + +-------------------------------------------------------------------------------- +-- Utilities + +ensureConversationActionAllowed :: + ( IsConvMember mem, + IsConversationAction a, + HasConversationActionEffects a r, + Members '[Error ActionError, Error InvalidInput] r + ) => + Local x -> + a -> + Conversation -> + mem -> + Galley r () +ensureConversationActionAllowed loc action conv self = do + let tag = conversationActionTag' (convMemberId loc self) action + -- general action check + ensureActionAllowed tag self + -- check if it is a group conversation (except for rename actions) + when (tag /= ModifyConversationName) $ + liftSem $ ensureGroupConversation conv + -- extra action-specific checks + ensureAllowed loc action conv self + +-- | Add users to a conversation without performing any checks. Return extra +-- notification targets and the action performed. +addMembersToLocalConversation :: + Members '[MemberStore] r => + Local ConvId -> + UserList UserId -> + RoleName -> + MaybeT (Galley r) (BotsAndMembers, ConversationJoin) +addMembersToLocalConversation lcnv users role = do + (lmems, rmems) <- lift . liftSem $ E.createMembers (tUnqualified lcnv) (fmap (,role) users) + neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users + let action = ConversationJoin neUsers role + pure (bmFromMembers lmems rmems, action) + +notifyConversationAction :: + Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => + Qualified UserId -> + Maybe ConnId -> + Local ConvId -> + BotsAndMembers -> + ConversationAction -> + Galley r Event +notifyConversationAction quid con (qUntagged -> qcnv) targets action = do + localDomain <- viewFederationDomain + now <- liftIO getCurrentTime + let e = conversationActionToEvent now quid qcnv action + + -- notify remote participants + liftSem $ + E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + F.onConversationUpdated F.clientRoutes localDomain $ + F.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action + + -- notify local participants and bots + pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index ee86e14933e..8c4b698bf38 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - module Galley.API.Create ( createGroupConversation, internalCreateManagedConversationH, @@ -25,7 +24,6 @@ module Galley.API.Create where import Control.Lens hiding ((??)) -import Control.Monad.Catch import Data.Id import Data.List1 (list1) import Data.Misc (FutureWork (FutureWork)) @@ -54,13 +52,15 @@ import Galley.Validation import Imports hiding ((\\)) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public -import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.ErrorDescription import Wire.API.Event.Conversation hiding (Conversation) -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Client import Wire.API.Routes.Public.Galley (ConversationResponse) import Wire.API.Routes.Public.Util import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) @@ -75,6 +75,13 @@ createGroupConversation :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -96,6 +103,13 @@ internalCreateManagedConversationH :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -112,6 +126,13 @@ internalCreateManagedConversation :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -123,12 +144,11 @@ internalCreateManagedConversation :: NewConvManaged -> Galley r ConversationResponse internalCreateManagedConversation zusr zcon (NewConvManaged body) = do - case newConvTeam body of - Nothing -> throwM internalError - Just tinfo -> createTeamGroupConv zusr zcon tinfo body + tinfo <- liftSem $ note CannotCreateManagedConv (newConvTeam body) + createTeamGroupConv zusr zcon tinfo body ensureNoLegalholdConflicts :: - Members '[LegalHoldStore, TeamStore] r => + Members '[Error LegalHoldError, LegalHoldStore, TeamStore] r => [Remote UserId] -> [UserId] -> Galley r () @@ -136,7 +156,7 @@ ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - throwErrorDescriptionType @MissingLegalholdConsent + liftSem $ throw MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: @@ -144,6 +164,10 @@ createRegularGroupConv :: '[ ConversationStore, BrigAccess, FederatorAccess, + Error ActionError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, GundeckAccess, LegalHoldStore, TeamStore @@ -155,9 +179,10 @@ createRegularGroupConv :: Galley r ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do lusr <- qualifyLocal zusr - name <- rangeCheckedMaybe (newConvName body) + name <- liftSem $ rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body - checkedUsers <- checkedConvSize allUsers + o <- view options + checkedUsers <- liftSem $ checkedConvSize o allUsers ensureConnected lusr allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- @@ -184,6 +209,13 @@ createTeamGroupConv :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -197,13 +229,14 @@ createTeamGroupConv :: Galley r ConversationResponse createTeamGroupConv zusr zcon tinfo body = do lusr <- qualifyLocal zusr - name <- rangeCheckedMaybe (newConvName body) + name <- liftSem $ rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo zusrMembership <- liftSem $ E.getTeamMember convTeam zusr void $ permissionCheck CreateConversation zusrMembership - checkedUsers <- checkedConvSize allUsers + o <- view options + checkedUsers <- liftSem $ checkedConvSize o allUsers convLocalMemberships <- mapM (liftSem . E.getTeamMember convTeam) (ulLocals allUsers) ensureAccessRole (accessRole body) (zip (ulLocals allUsers) convLocalMemberships) -- In teams we don't have 1:1 conversations, only regular conversations. We want @@ -247,7 +280,7 @@ createTeamGroupConv zusr zcon tinfo body = do -- Other kinds of conversations createSelfConversation :: - Member ConversationStore r => + Members '[ConversationStore, Error InternalError] r => UserId -> Galley r ConversationResponse createSelfConversation zusr = do @@ -264,6 +297,13 @@ createOne2OneConversation :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, TeamStore @@ -276,12 +316,12 @@ createOne2OneConversation :: createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do lusr <- qualifyLocal zusr let allUsers = newConvMembers lusr j - other <- ensureOne (ulAll lusr allUsers) - when (qUntagged lusr == other) $ - throwM (invalidOp "Cannot create a 1-1 with yourself") + other <- liftSem $ ensureOne (ulAll lusr allUsers) + liftSem . when (qUntagged lusr == other) $ + throw . InvalidOp $ One2OneConv mtid <- case newConvTeam j of Just ti - | cnvManaged ti -> throwM noManagedTeamConv + | cnvManaged ti -> liftSem $ throw NoManagedTeamConv | otherwise -> do foldQualified lusr @@ -289,7 +329,7 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do (const (pure Nothing)) other Nothing -> ensureConnected lusr allUsers $> Nothing - n <- rangeCheckedMaybe (newConvName j) + n <- liftSem $ rangeCheckedMaybe (newConvName j) foldQualified lusr (createLegacyOne2OneConversationUnchecked lusr zcon n mtid) @@ -299,8 +339,8 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do verifyMembership :: TeamId -> UserId -> Galley r () verifyMembership tid u = do membership <- liftSem $ E.getTeamMember tid u - when (isNothing membership) $ - throwM noBindingTeamMembers + liftSem . when (isNothing membership) $ + throw NoBindingTeamMembers checkBindingTeamPermissions :: Local UserId -> Local UserId -> @@ -314,11 +354,19 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do verifyMembership tid (tUnqualified lusr) verifyMembership tid (tUnqualified lother) pure (Just tid) - Just _ -> throwM nonBindingTeam - Nothing -> throwM teamNotFound + Just _ -> liftSem $ throw NotABindingTeamMember + Nothing -> liftSem $ throw TeamNotFound createLegacyOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error ActionError, + Error InternalError, + Error InvalidInput, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -337,7 +385,14 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error FederationError, + Error InternalError, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -353,7 +408,7 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, Error InternalError, FederatorAccess, GundeckAccess] r => Local ConvId -> Local UserId -> ConnId -> @@ -371,6 +426,7 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationRemotely :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> @@ -379,10 +435,22 @@ createOne2OneConversationRemotely :: Qualified UserId -> Galley r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = - throwM federationNotImplemented + liftSem $ + throw FederationNotImplemented createConnectConversation :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> Connect -> @@ -396,15 +464,27 @@ createConnectConversation usr conn j = do (cRecipient j) createConnectConversationWithRemote :: + Member (Error FederationError) r => Local UserId -> Maybe ConnId -> Remote UserId -> Galley r ConversationResponse createConnectConversationWithRemote _ _ _ = - throwM federationNotImplemented + liftSem $ + throw FederationNotImplemented createLegacyConnectConversation :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error InternalError, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local UserId -> Maybe ConnId -> Local UserId -> @@ -412,7 +492,7 @@ createLegacyConnectConversation :: Galley r ConversationResponse createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) - n <- rangeCheckedMaybe (cName j) + n <- liftSem $ rangeCheckedMaybe (cName j) conv <- liftSem $ E.getConversation (Data.localOne2OneConvId x y) maybe (create x y n) (update n) conv where @@ -474,10 +554,18 @@ createLegacyConnectConversation lusr conn lrecipient j = do ------------------------------------------------------------------------------- -- Helpers -conversationCreated :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationCreated :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv -conversationExisted :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationExisted :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationExisted usr cnv = Existed <$> conversationView usr cnv handleConversationResponse :: ConversationResponse -> Response @@ -486,7 +574,7 @@ handleConversationResponse = \case Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) notifyCreatedConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[Error InternalError, FederatorAccess, GundeckAccess] r => Maybe UTCTime -> UserId -> Maybe ConnId -> @@ -517,15 +605,23 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -localOne2OneConvId :: Local UserId -> Local UserId -> Galley r (Local ConvId) +localOne2OneConvId :: + Member (Error InvalidInput) r => + Local UserId -> + Local UserId -> + Galley r (Local ConvId) localOne2OneConvId self other = do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) pure . qualifyAs self $ Data.localOne2OneConvId x y -toUUIDs :: UserId -> UserId -> Galley r (U.UUID U.V4, U.UUID U.V4) +toUUIDs :: + Member (Error InvalidInput) r => + UserId -> + UserId -> + Galley r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 - b' <- U.fromUUID (toUUID b) & ifNothing invalidUUID4 + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 & liftSem + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 & liftSem return (a', b') accessRole :: NewConv -> AccessRole @@ -541,6 +637,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: [a] -> Galley r a +ensureOne :: Member (Error InvalidInput) r => [a] -> Sem r a ensureOne [x] = pure x -ensureOne _ = throwM (invalidRange "One-to-one conversations can only have a single invited member") +ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index 9630ca6b4cb..52cfd656b5d 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -22,7 +22,6 @@ module Galley.API.CustomBackend ) where -import Control.Monad.Catch import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util @@ -32,27 +31,39 @@ import Galley.Types import Imports hiding ((\\)) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified Wire.API.CustomBackend as Public -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Galley r Response +getCustomBackendByDomainH :: + Members + '[ CustomBackendStore, + Error CustomBackendError + ] + r => + Domain ::: JSON -> + Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Member CustomBackendStore r => Domain -> Galley r Public.CustomBackend +getCustomBackendByDomain :: + Members '[CustomBackendStore, Error CustomBackendError] r => + Domain -> + Galley r Public.CustomBackend getCustomBackendByDomain domain = - liftSem (getCustomBackend domain) >>= \case - Nothing -> throwM (customBackendNotFound domain) - Just customBackend -> pure customBackend + liftSem $ + getCustomBackend domain >>= \case + Nothing -> throw (CustomBackendNotFound domain) + Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- internalPutCustomBackendByDomainH :: - Member CustomBackendStore r => + Members '[CustomBackendStore, Error InvalidInput] r => Domain ::: JsonRequest CustomBackend -> Galley r Response internalPutCustomBackendByDomainH (domain ::: req) = do diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 005b93f32f5..ab555dcff61 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -17,8 +17,8 @@ module Galley.API.Error where -import Control.Monad.Catch (MonadThrow (..)) import Data.Domain (Domain, domainText) +import Data.Id import Data.Proxy import Data.String.Conversions (cs) import Data.Text.Lazy as LT (pack) @@ -28,8 +28,249 @@ import Galley.Types.Teams (hardTruncationLimit) import Imports import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Polysemy +import qualified Polysemy.Error as P +import Polysemy.Internal (Append) import Servant.API.Status (KnownStatus (..)) +import Wire.API.Conversation (ConvType (..)) +import Wire.API.Conversation.Role (Action) import Wire.API.ErrorDescription +import Wire.API.Federation.Client +import Wire.API.Federation.Error + +---------------------------------------------------------------------------- +-- Fine-grained API error types + +class APIError e where + toWai :: e -> Error + +data InternalError + = BadConvState ConvId + | BadMemberState + | NoPrekeyForUser + | CannotCreateManagedConv + | DeleteQueueFull + | InternalErrorWithDescription LText + +instance APIError InternalError where + toWai (BadConvState convId) = badConvState convId + toWai BadMemberState = mkError status500 "bad-state" "Bad internal member state." + toWai NoPrekeyForUser = internalError + toWai CannotCreateManagedConv = internalError + toWai DeleteQueueFull = deleteQueueFull + toWai (InternalErrorWithDescription t) = internalErrorWithDescription t + +data ActionError + = InvalidAction + | InvalidTargetAccess + | InvalidTargetUserOp + | ActionDenied Action + | AccessDenied + | InvalidOp ConvType + | OperationDenied String + | NotConnected + | NoAddToManaged + | BroadcastLimitExceeded + | InvalidTeamStatusUpdate + | InvalidPermissions + +instance APIError ActionError where + toWai InvalidAction = invalidActions + toWai InvalidTargetAccess = errorDescriptionTypeToWai @InvalidTargetAccess + toWai (ActionDenied action) = errorDescriptionToWai (actionDenied action) + toWai AccessDenied = accessDenied + toWai (InvalidOp RegularConv) = invalidOp "invalid operation" + toWai (InvalidOp SelfConv) = invalidSelfOp + toWai (InvalidOp One2OneConv) = invalidOne2OneOp + toWai (InvalidOp ConnectConv) = invalidConnectOp + toWai (OperationDenied p) = errorDescriptionToWai $ operationDeniedSpecialized p + toWai NotConnected = errorDescriptionTypeToWai @NotConnected + toWai InvalidTargetUserOp = invalidTargetUserOp + toWai NoAddToManaged = noAddToManaged + toWai BroadcastLimitExceeded = broadcastLimitExceeded + toWai InvalidTeamStatusUpdate = invalidTeamStatusUpdate + toWai InvalidPermissions = invalidPermissions + +data CustomBackendError = CustomBackendNotFound Domain + +instance APIError CustomBackendError where + toWai (CustomBackendNotFound d) = customBackendNotFound d + +data InvalidInput + = CustomRolesNotSupported + | InvalidRange LText + | InvalidUUID4 + | BulkGetMemberLimitExceeded + | InvalidPayload LText + +instance APIError InvalidInput where + toWai CustomRolesNotSupported = badRequest "Custom roles not supported" + toWai (InvalidRange t) = invalidRange t + toWai InvalidUUID4 = invalidUUID4 + toWai BulkGetMemberLimitExceeded = bulkGetMemberLimitExceeded + toWai (InvalidPayload t) = invalidPayload t + +data AuthenticationError + = ReAuthFailed + +instance APIError AuthenticationError where + toWai ReAuthFailed = reAuthFailed + +data ConversationError + = ConvAccessDenied + | ConvNotFound + | TooManyMembers + | ConvMemberNotFound + | NoBindingTeamMembers + | NoManagedTeamConv + +instance APIError ConversationError where + toWai ConvAccessDenied = errorDescriptionTypeToWai @ConvAccessDenied + toWai ConvNotFound = errorDescriptionTypeToWai @ConvNotFound + toWai TooManyMembers = tooManyMembers + toWai ConvMemberNotFound = errorDescriptionTypeToWai @ConvMemberNotFound + toWai NoBindingTeamMembers = noBindingTeamMembers + toWai NoManagedTeamConv = noManagedTeamConv + +data TeamError + = NoBindingTeam + | NoAddToBinding + | NotABindingTeamMember + | NotAOneMemberTeam + | TeamNotFound + | TeamMemberNotFound + | TeamSearchVisibilityNotEnabled + | UserBindingExists + | TooManyTeamMembers + | CannotEnableLegalHoldServiceLargeTeam + +instance APIError TeamError where + toWai NoBindingTeam = noBindingTeam + toWai NoAddToBinding = noAddToBinding + toWai NotABindingTeamMember = nonBindingTeam + toWai NotAOneMemberTeam = notAOneMemberTeam + toWai TeamNotFound = teamNotFound + toWai TeamMemberNotFound = teamMemberNotFound + toWai TeamSearchVisibilityNotEnabled = teamSearchVisibilityNotEnabled + toWai UserBindingExists = userBindingExists + toWai TooManyTeamMembers = tooManyTeamMembers + toWai CannotEnableLegalHoldServiceLargeTeam = cannotEnableLegalHoldServiceLargeTeam + +data TeamFeatureError + = AppLockinactivityTimeoutTooLow + | LegalHoldFeatureFlagNotEnabled + | LegalHoldWhitelistedOnly + | DisableSsoNotImplemented + +instance APIError TeamFeatureError where + toWai AppLockinactivityTimeoutTooLow = inactivityTimeoutTooLow + toWai LegalHoldFeatureFlagNotEnabled = legalHoldFeatureFlagNotEnabled + toWai LegalHoldWhitelistedOnly = legalHoldWhitelistedOnly + toWai DisableSsoNotImplemented = disableSsoNotImplemented + +data TeamNotificationError + = InvalidTeamNotificationId + +instance APIError TeamNotificationError where + toWai InvalidTeamNotificationId = invalidTeamNotificationId + +instance APIError FederationError where + toWai = federationErrorToWai + +data LegalHoldError + = MissingLegalholdConsent + | NoUserLegalHoldConsent + | LegalHoldNotEnabled + | LegalHoldDisableUnimplemented + | LegalHoldServiceInvalidKey + | LegalHoldServiceBadResponse + | UserLegalHoldAlreadyEnabled + | LegalHoldServiceNotRegistered + | LegalHoldCouldNotBlockConnections + | UserLegalHoldIllegalOperation + | TooManyTeamMembersOnTeamWithLegalhold + | NoLegalHoldDeviceAllocated + | UserLegalHoldNotPending + +instance APIError LegalHoldError where + toWai MissingLegalholdConsent = errorDescriptionTypeToWai @MissingLegalholdConsent + toWai NoUserLegalHoldConsent = userLegalHoldNoConsent + toWai LegalHoldNotEnabled = legalHoldNotEnabled + toWai LegalHoldDisableUnimplemented = legalHoldDisableUnimplemented + toWai LegalHoldServiceInvalidKey = legalHoldServiceInvalidKey + toWai LegalHoldServiceBadResponse = legalHoldServiceBadResponse + toWai UserLegalHoldAlreadyEnabled = userLegalHoldAlreadyEnabled + toWai LegalHoldServiceNotRegistered = legalHoldServiceNotRegistered + toWai LegalHoldCouldNotBlockConnections = legalHoldCouldNotBlockConnections + toWai UserLegalHoldIllegalOperation = userLegalHoldIllegalOperation + toWai TooManyTeamMembersOnTeamWithLegalhold = tooManyTeamMembersOnTeamWithLegalhold + toWai NoLegalHoldDeviceAllocated = noLegalHoldDeviceAllocated + toWai UserLegalHoldNotPending = userLegalHoldNotPending + +data CodeError = CodeNotFound + +instance APIError CodeError where + toWai CodeNotFound = errorDescriptionTypeToWai @CodeNotFound + +data ClientError = UnknownClient + +instance APIError ClientError where + toWai UnknownClient = errorDescriptionTypeToWai @UnknownClient + +throwED :: + ( e ~ ErrorDescription code label desc, + KnownSymbol desc, + Member (P.Error e) r + ) => + Sem r a +throwED = P.throw mkErrorDescription + +noteED :: + forall e code label desc r a. + ( e ~ ErrorDescription code label desc, + KnownSymbol desc, + Member (P.Error e) r + ) => + Maybe a -> + Sem r a +noteED = P.note (mkErrorDescription :: e) + +type AllErrorEffects = + '[ P.Error ActionError, + P.Error AuthenticationError, + P.Error ClientError, + P.Error CodeError, + P.Error ConversationError, + P.Error CustomBackendError, + P.Error FederationError, + P.Error InternalError, + P.Error InvalidInput, + P.Error LegalHoldError, + P.Error TeamError, + P.Error TeamFeatureError, + P.Error TeamNotificationError, + P.Error NotATeamMember + ] + +mapAllErrors :: Member (P.Error Error) r => Sem (Append AllErrorEffects r) a -> Sem r a +mapAllErrors = + P.mapError errorDescriptionToWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + +---------------------------------------------------------------------------- +-- Error description integration errorDescriptionToWai :: forall (code :: Nat) (lbl :: Symbol) (desc :: Symbol). @@ -49,22 +290,8 @@ errorDescriptionTypeToWai :: Error errorDescriptionTypeToWai = errorDescriptionToWai (mkErrorDescription :: e) -throwErrorDescription :: - (KnownStatus code, KnownSymbol lbl, MonadThrow m) => - ErrorDescription code lbl desc -> - m a -throwErrorDescription = throwM . errorDescriptionToWai - -throwErrorDescriptionType :: - forall e (code :: Nat) (lbl :: Symbol) (desc :: Symbol) m a. - ( KnownStatus code, - KnownSymbol lbl, - KnownSymbol desc, - MonadThrow m, - e ~ ErrorDescription code lbl desc - ) => - m a -throwErrorDescriptionType = throwErrorDescription (mkErrorDescription :: e) +---------------------------------------------------------------------------- +-- Other errors internalError :: Error internalError = internalErrorWithDescription "internal error" @@ -123,6 +350,12 @@ noBindingTeam = mkError status403 "no-binding-team" "Operation allowed only on b notAOneMemberTeam :: Error notAOneMemberTeam = mkError status403 "not-one-member-team" "Can only delete teams with a single member." +badConvState :: ConvId -> Error +badConvState cid = + mkError status500 "bad-state" $ + "Connect conversation with more than 2 members: " + <> LT.pack (show cid) + bulkGetMemberLimitExceeded :: Error bulkGetMemberLimitExceeded = mkError diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index a6ba85d5758..348bec3dec9 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -18,25 +18,23 @@ module Galley.API.Federation where import Brig.Types.Connection (Relation (Accepted)) import Control.Lens (itraversed, (<.>)) -import Control.Monad.Catch (throwM) import Control.Monad.Trans.Maybe (runMaybeT) import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) -import Data.Domain +import Data.Domain (Domain) import Data.Id (ConvId, UserId) import Data.Json.Util (Base64ByteString (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) import Data.Qualified -import Data.Range +import Data.Range (Range (fromRange)) import qualified Data.Set as Set import qualified Data.Text.Lazy as LT -import Galley.API.Error (invalidPayload) +import Galley.API.Action +import Galley.API.Error import qualified Galley.API.Mapping as Mapping -import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtrMessage, sendLocalMessages) -import Galley.API.Update (notifyConversationMetadataUpdate) -import qualified Galley.API.Update as API +import Galley.API.Message import Galley.API.Util import Galley.App import qualified Galley.Data.Conversation as Data @@ -44,9 +42,10 @@ import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.MemberStore as E -import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) -import Galley.Types.UserList +import Galley.Types.Conversations.Members +import Galley.Types.UserList (UserList (UserList)) import Imports +import Polysemy.Error (Error, throw) import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) @@ -56,52 +55,41 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation -import Wire.API.Federation.API.Common -import Wire.API.Federation.API.Galley - ( ConversationUpdate (..), - GetConversationsRequest (..), - GetConversationsResponse (..), - LeaveConversationRequest (..), - LeaveConversationResponse (..), - MessageSendRequest (..), - MessageSendResponse (..), - NewRemoteConversation (..), - RemoteMessage (..), - UserDeletedConversationsNotification, - ) -import qualified Wire.API.Federation.API.Galley as FederationAPIGalley +import Wire.API.Federation.API.Common (EmptyResponse (..)) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Client import Wire.API.Routes.Internal.Brig.Connection -import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..)) -import Wire.API.ServantProto (FromProto (..)) +import Wire.API.Routes.Public.Galley.Responses +import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) (Galley GalleyEffects) +federationSitemap :: ServerT (ToServantApi F.Api) (Galley GalleyEffects) federationSitemap = genericServerT $ - FederationAPIGalley.Api - { FederationAPIGalley.onConversationCreated = onConversationCreated, - FederationAPIGalley.getConversations = getConversations, - FederationAPIGalley.onConversationUpdated = onConversationUpdated, - FederationAPIGalley.leaveConversation = leaveConversation, - FederationAPIGalley.onMessageSent = onMessageSent, - FederationAPIGalley.sendMessage = sendMessage, - FederationAPIGalley.onUserDeleted = onUserDeleted + F.Api + { F.onConversationCreated = onConversationCreated, + F.getConversations = getConversations, + F.onConversationUpdated = onConversationUpdated, + F.leaveConversation = leaveConversation, + F.onMessageSent = onMessageSent, + F.sendMessage = sendMessage, + F.onUserDeleted = onUserDeleted } onConversationCreated :: Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - NewRemoteConversation ConvId -> + F.NewRemoteConversation ConvId -> Galley r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () - let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (rcNonCreatorMembers rc))) + let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (F.rcNonCreatorMembers rc))) addedUserIds <- addLocalUsersToRemoteConv - (rcCnvId qrc) - (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrc)) + (F.rcCnvId qrc) + (qUntagged (F.rcRemoteOrigUserId qrc)) localUserIds let connectedMembers = @@ -112,30 +100,30 @@ onConversationCreated domain rc = do (const True) . omQualifiedId ) - (rcNonCreatorMembers rc) + (F.rcNonCreatorMembers rc) -- Make sure to notify only about local users connected to the adder - let qrcConnected = qrc {rcNonCreatorMembers = connectedMembers} + let qrcConnected = qrc {F.rcNonCreatorMembers = connectedMembers} forM_ (fromNewRemoteConversation loc qrcConnected) $ \(mem, c) -> do let event = Event ConvCreate - (qUntagged (rcCnvId qrcConnected)) - (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrcConnected)) - (rcTime qrcConnected) + (qUntagged (F.rcCnvId qrcConnected)) + (qUntagged (F.rcRemoteOrigUserId qrcConnected)) + (F.rcTime qrcConnected) (EdConversation c) pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] getConversations :: Member ConversationStore r => Domain -> - GetConversationsRequest -> - Galley r GetConversationsResponse -getConversations domain (GetConversationsRequest uid cids) = do + F.GetConversationsRequest -> + Galley r F.GetConversationsResponse +getConversations domain (F.GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain liftSem $ - GetConversationsResponse + F.GetConversationsResponse . mapMaybe (Mapping.conversationToRemote localDomain ruid) <$> E.getConversations cids @@ -147,12 +135,12 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai onConversationUpdated :: Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - ConversationUpdate -> + F.ConversationUpdate -> Galley r () onConversationUpdated requestingDomain cu = do localDomain <- viewFederationDomain loc <- qualifyLocal () - let rconvId = toRemoteUnsafe requestingDomain (cuConvId cu) + let rconvId = toRemoteUnsafe requestingDomain (F.cuConvId cu) qconvId = qUntagged rconvId -- Note: we generally do not send notifications to users that are not part of @@ -160,7 +148,7 @@ onConversationUpdated requestingDomain cu = do -- backend. See also the comment below. (presentUsers, allUsersArePresent) <- liftSem $ - E.selectRemoteMembers (cuAlreadyPresentUsers cu) rconvId + E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId -- Perform action, and determine extra notification targets. -- @@ -170,10 +158,10 @@ onConversationUpdated requestingDomain cu = do -- are not in the conversations are being removed or have their membership state -- updated, we do **not** add them to the list of targets, because we have no -- way to make sure that they are actually supposed to receive that notification. - (mActualAction, extraTargets) <- case cuAction cu of + (mActualAction, extraTargets) <- case F.cuAction cu of ConversationActionAddMembers toAdd role -> do let (localUsers, remoteUsers) = partitionQualified loc toAdd - addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (cuOrigUserId cu) localUsers + addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (F.cuOrigUserId cu) localUsers let allAddedUsers = map (qUntagged . qualifyAs loc) addedLocalUsers <> map qUntagged remoteUsers case allAddedUsers of [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. @@ -181,19 +169,19 @@ onConversationUpdated requestingDomain cu = do ConversationActionRemoveMembers toRemove -> liftSem $ do let localUsers = getLocalUsers localDomain toRemove E.deleteMembersInRemoteConversation rconvId localUsers - pure (Just $ cuAction cu, []) - ConversationActionRename _ -> pure (Just $ cuAction cu, []) - ConversationActionMessageTimerUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, []) - ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, []) + pure (Just $ F.cuAction cu, []) + ConversationActionRename _ -> pure (Just $ F.cuAction cu, []) + ConversationActionMessageTimerUpdate _ -> pure (Just $ F.cuAction cu, []) + ConversationActionMemberUpdate _ _ -> pure (Just $ F.cuAction cu, []) + ConversationActionReceiptModeUpdate _ -> pure (Just $ F.cuAction cu, []) + ConversationActionAccessUpdate _ -> pure (Just $ F.cuAction cu, []) ConversationActionDelete -> liftSem $ do E.deleteMembersInRemoteConversation rconvId presentUsers - pure (Just $ cuAction cu, []) + pure (Just $ F.cuAction cu, []) unless allUsersArePresent $ Log.warn $ - Log.field "conversation" (toByteString' (cuConvId cu)) + Log.field "conversation" (toByteString' (F.cuConvId cu)) . Log.field "domain" (toByteString' requestingDomain) . Log.msg ( "Attempt to send notification about conversation update \ @@ -203,7 +191,7 @@ onConversationUpdated requestingDomain cu = do -- Send notifications for_ mActualAction $ \action -> do - let event = conversationActionToEvent (cuTime cu) (cuOrigUserId cu) qconvId action + let event = conversationActionToEvent (F.cuTime cu) (F.cuOrigUserId cu) qconvId action targets = nubOrd $ presentUsers <> extraTargets -- FUTUREWORK: support bots? @@ -242,6 +230,11 @@ leaveConversation :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -252,19 +245,19 @@ leaveConversation :: ] r => Domain -> - LeaveConversationRequest -> - Galley r LeaveConversationResponse + F.LeaveConversationRequest -> + Galley r F.LeaveConversationResponse leaveConversation requestingDomain lc = do - let leaver = Qualified (lcLeaver lc) requestingDomain - lcnv <- qualifyLocal (lcConvId lc) + let leaver = Qualified (F.lcLeaver lc) requestingDomain + lcnv <- qualifyLocal (F.lcConvId lc) fmap - ( LeaveConversationResponse + ( F.LeaveConversationResponse . maybe (Left RemoveFromConversationErrorUnchanged) Right ) . runMaybeT . void - . API.updateLocalConversation lcnv leaver Nothing - . ConversationActionRemoveMembers + . updateLocalConversation lcnv leaver Nothing + . ConversationLeave . pure $ leaver @@ -273,23 +266,23 @@ leaveConversation requestingDomain lc = do onMessageSent :: Members '[BotAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - RemoteMessage ConvId -> + F.RemoteMessage ConvId -> Galley r () onMessageSent domain rmUnqualified = do let rm = fmap (toRemoteUnsafe domain) rmUnqualified - convId = qUntagged $ rmConversation rm + convId = qUntagged $ F.rmConversation rm msgMetadata = MessageMetadata - { mmNativePush = rmPush rm, - mmTransient = rmTransient rm, - mmNativePriority = rmPriority rm, - mmData = rmData rm + { mmNativePush = F.rmPush rm, + mmTransient = F.rmTransient rm, + mmNativePriority = F.rmPriority rm, + mmData = F.rmData rm } - recipientMap = userClientMap $ rmRecipients rm + recipientMap = userClientMap $ F.rmRecipients rm msgs = toMapOf (itraversed <.> itraversed) recipientMap (members, allMembers) <- liftSem $ - E.selectRemoteMembers (Map.keys recipientMap) (rmConversation rm) + E.selectRemoteMembers (Map.keys recipientMap) (F.rmConversation rm) unless allMembers $ Log.warn $ Log.field "conversation" (toByteString' (qUnqualified convId)) @@ -300,7 +293,16 @@ onMessageSent domain rmUnqualified = do ByteString ) localMembers <- sequence $ Map.fromSet mkLocalMember (Set.fromList members) - void $ sendLocalMessages (rmTime rm) (rmSender rm) (rmSenderClient rm) Nothing convId localMembers msgMetadata msgs + void $ + sendLocalMessages + (F.rmTime rm) + (F.rmSender rm) + (F.rmSenderClient rm) + Nothing + convId + localMembers + msgMetadata + msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 mkLocalMember :: UserId -> Galley r LocalMember @@ -319,6 +321,7 @@ sendMessage :: BrigAccess, ClientStore, ConversationStore, + Error InvalidInput, FederatorAccess, GundeckAccess, ExternalAccess, @@ -327,14 +330,14 @@ sendMessage :: ] r => Domain -> - MessageSendRequest -> - Galley r MessageSendResponse + F.MessageSendRequest -> + Galley r F.MessageSendResponse sendMessage originDomain msr = do - let sender = Qualified (msrSender msr) originDomain - msg <- either err pure (fromProto (fromBase64ByteString (msrRawMessage msr))) - MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (msrConvId msr) msg + let sender = Qualified (F.msrSender msr) originDomain + msg <- either err pure (fromProto (fromBase64ByteString (F.msrRawMessage msr))) + F.MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (F.msrConvId msr) msg where - err = throwM . invalidPayload . LT.pack + err = liftSem . throw . InvalidPayload . LT.pack onUserDeleted :: Members @@ -347,12 +350,12 @@ onUserDeleted :: ] r => Domain -> - UserDeletedConversationsNotification -> + F.UserDeletedConversationsNotification -> Galley r EmptyResponse onUserDeleted origDomain udcn = do - let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udcnUser udcn) + let deletedUser = toRemoteUnsafe origDomain (F.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser - convIds = FederationAPIGalley.udcnConversations udcn + convIds = F.udcnConversations udcn spawnMany $ fromRange convIds <&> \c -> do @@ -374,5 +377,5 @@ onUserDeleted origDomain udcn = do let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) botsAndMembers = convBotsAndMembers conv - void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action + void $ notifyConversationAction untaggedDeletedUser Nothing lc botsAndMembers action pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5e510f293b9..e37590085ea 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,7 +38,7 @@ import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients import qualified Galley.API.Create as Create import qualified Galley.API.CustomBackend as CustomBackend -import Galley.API.Error (throwErrorDescriptionType) +import Galley.API.Error import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import qualified Galley.API.One2One as One2One @@ -73,11 +73,12 @@ import Galley.Types.UserList import Imports hiding (head) import Network.HTTP.Types (status200) import Network.Wai -import Network.Wai.Predicate hiding (err) +import Network.Wai.Predicate hiding (Error, err) import qualified Network.Wai.Predicate as P import Network.Wai.Routing hiding (route, toList) -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) import Network.Wai.Utilities.ZAuth +import Polysemy.Error import Servant.API hiding (JSON) import qualified Servant.API as Servant import Servant.API.Generic @@ -87,7 +88,7 @@ import System.Logger.Class hiding (Path, name) import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.Conversation.Action (ConversationAction (ConversationActionRemoveMembers)) -import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley (ConversationUpdate (..), UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Federation.Client (FederationError) @@ -303,7 +304,15 @@ servantSitemap = iGetTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r + ) => (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -311,7 +320,15 @@ iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> @@ -628,11 +645,17 @@ safeForever funName action = threadDelay 60000000 -- pause to keep worst-case noise in logs manageable guardLegalholdPolicyConflictsH :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalHoldError, + Error InvalidInput, + TeamStore + ] + r => (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) - >>= either (const (throwErrorDescriptionType @MissingLegalholdConsent)) pure + >>= either (const (liftSem (throw MissingLegalholdConsent))) pure pure $ Network.Wai.Utilities.setStatus status200 empty diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 0a6015259e7..998ea8ed751 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -38,7 +38,6 @@ import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) import Control.Exception (assert) import Control.Lens (view, (^.)) -import Control.Monad.Catch import Data.ByteString.Conversion (toByteString, toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) @@ -69,20 +68,31 @@ import Imports import Network.HTTP.Types (status200, status404) import Network.HTTP.Types.Status (status201, status204) import Network.Wai -import Network.Wai.Predicate hiding (or, result, setStatus, _3) -import Network.Wai.Utilities as Wai +import Network.Wai.Predicate hiding (Error, or, result, setStatus, _3) +import Network.Wai.Utilities as Wai hiding (Error) +import Polysemy.Error import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) +import Wire.API.ErrorDescription +import Wire.API.Federation.Client import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public -assertLegalHoldEnabledForTeam :: Members '[LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () -assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ throwM legalHoldNotEnabled +assertLegalHoldEnabledForTeam :: + Members '[Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r () +assertLegalHoldEnabledForTeam tid = + unlessM (isLegalHoldEnabledForTeam tid) $ + liftSem $ throw LegalHoldNotEnabled -isLegalHoldEnabledForTeam :: Members '[LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r Bool +isLegalHoldEnabledForTeam :: + Members '[LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do @@ -99,7 +109,17 @@ isLegalHoldEnabledForTeam tid = do liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid createSettingsH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do @@ -107,7 +127,17 @@ createSettingsH (zusr ::: tid ::: req ::: _) = do setStatus status201 . json <$> createSettings zusr tid newService createSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Public.NewLegalHoldService -> @@ -122,21 +152,39 @@ createSettings zusr tid newService = do void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LHService.validateServiceKey (newLegalHoldServiceKey newService) - >>= maybe (throwM legalHoldServiceInvalidKey) pure + >>= liftSem . note LegalHoldServiceInvalidKey LHService.checkLegalHoldServiceStatus fpr (newLegalHoldServiceUrl newService) let service = legalHoldService tid fpr newService key liftSem $ LegalHoldData.createSettings service pure . viewLegalHoldService $ service getSettingsH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid getSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r Public.ViewLegalHoldService @@ -156,6 +204,14 @@ removeSettingsH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -183,6 +239,14 @@ removeSettings :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -212,13 +276,13 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Galley r () + assertNotWhitelisting :: Member (Error LegalHoldError) r => Galley r () assertNotWhitelisting = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure () FeatureLegalHoldDisabledByDefault -> pure () FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - throwM legalHoldDisableUnimplemented + liftSem $ throw LegalHoldDisableUnimplemented -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: @@ -230,6 +294,14 @@ removeSettings' :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -267,7 +339,7 @@ removeSettings' tid = -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team getUserStatusH :: - Members '[LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do @@ -275,13 +347,12 @@ getUserStatusH (_zusr ::: tid ::: uid ::: _) = do getUserStatus :: forall r. - Members '[LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do - mTeamMember <- liftSem $ getTeamMember tid uid - teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember + teamMember <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid let status = view legalHoldStatus teamMember (mlk, lcid) <- case status of UserLegalHoldNoConsent -> pure (Nothing, Nothing) @@ -299,7 +370,7 @@ getUserStatus tid uid = do "expected to find a prekey for user: " <> toByteString' uid <> " but none was found" - throwM internalError + liftSem $ throw NoPrekeyForUser Just lstKey -> pure lstKey let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey pure (Just lastKey, Just clientId) @@ -313,6 +384,13 @@ grantConsentH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -340,6 +418,13 @@ grantConsent :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -356,15 +441,14 @@ grantConsent :: grantConsent zusr tid = do userLHStatus <- liftSem $ - fmap (view legalHoldStatus) <$> getTeamMember tid zusr + note TeamMemberNotFound + =<< fmap (view legalHoldStatus) <$> getTeamMember tid zusr case userLHStatus of - Nothing -> - throwM teamMemberNotFound - Just lhs@UserLegalHoldNoConsent -> + lhs@UserLegalHoldNoConsent -> changeLegalholdStatus tid zusr lhs UserLegalHoldDisabled $> GrantConsentSuccess - Just UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted - Just UserLegalHoldPending -> pure GrantConsentAlreadyGranted - Just UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted + UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted + UserLegalHoldPending -> pure GrantConsentAlreadyGranted + UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted -- | Request to provision a device on the legal hold service for a user requestDeviceH :: @@ -373,6 +457,13 @@ requestDeviceH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -402,6 +493,13 @@ requestDevice :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -424,12 +522,12 @@ requestDevice zusr tid uid = do . Log.field "action" (Log.val "LegalHold.requestDevice") zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - member <- maybe (throwM teamMemberNotFound) pure =<< liftSem (getTeamMember tid uid) + member <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid case member ^. legalHoldStatus of - UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> liftSem $ throw UserLegalHoldAlreadyEnabled lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice lhs lhs@UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice lhs - UserLegalHoldNoConsent -> throwM userLegalHoldNoConsent + UserLegalHoldNoConsent -> liftSem $ throw NoUserLegalHoldConsent where -- Wire's LH service that galley is usually calling here is idempotent in device creation, -- ie. it returns the existing device on multiple calls to `/init`, like here: @@ -464,6 +562,14 @@ approveDeviceH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -488,6 +594,14 @@ approveDevice :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -510,7 +624,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.approveDevice") - unless (zusr == uid) (throwM accessDenied) + liftSem . unless (zusr == uid) $ throw AccessDenied assertOnTeam uid tid ensureReAuthorised zusr mPassword userLHStatus <- @@ -521,7 +635,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo (prekeys, lastPrekey') <- case mPreKeys of Nothing -> do Log.info $ Log.msg @Text "No prekeys found" - throwM noLegalHoldDeviceAllocated + liftSem $ throw NoLegalHoldDeviceAllocated Just keys -> pure keys clientId <- liftSem $ addLegalHoldClientToUser uid connId prekeys lastPrekey' -- Note: teamId could be passed in the getLegalHoldAuthToken request instead of lookup up again @@ -535,13 +649,13 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: UserLegalHoldStatus -> Galley r () - assertUserLHPending userLHStatus = do + assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Galley r () + assertUserLHPending userLHStatus = liftSem $ do case userLHStatus of - UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled UserLegalHoldPending -> pure () - UserLegalHoldDisabled -> throwM userLegalHoldNotPending - UserLegalHoldNoConsent -> throwM userLegalHoldNotPending + UserLegalHoldDisabled -> throw UserLegalHoldNotPending + UserLegalHoldNoConsent -> throw UserLegalHoldNotPending disableForUserH :: Members @@ -549,6 +663,14 @@ disableForUserH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -578,6 +700,14 @@ disableForUser :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -626,6 +756,13 @@ changeLegalholdStatus :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -673,12 +810,12 @@ changeLegalholdStatus tid uid old new = do blockNonConsentingConnections uid handleGroupConvPolicyConflicts uid new noop = pure () - illegal = throwM userLegalHoldIllegalOperation + illegal = liftSem $ throw UserLegalHoldIllegalOperation -- FUTUREWORK: make this async? blockNonConsentingConnections :: forall r. - Members '[BrigAccess, LegalHoldStore, TeamStore] r => + Members '[BrigAccess, Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamStore] r => UserId -> Galley r () blockNonConsentingConnections uid = do @@ -690,7 +827,7 @@ blockNonConsentingConnections uid = do [] -> pure () msgs@(_ : _) -> do Log.warn $ Log.msg @String msgs - throwM legalHoldCouldNotBlockConnections + liftSem $ throw LegalHoldCouldNotBlockConnections where findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] findConflicts conns = do @@ -757,6 +894,11 @@ handleGroupConvPolicyConflicts :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index e7ce9a86671..3d193b2f6c8 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -26,27 +26,32 @@ module Galley.API.Mapping ) where -import Control.Monad.Catch import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified +import Galley.API.Error import Galley.API.Util (qualifyLocal) import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Types (convId) import Galley.Types.Conversations.Members import Imports -import Network.HTTP.Types.Status -import Network.Wai.Utilities.Error +import Polysemy +import Polysemy.Error import qualified System.Logger.Class as Log import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member (..)) +import qualified Wire.API.Conversation as Conversation import Wire.API.Federation.API.Galley -- | View for a given user of a stored conversation. -- -- Throws "bad-state" when the user is not part of the conversation. -conversationView :: UserId -> Data.Conversation -> Galley r Conversation +conversationView :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r Conversation conversationView uid conv = do luid <- qualifyLocal uid let mbConv = conversationViewMaybe luid conv @@ -58,8 +63,7 @@ conversationView uid conv = do +++ idToText uid +++ val " is not a member of conv " +++ idToText (convId conv) - throwM badState - badState = mkError status500 "bad-state" "Bad internal member state." + liftSem $ throw BadMemberState -- | View for a given user of a stored conversation. -- @@ -131,9 +135,9 @@ conversationToRemote localDomain ruid conv = do -- | Convert a local conversation member (as stored in the DB) to a publicly -- facing 'Member' structure. -localMemberToSelf :: Local x -> LocalMember -> Member +localMemberToSelf :: Local x -> LocalMember -> Conversation.Member localMemberToSelf loc lm = - Member + Conversation.Member { memId = qUntagged . qualifyAs loc . lmId $ lm, memService = lmService lm, memOtrMutedStatus = msOtrMutedStatus st, diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index d395b1e4246..e8983fc1ff3 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -35,7 +35,6 @@ where import qualified Cassandra as C import Control.Lens (sequenceAOf) -import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS import Data.Code @@ -63,37 +62,36 @@ import Galley.Types.Conversations.Roles import Imports import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (result, setStatus) -import Network.Wai.Utilities -import qualified Network.Wai.Utilities.Error as Wai +import Network.Wai.Predicate hiding (Error, result, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified System.Logger.Class as Logger import UnliftIO (pooledForConcurrentlyN) import Wire.API.Conversation (ConversationCoverView (..)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public -import Wire.API.ErrorDescription (ConvNotFound) +import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley (gcresConvs) import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError, executeFederated) -import Wire.API.Federation.Error +import Wire.API.Federation.Client (FederationError (FederationUnexpectedBody), executeFederated) import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public getBotConversationH :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => BotId ::: ConvId ::: JSON -> Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv getBotConversation :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => BotId -> ConvId -> Galley r Public.BotConvView getBotConversation zbot zcnv = do - (c, _) <- getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) (botUserId zbot) zcnv + (c, _) <- getConversationAndMemberWithError ConvNotFound (botUserId zbot) zcnv domain <- viewFederationDomain let cmems = mapMaybe (mkMember domain) (toList (Data.convLocalMembers c)) pure $ Public.botConvView zcnv (Data.convName c) cmems @@ -106,7 +104,7 @@ getBotConversation zbot zcnv = do Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError, Error InternalError] r => UserId -> ConvId -> Galley r Public.Conversation @@ -116,7 +114,13 @@ getUnqualifiedConversation zusr cnv = do getConversation :: forall r. - Member ConversationStore r => + Members + '[ ConversationStore, + Error ConversationError, + Error FederationError, + Error InternalError + ] + r => UserId -> Qualified ConvId -> Galley r Public.Conversation @@ -131,37 +135,40 @@ getConversation zusr cnv = do getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] - case conversations of - [] -> throwErrorDescriptionType @ConvNotFound + liftSem $ case conversations of + [] -> throw ConvNotFound [conv] -> pure conv - _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") + -- _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") + _convs -> throw $ FederationUnexpectedBody "expected one conversation, got multiple" getRemoteConversations :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError, Error FederationError] r => UserId -> [Remote ConvId] -> Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error - (failed : _, _) -> throwM (fgcError failed) + (failed : _, _) -> liftSem . throwFgcError $ failed ([], result) -> pure result data FailedGetConversationReason = FailedGetConversationLocally | FailedGetConversationRemotely FederationError -fgcrError :: FailedGetConversationReason -> Wai.Error -fgcrError FailedGetConversationLocally = errorDescriptionTypeToWai @ConvNotFound -fgcrError (FailedGetConversationRemotely e) = federationErrorToWai e +throwFgcrError :: + Members '[Error ConversationError, Error FederationError] r => FailedGetConversationReason -> Sem r a +throwFgcrError FailedGetConversationLocally = throw ConvNotFound +throwFgcrError (FailedGetConversationRemotely e) = throw e data FailedGetConversation = FailedGetConversation [Qualified ConvId] FailedGetConversationReason -fgcError :: FailedGetConversation -> Wai.Error -fgcError (FailedGetConversation _ r) = fgcrError r +throwFgcError :: + Members '[Error ConversationError, Error FederationError] r => FailedGetConversation -> Sem r a +throwFgcError (FailedGetConversation _ r) = throwFgcrError r failedGetConversationRemotely :: [Remote ConvId] -> FederationError -> FailedGetConversation @@ -231,7 +238,7 @@ getRemoteConversationsWithFailures zusr convs = do throwE e getConversationRoles :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => UserId -> ConvId -> Galley r Public.ConversationRolesList @@ -299,7 +306,6 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} remotesOnly :: - Members '[ListItems p (Remote ConvId)] r => Maybe C.PagingState -> Range 1 1000 Int32 -> Sem r Public.ConvIdsPage @@ -317,7 +323,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do } getConversations :: - Members '[ListItems LegacyPaging ConvId, ConversationStore] r => + Members '[Error InternalError, ListItems LegacyPaging ConvId, ConversationStore] r => UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> @@ -369,7 +375,7 @@ getConversationsInternal user mids mstart msize = do | otherwise = pure True listConversations :: - Member ConversationStore r => + Members '[ConversationStore, Error InternalError] r => UserId -> Public.ListConversations -> Galley r Public.ConversationsResponse @@ -485,7 +491,18 @@ getConversationMeta cnv = liftSem $ do pure Nothing getConversationByReusableCode :: - Members '[CodeStore, ConversationStore, BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> Key -> Value -> diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 0b58052ecc5..f73b5e2ebe2 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -60,7 +60,6 @@ where import Brig.Types.Intra (accountUser) import Brig.Types.Team (TeamSize (..)) import Control.Lens -import Control.Monad.Catch import Data.ByteString.Conversion (List, toByteString) import qualified Data.ByteString.Conversion import Data.ByteString.Lazy.Builder (lazyByteString) @@ -118,13 +117,15 @@ import Galley.Types.UserList import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (or, result, setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, or, result, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log import qualified Wire.API.Conversation.Role as Public -import Wire.API.ErrorDescription (ConvNotFound, NotATeamMember, operationDenied) +import Wire.API.ErrorDescription +import Wire.API.Federation.Client import qualified Wire.API.Notification as Public import qualified Wire.API.Team as Public import qualified Wire.API.Team.Conversation as Public @@ -138,17 +139,28 @@ import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) -getTeamH :: Member TeamStore r => UserId ::: TeamId ::: JSON -> Galley r Response +getTeamH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId ::: TeamId ::: JSON -> + Galley r Response getTeamH (zusr ::: tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid + maybe (liftSem (throw TeamNotFound)) (pure . json) =<< lookupTeam zusr tid -getTeamInternalH :: Member TeamStore r => TeamId ::: JSON -> Galley r Response +getTeamInternalH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: JSON -> + Galley r Response getTeamInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< liftSem (E.getTeam tid) + liftSem . fmap json $ + E.getTeam tid >>= note TeamNotFound -getTeamNameInternalH :: Member TeamStore r => TeamId ::: JSON -> Galley r Response +getTeamNameInternalH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: JSON -> + Galley r Response getTeamNameInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< liftSem (getTeamNameInternal tid) + liftSem . fmap json $ + getTeamNameInternal tid >>= note TeamNotFound getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName @@ -184,7 +196,16 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members '[GundeckAccess, BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do @@ -193,7 +214,15 @@ createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createNonBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.NonBindingNewTeam -> @@ -223,7 +252,7 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[BrigAccess, Error InvalidInput, GundeckAccess, TeamStore] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do @@ -246,7 +275,15 @@ createBindingTeam zusr tid (BindingNewTeam body) = do pure tid updateTeamStatusH :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response updateTeamStatusH (tid ::: req ::: _) = do @@ -254,9 +291,13 @@ updateTeamStatusH (tid ::: req ::: _) = do updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: Members '[BrigAccess, TeamStore] r => TeamId -> TeamStatusUpdate -> Galley r () +updateTeamStatus :: + Members '[BrigAccess, Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + TeamStatusUpdate -> + Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do - oldStatus <- tdStatus <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + oldStatus <- tdStatus <$> liftSem (E.getTeam tid >>= note TeamNotFound) valid <- validateTransition (oldStatus, newStatus) when valid $ do journal newStatus cur @@ -274,18 +315,26 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do then 1 else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime - journal _ _ = throwM invalidTeamStatusUpdate - validateTransition :: (TeamStatus, TeamStatus) -> Galley r Bool + journal _ _ = liftSem $ throw InvalidTeamStatusUpdate + validateTransition :: Member (Error ActionError) r => (TeamStatus, TeamStatus) -> Galley r Bool validateTransition = \case (PendingActive, Active) -> return True (Active, Active) -> return False (Active, Suspended) -> return True (Suspended, Active) -> return True (Suspended, Suspended) -> return False - (_, _) -> throwM invalidTeamStatusUpdate + (_, _) -> liftSem $ throw InvalidTeamStatusUpdate updateTeamH :: - Members '[GundeckAccess, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -294,7 +343,14 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty updateTeam :: - Members '[GundeckAccess, TeamStore] r => + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -315,7 +371,17 @@ updateTeam zusr zcon tid updateData = do liftSem . E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -325,17 +391,26 @@ deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do -- | 'TeamDeleteData' is only required for binding teams deleteTeam :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley r () deleteTeam zusr zcon tid mBody = do - team <- liftSem (E.getTeam tid) >>= ifNothing teamNotFound + team <- liftSem $ E.getTeam tid >>= note TeamNotFound case tdStatus team of - Deleted -> - throwM teamNotFound + Deleted -> liftSem $ throw TeamNotFound PendingDelete -> queueTeamDeletion tid zusr (Just zcon) _ -> do @@ -345,19 +420,22 @@ deleteTeam zusr zcon tid mBody = do checkPermissions team = do void $ permissionCheck DeleteTeam =<< liftSem (E.getTeamMember tid zusr) when ((tdTeam team) ^. teamBinding == Binding) $ do - body <- mBody & ifNothing (invalidPayload "missing request body") + body <- liftSem $ mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: Member TeamStore r => TeamId -> Galley r () +internalDeleteBindingTeamWithOneMember :: + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + Galley r () internalDeleteBindingTeamWithOneMember tid = do team <- liftSem (E.getTeam tid) - unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ - throwM noBindingTeam + liftSem . unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ + throw NoBindingTeam mems <- liftSem $ E.getTeamMembersWithLimit tid (unsafeRange 2) case mems ^. teamMembers of (mem : []) -> queueTeamDeletion tid (mem ^. userId) Nothing - _ -> throwM notAOneMemberTeam + _ -> liftSem $ throw NotAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. uncheckedDeleteTeam :: @@ -446,21 +524,18 @@ uncheckedDeleteTeam zusr zcon tid = do pure (pp', ee' ++ ee) getTeamConversationRoles :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - mem <- liftSem $ E.getTeamMember tid zusr - case mem of - Nothing -> throwErrorDescriptionType @NotATeamMember - Just _ -> do - -- NOTE: If/when custom roles are added, these roles should - -- be merged with the team roles (if they exist) - pure $ Public.ConversationRolesList wireConvRoles + liftSem . void $ E.getTeamMember tid zusr >>= noteED @NotATeamMember + -- NOTE: If/when custom roles are added, these roles should + -- be merged with the team roles (if they exist) + pure $ Public.ConversationRolesList wireConvRoles getTeamMembersH :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do @@ -468,27 +543,26 @@ getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do pure . json $ teamMemberListJson withPerms memberList getTeamMembers :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) -getTeamMembers zusr tid maxResults = do - liftSem (E.getTeamMember tid zusr) >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - mems <- liftSem $ E.getTeamMembersWithLimit tid maxResults - let withPerms = (m `canSeePermsOf`) - pure (mems, withPerms) +getTeamMembers zusr tid maxResults = liftSem $ do + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember + mems <- E.getTeamMembersWithLimit tid maxResults + let withPerms = (m `canSeePermsOf`) + pure (mems, withPerms) getTeamMembersCSVH :: - (Members '[BrigAccess, TeamStore] r) => + (Members '[BrigAccess, Error ActionError, TeamStore] r) => UserId ::: TeamId ::: JSON -> Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do - liftSem (E.getTeamMember tid zusr) >>= \case - Nothing -> throwM accessDenied - Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwM accessDenied + liftSem $ + E.getTeamMember tid zusr >>= \case + Nothing -> throw AccessDenied + Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw AccessDenied env <- ask -- In case an exception is thrown inside the StreamingBody of responseStream @@ -598,7 +672,14 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserScimExternalId _) -> Nothing bulkGetTeamMembersH :: - Member TeamStore r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do @@ -608,25 +689,23 @@ bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do -- | like 'getTeamMembers', but with an explicit list of users we are to return. bulkGetTeamMembers :: - Member TeamStore r => + Members '[Error ActionError, Error InvalidInput, Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley r (TeamMemberList, TeamMember -> Bool) -bulkGetTeamMembers zusr tid maxResults uids = do +bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do unless (length uids <= fromIntegral (fromRange maxResults)) $ - throwM bulkGetMemberLimitExceeded - liftSem (E.getTeamMember tid zusr) >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> liftSem $ do - mems <- E.selectTeamMembers tid uids - let withPerms = (m `canSeePermsOf`) - hasMore = ListComplete - pure (newTeamMemberList mems hasMore, withPerms) + throw BulkGetMemberLimitExceeded + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember + mems <- E.selectTeamMembers tid uids + let withPerms = (m `canSeePermsOf`) + hasMore = ListComplete + pure (newTeamMemberList mems hasMore, withPerms) getTeamMemberH :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do @@ -634,23 +713,22 @@ getTeamMemberH (zusr ::: tid ::: uid ::: _) = do pure . json $ teamMemberJson withPerms member getTeamMember :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> UserId -> Galley r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do - zusrMembership <- liftSem $ E.getTeamMember tid zusr - case zusrMembership of - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - let withPerms = (m `canSeePermsOf`) - liftSem (E.getTeamMember tid uid) >>= \case - Nothing -> throwM teamMemberNotFound - Just member -> pure (member, withPerms) + m <- + liftSem $ + E.getTeamMember tid zusr + >>= noteED @NotATeamMember + let withPerms = (m `canSeePermsOf`) + member <- liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound + pure (member, withPerms) internalDeleteBindingTeamWithOneMemberH :: - Member TeamStore r => + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do @@ -658,19 +736,19 @@ internalDeleteBindingTeamWithOneMemberH tid = do pure (empty & setStatus status202) uncheckedGetTeamMemberH :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid uncheckedGetTeamMember :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> UserId -> Galley r TeamMember -uncheckedGetTeamMember tid uid = do - liftSem (E.getTeamMember tid uid) >>= ifNothing teamMemberNotFound +uncheckedGetTeamMember tid uid = + liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound uncheckedGetTeamMembersH :: Member TeamStore r => @@ -690,6 +768,11 @@ addTeamMemberH :: Members '[ BrigAccess, GundeckAccess, + Error ActionError, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -708,6 +791,10 @@ addTeamMember :: Members '[ BrigAccess, GundeckAccess, + Error ActionError, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -743,9 +830,13 @@ addTeamMember zusr zcon tid nmem = do uncheckedAddTeamMemberH :: Members '[ BrigAccess, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, GundeckAccess, - MemberStore, LegalHoldStore, + MemberStore, TeamFeatureStore, TeamStore, TeamNotificationStore @@ -762,6 +853,9 @@ uncheckedAddTeamMember :: Members '[ BrigAccess, GundeckAccess, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, MemberStore, LegalHoldStore, TeamFeatureStore, @@ -781,7 +875,16 @@ uncheckedAddTeamMember tid nmem = do Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds updateTeamMemberH :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -792,7 +895,15 @@ updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -806,7 +917,7 @@ updateTeamMember zusr zcon tid targetMember = do . Log.field "action" (Log.val "Teams.updateTeamMember") -- get the team and verify permissions - team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + team <- liftSem . fmap tdTeam $ E.getTeam tid >>= note TeamNotFound user <- liftSem (E.getTeamMember tid zusr) >>= permissionCheck SetMemberPermissions @@ -814,16 +925,13 @@ updateTeamMember zusr zcon tid targetMember = do -- user may not elevate permissions targetPermissions `ensureNotElevated` user previousMember <- - liftSem (E.getTeamMember tid targetId) >>= \case - Nothing -> - -- target user must be in same team - throwM teamMemberNotFound - Just previousMember -> pure previousMember - when - ( downgradesOwner previousMember targetPermissions - && not (canDowngradeOwner user previousMember) - ) - $ throwM accessDenied + liftSem $ E.getTeamMember tid targetId >>= note TeamMemberNotFound + liftSem + . when + ( downgradesOwner previousMember targetPermissions + && not (canDowngradeOwner user previousMember) + ) + $ throw AccessDenied -- update target in Cassandra liftSem $ E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions @@ -864,6 +972,11 @@ deleteTeamMemberH :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -887,6 +1000,11 @@ deleteTeamMember :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -906,15 +1024,15 @@ deleteTeamMember zusr zcon tid remove mBody = do zusrMember <- liftSem $ E.getTeamMember tid zusr targetMember <- liftSem $ E.getTeamMember tid remove void $ permissionCheck RemoveTeamMember zusrMember - do - dm <- maybe (throwM teamMemberNotFound) pure zusrMember - tm <- maybe (throwM teamMemberNotFound) pure targetMember - unless (canDeleteMember dm tm) $ throwM accessDenied - team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + liftSem $ do + dm <- note TeamMemberNotFound zusrMember + tm <- note TeamMemberNotFound targetMember + unless (canDeleteMember dm tm) $ throw AccessDenied + team <- tdTeam <$> liftSem (E.getTeam tid >>= note TeamNotFound) mems <- getTeamMembersForFanout tid if team ^. teamBinding == Binding && isJust targetMember then do - body <- mBody & ifNothing (invalidPayload "missing request body") + body <- liftSem $ mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tmdAuthPassword) (TeamSize sizeBeforeDelete) <- liftSem $ E.getSize tid -- TeamSize is 'Natural' and subtracting from 0 is an error @@ -993,32 +1111,39 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do liftSem $ E.deliverAsync (bots `zip` repeat y) getTeamConversations :: - Member TeamStore r => + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r Public.TeamConversationList -getTeamConversations zusr tid = do +getTeamConversations zusr tid = liftSem $ do tm <- - liftSem (E.getTeamMember tid zusr) - >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + E.getTeamMember tid zusr + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) - liftSem $ Public.newTeamConversationList <$> E.getTeamConversations tid + throw . OperationDenied . show $ GetTeamConversations + Public.newTeamConversationList <$> E.getTeamConversations tid getTeamConversation :: - Member TeamStore r => + Members + '[ Error ActionError, + Error ConversationError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> TeamId -> ConvId -> Galley r Public.TeamConversation -getTeamConversation zusr tid cid = do +getTeamConversation zusr tid cid = liftSem $ do tm <- - liftSem (E.getTeamMember tid zusr) - >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + E.getTeamMember tid zusr + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) - liftSem (E.getTeamConversation tid cid) - >>= maybe (throwErrorDescriptionType @ConvNotFound) pure + throw . OperationDenied . show $ GetTeamConversations + E.getTeamConversation tid cid + >>= note ConvNotFound deleteTeamConversation :: Members @@ -1026,6 +1151,12 @@ deleteTeamConversation :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, FireAndForget, @@ -1046,7 +1177,14 @@ deleteTeamConversation zusr zcon _tid cid = do void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore] r => + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do @@ -1055,7 +1193,16 @@ getSearchVisibilityH (uid ::: tid ::: _) = do json <$> getSearchVisibilityInternal tid setSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore, TeamFeatureStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamStore, + TeamFeatureStore + ] + r => UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do @@ -1097,37 +1244,38 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: Member TeamStore r => [UserId] -> Galley r () +ensureUnboundUsers :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => [UserId] -> Galley r () ensureUnboundUsers uids = do -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. teams <- liftSem $ Map.elems <$> E.getUsersTeams uids binds <- liftSem $ E.getTeamsBindings teams - when (any (== Binding) binds) $ - throwM userBindingExists + liftSem . when (any (== Binding) binds) $ + throw UserBindingExists -ensureNonBindingTeam :: Member TeamStore r => TeamId -> Galley r () +ensureNonBindingTeam :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r () ensureNonBindingTeam tid = do - team <- liftSem (E.getTeam tid) >>= ifNothing teamNotFound - when ((tdTeam team) ^. teamBinding == Binding) $ - throwM noAddToBinding + team <- liftSem $ note TeamNotFound =<< E.getTeam tid + liftSem . when ((tdTeam team) ^. teamBinding == Binding) $ + throw NoAddToBinding -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Permissions -> TeamMember -> Galley r () +ensureNotElevated :: Member (Error ActionError) r => Permissions -> TeamMember -> Galley r () ensureNotElevated targetPermissions member = - unless - ( (targetPermissions ^. self) - `Set.isSubsetOf` (member ^. permissions . copy) - ) - $ throwM invalidPermissions - -ensureNotTooLarge :: Member BrigAccess r => TeamId -> Galley r TeamSize + liftSem + . unless + ( (targetPermissions ^. self) + `Set.isSubsetOf` (member ^. permissions . copy) + ) + $ throw InvalidPermissions + +ensureNotTooLarge :: Members '[BrigAccess, Error TeamError] r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options (TeamSize size) <- liftSem $ E.getSize tid - unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ - throwM tooManyTeamMembers + liftSem . unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ + throw TooManyTeamMembers return $ TeamSize size -- | Ensure that a team doesn't exceed the member count limit for the LegalHold @@ -1140,20 +1288,23 @@ ensureNotTooLarge tid = do -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. ensureNotTooLargeForLegalHold :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => TeamId -> Int -> Galley r () -ensureNotTooLargeForLegalHold tid teamSize = do - whenM (isLegalHoldEnabledForTeam tid) $ do - unlessM (teamSizeBelowLimit teamSize) $ do - throwM tooManyTeamMembersOnTeamWithLegalhold +ensureNotTooLargeForLegalHold tid teamSize = + whenM (isLegalHoldEnabledForTeam tid) $ + unlessM (teamSizeBelowLimit teamSize) $ + liftSem $ throw TooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: Members '[BrigAccess] r => TeamId -> Galley r () +ensureNotTooLargeToActivateLegalHold :: + Members '[BrigAccess, Error TeamError] r => + TeamId -> + Galley r () ensureNotTooLargeToActivateLegalHold tid = do (TeamSize teamSize) <- liftSem $ E.getSize tid - unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do - throwM cannotEnableLegalHoldServiceLargeTeam + unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ + liftSem $ throw CannotEnableLegalHoldServiceLargeTeam teamSizeBelowLimit :: Int -> Galley r Bool teamSizeBelowLimit teamSize = do @@ -1167,7 +1318,16 @@ teamSizeBelowLimit teamSize = do pure True addTeamMemberInternal :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamNotificationStore, TeamStore] r => + Members + '[ BrigAccess, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + MemberStore, + TeamNotificationStore, + TeamStore + ] + r => TeamId -> Maybe UserId -> Maybe ConnId -> @@ -1205,7 +1365,14 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi -- less warped. This is a work-around because we cannot send events to all of a large team. -- See haddocks of module "Galley.API.TeamNotifications" for details. getTeamNotificationsH :: - Members '[BrigAccess, TeamNotificationStore] r => + Members + '[ BrigAccess, + Error TeamError, + Error NotATeamMember, + Error TeamNotificationError, + TeamNotificationStore + ] + r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 @@ -1216,13 +1383,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Galley r (Maybe Public.NotificationId) + parseSince :: Member (Error TeamNotificationError) r => Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: ByteString -> Galley r Public.NotificationId + parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Galley r Public.NotificationId parseUUID raw = maybe - (throwM invalidTeamNotificationId) + (liftSem (throw InvalidTeamNotificationId)) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) @@ -1246,35 +1413,57 @@ finishCreateTeam team owner others zcon = do let r = membersToRecipients Nothing others liftSem . E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -withBindingTeam :: Member TeamStore r => UserId -> (TeamId -> Galley r b) -> Galley r b +-- FUTUREWORK: Get rid of CPS +withBindingTeam :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + (TeamId -> Galley r b) -> + Galley r b withBindingTeam zusr callback = do - tid <- liftSem (E.getOneUserTeam zusr) >>= ifNothing teamNotFound - binding <- liftSem (E.getTeamBinding tid) >>= ifNothing teamNotFound + tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound + binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> throwM nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember -getBindingTeamIdH :: Member TeamStore r => UserId -> Galley r Response +getBindingTeamIdH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: Member TeamStore r => UserId -> Galley r TeamId +getBindingTeamId :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: Member TeamStore r => UserId -> Galley r Response +getBindingTeamMembersH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: Member TeamStore r => UserId -> Galley r TeamMemberList +getBindingTeamMembers :: + Members + '[ Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => + UserId -> + Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> getTeamMembersForFanout tid canUserJoinTeamH :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold -canUserJoinTeam :: Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () +canUserJoinTeam :: + Members + '[ BrigAccess, + Error LegalHoldError, + LegalHoldStore, + TeamFeatureStore + ] + r => + TeamId -> + Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do @@ -1314,7 +1503,14 @@ getSearchVisibilityInternal = . SearchVisibilityData.getSearchVisibility setSearchVisibilityInternalH :: - Members '[SearchVisibilityStore, TeamFeatureStore] r => + Members + '[ Error InvalidInput, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamFeatureStore + ] + r => TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do @@ -1322,32 +1518,43 @@ setSearchVisibilityInternalH (tid ::: req ::: _) = do pure noContent setSearchVisibilityInternal :: - Members '[SearchVisibilityStore, TeamFeatureStore] r => + Members '[Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamFeatureStore] r => TeamId -> TeamSearchVisibilityView -> Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid - unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ - throwM teamSearchVisibilityNotEnabled + liftSem . unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ + throw TeamSearchVisibilityNotEnabled liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility -userIsTeamOwnerH :: Member TeamStore r => TeamId ::: UserId ::: JSON -> Galley r Response +userIsTeamOwnerH :: + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: UserId ::: JSON -> + Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty - False -> throwM accessDenied + False -> liftSem $ throw AccessDenied -userIsTeamOwner :: Member TeamStore r => TeamId -> UserId -> Galley r Bool +userIsTeamOwner :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + UserId -> + Galley r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion -queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley r () +queueTeamDeletion :: + Member (Error InternalError) r => + TeamId -> + UserId -> + Maybe ConnId -> + Galley r () queueTeamDeletion tid zusr zcon = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr zcon) - if ok - then pure () - else throwM deleteQueueFull + liftSem . unless ok $ + throw DeleteQueueFull diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index d4a2a076b72..4498865cf33 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -45,9 +45,7 @@ module Galley.API.Teams.Features ) where -import Bilge (MonadHttp) import Control.Lens -import Control.Monad.Catch import qualified Data.Aeson as Aeson import Data.ByteString.Conversion hiding (fromList) import qualified Data.HashMap.Strict as HashMap @@ -74,19 +72,16 @@ import Imports import Network.HTTP.Client (Manager) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus) -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) +import Polysemy.Error import Servant.API ((:<|>) ((:<|>))) import qualified Servant.Client as Client import qualified System.Logger.Class as Log import Util.Options (Endpoint, epHost, epPort) +import Wire.API.ErrorDescription import Wire.API.Event.FeatureConfig - ( EventData - ( EdFeatureApplockChanged, - EdFeatureSelfDeletingMessagesChanged, - EdFeatureWithoutConfigChanged - ), - ) import qualified Wire.API.Event.FeatureConfig as Event +import Wire.API.Federation.Client import qualified Wire.API.Routes.Internal.Brig as IAPI import Wire.API.Team.Feature (AllFeatureConfigs (..), FeatureHasNoConfig, KnownTeamFeatureName, TeamFeatureName) import qualified Wire.API.Team.Feature as Public @@ -97,7 +92,15 @@ data DoAuth = DoAuth UserId | DontDoAuth -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -114,7 +117,15 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -132,7 +143,15 @@ setFeatureStatus setter doauth tid status = do -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> Galley r (Public.TeamFeatureStatus a) @@ -147,7 +166,16 @@ getFeatureConfig getter zusr = do getter (Right tid) getAllFeatureConfigs :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InternalError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do @@ -157,7 +185,7 @@ getAllFeatureConfigs zusr = do forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a), - Member TeamStore r + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> Galley r (Text, Aeson.Value) @@ -183,7 +211,16 @@ getAllFeatureConfigs zusr = do ] getAllFeaturesH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = @@ -191,7 +228,16 @@ getAllFeaturesH (uid ::: tid ::: _) = getAllFeatures :: forall r. - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r Aeson.Value @@ -224,8 +270,7 @@ getAllFeatures uid tid = do getFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. - ( Public.KnownTeamFeatureName a, - Public.FeatureHasNoConfig a, + ( Public.FeatureHasNoConfig a, HasStatusCol a, Member TeamFeatureStore r ) => @@ -274,12 +319,12 @@ getSSOStatusInternal = FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case - Public.TeamFeatureDisabled -> const (throwM disableSsoNotImplemented) + Public.TeamFeatureDisabled -> const (liftSem (throw DisableSsoNotImplemented)) Public.TeamFeatureEnabled -> const (pure ()) getTeamSearchVisibilityAvailableInternal :: @@ -366,6 +411,15 @@ setLegalholdStatusInternal :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, + Error TeamFeatureError, ExternalAccess, FederatorAccess, FireAndForget, @@ -388,13 +442,13 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do -- enabeling LH for teams is only allowed in normal operation; disabled-permanently and -- whitelist-teams have no or their own way to do that, resp. featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) - case featureLegalHold of + liftSem $ case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do pure () FeatureLegalHoldDisabledPermanently -> do - throwM legalHoldFeatureFlagNotEnabled + throw LegalHoldFeatureFlagNotEnabled FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - throwM legalHoldWhitelistedOnly + throw LegalHoldWhitelistedOnly -- we're good to update the status now. case statusValue of @@ -445,13 +499,13 @@ getAppLockInternal mbtid = do pure $ fromMaybe defaultStatus status setAppLockInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ - throwM inactivityTimeoutTooLow + liftSem $ throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) @@ -467,7 +521,7 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: - Member TeamFeatureStore r => + Members '[Error InternalError, TeamFeatureStore] r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do @@ -528,7 +582,7 @@ pushFeatureConfigEvent tid event = do -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) getFeatureConfigViaAccount :: - (flag ~ 'Public.TeamFeatureConferenceCalling) => + (flag ~ 'Public.TeamFeatureConferenceCalling, Member (Error InternalError) r) => UserId -> Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do @@ -537,13 +591,14 @@ getFeatureConfigViaAccount uid = do getAccountFeatureConfigClient brigep mgr uid >>= handleResp where handleResp :: + Member (Error InternalError) r => Either Client.ClientError Public.TeamFeatureStatusNoConfig -> Galley r Public.TeamFeatureStatusNoConfig handleResp (Right cfg) = pure cfg - handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg + handleResp (Left errmsg) = liftSem . throw . InternalErrorWithDescription . cs . show $ errmsg getAccountFeatureConfigClient :: - (HasCallStack, MonadIO m, MonadHttp m) => + (HasCallStack, MonadIO m) => Endpoint -> Manager -> UserId -> @@ -559,7 +614,7 @@ getFeatureConfigViaAccount uid = do ) = Client.client (Proxy @IAPI.API) runHereClientM :: - (HasCallStack, MonadIO m, MonadHttp m) => + (HasCallStack, MonadIO m) => Endpoint -> Manager -> Client.ClientM a -> diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 8b4b0117a15..0836369ee8a 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -58,19 +58,17 @@ import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification import Imports import Network.HTTP.Types -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) +import Polysemy.Error getTeamNotifications :: - Members '[BrigAccess, TeamNotificationStore] r => + Members '[BrigAccess, Error TeamError, TeamNotificationStore] r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r QueuedNotificationList getTeamNotifications zusr since size = do - tid :: TeamId <- do - mtid <- liftSem $ (userTeam . accountUser =<<) <$> Intra.getUser zusr - let err = throwM teamNotFound - maybe err pure mtid + tid <- liftSem . (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr page <- liftSem $ E.getTeamNotifications tid since size pure $ queuedNotificationList @@ -80,11 +78,11 @@ getTeamNotifications zusr since size = do pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Galley r () pushTeamEvent tid evt = do - nid <- mkNotificationId + nid <- liftIO mkNotificationId liftSem $ E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) -- | 'Data.UUID.V1.nextUUID' is sometimes unsuccessful, so we try a few times. -mkNotificationId :: (MonadIO m, MonadThrow m) => m NotificationId +mkNotificationId :: IO NotificationId mkNotificationId = do ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) maybe (throwM err) return ni diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 7708afa49eb..98344a35462 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -33,7 +33,6 @@ module Galley.API.Update updateLocalConversationMessageTimer, updateConversationMessageTimerUnqualified, updateConversationMessageTimer, - updateLocalConversation, updateConversationAccessUnqualified, updateConversationAccess, deleteLocalConversation, @@ -50,9 +49,6 @@ module Galley.API.Update removeMemberFromLocalConv, removeMemberFromRemoteConv, - -- * Notifications - notifyConversationMetadataUpdate, - -- * Talking postProteusMessage, postOtrMessageUnqualified, @@ -69,23 +65,20 @@ module Galley.API.Update ) where -import qualified Brig.Types.User as User import Control.Lens -import Control.Monad.Catch import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Code import Data.Either.Extra (mapRight) import Data.Id import Data.Json.Util (fromBase64TextLenient, toUTCTimeMillis) -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.List1 import qualified Data.Map.Strict as Map -import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set import Data.Time +import Galley.API.Action import Galley.API.Error import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import Galley.API.Mapping @@ -96,7 +89,6 @@ import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) import Galley.Effects -import qualified Galley.Effects.BotAccess as E import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E import qualified Galley.Effects.CodeStore as E @@ -114,103 +106,131 @@ import Galley.Types.Bot hiding (addBot) import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members (newMember) -import Galley.Types.Conversations.Roles (Action (..), RoleName, roleNameWireMember) +import Galley.Types.Conversations.Roles (Action (..), roleNameWireMember) import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList -import Galley.Validation import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, and, failure, setStatus, _1, _2) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified Wire.API.Conversation as Public -import Wire.API.Conversation.Action import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription - ( CodeNotFound, - ConvNotFound, - MissingLegalholdConsent, - UnknownClient, - mkErrorDescription, - ) -import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (HasFederatorConfig (..)) -import Wire.API.Federation.Error (federationNotConfigured, federationNotImplemented) +import Wire.API.Federation.Client import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) -import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client acceptConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response acceptConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> acceptConv usr conn cnv acceptConv :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation acceptConv usr conn cnv = do conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation cnv >>= note ConvNotFound conv' <- acceptOne2One usr conv conn conversationView usr conv' blockConvH :: - Members '[ConversationStore, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + MemberStore + ] + r => UserId ::: ConvId -> Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv blockConv :: - Members '[ConversationStore, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + MemberStore + ] + r => UserId -> ConvId -> Galley r () blockConv zusr cnv = do - conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ - invalidOp "block: invalid conversation type" + liftSem . throw . InvalidOp . Data.convType $ conv let mems = Data.convLocalMembers conv when (zusr `isMember` mems) . liftSem $ E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response unblockConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> unblockConv usr conn cnv unblockConv :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation unblockConv usr conn cnv = do conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ - invalidOp "unblock: invalid conversation type" + liftSem . throw . InvalidOp . Data.convType $ conv conv' <- acceptOne2One usr conv conn conversationView usr conv' @@ -222,7 +242,23 @@ handleUpdateResult = \case Unchanged -> empty & setStatus status204 updateConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -238,7 +274,22 @@ updateConversationAccess usr con qcnv update = do doUpdate qcnv lusr con update updateConversationAccessUnqualified :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -250,106 +301,52 @@ updateConversationAccessUnqualified usr zcon cnv update = do updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateLocalConversationAccess lcnv lusr con target = +updateLocalConversationAccess lcnv lusr con = getUpdateResult . updateLocalConversation lcnv (qUntagged lusr) (Just con) - . ConversationActionAccessUpdate - $ target updateRemoteConversationAccess :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented +updateRemoteConversationAccess _ _ _ _ = liftSem $ throw FederationNotImplemented -performAccessUpdateAction :: - forall r. +updateConversationReceiptMode :: Members - '[ BrigAccess, - BotAccess, - CodeStore, - ConversationStore, + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, - FireAndForget, - GundeckAccess, - LegalHoldStore, - MemberStore, - TeamStore + GundeckAccess ] r => - Qualified UserId -> - Data.Conversation -> - ConversationAccessData -> - MaybeT (Galley r) () -performAccessUpdateAction qusr conv target = do - lcnv <- qualifyLocal (Data.convId conv) - guard $ Data.convAccessData conv /= target - -- Remove conversation codes if CodeAccess is revoked - when - ( CodeAccess `elem` Data.convAccess conv - && CodeAccess `notElem` cupAccess target - ) - $ lift $ do - key <- mkKey (tUnqualified lcnv) - liftSem $ E.deleteCode key ReusableCode - - -- Determine bots and members to be removed - let filterBotsAndMembers = filterActivated >=> filterTeammates - let current = convBotsAndMembers conv -- initial bots and members - desired <- lift . liftSem $ filterBotsAndMembers current -- desired bots and members - let toRemove = bmDiff current desired -- bots and members to be removed - - -- Update Cassandra - lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) target - lift . fireAndForget $ do - -- Remove bots - traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) - - -- Update current bots and members - let current' = current {bmBots = bmBots desired} - - -- Remove users and notify everyone - void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do - let action = ConversationActionRemoveMembers usersToRemove - void . runMaybeT $ performAction qusr conv action - notifyConversationMetadataUpdate qusr Nothing lcnv current' action - where - filterActivated :: BotsAndMembers -> Sem r BotsAndMembers - filterActivated bm - | ( Data.convAccessRole conv > ActivatedAccessRole - && cupAccessRole target <= ActivatedAccessRole - ) = do - activated <- map User.userId <$> E.lookupActivatedUsers (toList (bmLocals bm)) - -- FUTUREWORK: should we also remove non-activated remote users? - pure $ bm {bmLocals = Set.fromList activated} - | otherwise = pure bm - - filterTeammates :: BotsAndMembers -> Sem r BotsAndMembers - filterTeammates bm = do - -- In a team-only conversation we also want to remove bots and guests - case (cupAccessRole target, Data.convTeam conv) of - (TeamAccessRole, Just tid) -> do - onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> - isJust <$> E.getTeamMember tid user - pure $ - BotsAndMembers - { bmLocals = Set.fromList onlyTeamUsers, - bmBots = mempty, - bmRemotes = mempty - } - _ -> pure bm - -updateConversationReceiptMode :: - Members UpdateConversationActions r => + Members '[Error FederationError] r => UserId -> ConnId -> Qualified ConvId -> @@ -365,7 +362,16 @@ updateConversationReceiptMode usr zcon qcnv update = do doUpdate qcnv lusr zcon update updateConversationReceiptModeUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -377,7 +383,16 @@ updateConversationReceiptModeUnqualified usr zcon cnv update = do updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -385,19 +400,28 @@ updateLocalConversationReceiptMode :: Galley r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionReceiptModeUpdate update + updateLocalConversation lcnv (qUntagged lusr) (Just con) update updateRemoteConversationReceiptMode :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> Galley r (UpdateResult Event) -updateRemoteConversationReceiptMode _ _ _ _ = throwM federationNotImplemented +updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw FederationNotImplemented updateConversationMessageTimerUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -409,7 +433,17 @@ updateConversationMessageTimerUnqualified usr zcon cnv update = do updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: - (Member ConversationStore r, Members UpdateConversationActions r) => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -420,12 +454,21 @@ updateConversationMessageTimer usr zcon qcnv update = do foldQualified lusr (updateLocalConversationMessageTimer lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv update updateLocalConversationMessageTimer :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -433,115 +476,43 @@ updateLocalConversationMessageTimer :: Galley r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionMessageTimerUpdate update + updateLocalConversation lcnv (qUntagged lusr) (Just con) update deleteLocalConversation :: - Members UpdateConversationActions r => + Members + '[ CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + TeamStore + ] + r => Local UserId -> ConnId -> Local ConvId -> Galley r (UpdateResult Event) deleteLocalConversation lusr con lcnv = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete - --- FUTUREWORK: split conversation actions into multiple types so that we can --- have more granular effect constraints -type UpdateConversationActions = - '[ BotAccess, - BrigAccess, - ExternalAccess, - FederatorAccess, - FireAndForget, - GundeckAccess, - CodeStore, - ConversationStore, - LegalHoldStore, - MemberStore, - TeamStore - ] - --- | Update a local conversation, and notify all local and remote members. -updateLocalConversation :: - Members UpdateConversationActions r => - Local ConvId -> - Qualified UserId -> - Maybe ConnId -> - ConversationAction -> - MaybeT (Galley r) Event -updateLocalConversation lcnv qusr con action = do - -- retrieve conversation - (conv, self) <- - lift $ - getConversationAndMemberWithError - (errorDescriptionTypeToWai @ConvNotFound) - qusr - (tUnqualified lcnv) - - -- perform checks - lift $ ensureConversationActionAllowed action conv self - - -- perform action - (extraTargets, action') <- performAction qusr conv action - - -- send notifications to both local and remote users - lift $ - notifyConversationMetadataUpdate - qusr - con - lcnv - (convBotsAndMembers conv <> extraTargets) - action' + updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationDelete getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT --- | Perform a conversation action, and return extra notification targets and --- an updated action. -performAction :: - Members UpdateConversationActions r => - Qualified UserId -> - Data.Conversation -> - ConversationAction -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -performAction qusr conv action = case action of - ConversationActionAddMembers members role -> - performAddMemberAction qusr conv members role - ConversationActionRemoveMembers members -> do - performRemoveMemberAction conv (toList members) - pure (mempty, action) - ConversationActionRename rename -> lift $ do - cn <- rangeChecked (cupName rename) - liftSem $ E.setConversationName (Data.convId conv) cn - pure (mempty, action) - ConversationActionMessageTimerUpdate update -> do - guard $ Data.convMessageTimer conv /= cupMessageTimer update - lift . liftSem $ E.setConversationMessageTimer (Data.convId conv) (cupMessageTimer update) - pure (mempty, action) - ConversationActionReceiptModeUpdate update -> do - guard $ Data.convReceiptMode conv /= Just (cruReceiptMode update) - lift . liftSem $ E.setConversationReceiptMode (Data.convId conv) (cruReceiptMode update) - pure (mempty, action) - ConversationActionMemberUpdate target update -> lift $ do - lcnv <- qualifyLocal (Data.convId conv) - void $ ensureOtherMember lcnv target conv - liftSem $ E.setOtherMember lcnv target update - pure (mempty, action) - ConversationActionAccessUpdate update -> do - performAccessUpdateAction qusr conv update - pure (mempty, action) - ConversationActionDelete -> lift $ do - let cid = Data.convId conv - key <- mkKey cid - liftSem $ E.deleteCode key ReusableCode - liftSem $ case Data.convTeam conv of - Nothing -> E.deleteConversation cid - Just tid -> E.deleteTeamConversation tid cid - pure (mempty, action) - addCodeH :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response addCodeH (usr ::: zcon ::: cnv) = @@ -555,7 +526,14 @@ data AddCodeResult addCode :: forall r. - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -564,11 +542,9 @@ addCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain - conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound ensureConvMember (Data.convLocalMembers conv) usr - ensureAccess conv CodeAccess + liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv mCode <- liftSem $ E.getCode key ReusableCode @@ -591,14 +567,28 @@ addCode usr zcon cnv = do return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv rmCode :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -608,10 +598,9 @@ rmCode usr zcon cnv = do let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation cnv >>= note ConvNotFound ensureConvMember (Data.convLocalMembers conv) usr - ensureAccess conv CodeAccess + liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv liftSem $ E.deleteCode key ReusableCode @@ -621,27 +610,36 @@ rmCode usr zcon cnv = do pure event getCodeH :: - Members '[CodeStore, ConversationStore] r => + Members + '[ CodeStore, + ConversationStore, + Error CodeError, + Error ConversationError + ] + r => UserId ::: ConvId -> Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv getCode :: - Members '[CodeStore, ConversationStore] r => + Members + '[ CodeStore, + ConversationStore, + Error CodeError, + Error ConversationError + ] + r => UserId -> ConvId -> Galley r Public.ConversationCode getCode usr cnv = do conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv CodeAccess + liftSem $ E.getConversation cnv >>= note ConvNotFound + liftSem $ ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr key <- mkKey cnv - c <- - liftSem (E.getCode key ReusableCode) - >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) + c <- liftSem $ E.getCode key ReusableCode >>= note CodeNotFound returnCode c returnCode :: Code -> Galley r Public.ConversationCode @@ -649,13 +647,19 @@ returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCodeH :: Member CodeStore r => JsonRequest Public.ConversationCode -> Galley r Response +checkReusableCodeH :: + Members '[CodeStore, Error CodeError, Error InvalidInput] r => + JsonRequest Public.ConversationCode -> + Galley r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode pure empty -checkReusableCode :: Member CodeStore r => Public.ConversationCode -> Galley r () +checkReusableCode :: + Members '[CodeStore, Error CodeError] r => + Public.ConversationCode -> + Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode @@ -665,6 +669,12 @@ joinConversationByReusableCodeH :: CodeStore, ConversationStore, FederatorAccess, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -682,6 +692,12 @@ joinConversationByReusableCode :: '[ BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, FederatorAccess, ExternalAccess, GundeckAccess, @@ -702,6 +718,11 @@ joinConversationByIdH :: '[ BrigAccess, ConversationStore, FederatorAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -718,6 +739,11 @@ joinConversationById :: '[ BrigAccess, FederatorAccess, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -736,6 +762,11 @@ joinConversation :: '[ BrigAccess, ConversationStore, FederatorAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -751,7 +782,7 @@ joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv conv <- ensureConversationAccess zusr cnv access - ensureGroupConvThrowing conv + liftSem . ensureGroupConversation $ conv -- FUTUREWORK: remote users? ensureMemberLimit (toList $ Data.convLocalMembers conv) [zusr] getUpdateResult $ do @@ -762,117 +793,31 @@ joinConversation zusr zcon cnv access = do (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember lift $ - notifyConversationMetadataUpdate + notifyConversationAction (qUntagged lusr) (Just zcon) lcnv (convBotsAndMembers conv <> extraTargets) - action - --- | Add users to a conversation without performing any checks. Return extra --- notification targets and the action performed. -addMembersToLocalConversation :: - Members '[MemberStore] r => - Local ConvId -> - UserList UserId -> - RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -addMembersToLocalConversation lcnv users role = do - (lmems, rmems) <- lift . liftSem $ E.createMembers (tUnqualified lcnv) (fmap (,role) users) - neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users - let action = ConversationActionAddMembers neUsers role - pure (bmFromMembers lmems rmems, action) - -performAddMemberAction :: - forall r. - Members UpdateConversationActions r => - Qualified UserId -> - Data.Conversation -> - NonEmpty (Qualified UserId) -> - RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -performAddMemberAction qusr conv invited role = do - lcnv <- lift $ qualifyLocal (Data.convId conv) - let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited - lift $ do - ensureMemberLimit (toList (Data.convLocalMembers conv)) newMembers - ensureAccess conv InviteAccess - checkLocals lcnv (Data.convTeam conv) (ulLocals newMembers) - checkRemotes (ulRemotes newMembers) - checkLHPolicyConflictsLocal lcnv (ulLocals newMembers) - checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) - addMembersToLocalConversation lcnv newMembers role - where - userIsMember u = (^. userId . to (== u)) - - checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () - checkLocals lcnv (Just tid) newUsers = do - tms <- liftSem $ E.selectTeamMembers tid newUsers - let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers - ensureAccessRole (Data.convAccessRole conv) userMembershipMap - tcv <- liftSem $ E.getTeamConversation tid (tUnqualified lcnv) - when (maybe True (view managedConversation) tcv) $ - throwM noAddToManaged - ensureConnectedOrSameTeam qusr newUsers - checkLocals _ Nothing newUsers = do - ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) - ensureConnectedOrSameTeam qusr newUsers - - checkRemotes :: [Remote UserId] -> Galley r () - checkRemotes remotes = do - -- if federator is not configured, we fail early, so we avoid adding - -- remote members to the database - unless (null remotes) $ do - endpoint <- federatorEndpoint - when (isNothing endpoint) $ - throwM federationNotConfigured - - loc <- qualifyLocal () - foldQualified - loc - ensureConnectedToRemotes - (\_ _ -> throwM federationNotImplemented) - qusr - remotes - - checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley r () - checkLHPolicyConflictsLocal lcnv newUsers = do - let convUsers = Data.convLocalMembers conv - - allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers - - whenM (anyLegalholdActivated (lmId <$> convUsers)) $ - unless allNewUsersGaveConsent $ - throwErrorDescriptionType @MissingLegalholdConsent - - whenM (anyLegalholdActivated newUsers) $ do - unless allNewUsersGaveConsent $ - throwErrorDescriptionType @MissingLegalholdConsent - - convUsersLHStatus <- do - uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) - pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus - - if any - ( \(mem, status) -> - lmConvRoleName mem == roleNameWireAdmin - && consentGiven status == ConsentGiven - ) - convUsersLHStatus - then do - for_ convUsersLHStatus $ \(mem, status) -> - when (consentGiven status == ConsentNotGiven) $ do - qvictim <- qUntagged <$> qualifyLocal (lmId mem) - void . runMaybeT $ - updateLocalConversation lcnv qvictim Nothing $ - ConversationActionRemoveMembers (pure qvictim) - else throwErrorDescriptionType @MissingLegalholdConsent - - checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley r () - checkLHPolicyConflictsRemote _remotes = pure () + (conversationAction action) addMembersUnqualified :: - Members UpdateConversationActions r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -883,7 +828,23 @@ addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do addMembers zusr zcon cnv (Public.InviteQualified qusers role) addMembers :: - Members UpdateConversationActions r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -894,10 +855,17 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do lcnv <- qualifyLocal cnv getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ - ConversationActionAddMembers users role + ConversationJoin users role updateSelfMember :: - Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ConversationError, + GundeckAccess, + ExternalAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -906,7 +874,7 @@ updateSelfMember :: updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr exists <- liftSem $ foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr - unless exists (throwErrorDescriptionType @ConvNotFound) + liftSem . unless exists . throw $ ConvNotFound liftSem $ E.setSelfMember qcnv lusr update now <- liftIO getCurrentTime let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) @@ -941,7 +909,14 @@ updateSelfMember zusr zcon qcnv update = do } updateUnqualifiedSelfMember :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -952,7 +927,17 @@ updateUnqualifiedSelfMember zusr zcon cnv update = do updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -966,7 +951,18 @@ updateOtherMemberUnqualified zusr zcon cnv victim update = do updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -979,7 +975,17 @@ updateOtherMember zusr zcon qcnv qvictim update = do doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -987,22 +993,33 @@ updateOtherMemberLocalConv :: Public.OtherMemberUpdate -> Galley r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - when (qUntagged lusr == qvictim) $ - throwM invalidTargetUserOp + lift . liftSem . when (qUntagged lusr == qvictim) $ + throw InvalidTargetUserOp updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionMemberUpdate qvictim update + ConversationMemberUpdate qvictim update updateOtherMemberRemoteConv :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> Galley r () -updateOtherMemberRemoteConv _ _ _ _ _ = throwM federationNotImplemented +updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw FederationNotImplemented removeMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -1014,7 +1031,17 @@ removeMemberUnqualified zusr con cnv victim = do removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1025,7 +1052,7 @@ removeMemberQualified zusr con qcnv victim = do foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: - Member FederatorAccess r => + Members '[FederatorAccess] r => Remote ConvId -> Local UserId -> Maybe ConnId -> @@ -1049,20 +1076,19 @@ removeMemberFromRemoteConv cnv lusr _ victim <$> E.runFederated cnv rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed -performRemoveMemberAction :: - Member MemberStore r => - Data.Conversation -> - [Qualified UserId] -> - MaybeT (Galley r) () -performRemoveMemberAction conv victims = do - loc <- qualifyLocal () - let presentVictims = filter (isConvMember loc conv) victims - guard . not . null $ presentVictims - lift . liftSem $ E.deleteMembers (Data.convId conv) (toUserList loc presentVictims) - -- | Remove a member from a local conversation. removeMemberFromLocalConv :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> Maybe ConnId -> @@ -1073,7 +1099,7 @@ removeMemberFromLocalConv lcnv lusr con victim = fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT . updateLocalConversation lcnv (qUntagged lusr) con - . ConversationActionRemoveMembers + . ConversationLeave . pure $ victim @@ -1082,15 +1108,23 @@ removeMemberFromLocalConv lcnv lusr con victim = data OtrResult = OtrSent !Public.ClientMismatch | OtrMissingRecipients !Public.ClientMismatch - | OtrUnknownClient !Public.UnknownClient - | OtrConversationNotFound !Public.ConvNotFound + | OtrUnknownClient !UnknownClient + | OtrConversationNotFound !ConvNotFound -handleOtrResult :: OtrResult -> Galley r Response -handleOtrResult = \case - OtrSent m -> pure $ json m & setStatus status201 - OtrMissingRecipients m -> pure $ json m & setStatus status412 - OtrUnknownClient _ -> throwErrorDescriptionType @UnknownClient - OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound +handleOtrResult :: + Members + '[ Error ClientError, + Error ConversationError + ] + r => + OtrResult -> + Galley r Response +handleOtrResult = + liftSem . \case + OtrSent m -> pure $ json m & setStatus status201 + OtrMissingRecipients m -> pure $ json m & setStatus status412 + OtrUnknownClient _ -> throw UnknownClient + OtrConversationNotFound _ -> throw ConvNotFound postBotMessageH :: Members @@ -1098,6 +1132,10 @@ postBotMessageH :: BrigAccess, ClientStore, ConversationStore, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, FederatorAccess, GundeckAccess, ExternalAccess, @@ -1118,9 +1156,10 @@ postBotMessage :: BrigAccess, ClientStore, ConversationStore, + Error LegalHoldError, + ExternalAccess, FederatorAccess, GundeckAccess, - ExternalAccess, MemberStore, TeamStore ] @@ -1130,8 +1169,7 @@ postBotMessage :: Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley r OtrResult -postBotMessage zbot zcnv val message = - postNewOtrMessage Bot (botUserId zbot) Nothing zcnv val message +postBotMessage zbot = postNewOtrMessage Bot (botUserId zbot) Nothing postProteusMessage :: Members @@ -1206,7 +1244,20 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage postProtoOtrBroadcastH :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do @@ -1215,7 +1266,20 @@ postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcastH :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do @@ -1224,7 +1288,17 @@ postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.OtrFilterMissing -> @@ -1244,7 +1318,17 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep -- | bots are not supported on broadcast postNewOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> Maybe ConnId -> OtrFilterMissing -> @@ -1266,6 +1350,7 @@ postNewOtrMessage :: BrigAccess, ClientStore, ConversationStore, + Error LegalHoldError, ExternalAccess, GundeckAccess, MemberStore, @@ -1327,7 +1412,17 @@ newMessage qusr con qcnv msg now (m, c, t) ~(toBots, toUsers) = in (toBots, p : toUsers) updateConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1338,12 +1433,21 @@ updateConversationName zusr zcon qcnv convRename = do foldQualified lusr (updateLocalConversationName lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv convRename updateUnqualifiedConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -1355,7 +1459,16 @@ updateUnqualifiedConversationName zusr zcon cnv rename = do updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -1368,7 +1481,16 @@ updateLocalConversationName lusr zcon lcnv convRename = do else liftSem $ Nothing <$ E.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -1376,33 +1498,16 @@ updateLiveLocalConversationName :: Galley r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionRename rename - -notifyConversationMetadataUpdate :: - Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => - Qualified UserId -> - Maybe ConnId -> - Local ConvId -> - BotsAndMembers -> - ConversationAction -> - Galley r Event -notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do - localDomain <- viewFederationDomain - now <- liftIO getCurrentTime - let e = conversationActionToEvent now quid qcnv action - - -- notify remote participants - liftSem $ - E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ - FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action - - -- notify local participants and bots - pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e + updateLocalConversation lcnv (qUntagged lusr) (Just con) rename isTypingH :: - Members '[GundeckAccess, MemberStore] r => + Members + '[ Error ConversationError, + Error InvalidInput, + GundeckAccess, + MemberStore + ] + r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do @@ -1411,7 +1516,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do pure empty isTyping :: - Members '[GundeckAccess, MemberStore] r => + Members '[Error ConversationError, GundeckAccess, MemberStore] r => UserId -> ConnId -> ConvId -> @@ -1422,8 +1527,7 @@ isTyping zusr zcon cnv typingData = do let qcnv = Qualified cnv localDomain qusr = Qualified zusr localDomain mm <- liftSem $ E.getLocalMembers cnv - unless (zusr `isMember` mm) $ - throwErrorDescriptionType @ConvNotFound + liftSem . unless (zusr `isMember` mm) . throw $ ConvNotFound now <- liftIO getCurrentTime let e = Event Typing qcnv qusr now (EdTyping typingData) for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> mm)) $ \p -> @@ -1433,12 +1537,22 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: Member ServiceStore r => JsonRequest Service -> Galley r Response +addServiceH :: + Members + '[ Error InvalidInput, + ServiceStore + ] + r => + JsonRequest Service -> + Galley r Response addServiceH req = do liftSem . E.createService =<< fromJsonBody req return empty -rmServiceH :: Member ServiceStore r => JsonRequest ServiceRef -> Galley r Response +rmServiceH :: + Members '[Error InvalidInput, ServiceStore] r => + JsonRequest ServiceRef -> + Galley r Response rmServiceH req = do liftSem . E.deleteService =<< fromJsonBody req return empty @@ -1447,6 +1561,9 @@ addBotH :: Members '[ ClientStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, ExternalAccess, GundeckAccess, MemberStore, @@ -1464,6 +1581,9 @@ addBot :: Members '[ ClientStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, ExternalAccess, GundeckAccess, MemberStore, @@ -1477,8 +1597,7 @@ addBot :: addBot zusr zcon b = do lusr <- qualifyLocal zusr c <- - liftSem (E.getConversation (b ^. addBotConv)) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation (b ^. addBotConv) >>= note ConvNotFound -- Check some preconditions on adding bots to a conversation for_ (Data.convTeam c) $ teamConvChecks (b ^. addBotConv) (bots, users) <- regularConvChecks lusr c @@ -1506,10 +1625,10 @@ addBot zusr zcon b = do where regularConvChecks lusr c = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) - unless (zusr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound - ensureGroupConvThrowing c - ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users + liftSem . unless (zusr `isMember` users) . throw $ ConvNotFound + liftSem $ ensureGroupConversation c + self <- getSelfMemberFromLocals zusr users + ensureActionAllowed AddConversationMember self unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] @@ -1517,11 +1636,21 @@ addBot zusr zcon b = do teamConvChecks :: ConvId -> TeamId -> Galley r () teamConvChecks cid tid = do tcv <- liftSem $ E.getTeamConversation tid cid - when (maybe True (view managedConversation) tcv) $ - throwM noAddToManaged + liftSem $ + when (maybe True (view managedConversation) tcv) $ + throw NoAddToManaged rmBotH :: - Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore] r => + Members + '[ ClientStore, + ConversationStore, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley r Response rmBotH (zusr ::: zcon ::: req) = do @@ -1529,20 +1658,27 @@ rmBotH (zusr ::: zcon ::: req) = do handleUpdateResult <$> rmBot zusr zcon bot rmBot :: - Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore] r => + Members + '[ ClientStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> RemoveBot -> Galley r (UpdateResult Event) rmBot zusr zcon b = do c <- - liftSem (E.getConversation (b ^. rmBotConv)) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation (b ^. rmBotConv) >>= note ConvNotFound localDomain <- viewFederationDomain let qcnv = Qualified (Data.convId c) localDomain qusr = Qualified zusr localDomain - unless (zusr `isMember` Data.convLocalMembers c) $ - throwErrorDescriptionType @ConvNotFound + liftSem . unless (zusr `isMember` Data.convLocalMembers c) $ + throw ConvNotFound let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) then pure Unchanged @@ -1561,17 +1697,10 @@ rmBot zusr zcon b = do ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley r () -ensureMemberLimit old new = do - o <- view options - let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) - when (length old + length new > maxSize) $ - throwM tooManyMembers - -ensureConvMember :: [LocalMember] -> UserId -> Galley r () +ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = - unless (usr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound + liftSem $ + unless (usr `isMember` users) $ throw ConvNotFound ------------------------------------------------------------------------------- -- OtrRecipients Validation @@ -1589,7 +1718,17 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: - Members '[BrigAccess, ClientStore, TeamStore] r => + forall r. + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r => UserId -> ClientId -> OtrRecipients -> @@ -1600,8 +1739,8 @@ withValidOtrBroadcastRecipients :: withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early - unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ - throwM broadcastLimitExceeded + liftSem . unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ + throw BroadcastLimitExceeded -- In large teams, we may still use the broadcast endpoint but only if `report_missing` -- is used and length `report_missing` < limit since we cannot fetch larger teams than -- that. @@ -1625,17 +1764,26 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ let localUserIdsInFilter = toList uListInFilter let localUserIdsInRcps = Map.keys $ userClientMap (otrRecipientsMap rcps) let localUserIdsToLookup = Set.toList $ Set.union (Set.fromList localUserIdsInFilter) (Set.fromList localUserIdsInRcps) - unless (length localUserIdsToLookup <= limit) $ - throwM broadcastLimitExceeded + liftSem . unless (length localUserIdsToLookup <= limit) $ + throw BroadcastLimitExceeded liftSem $ E.selectTeamMembers tid localUserIdsToLookup + maybeFetchAllMembersInTeam :: TeamId -> Galley r [TeamMember] maybeFetchAllMembersInTeam tid = do mems <- getTeamMembersForFanout tid - when (mems ^. teamMemberListType == ListTruncated) $ - throwM broadcastLimitExceeded + liftSem . when (mems ^. teamMemberListType == ListTruncated) $ + throw BroadcastLimitExceeded pure (mems ^. teamMembers) withValidOtrRecipients :: - Members '[BrigAccess, ClientStore, ConversationStore, MemberStore, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + ConversationStore, + Error LegalHoldError, + MemberStore, + TeamStore + ] + r => UserType -> UserId -> ClientId -> @@ -1663,7 +1811,7 @@ withValidOtrRecipients utype usr clt cnv rcps val now go = do handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: - Members '[BrigAccess, TeamStore] r => + Members '[BrigAccess, Error LegalHoldError, TeamStore] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1687,7 +1835,7 @@ handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipi ValidOtrRecipients m r -> go r >> pure (OtrSent m) MissingOtrRecipients m -> do guardLegalholdPolicyConflicts (userToProtectee utype usr) (missingClients m) - >>= either (const (throwErrorDescriptionType @MissingLegalholdConsent)) pure + >>= either (const (liftSem . throw $ MissingLegalholdConsent)) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription @@ -1775,10 +1923,18 @@ checkOtrRecipients usr sid prs vms vcs val now OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss -- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: Member TeamStore r => UserId -> (TeamId -> Galley r b) -> Galley r b +withBindingTeam :: + Members + '[ Error TeamError, + TeamStore + ] + r => + UserId -> + (TeamId -> Galley r b) -> + Galley r b withBindingTeam zusr callback = do - tid <- liftSem (E.getOneUserTeam zusr) >>= ifNothing teamNotFound - binding <- liftSem (E.getTeamBinding tid) >>= ifNothing teamNotFound + tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound + binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> throwM nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 5f434712e39..f76e4ff748b 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -23,11 +23,8 @@ module Galley.API.Util where import Brig.Types (Relation (..)) import Brig.Types.Intra (ReAuthUser (..)) import Control.Arrow (Arrow (second), second) -import Control.Error (ExceptT, hoistEither, note) import Control.Lens (set, view, (.~), (^.)) -import Control.Monad.Catch -import Control.Monad.Except (runExceptT) -import Control.Monad.Extra (allM, anyM, eitherM) +import Control.Monad.Extra (allM, anyM) import Data.ByteString.Conversion import Data.Domain (Domain) import Data.Id as Id @@ -37,7 +34,6 @@ import qualified Data.Map as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set -import qualified Data.Text.Lazy as LT import Data.Time import Galley.API.Error import Galley.App @@ -55,7 +51,7 @@ import Galley.Effects.LegalHoldStore import Galley.Effects.MemberStore import Galley.Effects.TeamStore import Galley.Intra.Push -import Galley.Options (optSettings, setFeatureFlags, setFederationDomain) +import Galley.Options import Galley.Types import Galley.Types.Conversations.Members (localMemberToOther, remoteMemberToOther) import Galley.Types.Conversations.Roles @@ -65,25 +61,30 @@ import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) -import Network.Wai.Utilities +import qualified Network.Wai.Utilities as Wai +import Polysemy +import Polysemy.Error import qualified Wire.API.Conversation as Public -import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Client type JSON = Media "application" "json" -ensureAccessRole :: Member BrigAccess r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () -ensureAccessRole role users = case role of - PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied +ensureAccessRole :: + Members '[BrigAccess, Error NotATeamMember, Error ConversationError] r => + AccessRole -> + [(UserId, Maybe TeamMember)] -> + Galley r () +ensureAccessRole role users = liftSem $ case role of + PrivateAccessRole -> throw ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ - throwErrorDescriptionType @NotATeamMember + throwED @NotATeamMember ActivatedAccessRole -> do - activated <- liftSem $ lookupActivatedUsers $ map fst users + activated <- lookupActivatedUsers $ map fst users when (length activated /= length users) $ - throwErrorDescriptionType @ConvAccessDenied + throw ConvAccessDenied NonActivatedAccessRole -> return () -- | Check that the given user is either part of the same team(s) as the other @@ -92,170 +93,148 @@ ensureAccessRole role users = case role of -- Team members are always considered connected, so we only check 'ensureConnected' -- for non-team-members of the _given_ user ensureConnectedOrSameTeam :: - Members '[BrigAccess, TeamStore] r => - Qualified UserId -> + Members '[BrigAccess, TeamStore, Error ActionError] r => + Local UserId -> [UserId] -> Galley r () ensureConnectedOrSameTeam _ [] = pure () -ensureConnectedOrSameTeam (Qualified u domain) uids = do - -- FUTUREWORK(federation, #1262): handle remote users (can't be part of the same team, just check connections) - localDomain <- viewFederationDomain - when (localDomain == domain) $ do - uTeams <- liftSem $ getUserTeams u - -- We collect all the relevant uids from same teams as the origin user - sameTeamUids <- liftSem . forM uTeams $ \team -> - fmap (view userId) <$> selectTeamMembers team uids - -- Do not check connections for users that are on the same team - ensureConnectedToLocals u (uids \\ join sameTeamUids) +ensureConnectedOrSameTeam (tUnqualified -> u) uids = do + uTeams <- liftSem $ getUserTeams u + -- We collect all the relevant uids from same teams as the origin user + sameTeamUids <- liftSem . forM uTeams $ \team -> + fmap (view userId) <$> selectTeamMembers team uids + -- Do not check connections for users that are on the same team + ensureConnectedToLocals u (uids \\ join sameTeamUids) -- | Check that the user is connected to everybody else. -- -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: Member BrigAccess r => Local UserId -> UserList UserId -> Galley r () +ensureConnected :: + Members '[BrigAccess, Error ActionError] r => + Local UserId -> + UserList UserId -> + Galley r () ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: Member BrigAccess r => UserId -> [UserId] -> Galley r () +ensureConnectedToLocals :: + Members '[BrigAccess, Error ActionError] r => + UserId -> + [UserId] -> + Galley r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do +ensureConnectedToLocals u uids = liftSem $ do (connsFrom, connsTo) <- - liftSem $ - getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) + getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ - throwErrorDescriptionType @NotConnected + throw NotConnected -ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () +ensureConnectedToRemotes :: + Members '[BrigAccess, Error ActionError] r => + Local UserId -> + [Remote UserId] -> + Galley r () ensureConnectedToRemotes _ [] = pure () -ensureConnectedToRemotes u remotes = do - acceptedConns <- - liftSem $ - getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) +ensureConnectedToRemotes u remotes = liftSem $ do + acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ - throwErrorDescriptionType @NotConnected - -ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () -ensureReAuthorised u secret = do - reAuthed <- liftSem $ reauthUser u (ReAuthUser secret) + throw NotConnected + +ensureReAuthorised :: + Members + '[ BrigAccess, + Error AuthenticationError + ] + r => + UserId -> + Maybe PlainTextPassword -> + Galley r () +ensureReAuthorised u secret = liftSem $ do + reAuthed <- reauthUser u (ReAuthUser secret) unless reAuthed $ - throwM reAuthFailed + throw ReAuthFailed -- | Given a member in a conversation, check if the given action -- is permitted. If the user does not have the given permission, throw -- 'operationDenied'. -ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley r () -ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of +ensureActionAllowed :: + (IsConvMember mem, Members '[Error ActionError, Error InvalidInput] r) => + Action -> + mem -> + Galley r () +ensureActionAllowed action self = liftSem $ case isActionAllowed action (convMemberRole self) of Just True -> pure () - Just False -> throwErrorDescription (actionDenied action) + Just False -> throw (ActionDenied action) -- Actually, this will "never" happen due to the -- fact that there can be no custom roles at the moment - Nothing -> throwM (badRequest "Custom roles not supported") + Nothing -> throw CustomRolesNotSupported --- | Comprehensive permission check, taking action-specific logic into account. -ensureConversationActionAllowed :: - (IsConvMember mem, Member TeamStore r) => - ConversationAction -> - Data.Conversation -> - mem -> - Galley r () -ensureConversationActionAllowed action conv self = do - loc <- qualifyLocal () - let tag = conversationActionTag (convMemberId loc self) action - -- general action check - ensureActionAllowed tag self - -- check if it is a group conversation (except for rename actions) - when (tag /= ModifyConversationName) $ - ensureGroupConvThrowing conv - -- extra action-specific checks - case action of - ConversationActionAddMembers _ role -> ensureConvRoleNotElevated self role - ConversationActionDelete -> do - case Data.convTeam conv of - Just tid -> do - foldQualified - loc - ( \lusr -> do - void $ - liftSem (getTeamMember tid (tUnqualified lusr)) - >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) - ) - (\_ -> throwM federationNotImplemented) - (convMemberId loc self) - Nothing -> pure () - ConversationActionAccessUpdate target -> do - -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and - -- so on; users are not supposed to be able to make other conversations - -- have 'PrivateAccessRole' - when - ( PrivateAccess `elem` Public.cupAccess target - || PrivateAccessRole == Public.cupAccessRole target - ) - $ throwErrorDescriptionType @InvalidTargetAccess - -- Team conversations incur another round of checks - case Data.convTeam conv of - Just tid -> do - -- Access mode change for managed conversation is not allowed - tcv <- liftSem $ getTeamConversation tid (Data.convId conv) - when (maybe False (view managedConversation) tcv) $ - throwM invalidManagedConvOp - -- Access mode change might result in members being removed from the - -- conversation, so the user must have the necessary permission flag - ensureActionAllowed RemoveConversationMember self - Nothing -> - when (Public.cupAccessRole target == TeamAccessRole) $ - throwErrorDescriptionType @InvalidTargetAccess - _ -> pure () - -ensureGroupConvThrowing :: Data.Conversation -> Galley r () -ensureGroupConvThrowing conv = case Data.convType conv of - SelfConv -> throwM invalidSelfOp - One2OneConv -> throwM invalidOne2OneOp - ConnectConv -> throwM invalidConnectOp - _ -> pure () +ensureGroupConversation :: Member (Error ActionError) r => Data.Conversation -> Sem r () +ensureGroupConversation conv = do + let ty = Data.convType conv + when (ty /= RegularConv) $ throw (InvalidOp ty) -- | Ensure that the set of actions provided are not "greater" than the user's -- own. This is used to ensure users cannot "elevate" allowed actions -- This function needs to be review when custom roles are introduced since only -- custom roles can cause `roleNameToActions` to return a Nothing -ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley r () -ensureConvRoleNotElevated origMember targetRole = do +ensureConvRoleNotElevated :: + (IsConvMember mem, Members '[Error InvalidInput, Error ActionError] r) => + mem -> + RoleName -> + Galley r () +ensureConvRoleNotElevated origMember targetRole = liftSem $ do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> unless (Set.isSubsetOf targetActions memberActions) $ - throwM invalidActions + throw InvalidAction (_, _) -> - throwM (badRequest "Custom roles not supported") + throw CustomRolesNotSupported -- | If a team member is not given throw 'notATeamMember'; if the given team -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. -permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley r TeamMember -permissionCheck p = \case - Just m -> do - if m `hasPermission` p - then pure m - else throwErrorDescription (operationDenied p) - Nothing -> throwErrorDescriptionType @NotATeamMember - -assertTeamExists :: Members '[TeamStore] r => TeamId -> Galley r () -assertTeamExists tid = do - teamExists <- liftSem $ isJust <$> getTeam tid +permissionCheck :: + (IsPerm perm, Show perm, Members '[Error ActionError, Error NotATeamMember] r) => + perm -> + Maybe TeamMember -> + Galley r TeamMember +permissionCheck p = + liftSem . \case + Just m -> do + if m `hasPermission` p + then pure m + else throw (OperationDenied (show p)) + Nothing -> throwED @NotATeamMember + +assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () +assertTeamExists tid = liftSem $ do + teamExists <- isJust <$> getTeam tid if teamExists then pure () - else throwM teamNotFound + else throw TeamNotFound -assertOnTeam :: Members '[TeamStore] r => UserId -> TeamId -> Galley r () -assertOnTeam uid tid = do - liftSem (getTeamMember tid uid) >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just _ -> return () +assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r () +assertOnTeam uid tid = + liftSem $ + getTeamMember tid uid >>= \case + Nothing -> throwED @NotATeamMember + Just _ -> return () -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). permissionCheckTeamConv :: - Members '[ConversationStore, TeamStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> ConvId -> Perm -> @@ -265,11 +244,19 @@ permissionCheckTeamConv zusr cnv perm = Just cnv' -> case Data.convTeam cnv' of Just tid -> void $ permissionCheck perm =<< liftSem (getTeamMember tid zusr) Nothing -> pure () - Nothing -> throwErrorDescriptionType @ConvNotFound + Nothing -> liftSem $ throw ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: - Members '[ConversationStore, MemberStore, GundeckAccess] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + MemberStore, + GundeckAccess + ] + r => UserId -> Data.Conversation -> Maybe ConnId -> @@ -286,10 +273,10 @@ acceptOne2One usr conv conn = do return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of [_, _] | usr `isMember` mems -> liftSem promote - [_, _] -> throwErrorDescriptionType @ConvNotFound + [_, _] -> liftSem $ throw ConvNotFound _ -> do when (length mems > 2) $ - throwM badConvState + liftSem . throw . BadConvState $ cid now <- liftIO getCurrentTime mm <- liftSem $ createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] @@ -298,17 +285,13 @@ acceptOne2One usr conv conn = do for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> liftSem $ push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect return $ conv' {Data.convLocalMembers = mems'} - _ -> throwM $ invalidOp "accept: invalid conversation type" + x -> liftSem . throw . InvalidOp $ x where cid = Data.convId conv mems = Data.convLocalMembers conv promote = do acceptConnectConversation cid return $ conv {Data.convType = One2OneConv} - badConvState = - mkError status500 "bad-state" $ - "Connect conversation with more than 2 members: " - <> LT.pack (show cid) memberJoinEvent :: Local UserId -> @@ -449,7 +432,7 @@ localBotsAndUsers = foldMap botOrUser Nothing -> ([], [m]) location :: ToByteString a => a -> Response -> Response -location = addHeader hLocation . toByteString' +location = Wai.addHeader hLocation . toByteString' nonTeamMembers :: [LocalMember] -> [TeamMember] -> [LocalMember] nonTeamMembers cm tm = filter (not . isMemberOfTeam . lmId) cm @@ -468,40 +451,42 @@ membersToRecipients :: Maybe UserId -> [TeamMember] -> [Recipient] membersToRecipients Nothing = map (userRecipient . view userId) membersToRecipients (Just u) = map userRecipient . filter (/= u) . map (view userId) --- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. -getSelfMemberFromLocalsLegacy :: - Foldable t => +getSelfMemberFromLocals :: + (Foldable t, Member (Error ConversationError) r) => UserId -> t LocalMember -> Galley r LocalMember -getSelfMemberFromLocalsLegacy usr lmems = - eitherM throwErrorDescription pure . runExceptT $ - getMember lmId (mkErrorDescription :: ConvNotFound) usr lmems +getSelfMemberFromLocals usr lmems = + liftSem $ getMember lmId ConvNotFound usr lmems -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). ensureOtherMember :: + Member (Error ConversationError) r => Local a -> Qualified UserId -> Data.Conversation -> - Galley r (Either LocalMember RemoteMember) + Sem r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = - maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ - (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) - <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) - -getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley r RemoteMember -getSelfMemberFromRemotesLegacy usr rmems = - eitherM throwErrorDescription pure . runExceptT $ - getMember rmId (mkErrorDescription :: ConvNotFound) usr rmems + note ConvMemberNotFound $ + Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv) + <|> Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv) + +getSelfMemberFromRemotes :: + (Foldable t, Member (Error ConversationError) r) => + Remote UserId -> + t RemoteMember -> + Galley r RemoteMember +getSelfMemberFromRemotes usr rmems = + liftSem $ getMember rmId ConvNotFound usr rmems getQualifiedMember :: - Monad m => + Member (Error e) r => Local x -> e -> Qualified UserId -> Data.Conversation -> - ExceptT e m (Either LocalMember RemoteMember) + Sem r (Either LocalMember RemoteMember) getQualifiedMember loc e qusr conv = foldQualified loc @@ -510,7 +495,7 @@ getQualifiedMember loc e qusr conv = qusr getMember :: - (Foldable t, Eq userId, Monad m) => + (Foldable t, Eq userId, Member (Error e) r) => -- | A projection from a member type to its user ID (mem -> userId) -> -- | An error to throw in case the user is not in the list @@ -519,39 +504,35 @@ getMember :: userId -> -- | A list of members to search t mem -> - ExceptT e m mem -getMember p ex u = hoistEither . note ex . find ((u ==) . p) + Sem r mem +getMember p ex u = note ex . find ((u ==) . p) getConversationAndCheckMembership :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => UserId -> ConvId -> Galley r Data.Conversation getConversationAndCheckMembership uid cnv = do (conv, _) <- getConversationAndMemberWithError - (errorDescriptionTypeToWai @ConvAccessDenied) + ConvAccessDenied uid cnv pure conv getConversationAndMemberWithError :: - (Member ConversationStore r, IsConvMemberId uid mem) => - Error -> + (Members '[ConversationStore, Error ConversationError] r, IsConvMemberId uid mem) => + ConversationError -> uid -> ConvId -> Galley r (Data.Conversation, mem) getConversationAndMemberWithError ex usr convId = do - c <- - liftSem (getConversation convId) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - when (DataTypes.isConvDeleted c) $ do - liftSem $ deleteConversation convId - throwErrorDescriptionType @ConvNotFound + c <- liftSem $ getConversation convId >>= note ConvNotFound + liftSem . when (DataTypes.isConvDeleted c) $ do + deleteConversation convId + throw ConvNotFound loc <- qualifyLocal () - member <- - either throwM pure . note ex $ - getConvMember loc c usr + member <- liftSem . note ex $ getConvMember loc c usr pure (c, member) -- | Deletion requires a permission check, but also a 'Role' comparison: @@ -586,38 +567,55 @@ pushConversationEvent conn e users bots = do liftSem $ deliverAsync (toList bots `zip` repeat e) verifyReusableCode :: - Member CodeStore r => + Members '[CodeStore, Error CodeError] r => ConversationCode -> Galley r DataTypes.Code verifyReusableCode convCode = do c <- - liftSem (getCode (conversationKey convCode) DataTypes.ReusableCode) - >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ + getCode (conversationKey convCode) DataTypes.ReusableCode + >>= note CodeNotFound unless (DataTypes.codeValue c == conversationCode convCode) $ - throwM (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ throw CodeNotFound return c ensureConversationAccess :: - Members '[BrigAccess, ConversationStore, TeamStore] r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> ConvId -> Access -> Galley r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- - liftSem (getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv access + liftSem $ + getConversation cnv >>= note ConvNotFound + liftSem $ ensureAccess conv access zusrMembership <- liftSem $ maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv -ensureAccess :: Data.Conversation -> Access -> Galley r () +ensureAccess :: + Member (Error ConversationError) r => + Data.Conversation -> + Access -> + Sem r () ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ - throwErrorDescriptionType @ConvAccessDenied + throw ConvAccessDenied + +ensureLocal :: Member (Error FederationError) r => Local x -> Qualified a -> Sem r (Local a) +ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation @@ -833,3 +831,10 @@ getTeamMembersForFanout :: Member TeamStore r => TeamId -> Galley r TeamMemberLi getTeamMembersForFanout tid = do lim <- fanoutLimit liftSem $ getTeamMembersWithLimit tid lim + +ensureMemberLimit :: (Foldable f, Member (Error ConversationError) r) => [LocalMember] -> f a -> Galley r () +ensureMemberLimit old new = do + o <- view options + let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) + liftSem . when (length old + length new > maxSize) $ + throw TooManyMembers diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index bdb74e49923..5d512b05f92 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -46,18 +46,18 @@ module Galley.App toServantHandler, -- * Utilities - ifNothing, fromJsonBody, fromOptionalJsonBody, fromProtoBody, fanoutLimit, currentFanoutLimit, - -- * MonadUnliftIO / Sem compatibility + -- * Temporary compatibility functions fireAndForget, spawnMany, liftGalley0, liftSem, + unGalley, interpretGalleyToGalley0, ) where @@ -116,11 +116,12 @@ import Network.HTTP.Types (hContentType) import Network.HTTP.Types.Status (statusCode, statusMessage) import Network.Wai import Network.Wai.Utilities hiding (Error) -import qualified Network.Wai.Utilities as WaiError +import qualified Network.Wai.Utilities as Wai import qualified Network.Wai.Utilities.Server as Server import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl import Polysemy +import Polysemy.Error import Polysemy.Internal (Append) import qualified Polysemy.Reader as P import qualified Polysemy.TinyLog as P @@ -156,9 +157,6 @@ instance Monad (Galley r) where instance MonadIO (Galley r) where liftIO action = Galley (liftIO action) -instance MonadThrow (Galley r) where - throwM e = Galley (embed @IO (throwM e)) - instance MonadReader Env (Galley r) where ask = Galley $ P.ask @Env local f m = Galley $ P.local f (unGalley m) @@ -278,24 +276,25 @@ evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -fromJsonBody :: FromJSON a => JsonRequest a -> Galley r a -fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) +fromJsonBody :: (Member (Error InvalidInput) r, FromJSON a) => JsonRequest a -> Galley r a +fromJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} -fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley r (Maybe a) -fromOptionalJsonBody r = exceptT (throwM . invalidPayload) return (parseOptionalBody r) +fromOptionalJsonBody :: + ( Member (Error InvalidInput) r, + FromJSON a + ) => + OptionalJsonRequest a -> + Galley r (Maybe a) +fromOptionalJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseOptionalBody r) {-# INLINE fromOptionalJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> Galley r a +fromProtoBody :: (Member (Error InvalidInput) r, Proto.Decode a) => Request -> Galley r a fromProtoBody r = do b <- readBody r - either (throwM . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) + either (liftSem . throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: WaiError.Error -> Maybe a -> Galley r a -ifNothing e = maybe (throwM e) return -{-# INLINE ifNothing #-} - toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) @@ -304,14 +303,14 @@ toServantHandler env galley = do handleWaiErrors (view applog env) (unRequestId (view reqId env)) werr Right result -> pure result where - handleWaiErrors :: Logger -> ByteString -> WaiError.Error -> Servant.Handler a + handleWaiErrors :: Logger -> ByteString -> Wai.Error -> Servant.Handler a handleWaiErrors logger reqId' werr = do Server.logError' logger (Just reqId') werr Servant.throwError $ Servant.ServerError (mkCode werr) (mkPhrase werr) (Aeson.encode werr) [(hContentType, renderHeader (Servant.contentType (Proxy @Servant.JSON)))] - mkCode = statusCode . WaiError.code - mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . WaiError.code + mkCode = statusCode . Wai.code + mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . Wai.code withLH :: Member (P.Reader Env) r => @@ -322,9 +321,17 @@ withLH f action = do lh <- P.asks (view (options . optSettings . setFeatureFlags . Teams.flagLegalHold)) f lh action +interpretErrorToException :: + (Exception e, Member (Embed IO) r) => + Sem (Error e ': r) a -> + Sem r a +interpretErrorToException = (either (embed @IO . UnliftIO.throwIO) pure =<<) . runError + interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a interpretGalleyToGalley0 = Galley + . interpretErrorToException + . mapAllErrors . interpretInternalTeamListToCassandra . interpretTeamListToCassandra . interpretLegacyConversationListToCassandra @@ -376,6 +383,9 @@ instance MonadMask Galley0 where (\resource exitCase -> evalGalley0 env (unGalley (release resource exitCase))) (\resource -> evalGalley0 env (unGalley (useB resource))) +instance MonadThrow Galley0 where + throwM e = Galley (embed @IO (throwM e)) + instance MonadCatch Galley0 where catch = UnliftIO.catch diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs index ac9d03525a3..539c2aaa4ec 100644 --- a/services/galley/src/Galley/Cassandra/Code.hs +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -25,6 +25,7 @@ import Cassandra import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store import Galley.Data.Types +import qualified Galley.Data.Types as Code import Galley.Effects.CodeStore (CodeStore (..)) import Imports import Polysemy @@ -38,6 +39,8 @@ interpretCodeStoreToCassandra = interpret $ \case GetCode k s -> embedClient $ lookupCode k s CreateCode code -> embedClient $ insertCode code DeleteCode k s -> embedClient $ deleteCode k s + MakeKey cid -> Code.mkKey cid + GenerateCode cid s t -> Code.generate cid s t -- | Insert a conversation code insertCode :: Code -> Client () diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index e2f26dea92f..f56cde0885b 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -57,6 +57,7 @@ where import Data.Id import Data.Qualified +import Galley.API.Error import Galley.Cassandra.Paging import Galley.Effects.BotAccess import Galley.Effects.BrigAccess @@ -78,10 +79,12 @@ import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamMemberStore import Galley.Effects.TeamNotificationStore import Galley.Effects.TeamStore +import qualified Network.Wai.Utilities as Wai import Polysemy +import Polysemy.Error +import Polysemy.Internal --- All the possible high-level effects. -type GalleyEffects1 = +type NonErrorGalleyEffects1 = '[ BrigAccess, GundeckAccess, SparAccess, @@ -107,3 +110,9 @@ type GalleyEffects1 = ListItems LegacyPaging TeamId, ListItems InternalPaging TeamId ] + +-- All the possible high-level effects. +type GalleyEffects1 = + Append + NonErrorGalleyEffects1 + (Append AllErrorEffects '[Error Wai.Error]) diff --git a/services/galley/src/Galley/Effects/CodeStore.hs b/services/galley/src/Galley/Effects/CodeStore.hs index 246210c230f..d06105ce5f4 100644 --- a/services/galley/src/Galley/Effects/CodeStore.hs +++ b/services/galley/src/Galley/Effects/CodeStore.hs @@ -22,15 +22,20 @@ module Galley.Effects.CodeStore -- * Create code createCode, - -- * Read code, + -- * Read code getCode, - -- * Delete code, + -- * Delete code deleteCode, + + -- * Code generation + makeKey, + generateCode, ) where import Brig.Types.Code +import Data.Id import Galley.Data.Types import Imports import Polysemy @@ -39,5 +44,7 @@ data CodeStore m a where CreateCode :: Code -> CodeStore m () GetCode :: Key -> Scope -> CodeStore m (Maybe Code) DeleteCode :: Key -> Scope -> CodeStore m () + MakeKey :: ConvId -> CodeStore m Key + GenerateCode :: ConvId -> Scope -> Timeout -> CodeStore m Code makeSem ''CodeStore diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 1c4a3038ecb..affafacf2ee 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -56,6 +56,7 @@ import qualified OpenSSL.PEM as SSL import qualified OpenSSL.RSA as SSL import qualified OpenSSL.Session as SSL import Polysemy +import Polysemy.Error import Ssl.Util import qualified Ssl.Util as SSL import qualified System.Logger.Class as Log @@ -65,14 +66,18 @@ import URI.ByteString (uriPath) -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. -checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley r () +checkLegalHoldServiceStatus :: + Member (Error LegalHoldError) r => + Fingerprint Rsa -> + HttpsUrl -> + Galley r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder if | Bilge.statusCode resp < 400 -> pure () | otherwise -> do Log.info . Log.msg $ showResponse resp - throwM legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = @@ -82,7 +87,7 @@ checkLegalHoldServiceStatus fpr url = do -- | @POST /initiate@. requestNewDevice :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> Galley r NewLegalHoldClient @@ -91,7 +96,7 @@ requestNewDevice tid uid = do case eitherDecode (responseBody resp) of Left e -> do Log.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e - throwM legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse Right client -> pure client where reqParams = @@ -104,7 +109,7 @@ requestNewDevice tid uid = do -- | @POST /confirm@ -- Confirm that a device has been linked to a user and provide an authorization token confirmLegalHold :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => ClientId -> TeamId -> UserId -> @@ -124,7 +129,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do -- | @POST /remove@ -- Inform the LegalHold Service that a user's legalhold has been disabled. removeLegalHold :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> Galley r () @@ -145,14 +150,14 @@ removeLegalHold tid uid = do -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. makeLegalHoldServiceRequest :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do maybeLHSettings <- liftSem $ LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of - Nothing -> throwM legalHoldServiceNotRegistered + Nothing -> liftSem $ throw LegalHoldServiceNotRegistered Just lhSettings -> pure lhSettings let LegalHoldService { legalHoldServiceUrl = baseUrl, diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index 13471a96218..b3aad0e32df 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -25,21 +25,21 @@ module Galley.Validation where import Control.Lens -import Control.Monad.Catch import Data.Range import Galley.API.Error -import Galley.Env import Galley.Options import Imports +import Polysemy +import Polysemy.Error -rangeChecked :: (MonadThrow galley, Within a n m) => a -> galley (Range n m a) +rangeChecked :: (Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} rangeCheckedMaybe :: - (MonadThrow galley, Within a n m) => + (Member (Error InvalidInput) r, Within a n m) => Maybe a -> - galley (Maybe (Range n m a)) + Sem r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -49,16 +49,16 @@ newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) checkedConvSize :: - (MonadReader Env galley, MonadThrow galley, Foldable f) => + (Member (Error InvalidInput) r, Foldable f) => + Opts -> f a -> - galley (ConvSizeChecked f a) -checkedConvSize x = do - o <- view options + Sem r (ConvSizeChecked f a) +checkedConvSize o x = do let minV :: Integer = 0 limit = o ^. optSettings . setMaxConvSize - 1 if length x <= fromIntegral limit then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: MonadThrow galley => String -> galley a -throwErr = throwM . invalidRange . fromString +throwErr :: Member (Error InvalidInput) r => String -> Sem r a +throwErr = throw . InvalidRange . fromString From c335c8cd44e347be28d84c2f53c8eba63348307e Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 10 Nov 2021 11:32:45 +0100 Subject: [PATCH 81/88] Add /list-connections to the local nginz config (#1921) --- deploy/services-demo/conf/nginz/nginx.conf | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 543dc2d8c3c..62e6ce5685f 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -243,6 +243,11 @@ http { proxy_pass http://brig; } + location /list-connections { + include common_response_with_zauth.conf; + proxy_pass http://brig; + } + location ~* ^/teams/([^/]+)/search$ { include common_response_with_zauth.conf; proxy_pass http://brig; From eb6b802471157df0e600104b633e435a8b7c7059 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 10 Nov 2021 11:35:56 +0100 Subject: [PATCH 82/88] Report QualifiedCapture correctly in prometheus metrics (#1919) For prometheus metrics middleware to be able to replace /users/4f7cbd8c-5fe3-4818-94c0-8ae68460ba13 with /users/:uid, it needs to know the paths in servant that exist. This is generated statically using the class `RoutesToPaths`. This class had an overlappable instance for everything, this caused to not notice when we created the QualifiedCapture type. In order to ensure that we instantiate this class correctly, this commit removes this catch-all instance and instantiate the class for every type that needs it explicitly. --- changelog.d/3-bug-fixes/metrics-handlers | 1 + libs/extended/extended.cabal | 3 +- libs/extended/package.yaml | 1 + libs/extended/src/Servant/API/Extended.hs | 4 ++ libs/metrics-wai/metrics-wai.cabal | 4 +- libs/metrics-wai/package.yaml | 1 + libs/metrics-wai/src/Data/Metrics/Servant.hs | 61 +++++++++++++------ libs/wire-api/package.yaml | 13 ++-- .../wire-api/src/Wire/API/ErrorDescription.hs | 4 ++ .../wire-api/src/Wire/API/Routes/MultiVerb.hs | 4 ++ libs/wire-api/src/Wire/API/Routes/Public.hs | 7 +++ .../src/Wire/API/Routes/QualifiedCapture.hs | 9 +++ libs/wire-api/test/unit/Main.hs | 4 +- .../test/unit/Test/Wire/API/Routes.hs | 23 +++++++ libs/wire-api/wire-api.cabal | 6 +- 15 files changed, 117 insertions(+), 28 deletions(-) create mode 100644 changelog.d/3-bug-fixes/metrics-handlers create mode 100644 libs/wire-api/test/unit/Test/Wire/API/Routes.hs diff --git a/changelog.d/3-bug-fixes/metrics-handlers b/changelog.d/3-bug-fixes/metrics-handlers new file mode 100644 index 00000000000..9104e640064 --- /dev/null +++ b/changelog.d/3-bug-fixes/metrics-handlers @@ -0,0 +1 @@ +Ensure that all endpoints have a correct handler in prometheus metrics \ No newline at end of file diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index ccadad0f1b6..4c7304bccc2 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 18004f2559de4d4ac804d0a36a2d2780d0bbc10d79ebf78f337c9e6ba7a4ff3f +-- hash: 65015665656bc1ae721971ef3e88ed707aa7a2be02ba04cf4aab39ac6188714a name: extended version: 0.1.0 @@ -42,6 +42,7 @@ library , extra , http-types , imports + , metrics-wai , optparse-applicative , servant , servant-server diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml index a2239b49a1d..aa4cdd43ab9 100644 --- a/libs/extended/package.yaml +++ b/libs/extended/package.yaml @@ -27,6 +27,7 @@ dependencies: # for servant's 'ReqBodyCustomError' type defined here. - errors - http-types +- metrics-wai - servant - servant-server - servant-swagger diff --git a/libs/extended/src/Servant/API/Extended.hs b/libs/extended/src/Servant/API/Extended.hs index 4b69d1561fe..90e1a8516fa 100644 --- a/libs/extended/src/Servant/API/Extended.hs +++ b/libs/extended/src/Servant/API/Extended.hs @@ -23,6 +23,7 @@ module Servant.API.Extended where import qualified Data.ByteString.Lazy as BL import Data.EitherR (fmapL) +import Data.Metrics.Servant import Data.String.Conversions (cs) import Data.Typeable import GHC.TypeLits @@ -113,3 +114,6 @@ instance HasSwagger (ReqBodyCustomError cts tag a :> api) where toSwagger Proxy = toSwagger (Proxy @(ReqBody' '[Required, Strict] cts a :> api)) + +instance RoutesToPaths rest => RoutesToPaths (ReqBodyCustomError' mods list tag a :> rest) where + getRoutes = getRoutes @rest diff --git a/libs/metrics-wai/metrics-wai.cabal b/libs/metrics-wai/metrics-wai.cabal index 3631c86077f..7658bf9348a 100644 --- a/libs/metrics-wai/metrics-wai.cabal +++ b/libs/metrics-wai/metrics-wai.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 1fdffa4b08c579feb0c18fe4c3c12c81ee6c503b5672735f7df5a02e02081c67 +-- hash: aefa1a394ca2caa5cad577e67967aace67b79d4c94afeba4dd399b77de826a6c name: metrics-wai version: 0.5.7 @@ -40,6 +40,7 @@ library , imports , metrics-core >=0.3 , servant + , servant-multipart , string-conversions , text >=0.11 , wai >=3 @@ -70,6 +71,7 @@ test-suite unit , metrics-core >=0.3 , metrics-wai , servant + , servant-multipart , string-conversions , text >=0.11 , wai >=3 diff --git a/libs/metrics-wai/package.yaml b/libs/metrics-wai/package.yaml index 85b90bb530a..75e681fd7aa 100644 --- a/libs/metrics-wai/package.yaml +++ b/libs/metrics-wai/package.yaml @@ -16,6 +16,7 @@ dependencies: - metrics-core >=0.3 - containers - servant +- servant-multipart - string-conversions - text >=0.11 - wai >=3 diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index b1398b9cb4c..1bcac5d86e1 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -40,6 +40,7 @@ import Network.Wai.Middleware.Prometheus import qualified Network.Wai.Middleware.Prometheus as Promth import Network.Wai.Routing (Routes, prepare) import Servant.API +import Servant.Multipart -- | This does not catch errors, so it must be called outside of 'WU.catchErrors'. servantPrometheusMiddleware :: forall proxy api. (RoutesToPaths api) => proxy api -> Wai.Middleware @@ -79,27 +80,59 @@ class RoutesToPaths routes where -- "seg" :> routes instance - {-# OVERLAPPING #-} - ( KnownSymbol seg, - RoutesToPaths segs - ) => + (KnownSymbol seg, RoutesToPaths segs) => RoutesToPaths (seg :> segs) where getRoutes = [Node (Right . cs $ symbolVal (Proxy @seg)) (getRoutes @segs)] -- :> routes instance - {-# OVERLAPPING #-} - ( KnownSymbol capture, - RoutesToPaths segs - ) => + (KnownSymbol capture, RoutesToPaths segs) => RoutesToPaths (Capture' mods capture a :> segs) where getRoutes = [Node (Left (cs (":" <> symbolVal (Proxy @capture)))) (getRoutes @segs)] +instance + (RoutesToPaths rest) => + RoutesToPaths (Header' mods name a :> rest) + where + getRoutes = getRoutes @rest + +instance + (RoutesToPaths rest) => + RoutesToPaths (ReqBody' mods cts a :> rest) + where + getRoutes = getRoutes @rest + +instance + (RoutesToPaths rest) => + RoutesToPaths (Summary summary :> rest) + where + getRoutes = getRoutes @rest + +instance + RoutesToPaths rest => + RoutesToPaths (QueryParam' mods name a :> rest) + where + getRoutes = getRoutes @rest + +instance RoutesToPaths rest => RoutesToPaths (MultipartForm tag a :> rest) where + getRoutes = getRoutes @rest + +instance + RoutesToPaths rest => + RoutesToPaths (Description desc :> rest) + where + getRoutes = getRoutes @rest + +instance RoutesToPaths (Verb method status cts a) where + getRoutes = [] + +instance RoutesToPaths (NoContentVerb method) where + getRoutes = [] + -- route :<|> routes instance - {-# OVERLAPPING #-} ( RoutesToPaths route, RoutesToPaths routes ) => @@ -107,13 +140,5 @@ instance where getRoutes = getRoutes @route <> getRoutes @routes -instance - {-# OVERLAPPABLE #-} - ( RoutesToPaths segs - ) => - RoutesToPaths (anything :> segs) - where - getRoutes = getRoutes @segs - -instance {-# OVERLAPPABLE #-} RoutesToPaths anything where +instance RoutesToPaths Raw where getRoutes = [] diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index 9d813db174d..adb7ee71461 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -10,14 +10,16 @@ copyright: (c) 2020 Wire Swiss GmbH license: AGPL-3 dependencies: - aeson >=0.6 -- containers >=0.5 -- imports -- types-common >=0.16 -- servant-swagger-ui - case-insensitive +- containers >=0.5 +- filepath - hscim +- imports +- metrics-wai - saml2-web-sso -- filepath +- servant +- servant-swagger-ui +- types-common >=0.16 library: source-dirs: src dependencies: @@ -62,7 +64,6 @@ library: - QuickCheck >=2.14 - quickcheck-instances >=0.3.16 - resourcet - - servant - servant-client - servant-client-core - servant-multipart diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 42363dc0e8c..ca896ff1462 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -3,6 +3,7 @@ module Wire.API.ErrorDescription where import Control.Lens (at, (%~), (.~), (<>~), (?~)) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS +import Data.Metrics.Servant import Data.SOP (I (..), NP (..), NS (..)) import Data.Schema import Data.Swagger (Swagger) @@ -45,6 +46,9 @@ instance route _ = route (Proxy @api) hoistServerWithContext _ = hoistServerWithContext (Proxy @api) +instance RoutesToPaths api => RoutesToPaths (CanThrow err :> api) where + getRoutes = getRoutes @api + errorDescriptionAddToSwagger :: forall (code :: Nat) (label :: Symbol) (desc :: Symbol). (KnownStatus code, KnownSymbol label, KnownSymbol desc) => diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index be89caee6c5..79b9f508253 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -47,6 +47,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Containers.ListUtils import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.Metrics.Servant import Data.Proxy import Data.SOP import qualified Data.Sequence as Seq @@ -633,3 +634,6 @@ instance method = reflectMethod (Proxy @method) hoistClientMonad _ _ f = f + +instance RoutesToPaths (MultiVerb method cs as r) where + getRoutes = [] diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index 9dcf9066518..f52a0cc0fe9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -23,6 +23,7 @@ module Wire.API.Routes.Public where import Control.Lens ((<>~)) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id as Id +import Data.Metrics.Servant import Data.Swagger import GHC.Base (Symbol) import GHC.TypeLits (KnownSymbol) @@ -94,6 +95,9 @@ instance hoistServerWithContext _ pc nt s = Servant.hoistServerWithContext (Proxy @(InternalAuth ztype opts :> api)) pc nt s +instance RoutesToPaths api => RoutesToPaths (ZAuthServant ztype opts :> api) where + getRoutes = getRoutes @api + -- FUTUREWORK: Make a PR to the servant-swagger package with this instance instance ToSchema a => ToSchema (Headers ls a) where declareNamedSchema _ = declareNamedSchema (Proxy @a) @@ -116,3 +120,6 @@ instance HasServer api ctx => HasServer (OmitDocs :> api) ctx where route _ = route (Proxy :: Proxy api) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s + +instance RoutesToPaths api => RoutesToPaths (OmitDocs :> api) where + getRoutes = getRoutes @api diff --git a/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs b/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs index 9e4f2ab24c6..78febbd5799 100644 --- a/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs +++ b/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs @@ -22,6 +22,7 @@ module Wire.API.Routes.QualifiedCapture where import Data.Domain +import Data.Metrics.Servant import Data.Qualified import Data.Swagger import GHC.TypeLits @@ -96,3 +97,11 @@ instance clientWithRoute pm _ req (Qualified value domain) = clientWithRoute pm (Proxy @(WithDomain mods capture a api)) req domain value hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @api) f . cl + +instance (RoutesToPaths api, KnownSymbol (AppendSymbol capture "_domain"), KnownSymbol capture) => RoutesToPaths (QualifiedCapture' mods capture a :> api) where + getRoutes = + getRoutes + @( Capture' mods (AppendSymbol capture "_domain") Domain + :> Capture' mods capture a + :> api + ) diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index 982dff2fca9..2ac40db0d90 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Main.hs @@ -30,6 +30,7 @@ import qualified Test.Wire.API.Golden.Protobuf as Golden.Protobuf import qualified Test.Wire.API.Roundtrip.Aeson as Roundtrip.Aeson import qualified Test.Wire.API.Roundtrip.ByteString as Roundtrip.ByteString import qualified Test.Wire.API.Roundtrip.CSV as Roundtrip.CSV +import qualified Test.Wire.API.Routes as Routes import qualified Test.Wire.API.Swagger as Swagger import qualified Test.Wire.API.Team.Member as Team.Member import qualified Test.Wire.API.User as User @@ -53,5 +54,6 @@ main = Golden.Generated.tests, Golden.Manual.tests, Golden.FromJSON.tests, - Golden.Protobuf.tests + Golden.Protobuf.tests, + Routes.tests ] diff --git a/libs/wire-api/test/unit/Test/Wire/API/Routes.hs b/libs/wire-api/test/unit/Test/Wire/API/Routes.hs new file mode 100644 index 00000000000..0c28074f69e --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Routes.hs @@ -0,0 +1,23 @@ +module Test.Wire.API.Routes where + +import Data.Metrics.Servant +import Data.Tree +import Imports +import Servant.API +import qualified Test.Tasty as T +import Test.Tasty.HUnit +import Wire.API.Routes.QualifiedCapture + +tests :: T.TestTree +tests = + T.testGroup "Routes" $ + [T.testGroup "QualifiedCapture" [testCase "must expose the captures in metrics" qualifiedCaptureMetrics]] + +type QualifiedCaptureAPI = "users" :> QualifiedCapture' '[] "uid" Int :> Get '[] Int + +qualifiedCaptureMetrics :: Assertion +qualifiedCaptureMetrics = + assertEqual + "match metrics path" + [Node (Right "users") [Node (Left ":uid_domain") [Node (Left ":uid") []]]] + (getRoutes @QualifiedCaptureAPI) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 623fa0c173f..42843d6f7cf 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 2d17ec32d1990b4f59c918291cd7a1286d20e5c54ad921ecd5eb9d01b4b9f1c8 +-- hash: 2e805d6416bf9f547993a1c6fb55d615479783065d19d63e639ffc443301ecee name: wire-api version: 0.1.0 @@ -142,6 +142,7 @@ library , iso639 >=0.1 , lens >=4.12 , memory + , metrics-wai , mime >=0.4 , mtl , pem >=0.2 @@ -424,6 +425,7 @@ test-suite wire-api-tests Test.Wire.API.Roundtrip.Aeson Test.Wire.API.Roundtrip.ByteString Test.Wire.API.Roundtrip.CSV + Test.Wire.API.Routes Test.Wire.API.Swagger Test.Wire.API.Team.Member Test.Wire.API.User @@ -453,11 +455,13 @@ test-suite wire-api-tests , iso3166-country-codes , iso639 , lens + , metrics-wai , mime , pem , pretty , proto-lens , saml2-web-sso + , servant , servant-swagger-ui , string-conversions , swagger2 From 922ec36f798459adc2a7f11fbeb19f2ccbd264fb Mon Sep 17 00:00:00 2001 From: jschaul Date: Wed, 10 Nov 2021 12:01:31 +0100 Subject: [PATCH 83/88] Allow filtering cassandra nodes by datacentre (#1886) * cassandra-util: initial version of a dcAwarePolicy for talking to cassandra * Spar: allow filtering nodes by datacentre * refactor policy code to make it reusable across services * Set dcFilterPolicyIfConfigured also for brig/galley/gundeck * changelog --- .../5-internal/cassandra-dc-aware-policy | 1 + libs/cassandra-util/cassandra-util.cabal | 3 +- libs/cassandra-util/package.yaml | 1 + libs/cassandra-util/src/Cassandra/Settings.hs | 27 ++++++++++++++++- libs/types-common/src/Util/Options.hs | 29 +++++-------------- libs/wire-api/src/Wire/API/User/Saml.hs | 1 + services/brig/brig.integration.yaml | 1 + services/brig/src/Brig/App.hs | 7 +++-- services/galley/galley.integration.yaml | 1 + services/galley/src/Galley/App.hs | 1 + services/gundeck/gundeck.integration.yaml | 1 + services/gundeck/src/Gundeck/Env.hs | 1 + services/spar/spar.integration.yaml | 1 + services/spar/src/Spar/Run.hs | 10 ++++--- 14 files changed, 54 insertions(+), 31 deletions(-) create mode 100644 changelog.d/5-internal/cassandra-dc-aware-policy diff --git a/changelog.d/5-internal/cassandra-dc-aware-policy b/changelog.d/5-internal/cassandra-dc-aware-policy new file mode 100644 index 00000000000..b574e655f58 --- /dev/null +++ b/changelog.d/5-internal/cassandra-dc-aware-policy @@ -0,0 +1 @@ +Add a 'filterNodesByDatacentre' config option useful during cassandra DC migration diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index a26223c7aa4..d68adc82518 100644 --- a/libs/cassandra-util/cassandra-util.cabal +++ b/libs/cassandra-util/cassandra-util.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9a030e92940be80f5ff4f31e38dbbddc2d24567f1114953edf9924cf61f9c43f +-- hash: 0e7f101562d82c7e04fbc1824f5bc9ef427915eacf3bd7370a2412a016a022be name: cassandra-util version: 0.16.5 @@ -35,6 +35,7 @@ library aeson >=0.7 , base >=4.6 && <5.0 , conduit + , containers , cql >=3.0.0 , cql-io >=0.14 , cql-io-tinylog diff --git a/libs/cassandra-util/package.yaml b/libs/cassandra-util/package.yaml index ca9dc4318b5..cb0241dc840 100644 --- a/libs/cassandra-util/package.yaml +++ b/libs/cassandra-util/package.yaml @@ -12,6 +12,7 @@ dependencies: - aeson >=0.7 - base >=4.6 && <5.0 - conduit +- containers - cql >=3.0.0 - cql-io >=0.14 - cql-io-tinylog diff --git a/libs/cassandra-util/src/Cassandra/Settings.hs b/libs/cassandra-util/src/Cassandra/Settings.hs index f11c0b7a6c2..ae289828c0d 100644 --- a/libs/cassandra-util/src/Cassandra/Settings.hs +++ b/libs/cassandra-util/src/Cassandra/Settings.hs @@ -23,6 +23,8 @@ module Cassandra.Settings ( module C, initialContactsDisco, initialContactsPlain, + dcAwareRandomPolicy, + dcFilterPolicyIfConfigured, ) where @@ -30,10 +32,11 @@ import Control.Lens import Data.Aeson.Lens import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (pack, stripSuffix, unpack) -import Database.CQL.IO as C (Policy, Settings, addContact, defSettings, setCompression, setConnectTimeout, setContacts, setIdleTimeout, setKeyspace, setLogger, setMaxConnections, setMaxStreams, setMaxTimeouts, setPolicy, setPoolStripes, setPortNumber, setPrepareStrategy, setProtocolVersion, setResponseTimeout, setRetrySettings, setSendTimeout) +import Database.CQL.IO as C hiding (values) import Database.CQL.IO.Tinylog as C (mkLogger) import Imports import Network.Wreq +import qualified System.Logger as Log -- | This function is likely only useful at Wire, as it is Wire-infra specific. -- Given a server name and a url returning a wire-custom "disco" json (AWS describe-instances-like json), e.g. @@ -62,3 +65,25 @@ initialContactsDisco (pack -> srv) url = liftIO $ do -- | Puts the address into a list using the same signature as the other initialContacts initialContactsPlain :: MonadIO m => Text -> m (NonEmpty String) initialContactsPlain address = pure $ unpack address :| [] + +-- | Use dcAwareRandomPolicy if config option filterNodesByDatacentre is set, +-- otherwise use all available nodes with the default random policy. +-- +-- This is only useful during a cassandra datacentre migration. +dcFilterPolicyIfConfigured :: Log.Logger -> Maybe Text -> IO Policy +dcFilterPolicyIfConfigured lgr mDatacentre = do + Log.info lgr $ + Log.msg ("Using the following cassandra load balancing options ('Policy'):" :: Text) + . Log.field "filter_datacentre" (show mDatacentre) + maybe random dcAwareRandomPolicy mDatacentre + +-- | Return hosts in random order for a given DC. +-- +-- This is only useful during a cassandra datacentre migration. +dcAwareRandomPolicy :: Text -> IO Policy +dcAwareRandomPolicy dc = do + randomPolicy <- C.random + pure $ randomPolicy {acceptable = dcAcceptable} + where + dcAcceptable :: Host -> IO Bool + dcAcceptable host = pure $ (host ^. dataCentre) == dc diff --git a/libs/types-common/src/Util/Options.hs b/libs/types-common/src/Util/Options.hs index 33313e9a5ce..1897caa8e69 100644 --- a/libs/types-common/src/Util/Options.hs +++ b/libs/types-common/src/Util/Options.hs @@ -87,7 +87,13 @@ makeLenses ''Endpoint data CassandraOpts = CassandraOpts { _casEndpoint :: !Endpoint, - _casKeyspace :: !Text + _casKeyspace :: !Text, + -- | If this option is unset, use all available nodes. + -- If this option is set, use only cassandra nodes in the given datacentre + -- + -- This option is most likely only necessary during a cassandra DC migration + -- FUTUREWORK: remove this option again, or support a datacentre migration feature + _casFilterNodesByDatacentre :: !(Maybe Text) } deriving (Show, Generic) @@ -156,27 +162,6 @@ parseConfigPath defaultPath desc = do parseAWSEndpoint :: ReadM AWSEndpoint parseAWSEndpoint = readerAsk >>= maybe (error "Could not parse AWS endpoint") return . fromByteString . fromString -cassandraParser :: Parser CassandraOpts -cassandraParser = - CassandraOpts - <$> ( Endpoint - <$> ( textOption $ - long "cassandra-host" - <> metavar "HOSTNAME" - <> help "Cassandra hostname or address" - ) - <*> ( option auto $ - long "cassandra-port" - <> metavar "PORT" - <> help "Cassandra port" - ) - ) - <*> ( textOption $ - long "cassandra-keyspace" - <> metavar "STRING" - <> help "Cassandra keyspace" - ) - discoUrlParser :: Parser Text discoUrlParser = textOption $ diff --git a/libs/wire-api/src/Wire/API/User/Saml.hs b/libs/wire-api/src/Wire/API/User/Saml.hs index c9b21fdf3a0..7c7c99fed5a 100644 --- a/libs/wire-api/src/Wire/API/User/Saml.hs +++ b/libs/wire-api/src/Wire/API/User/Saml.hs @@ -88,6 +88,7 @@ substituteVar' var val = ST.intercalate val . ST.splitOn var type Opts = Opts' DerivedOpts +-- FUTUREWORK: Shouldn't these types be in spar, not in wire-api? data Opts' a = Opts { saml :: !SAML.Config, brig :: !Endpoint, diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index ee9b28c2f26..b5ca314dfb9 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -7,6 +7,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: brig_test + # filterNodesByDatacentre: datacenter1 elasticsearch: url: http://127.0.0.1:9200 diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 00899404253..98fca2d7d3e 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -395,20 +395,21 @@ initCassandra :: Opts -> Logger -> IO Cas.ClientState initCassandra o g = do c <- maybe - (Cas.initialContactsPlain ((Opt.cassandra o) ^. casEndpoint . epHost)) + (Cas.initialContactsPlain (Opt.cassandra o ^. casEndpoint . epHost)) (Cas.initialContactsDisco "cassandra_brig") (unpack <$> Opt.discoUrl o) p <- Cas.init $ Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.brig") g)) . Cas.setContacts (NE.head c) (NE.tail c) - . Cas.setPortNumber (fromIntegral ((Opt.cassandra o) ^. casEndpoint . epPort)) - . Cas.setKeyspace (Keyspace ((Opt.cassandra o) ^. casKeyspace)) + . Cas.setPortNumber (fromIntegral (Opt.cassandra o ^. casEndpoint . epPort)) + . Cas.setKeyspace (Keyspace (Opt.cassandra o ^. casKeyspace)) . Cas.setMaxConnections 4 . Cas.setPoolStripes 4 . Cas.setSendTimeout 3 . Cas.setResponseTimeout 10 . Cas.setProtocolVersion Cas.V4 + . Cas.setPolicy (Cas.dcFilterPolicyIfConfigured g (Opt.cassandra o ^. casFilterNodesByDatacentre)) $ Cas.defSettings runClient p $ versionCheck schemaVersion return p diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 5a617f7e3b2..16ab778ef1f 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -7,6 +7,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: galley_test + # filterNodesByDatacentre: datacenter1 brig: host: 0.0.0.0 diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 5d512b05f92..3053713219c 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -231,6 +231,7 @@ initCassandra o l = do . C.setSendTimeout 3 . C.setResponseTimeout 10 . C.setProtocolVersion C.V4 + . C.setPolicy (C.dcFilterPolicyIfConfigured l (o ^. optCassandra . casFilterNodesByDatacentre)) $ C.defSettings initHttpManager :: Opts -> IO Manager diff --git a/services/gundeck/gundeck.integration.yaml b/services/gundeck/gundeck.integration.yaml index edcd47d014f..e33c0e6cc90 100644 --- a/services/gundeck/gundeck.integration.yaml +++ b/services/gundeck/gundeck.integration.yaml @@ -7,6 +7,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: gundeck_test + # filterNodesByDatacentre: datacenter1 redis: host: 127.0.0.1 diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index 3c9888281d4..1a0c7d42985 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -93,6 +93,7 @@ createEnv m o = do . C.setSendTimeout 3 . C.setResponseTimeout 10 . C.setProtocolVersion C.V4 + . C.setPolicy (C.dcFilterPolicyIfConfigured l (o ^. optCassandra . casFilterNodesByDatacentre)) $ C.defSettings a <- Aws.mkEnv l o n io <- diff --git a/services/spar/spar.integration.yaml b/services/spar/spar.integration.yaml index 6b40d809505..77792b4ee16 100644 --- a/services/spar/spar.integration.yaml +++ b/services/spar/spar.integration.yaml @@ -27,6 +27,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: spar_test + filterNodesByDatacentre: datacenter1 # Wire/AWS specific, optional # discoUrl: "https://" diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 8dd7bd7439b..325d96665e6 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -54,7 +54,7 @@ import Spar.Orphans () import Spar.Sem.Logger.TinyLog (toLevel) import System.Logger.Class (Logger) import qualified System.Logger.Extended as Log -import Util.Options (casEndpoint, casKeyspace, epHost, epPort) +import Util.Options (casEndpoint, casFilterNodesByDatacentre, casKeyspace, epHost, epPort) import Wire.API.User.Saml as Types ---------------------------------------------------------------------- @@ -62,9 +62,10 @@ import Wire.API.User.Saml as Types initCassandra :: Opts -> Logger -> IO ClientState initCassandra opts lgr = do + let cassOpts = Types.cassandra opts connectString <- maybe - (Cas.initialContactsPlain (Types.cassandra opts ^. casEndpoint . epHost)) + (Cas.initialContactsPlain (cassOpts ^. casEndpoint . epHost)) (Cas.initialContactsDisco "cassandra_spar") (cs <$> Types.discoUrl opts) cas <- @@ -72,14 +73,15 @@ initCassandra opts lgr = do Cas.defSettings & Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.spar") lgr)) & Cas.setContacts (NE.head connectString) (NE.tail connectString) - & Cas.setPortNumber (fromIntegral $ Types.cassandra opts ^. casEndpoint . epPort) - & Cas.setKeyspace (Keyspace $ Types.cassandra opts ^. casKeyspace) + & Cas.setPortNumber (fromIntegral $ cassOpts ^. casEndpoint . epPort) + & Cas.setKeyspace (Keyspace $ cassOpts ^. casKeyspace) & Cas.setMaxConnections 4 & Cas.setMaxStreams 128 & Cas.setPoolStripes 4 & Cas.setSendTimeout 3 & Cas.setResponseTimeout 10 & Cas.setProtocolVersion V4 + & Cas.setPolicy (Cas.dcFilterPolicyIfConfigured lgr (cassOpts ^. casFilterNodesByDatacentre)) runClient cas $ Cas.versionCheck Data.schemaVersion pure cas From 65c208012d648588030e82f29da3f8833d55b826 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 10 Nov 2021 17:28:09 +0100 Subject: [PATCH 84/88] direnv.nix: List all system deps for building haskell libraries (#1922) It makes the cabal build even more pure because it doesn't depend on preset values of LD_LIBRARY_PATH, CPATH, etc. --- direnv.nix | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/direnv.nix b/direnv.nix index e91f6a7f5c5..65fb8cada9d 100644 --- a/direnv.nix +++ b/direnv.nix @@ -112,7 +112,15 @@ let compile-deps = pkgs.buildEnv { name = "wire-server-compile-deps"; paths = [ + pkgs.bash + pkgs.coreutils + pkgs.gnused + pkgs.gnugrep pkgs.pkgconfig + pkgs.gawk + pkgs.git + + pkgs.haskell.compiler.ghc884 pkgs.protobuf pkgs.cryptobox @@ -143,11 +151,11 @@ let # for cabal, as setting it in direnv can interfere with programs in the host # system, especially for non-NixOS users. cabal-wrapper = pkgs.writeShellScriptBin "cabal" '' - export CPATH="${compile-deps}/include:$CPATH" - export LD_LIBRARY_PATH="${compile-deps}/lib:$LD_LIBRARY_PATH" - export LIBRARY_PATH="${compile-deps}/lib:$LIBRARY_PATH" - export PKG_CONFIG_PATH="${compile-deps}/lib/pkgconfig:$PKG_CONFIG_PATH" - export PATH="${compile-deps}/bin:$PATH" + export CPATH="${compile-deps}/include" + export LD_LIBRARY_PATH="${compile-deps}/lib" + export LIBRARY_PATH="${compile-deps}/lib" + export PKG_CONFIG_PATH="${compile-deps}/lib/pkgconfig" + export PATH="${compile-deps}/bin" exec "${pkgs.cabal-install}/bin/cabal" "$@" ''; in pkgs.buildEnv { @@ -175,7 +183,6 @@ in pkgs.buildEnv { pinned.kind # For cabal-migration - pkgs.haskell.compiler.ghc884 pkgs.haskellPackages.cabal-plan # We don't use pkgs.cabal-install here, as we invoke it with a wrapper From 187d52c75a0bd271fb100bbf10300cc5df583ece Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 12 Nov 2021 10:20:32 +0100 Subject: [PATCH 85/88] Update documentation of dependency setup (#1900) * added pcre packages (perl compatible regex needed for headroom) * put more emphasis on the stack version which should match the one on the Dockerfile and added a note on how to downgrade if necessary * moved and updated nix and direnv instruction * Update docs/developer/dependencies.md Co-authored-by: jschaul * added a note on building nginz Co-authored-by: jschaul --- docs/developer/dependencies.md | 44 ++++++++++++++++++++++++++-------- docs/developer/how-to.md | 1 + tools/nginz_disco/README.md | 2 +- 3 files changed, 36 insertions(+), 11 deletions(-) diff --git a/docs/developer/dependencies.md b/docs/developer/dependencies.md index 3cd670834ed..878132cebfc 100644 --- a/docs/developer/dependencies.md +++ b/docs/developer/dependencies.md @@ -11,6 +11,32 @@ In addition to the information below, you can also consult the Dockerfiles for A ## General package dependencies (needed to compile Haskell services) +*Note: all the below sections for getting compile-time dependencies necessary to compile all of wire-server may potentially go out of date; if you spot a mistake please open an issue or PR* + +### Nix + Direnv + +Using Stack's [Nix integration](https://docs.haskellstack.org/en/stable/nix_integration/), Stack will take care of installing any system +dependencies automatically - including `cryptobox-c`. If new system dependencies are needed, add them to the `stack-deps.nix` file in the project root. + +If you have `direnv` and `nix`, you will automatically have `make`, `docker-compose` and `stack` in `PATH` once you `cd` into the project root and `direnv allow`. +You can then run all the builds, and the native dependencies will be automatically present. + +1. Install [Nix](https://nixos.org/download.html) + * MacOS users with a recent Mac might need to follow [these + instructions](https://nixos.org/nix/manual/#sect-macos-installation) + * Debian users can use their distro's `nix` package, and should remember + + to add their user to the `nix-users` group in /etc/group, and re-start + their login session. +2. Install [Direnv](https://direnv.net/). + * On debian, you can install the `direnv` package. On MacOS use `brew install direnv`. + * On NixOS with home-manager, you can set `programs.direnv.enable = true;`. + * Make sure direnv is hooked into your shell via it's appripriate `rc` file. + Add `eval "$(direnv hook bash|zsh|fish)"` to your ~/.(bash|zsh|fish)rc . + * When successfully installed and hooked, direnv should ask you to `direnv allow` + the current `.envrc` when you cd to this repository. + See the [Installation documentation](https://direnv.net/docs/installation.html) for further details. + ### Fedora: ```bash @@ -22,7 +48,7 @@ sudo dnf install -y pkgconfig haskell-platform libstdc++-devel libstdc++-static _Note_: Debian is not recommended due to this issue when running local integration tests: [#327](https://github.com/wireapp/wire-server/issues/327). This issue does not occur with Ubuntu. ```bash -sudo apt install pkg-config libsodium-dev openssl-dev libtool automake build-essential libicu-dev libsnappy-dev libgeoip-dev protobuf-compiler libxml2-dev zlib1g-dev libtinfo-dev liblzma-dev -y +sudo apt install pkg-config libsodium-dev openssl-dev libtool automake build-essential libicu-dev libsnappy-dev libgeoip-dev protobuf-compiler libxml2-dev zlib1g-dev libtinfo-dev liblzma-dev libpcre3 libpcre3-dev -y ``` If `openssl-dev` does not work for you, try `libssl-dev`. @@ -63,7 +89,13 @@ sudo installer -pkg /Library/Developer/CommandLineTools/Packages/macOS_SDK_heade Please refer to [Stack's installation instructions](https://docs.haskellstack.org/en/stable/README/#how-to-install). -When you're done, ensure `stack --version` is recent, ideally the same as `STACK_ALPINE_VERSION` in [`build/alpine/Dockerfile.prebuilder`](../../build/alpine/Dockerfile.prebuilder). +When you're done, ensure `stack --version` is the same as `STACK_ALPINE_VERSION` in [`build/alpine/Dockerfile.prebuilder`](../../build/alpine/Dockerfile.prebuilder). + +If you have to, you can downgrade stack with this command: + +```bash +stack upgrade --binary-version +``` ### Ubuntu / Debian _Note_: The packaged versions of `haskell-stack` are too old. It is recommended to follow the generic instructions or to use stack to update stack (`stack upgrade`). @@ -174,14 +206,6 @@ docker login --username= * [Install docker](https://docker.com) * [Install docker-compose](https://docs.docker.com/compose/install/) -## Nix + Direnv - -Using Stack's [Nix integration](https://docs.haskellstack.org/en/stable/nix_integration/), Stack will take care of installing any system -dependencies automatically - including `cryptobox-c`. If new system dependencies are needed, add them to the `stack-deps.nix` file in the project root. - -If you have `direnv` and `nix`, you will automatically have `make`, `docker-compose` and `stack` in `PATH` once you `cd` into the project root and `direnv allow`. -You can then run all the builds, and the native dependencies will be automatically present. - ## Telepresence You can instead use [telepresence](https://www.telepresence.io) to allow you to talk to services installed in a given kubernetes namespace on a local or remote kubernetes cluster using easy DNS names like: `curl http://elasticsearch:9200`. diff --git a/docs/developer/how-to.md b/docs/developer/how-to.md index 883eabb8bdc..aa2a42b7f89 100644 --- a/docs/developer/how-to.md +++ b/docs/developer/how-to.md @@ -9,6 +9,7 @@ Terminal 1: Terminal 2: * Compile all services: `make services` + * Note that you have to [import the public signing keys for nginx](../../services/nginz/README.md#common-problems-while-compiling) to be able to build nginz * Run services including nginz: `export INTEGRATION_USE_NGINZ=1; ./services/start-services-only.sh` Open your browser at: diff --git a/tools/nginz_disco/README.md b/tools/nginz_disco/README.md index da952414c76..5571c7a1a38 100644 --- a/tools/nginz_disco/README.md +++ b/tools/nginz_disco/README.md @@ -2,5 +2,5 @@ Due to nginx not supporting DNS names for its list of upstream servers (unless you pay extra), the nginz-disco container is a simple bash script to do DNS lookups and write the resulting IPs to a file. Nginz reloads on changes to this file. -This is useful as a sidecar container to nginz in kubernetes. See also [wire-server-deploy/nginz](https://github.com/wireapp/wire-server-deploy/charts/nginz/) +This is useful as a sidecar container to nginz in kubernetes. See also [wire-server-deploy/nginz](https://github.com/wireapp/wire-server-deploy/charts/nginz/) +# [2021-11-15] + +## Release notes + +* In case you use a multi-datacentre cassandra setup (most likely you do not), be aware that now [LOCAL_QUORUM](https://docs.datastax.com/en/cassandra-oss/3.0/cassandra/dml/dmlConfigConsistency.html) is in use as a default. (#1884) +* Deploy galley before brig. (#1857) +* Upgrade webapp version to 2021-11-01-production.0-v0.28.29-0-d919633 (#1856) + +## API changes + +* Remove locale from publicly facing user profiles (but not from the self profile) (#1888) + +## Features + +* End-points for configuring self-deleting messages. (#1857) + +## Bug fixes and other updates + +* Ensure that all endpoints have a correct handler in prometheus metrics (#1919) +* Push events when AppLock or SelfDeletingMessages config change. (#1901) + +## Documentation + +* Federation: Document how to deploy local builds (#1880) + +## Internal changes + +* Add a 'filterNodesByDatacentre' config option useful during cassandra DC migration (#1886) +* Add ormolu to the direnv, add a GH Action to ensure formatting (#1908) +* Turn placeholder access effects into actual Polysemy effects. (#1904) +* Fix a bug in the IdP.Mem interpreter, and added law tests for IdP (#1863) +* Introduce fine-grained error types and polysemy error effects in Galley. (#1907) +* Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy (#1890, #1906). (#1890) +* Make golden-tests in wire-api package a separate test suite (for faster feedback loop during development). (#1926) +* Separate IdPRawMetadataStore effect from IdP effect (#1924) +* Test sending message to multiple remote domains (#1899) +* Use cabal to build wire-server (opt-in) (#1853) + +## Federation changes + +* Close GRPC client after making a request to a federator. (#1865) +* Do not fail user deletion when a remote notification fails (#1912) +* Add a one-to-one conversation test in getting conversations in the federation API (#1899) +* Notify remote participants when a user leaves a conversation because they were deleted (#1891) + # [2021-10-29] ## Release notes diff --git a/changelog.d/0-release-notes/cassandra-local-quorum b/changelog.d/0-release-notes/cassandra-local-quorum deleted file mode 100644 index 7fa32fb3982..00000000000 --- a/changelog.d/0-release-notes/cassandra-local-quorum +++ /dev/null @@ -1 +0,0 @@ -In case you use a multi-datacentre cassandra setup (most likely you do not), be aware that now [LOCAL_QUORUM](https://docs.datastax.com/en/cassandra-oss/3.0/cassandra/dml/dmlConfigConsistency.html) is in use as a default. diff --git a/changelog.d/0-release-notes/pr-1857 b/changelog.d/0-release-notes/pr-1857 deleted file mode 100644 index 0592108c6f7..00000000000 --- a/changelog.d/0-release-notes/pr-1857 +++ /dev/null @@ -1 +0,0 @@ -Deploy galley before brig. diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade deleted file mode 100644 index c99f65cd9f5..00000000000 --- a/changelog.d/0-release-notes/webapp-upgrade +++ /dev/null @@ -1 +0,0 @@ -Upgrade webapp version to 2021-11-01-production.0-v0.28.29-0-d919633 diff --git a/changelog.d/1-api-changes/remove-locale-in-user-profiles b/changelog.d/1-api-changes/remove-locale-in-user-profiles deleted file mode 100644 index bab32abbbb7..00000000000 --- a/changelog.d/1-api-changes/remove-locale-in-user-profiles +++ /dev/null @@ -1 +0,0 @@ -Remove locale from publicly facing user profiles (but not from the self profile) diff --git a/changelog.d/2-features/pr-1857-self-deleting-messages-feature b/changelog.d/2-features/pr-1857-self-deleting-messages-feature deleted file mode 100644 index dbfd30c783f..00000000000 --- a/changelog.d/2-features/pr-1857-self-deleting-messages-feature +++ /dev/null @@ -1 +0,0 @@ -End-points for configuring self-deleting messages. \ No newline at end of file diff --git a/changelog.d/3-bug-fixes/metrics-handlers b/changelog.d/3-bug-fixes/metrics-handlers deleted file mode 100644 index 9104e640064..00000000000 --- a/changelog.d/3-bug-fixes/metrics-handlers +++ /dev/null @@ -1 +0,0 @@ -Ensure that all endpoints have a correct handler in prometheus metrics \ No newline at end of file diff --git a/changelog.d/3-bug-fixes/pr-1901 b/changelog.d/3-bug-fixes/pr-1901 deleted file mode 100644 index 177e67f63ab..00000000000 --- a/changelog.d/3-bug-fixes/pr-1901 +++ /dev/null @@ -1 +0,0 @@ -Push events when AppLock or SelfDeletingMessages config change. diff --git a/changelog.d/4-docs/doc-more-helm-deploy b/changelog.d/4-docs/doc-more-helm-deploy deleted file mode 100644 index 536e1c1178f..00000000000 --- a/changelog.d/4-docs/doc-more-helm-deploy +++ /dev/null @@ -1 +0,0 @@ -Federation: Document how to deploy local builds diff --git a/changelog.d/5-internal/cassandra-dc-aware-policy b/changelog.d/5-internal/cassandra-dc-aware-policy deleted file mode 100644 index b574e655f58..00000000000 --- a/changelog.d/5-internal/cassandra-dc-aware-policy +++ /dev/null @@ -1 +0,0 @@ -Add a 'filterNodesByDatacentre' config option useful during cassandra DC migration diff --git a/changelog.d/5-internal/ormolu-direnv b/changelog.d/5-internal/ormolu-direnv deleted file mode 100644 index ae0dddfd756..00000000000 --- a/changelog.d/5-internal/ormolu-direnv +++ /dev/null @@ -1 +0,0 @@ -Add ormolu to the direnv, add a GH Action to ensure formatting diff --git a/changelog.d/5-internal/polysemy-access-effects b/changelog.d/5-internal/polysemy-access-effects deleted file mode 100644 index ac3addb66f7..00000000000 --- a/changelog.d/5-internal/polysemy-access-effects +++ /dev/null @@ -1 +0,0 @@ -Turn placeholder access effects into actual Polysemy effects. diff --git a/changelog.d/5-internal/polysemy-check-spar b/changelog.d/5-internal/polysemy-check-spar deleted file mode 100644 index bd9600b4fd7..00000000000 --- a/changelog.d/5-internal/polysemy-check-spar +++ /dev/null @@ -1 +0,0 @@ -Fix a bug in the IdP.Mem interpreter, and added law tests for IdP diff --git a/changelog.d/5-internal/polysemy-errors b/changelog.d/5-internal/polysemy-errors deleted file mode 100644 index b7b8060ebf0..00000000000 --- a/changelog.d/5-internal/polysemy-errors +++ /dev/null @@ -1 +0,0 @@ -Introduce fine-grained error types and polysemy error effects in Galley. diff --git a/changelog.d/5-internal/polysemy-store b/changelog.d/5-internal/polysemy-store deleted file mode 100644 index 92950ac7efe..00000000000 --- a/changelog.d/5-internal/polysemy-store +++ /dev/null @@ -1 +0,0 @@ -Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy (#1890, #1906). diff --git a/changelog.d/5-internal/separate-golden-testa b/changelog.d/5-internal/separate-golden-testa deleted file mode 100644 index 2f84041c317..00000000000 --- a/changelog.d/5-internal/separate-golden-testa +++ /dev/null @@ -1 +0,0 @@ -Make golden-tests in wire-api package a separate test suite (for faster feedback loop during development). diff --git a/changelog.d/5-internal/split-eff1 b/changelog.d/5-internal/split-eff1 deleted file mode 100644 index 6ee92481a37..00000000000 --- a/changelog.d/5-internal/split-eff1 +++ /dev/null @@ -1 +0,0 @@ -Separate IdPRawMetadataStore effect from IdP effect diff --git a/changelog.d/5-internal/test-fed-message-multi-domain b/changelog.d/5-internal/test-fed-message-multi-domain deleted file mode 100644 index 6414bf856c0..00000000000 --- a/changelog.d/5-internal/test-fed-message-multi-domain +++ /dev/null @@ -1 +0,0 @@ -Test sending message to multiple remote domains \ No newline at end of file diff --git a/changelog.d/5-internal/use-cabal b/changelog.d/5-internal/use-cabal deleted file mode 100644 index 2f8378eadcb..00000000000 --- a/changelog.d/5-internal/use-cabal +++ /dev/null @@ -1 +0,0 @@ -Use cabal to build wire-server (opt-in) diff --git a/changelog.d/6-federation/close-grpc-client b/changelog.d/6-federation/close-grpc-client deleted file mode 100644 index 274b7be3c62..00000000000 --- a/changelog.d/6-federation/close-grpc-client +++ /dev/null @@ -1 +0,0 @@ -Close GRPC client after making a request to a federator. diff --git a/changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes b/changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes deleted file mode 100644 index 0b55867b7c8..00000000000 --- a/changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes +++ /dev/null @@ -1 +0,0 @@ -Do not fail user deletion when a remote notification fails diff --git a/changelog.d/6-federation/extend-get-conversations-test b/changelog.d/6-federation/extend-get-conversations-test deleted file mode 100644 index 8de3baa748c..00000000000 --- a/changelog.d/6-federation/extend-get-conversations-test +++ /dev/null @@ -1 +0,0 @@ -Add a one-to-one conversation test in getting conversations in the federation API diff --git a/changelog.d/6-federation/notify-remotes b/changelog.d/6-federation/notify-remotes deleted file mode 100644 index 0aeaa8c457f..00000000000 --- a/changelog.d/6-federation/notify-remotes +++ /dev/null @@ -1 +0,0 @@ -Notify remote participants when a user leaves a conversation because they were deleted