Spar Polysemy: Split VerdictFormatStore from AReqIdStore (#1925)

* Split out VerdictFormatStore effect

Also did some related cleanup around orphan instances

* make format

* changelog

* Cleanup imports

Co-authored-by: Matthias Fischmann <[email protected]>

Author: isovector

changelog.d/5-internal/split-eff2

@@ -0,0 +1 @@
+Separate VerdictFormatStore effect from AReqIdStore effect

services/spar/spar.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 6007f4f8ec59cf0a438cd7831dc87bda6d60acd7865f6c251bd6f2da5617b381
+-- hash: f787f064cceffbeeef6ac5c1ca7475e519a51afc3fdd173bf7a7a86a9016b238
 
 name:           spar
 version:        0.1
@@ -74,6 +74,8 @@ library
       Spar.Sem.ScimTokenStore.Cassandra
       Spar.Sem.ScimUserTimesStore
       Spar.Sem.ScimUserTimesStore.Cassandra
+      Spar.Sem.VerdictFormatStore
+      Spar.Sem.VerdictFormatStore.Cassandra
   other-modules:
       Paths_spar
   hs-source-dirs:

services/spar/src/Spar/API.hs

@@ -67,7 +67,6 @@ import qualified Spar.Intra.BrigApp as Brig
 import Spar.Orphans ()
 import Spar.Scim
 import Spar.Sem.AReqIDStore (AReqIDStore)
-import qualified Spar.Sem.AReqIDStore as AReqIDStore
 import Spar.Sem.AssIDStore (AssIDStore)
 import Spar.Sem.BindCookieStore (BindCookieStore)
 import qualified Spar.Sem.BindCookieStore as BindCookieStore
@@ -96,6 +95,8 @@ import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore)
 import Spar.Sem.ScimTokenStore (ScimTokenStore)
 import qualified Spar.Sem.ScimTokenStore as ScimTokenStore
 import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore)
+import Spar.Sem.VerdictFormatStore (VerdictFormatStore)
+import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore
 import System.Logger (Msg)
 import qualified URI.ByteString as URI
 import Wire.API.Cookie
@@ -116,6 +117,7 @@ api ::
        BindCookieStore,
        AssIDStore,
        AReqIDStore,
+       VerdictFormatStore,
        ScimExternalIdStore,
        ScimUserTimesStore,
        ScimTokenStore,
@@ -153,6 +155,7 @@ apiSSO ::
        BrigAccess,
        BindCookieStore,
        AssIDStore,
+       VerdictFormatStore,
        AReqIDStore,
        ScimTokenStore,
        DefaultSsoCode,
@@ -241,6 +244,7 @@ authreq ::
        Logger String,
        BindCookieStore,
        AssIDStore,
+       VerdictFormatStore,
        AReqIDStore,
        SAML2,
        SamlProtocolSettings,
@@ -266,7 +270,7 @@ authreq authreqttl _ zusr msucc merr idpid = do
           WireIdPAPIV1 -> Nothing
           WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam
     SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid
-  AReqIDStore.storeVerdictFormat authreqttl reqid vformat
+  VerdictFormatStore.store authreqttl reqid vformat
   cky <- initializeBindCookie zusr authreqttl
   Logger.log SAML.Debug $ "setting bind cookie: " <> show cky
   pure $ addHeader cky form
@@ -324,6 +328,7 @@ authresp ::
        BrigAccess,
        BindCookieStore,
        AssIDStore,
+       VerdictFormatStore,
        AReqIDStore,
        ScimTokenStore,
        IdPEffect.IdP,

services/spar/src/Spar/App.hs

@@ -81,7 +81,6 @@ import Spar.Error hiding (sparToServerErrorWithLogging)
 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.BindCookieStore (BindCookieStore)
 import qualified Spar.Sem.BindCookieStore as BindCookieStore
 import Spar.Sem.BrigAccess (BrigAccess)
@@ -102,6 +101,8 @@ import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore)
 import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore
 import Spar.Sem.ScimTokenStore (ScimTokenStore)
 import qualified Spar.Sem.ScimTokenStore as ScimTokenStore
+import Spar.Sem.VerdictFormatStore (VerdictFormatStore)
+import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore
 import qualified System.Logger as TinyLog
 import URI.ByteString as URI
 import Web.Cookie (SetCookie, renderSetCookie)
@@ -375,6 +376,7 @@ verdictHandler ::
        BrigAccess,
        BindCookieStore,
        AReqIDStore,
+       VerdictFormatStore,
        ScimTokenStore,
        IdPEffect.IdP,
        Error SparError,
@@ -393,7 +395,7 @@ verdictHandler cky mbteam aresp verdict = do
   -- the InResponseTo attribute MUST match the request's ID.
   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
+  format :: Maybe VerdictFormat <- VerdictFormatStore.get reqid
   resp <- case format of
     Just (VerdictFormatWeb) ->
       verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb

services/spar/src/Spar/CanonicalInterpreter.hs

@@ -48,6 +48,8 @@ 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.VerdictFormatStore (VerdictFormatStore)
+import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra)
 import qualified System.Logger as TinyLog
 import Wire.API.User.Saml
 
@@ -57,6 +59,7 @@ type CanonicalEffs =
      BindCookieStore,
      AssIDStore,
      AReqIDStore,
+     VerdictFormatStore,
      ScimExternalIdStore,
      ScimUserTimesStore,
      ScimTokenStore,
@@ -104,6 +107,7 @@ runSparToIO ctx action =
     . scimTokenStoreToCassandra
     . scimUserTimesStoreToCassandra
     . scimExternalIdStoreToCassandra
+    . verdictFormatStoreToCassandra
     . aReqIDStoreToCassandra
     . assIDStoreToCassandra
     . bindCookieStoreToCassandra

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

@@ -1,16 +1,13 @@
 module Spar.Sem.AReqIDStore where
 
-import Data.Time (NominalDiffTime)
 import Imports
 import Polysemy
 import qualified SAML2.WebSSO.Types as SAML
-import Wire.API.User.Saml (AReqId, VerdictFormat)
+import Wire.API.User.Saml (AReqId)
 
 data AReqIDStore m a where
   Store :: AReqId -> SAML.Time -> AReqIDStore m ()
   UnStore :: AReqId -> AReqIDStore m ()
   IsAlive :: AReqId -> AReqIDStore m Bool
-  StoreVerdictFormat :: NominalDiffTime -> AReqId -> VerdictFormat -> AReqIDStore m ()
-  GetVerdictFormat :: AReqId -> AReqIDStore m (Maybe VerdictFormat)
 
 makeSem ''AReqIDStore

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

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 module Spar.Sem.AReqIDStore.Cassandra where
 
 import Cassandra
@@ -8,31 +6,29 @@ import Imports hiding (MonadReader (..), Reader)
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input (Input, input)
-import SAML2.WebSSO (HasNow, fromTime, getNow)
+import SAML2.WebSSO (fromTime)
 import qualified SAML2.WebSSO as SAML
 import qualified Spar.Data as Data
 import Spar.Error
 import Spar.Sem.AReqIDStore
+import Spar.Sem.Now (Now)
+import qualified Spar.Sem.Now as Now
 import Wire.API.User.Saml (Opts, TTLError)
 
-instance Member (Embed IO) r => HasNow (Sem r)
-
 aReqIDStoreToCassandra ::
   forall m r a.
-  (MonadClient m, Members '[Embed m, Error TTLError, Embed IO, Input Opts] r) =>
+  (MonadClient m, Members '[Embed m, Now, Error TTLError, Embed IO, Input Opts] r) =>
   Sem (AReqIDStore ': r) a ->
   Sem r a
 aReqIDStoreToCassandra = interpret $ \case
   Store itla t -> do
-    denv <- Data.mkEnv <$> input <*> (fromTime <$> getNow)
+    denv <- Data.mkEnv <$> input <*> (fromTime <$> Now.get)
     a <- embed @m $ runExceptT $ runReaderT (Data.storeAReqID itla t) denv
     case a of
       Left err -> throw err
       Right () -> pure ()
   UnStore itla -> embed @m $ Data.unStoreAReqID itla
   IsAlive itla -> embed @m $ Data.isAliveAReqID itla
-  StoreVerdictFormat ndt itla vf -> embed @m $ Data.storeVerdictFormat ndt itla vf
-  GetVerdictFormat itla -> embed @m $ Data.getVerdictFormat itla
 
 ttlErrorToSparError :: Member (Error SparError) r => Sem (Error TTLError ': r) a -> Sem r a
 ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError)

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

@@ -6,21 +6,22 @@ import Imports hiding (MonadReader (..), Reader)
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input
-import SAML2.WebSSO (fromTime, getNow)
+import SAML2.WebSSO (fromTime)
 import qualified Spar.Data as Data
-import Spar.Sem.AReqIDStore.Cassandra ()
 import Spar.Sem.AssIDStore
+import Spar.Sem.Now (Now)
+import qualified Spar.Sem.Now as Now
 import Wire.API.User.Saml (Opts, TTLError)
 
 assIDStoreToCassandra ::
   forall m r a.
-  (MonadClient m, Members '[Embed m, Error TTLError, Embed IO, Input Opts] r) =>
+  (MonadClient m, Members '[Embed m, Now, Error TTLError, Embed IO, Input Opts] r) =>
   Sem (AssIDStore ': r) a ->
   Sem r a
 assIDStoreToCassandra =
   interpret $ \case
     Store itla t -> do
-      denv <- Data.mkEnv <$> input <*> (fromTime <$> getNow)
+      denv <- Data.mkEnv <$> input <*> (fromTime <$> Now.get)
       a <- embed @m $ runExceptT $ runReaderT (Data.storeAssID itla t) denv
       case a of
         Left err -> throw err

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

@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
 
 module Spar.Sem.BindCookieStore.Cassandra where
@@ -9,20 +8,21 @@ import Imports hiding (MonadReader (..), Reader)
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input
-import SAML2.WebSSO (fromTime, getNow)
+import SAML2.WebSSO (fromTime)
 import qualified Spar.Data as Data
-import Spar.Sem.AReqIDStore.Cassandra ()
 import Spar.Sem.BindCookieStore
+import Spar.Sem.Now (Now)
+import qualified Spar.Sem.Now as Now
 import Wire.API.User.Saml (Opts, TTLError)
 
 bindCookieStoreToCassandra ::
   forall m r a.
-  (MonadClient m, Members '[Embed m, Error TTLError, Embed IO, Input Opts] r) =>
+  (MonadClient m, Members '[Embed m, Now, Error TTLError, Embed IO, Input Opts] r) =>
   Sem (BindCookieStore ': r) a ->
   Sem r a
 bindCookieStoreToCassandra = interpret $ \case
   Insert sbc uid ndt -> do
-    denv <- Data.mkEnv <$> input <*> (fromTime <$> getNow)
+    denv <- Data.mkEnv <$> input <*> (fromTime <$> Now.get)
     a <- embed @m $ runExceptT $ runReaderT (Data.insertBindCookie sbc uid ndt) denv
     case a of
       Left err -> throw err

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

@@ -0,0 +1,12 @@
+module Spar.Sem.VerdictFormatStore where
+
+import Data.Time (NominalDiffTime)
+import Imports
+import Polysemy
+import Wire.API.User.Saml (AReqId, VerdictFormat)
+
+data VerdictFormatStore m a where
+  Store :: NominalDiffTime -> AReqId -> VerdictFormat -> VerdictFormatStore m ()
+  Get :: AReqId -> VerdictFormatStore m (Maybe VerdictFormat)
+
+makeSem ''VerdictFormatStore