Spar Polysemy: Split IdPRawMetadataStore from IdP (#1924)

* Separate IdPRawMetadataStore

* make format

* Changelog

* Fix bad merge

* Split out IdPSpec also

* make format

* hpack

Author: isovector

changelog.d/5-internal/split-eff1

@@ -0,0 +1 @@
+Separate IdPRawMetadataStore effect from IdP effect

services/spar/spar.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: a0e25b55baaade0d8e5c5317b255ef5191d861abfde4369ef34ffb6d77bc8e0d
+-- hash: 6007f4f8ec59cf0a438cd7831dc87bda6d60acd7865f6c251bd6f2da5617b381
 
 name:           spar
 version:        0.1
@@ -51,6 +51,9 @@ library
       Spar.Sem.IdP
       Spar.Sem.IdP.Cassandra
       Spar.Sem.IdP.Mem
+      Spar.Sem.IdPRawMetadataStore
+      Spar.Sem.IdPRawMetadataStore.Cassandra
+      Spar.Sem.IdPRawMetadataStore.Mem
       Spar.Sem.Logger
       Spar.Sem.Logger.TinyLog
       Spar.Sem.Now
@@ -499,6 +502,7 @@ test-suite spec
       Test.Spar.Intra.BrigSpec
       Test.Spar.Roundtrip.ByteString
       Test.Spar.ScimSpec
+      Test.Spar.Sem.IdPRawMetadataStoreSpec
       Test.Spar.Sem.IdPSpec
       Test.Spar.TypesSpec
       Paths_spar

services/spar/src/Spar/API.hs

@@ -78,6 +78,8 @@ import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode
 import Spar.Sem.GalleyAccess (GalleyAccess)
 import qualified Spar.Sem.GalleyAccess as GalleyAccess
 import qualified Spar.Sem.IdP as IdPEffect
+import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore)
+import qualified Spar.Sem.IdPRawMetadataStore as IdPRawMetadataStore
 import Spar.Sem.Logger (Logger)
 import qualified Spar.Sem.Logger as Logger
 import Spar.Sem.Now (Now)
@@ -119,6 +121,7 @@ api ::
        ScimTokenStore,
        DefaultSsoCode,
        IdPEffect.IdP,
+       IdPRawMetadataStore,
        SAMLUserStore,
        Random,
        Error SparError,
@@ -181,6 +184,7 @@ apiIDP ::
        BrigAccess,
        ScimTokenStore,
        IdPEffect.IdP,
+       IdPRawMetadataStore,
        SAMLUserStore,
        Error SparError
      ]
@@ -380,14 +384,21 @@ idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do
   pure idp
 
 idpGetRaw ::
-  Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r =>
+  Members
+    '[ GalleyAccess,
+       BrigAccess,
+       IdPEffect.IdP,
+       IdPRawMetadataStore,
+       Error SparError
+     ]
+    r =>
   Maybe UserId ->
   SAML.IdPId ->
   Sem r RawIdPMetadata
 idpGetRaw zusr idpid = do
   idp <- getIdPConfig idpid
   _ <- authorizeIdP zusr idp
-  IdPEffect.getRawMetadata idpid >>= \case
+  IdPRawMetadataStore.get idpid >>= \case
     Just txt -> pure $ RawIdPMetadata txt
     Nothing -> throwSparSem $ SparIdPNotFound (cs $ show idpid)
 
@@ -426,6 +437,7 @@ idpDelete ::
        ScimTokenStore,
        SAMLUserStore,
        IdPEffect.IdP,
+       IdPRawMetadataStore,
        Error SparError
      ]
     r =>
@@ -462,7 +474,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons
   -- Delete IdP config
   do
     IdPEffect.deleteConfig idp
-    IdPEffect.deleteRawMetadata idpid
+    IdPRawMetadataStore.delete idpid
   return NoContent
   where
     updateOldIssuers :: IdP -> Sem r ()
@@ -492,6 +504,7 @@ idpCreate ::
        GalleyAccess,
        BrigAccess,
        ScimTokenStore,
+       IdPRawMetadataStore,
        IdPEffect.IdP,
        Error SparError
      ]
@@ -512,6 +525,7 @@ idpCreateXML ::
        BrigAccess,
        ScimTokenStore,
        IdPEffect.IdP,
+       IdPRawMetadataStore,
        Error SparError
      ]
     r =>
@@ -526,7 +540,7 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive
   GalleyAccess.assertSSOEnabled teamid
   assertNoScimOrNoIdP teamid
   idp <- validateNewIdP apiversion idpmeta teamid mReplaces
-  IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw
+  IdPRawMetadataStore.store (idp ^. SAML.idpId) raw
   storeIdPConfig idp
   forM_ mReplaces $ \replaces -> do
     IdPEffect.setReplacedBy (Data.Replaced replaces) (Data.Replacing (idp ^. SAML.idpId))
@@ -635,6 +649,7 @@ idpUpdate ::
        GalleyAccess,
        BrigAccess,
        IdPEffect.IdP,
+       IdPRawMetadataStore,
        Error SparError
      ]
     r =>
@@ -651,6 +666,7 @@ idpUpdateXML ::
        GalleyAccess,
        BrigAccess,
        IdPEffect.IdP,
+       IdPRawMetadataStore,
        Error SparError
      ]
     r =>
@@ -662,7 +678,7 @@ idpUpdateXML ::
 idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^. SAML.idpId)) $ do
   (teamid, idp) <- validateIdPUpdate zusr idpmeta idpid
   GalleyAccess.assertSSOEnabled teamid
-  IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw
+  IdPRawMetadataStore.store (idp ^. SAML.idpId) raw
   -- (if raw metadata is stored and then spar goes out, raw metadata won't match the
   -- structured idp config.  since this will lead to a 5xx response, the client is epected to
   -- try again, which would clean up cassandra state.)

services/spar/src/Spar/CanonicalInterpreter.hs

@@ -26,6 +26,8 @@ import Spar.Sem.GalleyAccess (GalleyAccess)
 import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp)
 import qualified Spar.Sem.IdP as IdPEffect
 import Spar.Sem.IdP.Cassandra (idPToCassandra)
+import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore)
+import Spar.Sem.IdPRawMetadataStore.Cassandra (idpRawMetadataStoreToCassandra)
 import Spar.Sem.Logger (Logger)
 import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog)
 import Spar.Sem.Now (Now)
@@ -60,6 +62,7 @@ type CanonicalEffs =
      ScimTokenStore,
      DefaultSsoCode,
      IdPEffect.IdP,
+     IdPRawMetadataStore,
      SAMLUserStore,
      Embed (Cas.Client),
      BrigAccess,
@@ -95,6 +98,7 @@ runSparToIO ctx action =
     . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx)
     . interpretClientToIO (sparCtxCas ctx)
     . samlUserStoreToCassandra
+    . idpRawMetadataStoreToCassandra
     . idPToCassandra
     . defaultSsoCodeToCassandra
     . scimTokenStoreToCassandra

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

@@ -36,11 +36,6 @@ data IdP m a where
   -- affects _wiReplacedBy in GetConfig
   SetReplacedBy :: Replaced -> Replacing -> IdP m ()
   ClearReplacedBy :: Replaced -> IdP m ()
-  -- TODO(sandy): maybe this wants  to be a separate effect
-  -- data Metadata  m a where
-  StoreRawMetadata :: SAML.IdPId -> Text -> IdP m ()
-  GetRawMetadata :: SAML.IdPId -> IdP m (Maybe Text)
-  DeleteRawMetadata :: SAML.IdPId -> IdP m ()
 
 deriving stock instance Show (IdP m a)
 

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

@@ -29,6 +29,3 @@ idPToCassandra =
          in Data.deleteIdPConfig idpid issuer team
       SetReplacedBy r r11 -> Data.setReplacedBy r r11
       ClearReplacedBy r -> Data.clearReplacedBy r
-      StoreRawMetadata i t -> Data.storeIdPRawMetadata i t
-      GetRawMetadata i -> Data.getIdPRawMetadata i
-      DeleteRawMetadata i -> Data.deleteIdPRawMetadata i

services/spar/src/Spar/Sem/IdP/Mem.hs

@@ -1,8 +1,8 @@
 {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
 
-module Spar.Sem.IdP.Mem (idPToMem, IS) where
+module Spar.Sem.IdP.Mem (idPToMem, TypedState) where
 
-import Control.Lens ((%~), (.~), (^.), _1, _2)
+import Control.Lens ((.~), (^.))
 import Data.Id (TeamId)
 import qualified Data.Map as M
 import Imports
@@ -12,45 +12,35 @@ import qualified SAML2.WebSSO.Types as SAML
 import qualified Spar.Sem.IdP as Eff
 import qualified Wire.API.User.IdentityProvider as IP
 
-type IS = (TypedState, RawState)
-
 type TypedState = Map SAML.IdPId IP.IdP
 
-type RawState = Map SAML.IdPId Text
-
 idPToMem ::
   forall r a.
   Sem (Eff.IdP ': r) a ->
-  Sem r (IS, a)
+  Sem r (TypedState, a)
 idPToMem = evState . evEff
   where
-    evState :: Sem (State IS : r) a -> Sem r (IS, a)
+    evState :: Sem (State TypedState : r) a -> Sem r (TypedState, a)
     evState = runState mempty
 
-    evEff :: Sem (Eff.IdP ': r) a -> Sem (State IS ': r) a
-    evEff = reinterpret @_ @(State IS) $ \case
+    evEff :: Sem (Eff.IdP ': r) a -> Sem (State TypedState ': r) a
+    evEff = reinterpret @_ @(State TypedState) $ \case
       Eff.StoreConfig iw ->
-        modify' (_1 %~ storeConfig iw)
+        modify' (storeConfig iw)
       Eff.GetConfig i ->
-        gets (getConfig i . (^. _1))
+        gets (getConfig i)
       Eff.GetIdByIssuerWithoutTeam iss ->
-        gets (getIdByIssuerWithoutTeam iss . (^. _1))
+        gets (getIdByIssuerWithoutTeam iss)
       Eff.GetIdByIssuerWithTeam iss team ->
-        gets (getIdByIssuerWithTeam iss team . (^. _1))
+        gets (getIdByIssuerWithTeam iss team)
       Eff.GetConfigsByTeam team ->
-        gets (getConfigsByTeam team . (^. _1))
+        gets (getConfigsByTeam team)
       Eff.DeleteConfig idp ->
-        modify' (_1 %~ deleteConfig idp)
+        modify' (deleteConfig idp)
       Eff.SetReplacedBy (Eff.Replaced replaced) (Eff.Replacing replacing) ->
-        modify' (_1 %~ ((updateReplacedBy (Just replacing) replaced) <$>))
+        modify' (updateReplacedBy (Just replacing) replaced <$>)
       Eff.ClearReplacedBy (Eff.Replaced replaced) ->
-        modify' (_1 %~ ((updateReplacedBy Nothing replaced) <$>))
-      Eff.StoreRawMetadata i txt ->
-        modify (_2 %~ storeRawMetadata i txt)
-      Eff.GetRawMetadata i ->
-        gets (getRawMetadata i . (^. _2))
-      Eff.DeleteRawMetadata i ->
-        modify (_2 %~ deleteRawMetadata i)
+        modify' (updateReplacedBy Nothing replaced <$>)
 
 storeConfig :: IP.IdP -> TypedState -> TypedState
 storeConfig iw =
@@ -107,12 +97,3 @@ updateReplacedBy mbReplacing replaced idp =
     & if idp ^. SAML.idpId == replaced
       then SAML.idpExtraInfo . IP.wiReplacedBy .~ mbReplacing
       else id
-
-storeRawMetadata :: SAML.IdPId -> Text -> RawState -> RawState
-storeRawMetadata = M.insert
-
-getRawMetadata :: SAML.IdPId -> RawState -> Maybe Text
-getRawMetadata = M.lookup
-
-deleteRawMetadata :: SAML.IdPId -> RawState -> RawState
-deleteRawMetadata idpid = M.filterWithKey (\idpid' _ -> idpid' /= idpid)

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

@@ -0,0 +1,15 @@
+module Spar.Sem.IdPRawMetadataStore where
+
+import Imports
+import Polysemy
+import qualified SAML2.WebSSO as SAML
+
+data IdPRawMetadataStore m a where
+  Store :: SAML.IdPId -> Text -> IdPRawMetadataStore m ()
+  Get :: SAML.IdPId -> IdPRawMetadataStore m (Maybe Text)
+  Delete :: SAML.IdPId -> IdPRawMetadataStore m ()
+
+deriving stock instance Show (IdPRawMetadataStore m a)
+
+-- TODO(sandy): Inline this definition --- no TH
+makeSem ''IdPRawMetadataStore

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

@@ -0,0 +1,19 @@
+module Spar.Sem.IdPRawMetadataStore.Cassandra where
+
+import Cassandra
+import Imports
+import Polysemy
+import qualified Spar.Data as Data
+import Spar.Sem.IdPRawMetadataStore
+
+idpRawMetadataStoreToCassandra ::
+  forall m r a.
+  (MonadClient m, Member (Embed m) r) =>
+  Sem (IdPRawMetadataStore ': r) a ->
+  Sem r a
+idpRawMetadataStoreToCassandra =
+  interpret $
+    embed @m . \case
+      Store i t -> Data.storeIdPRawMetadata i t
+      Get i -> Data.getIdPRawMetadata i
+      Delete i -> Data.deleteIdPRawMetadata i

services/spar/src/Spar/Sem/IdPRawMetadataStore/Mem.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Spar.Sem.IdPRawMetadataStore.Mem (idpRawMetadataStoreToMem, RawState) where
+
+import qualified Data.Map as M
+import Imports
+import Polysemy
+import Polysemy.State (State, gets, modify, runState)
+import qualified SAML2.WebSSO.Types as SAML
+import Spar.Sem.IdPRawMetadataStore
+
+type RawState = Map SAML.IdPId Text
+
+idpRawMetadataStoreToMem ::
+  forall r a.
+  Sem (IdPRawMetadataStore ': r) a ->
+  Sem r (RawState, a)
+idpRawMetadataStoreToMem = runState mempty . evEff
+  where
+    evEff :: Sem (IdPRawMetadataStore ': r) a -> Sem (State RawState ': r) a
+    evEff = reinterpret @_ @(State RawState) $ \case
+      Store i txt ->
+        modify $ M.insert i txt
+      Get i ->
+        gets $ M.lookup i
+      Delete idpid ->
+        modify $ M.filterWithKey (\idpid' _ -> idpid' /= idpid)