Galley polysemy (3/5) - Access effects

changelog.d/5-internal/polysemy-access-effects

@@ -0,0 +1 @@
+Turn placeholder access effects into actual Polysemy 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: 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

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

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

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

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)