Galley polysemy (1/5) - Introduce Sem and "access" effects

changelog.d/5-internal/galley-polysemy

@@ -0,0 +1 @@
+Turn `Galley` into a polysemy monad stack.

libs/bilge/src/Bilge/RPC.hs

@@ -33,15 +33,14 @@ 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)
 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 ->

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"

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

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

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

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