Galley polysemy (3/5) - Access effects

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

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,

services/galley/galley.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1b185cc3a9afe5d7a6c21c93d6c031963a5eb924885b6314ffc92ce96c6b545d
+-- hash: 38ac7f6aba3a32570b8ba7cee173570f8bbe29c53084b8aac249f9b809e49d86
 
 name:           galley
 version:        0.83.0
@@ -71,6 +71,8 @@ library
       Galley.Data.TeamNotifications
       Galley.Data.Types
       Galley.Effects
+      Galley.Effects.BotAccess
+      Galley.Effects.BrigAccess
       Galley.Effects.ClientStore
       Galley.Effects.CodeStore
       Galley.Effects.ConversationStore
@@ -80,12 +82,15 @@ library
       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.Journal
       Galley.Intra.Push
       Galley.Intra.Spar

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 ::

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

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 ()

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)
 

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

@@ -26,11 +26,11 @@ 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.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
@@ -255,10 +255,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))

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

@@ -94,18 +94,17 @@ 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.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 +268,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
@@ -379,7 +378,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 $
@@ -398,7 +397,7 @@ uncheckedDeleteTeam zusr zcon tid = do
     -- 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
@@ -509,8 +508,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 +567,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 +713,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 +735,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 +803,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
 
@@ -874,15 +877,15 @@ 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
       let sizeAfterDelete =
             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
@@ -1081,7 +1084,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 +1106,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
 
@@ -1226,7 +1229,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)