Spar Polysemy: Separate Misc Utilities

changelog.d/5-internal/sem-utils

@@ -0,0 +1 @@
+Separate some Spar.Sem utility functions into their own module

services/spar/spar.cabal

@@ -86,6 +86,7 @@ library
       Spar.Sem.ScimUserTimesStore
       Spar.Sem.ScimUserTimesStore.Cassandra
       Spar.Sem.ScimUserTimesStore.Mem
+      Spar.Sem.Utils
       Spar.Sem.VerdictFormatStore
       Spar.Sem.VerdictFormatStore.Cassandra
       Spar.Sem.VerdictFormatStore.Mem

services/spar/src/Spar/CanonicalInterpreter.hs

@@ -30,7 +30,7 @@ import Spar.App hiding (sparToServerErrorWithLogging)
 import Spar.Error
 import Spar.Orphans ()
 import Spar.Sem.AReqIDStore (AReqIDStore)
-import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError)
+import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra)
 import Spar.Sem.AssIDStore (AssIDStore)
 import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra)
 import Spar.Sem.BindCookieStore (BindCookieStore)
@@ -56,7 +56,7 @@ import Spar.Sem.Reporter.Wai (reporterToTinyLogWai)
 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.SAMLUserStore.Cassandra (samlUserStoreToCassandra)
 import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings)
 import Spar.Sem.SamlProtocolSettings.Servant (sparRouteToServant)
 import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore)
@@ -65,6 +65,7 @@ import Spar.Sem.ScimTokenStore (ScimTokenStore)
 import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra)
 import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore)
 import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra)
+import Spar.Sem.Utils (interpretClientToIO, ttlErrorToSparError)
 import Spar.Sem.VerdictFormatStore (VerdictFormatStore)
 import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra)
 import qualified System.Logger as TinyLog

services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs

@@ -28,7 +28,6 @@ import SAML2.WebSSO (fromTime)
 import qualified SAML2.WebSSO as SAML
 import qualified Spar.Data as Data
 import Spar.Data.Instances ()
-import Spar.Error
 import Spar.Sem.AReqIDStore
 import Spar.Sem.Now (Now)
 import qualified Spar.Sem.Now as Now
@@ -49,9 +48,6 @@ aReqIDStoreToCassandra = interpret $ \case
   UnStore itla -> embed @m $ unStoreAReqID itla
   IsAlive itla -> embed @m $ isAliveAReqID itla
 
-ttlErrorToSparError :: Member (Error SparError) r => Sem (Error TTLError ': r) a -> Sem r a
-ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError)
-
 storeAReqID ::
   (HasCallStack, MonadReader Data.Env m, MonadClient m, MonadError TTLError m) =>
   AReqId ->

services/spar/src/Spar/Sem/BrigAccess/Http.hs

@@ -24,8 +24,8 @@ import Polysemy.Error (Error)
 import Spar.Error (SparError)
 import qualified Spar.Intra.Brig as Intra
 import Spar.Sem.BrigAccess
-import Spar.Sem.GalleyAccess.Http (RunHttpEnv (..), viaRunHttp)
 import Spar.Sem.Logger (Logger)
+import Spar.Sem.Utils (RunHttpEnv (..), viaRunHttp)
 import qualified System.Logger as TinyLog
 
 brigAccessToHttp ::

services/spar/src/Spar/Sem/GalleyAccess/Http.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
@@ -20,67 +18,15 @@
 module Spar.Sem.GalleyAccess.Http where
 
 import Bilge
-import Control.Monad.Except
 import Imports hiding (log)
 import Polysemy
 import Polysemy.Error
 import Spar.Error (SparError)
-import Spar.Intra.Brig (MonadSparToBrig (..))
-import Spar.Intra.Galley (MonadSparToGalley)
 import qualified Spar.Intra.Galley as Intra
 import Spar.Sem.GalleyAccess
 import Spar.Sem.Logger (Logger)
-import qualified Spar.Sem.Logger as Logger
-import Spar.Sem.Logger.TinyLog (fromLevel)
+import Spar.Sem.Utils
 import qualified System.Logger as TinyLog
-import qualified System.Logger.Class as TinyLog
-
-data RunHttpEnv r = RunHttpEnv
-  { rheManager :: Bilge.Manager,
-    rheRequest :: Bilge.Request
-  }
-
-newtype RunHttp r a = RunHttp
-  { unRunHttp :: ReaderT (RunHttpEnv r) (ExceptT SparError (HttpT (Sem r))) a
-  }
-  deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadReader (RunHttpEnv r))
-
-instance Member (Embed IO) r => MonadIO (RunHttp r) where
-  liftIO = semToRunHttp . embed
-
-instance Member (Embed IO) r => MonadHttp (RunHttp r) where
-  handleRequestWithCont r fribia =
-    RunHttp $
-      lift $
-        lift $
-          handleRequestWithCont r fribia
-
-semToRunHttp :: Sem r a -> RunHttp r a
-semToRunHttp = RunHttp . lift . lift . lift
-
-viaRunHttp ::
-  Members '[Error SparError, Embed IO] r =>
-  RunHttpEnv r ->
-  RunHttp r a ->
-  Sem r a
-viaRunHttp env m = do
-  ma <- runHttpT (rheManager env) $ runExceptT $ flip runReaderT env $ unRunHttp m
-  case ma of
-    Left err -> throw err
-    Right a -> pure a
-
-instance Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r => TinyLog.MonadLogger (RunHttp r) where
-  log lvl msg = semToRunHttp $ Logger.log (fromLevel lvl) msg
-
-instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToGalley (RunHttp r) where
-  call modreq = do
-    req <- asks rheRequest
-    httpLbs req modreq
-
-instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToBrig (RunHttp r) where
-  call modreq = do
-    req <- asks rheRequest
-    httpLbs req modreq
 
 galleyAccessToHttp ::
   Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Error SparError, Embed IO] r =>

services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs

@@ -21,18 +21,13 @@ module Spar.Sem.SAMLUserStore.Cassandra where
 
 import Cassandra as Cas
 import Control.Lens
-import qualified Control.Monad.Catch as Catch
 import Control.Monad.Except
 import Data.Id
-import Data.String.Conversions
 import Imports
 import Polysemy
-import Polysemy.Error
-import Polysemy.Final
 import qualified SAML2.WebSSO as SAML
 import qualified Spar.Data as Data
 import Spar.Data.Instances ()
-import Spar.Error
 import Spar.Sem.SAMLUserStore
 
 samlUserStoreToCassandra ::
@@ -50,19 +45,6 @@ samlUserStoreToCassandra =
       DeleteByIssuer is -> deleteSAMLUsersByIssuer is
       Delete uid ur -> deleteSAMLUser uid ur
 
--- TODO(sandy): move me
-interpretClientToIO ::
-  Members '[Error SparError, Final IO] r =>
-  ClientState ->
-  Sem (Embed Client ': r) a ->
-  Sem r a
-interpretClientToIO ctx = interpret $ \case
-  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
-
 -- | 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 LocalQuorum (tenant, Data.normalizeQualifiedNameId subject, subject, uid)

services/spar/src/Spar/Sem/Utils.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
+--
+-- 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 <https://www.gnu.org/licenses/>.
+
+module Spar.Sem.Utils (viaRunHttp, RunHttpEnv (..), interpretClientToIO, ttlErrorToSparError) where
+
+import Bilge
+import Cassandra as Cas
+import qualified Control.Monad.Catch as Catch
+import Control.Monad.Except
+import Data.String.Conversions
+import Imports hiding (log)
+import Polysemy
+import Polysemy.Error
+import Polysemy.Final
+import qualified SAML2.WebSSO as SAML
+import Spar.Error
+import Spar.Intra.Brig (MonadSparToBrig (..))
+import Spar.Intra.Galley (MonadSparToGalley)
+import qualified Spar.Intra.Galley as Intra
+import Spar.Sem.Logger (Logger)
+import qualified Spar.Sem.Logger as Logger
+import Spar.Sem.Logger.TinyLog (fromLevel)
+import qualified System.Logger as TinyLog
+import qualified System.Logger.Class as TinyLog
+import Wire.API.User.Saml
+
+-- | Run an embedded Cassandra 'Client'  in @Final IO@.
+interpretClientToIO ::
+  Members '[Error SparError, Final IO] r =>
+  ClientState ->
+  Sem (Embed Client ': r) a ->
+  Sem r a
+interpretClientToIO ctx = interpret $ \case
+  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
+
+ttlErrorToSparError :: Member (Error SparError) r => Sem (Error TTLError ': r) a -> Sem r a
+ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError)
+
+data RunHttpEnv r = RunHttpEnv
+  { rheManager :: Bilge.Manager,
+    rheRequest :: Bilge.Request
+  }
+
+newtype RunHttp r a = RunHttp
+  { unRunHttp :: ReaderT (RunHttpEnv r) (ExceptT SparError (HttpT (Sem r))) a
+  }
+  deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadReader (RunHttpEnv r))
+
+instance Member (Embed IO) r => MonadIO (RunHttp r) where
+  liftIO = semToRunHttp . embed
+
+instance Member (Embed IO) r => MonadHttp (RunHttp r) where
+  handleRequestWithCont r fribia =
+    RunHttp $
+      lift $
+        lift $
+          handleRequestWithCont r fribia
+
+semToRunHttp :: Sem r a -> RunHttp r a
+semToRunHttp = RunHttp . lift . lift . lift
+
+viaRunHttp ::
+  Members '[Error SparError, Embed IO] r =>
+  RunHttpEnv r ->
+  RunHttp r a ->
+  Sem r a
+viaRunHttp env m = do
+  ma <- runHttpT (rheManager env) $ runExceptT $ flip runReaderT env $ unRunHttp m
+  case ma of
+    Left err -> throw err
+    Right a -> pure a
+
+instance Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r => TinyLog.MonadLogger (RunHttp r) where
+  log lvl msg = semToRunHttp $ Logger.log (fromLevel lvl) msg
+
+instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToGalley (RunHttp r) where
+  call modreq = do
+    req <- asks rheRequest
+    httpLbs req modreq
+
+instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToBrig (RunHttp r) where
+  call modreq = do
+    req <- asks rheRequest
+    httpLbs req modreq