Spar Polysemy: Split VerdictFormatStore from AReqIdStore

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

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

@@ -0,0 +1,16 @@
+module Spar.Sem.VerdictFormatStore.Cassandra where
+
+import Cassandra
+import Imports hiding (MonadReader (..), Reader)
+import Polysemy
+import qualified Spar.Data as Data
+import Spar.Sem.VerdictFormatStore
+
+verdictFormatStoreToCassandra ::
+  forall m r a.
+  (MonadClient m, Member (Embed m) r) =>
+  Sem (VerdictFormatStore ': r) a ->
+  Sem r a
+verdictFormatStoreToCassandra = interpret $ \case
+  Store ndt itla vf -> embed @m $ Data.storeVerdictFormat ndt itla vf
+  Get itla -> embed @m $ Data.getVerdictFormat itla

services/spar/test-integration/Test/Spar/DataSpec.hs

@@ -41,6 +41,7 @@ import qualified Spar.Sem.BindCookieStore as BindCookieStore
 import qualified Spar.Sem.IdP as IdPEffect
 import qualified Spar.Sem.SAMLUserStore as SAMLUserStore
 import qualified Spar.Sem.ScimTokenStore as ScimTokenStore
+import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore
 import Type.Reflection (typeRep)
 import URI.ByteString.QQ (uri)
 import Util.Core
@@ -93,24 +94,24 @@ spec = do
       context "insert and get are \"inverses\"" $ do
         let check vf = it (show vf) $ do
               vid <- nextSAMLID
-              () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid vf
-              mvf <- runSpar $ AReqIDStore.getVerdictFormat vid
+              () <- runSpar $ VerdictFormatStore.store 1 vid vf
+              mvf <- runSpar $ VerdictFormatStore.get vid
               liftIO $ mvf `shouldBe` Just vf
         check
           `mapM_` [ VerdictFormatWeb,
                     VerdictFormatMobile [uri|https://fw/ooph|] [uri|https://lu/gn|]
                   ]
       context "has timed out" $ do
-        it "AReqIDStore.getVerdictFormat returns Nothing" $ do
+        it "VerdictFormatStore.get returns Nothing" $ do
           vid <- nextSAMLID
-          () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid VerdictFormatWeb
+          () <- runSpar $ VerdictFormatStore.store 1 vid VerdictFormatWeb
           liftIO $ threadDelay 2000000
-          mvf <- runSpar $ AReqIDStore.getVerdictFormat vid
+          mvf <- runSpar $ VerdictFormatStore.get vid
           liftIO $ mvf `shouldBe` Nothing
       context "does not exist" $ do
-        it "AReqIDStore.getVerdictFormat returns Nothing" $ do
+        it "VerdictFormatStore.get returns Nothing" $ do
           vid <- nextSAMLID
-          mvf <- runSpar $ AReqIDStore.getVerdictFormat vid
+          mvf <- runSpar $ VerdictFormatStore.get vid
           liftIO $ mvf `shouldBe` Nothing
     describe "User" $ do
       context "user is new" $ do