polysemy-check laws for IdP effect

changelog.d/5-internal/polysemy-check-spar

@@ -0,0 +1 @@
+Fix a bug in the IdP.Mem interpreter, and added law tests for IdP

services/spar/package.yaml

@@ -99,6 +99,7 @@ tests:
       - QuickCheck
       - spar
       - uri-bytestring
+      - polysemy-check
 
 executables:
   spar:

services/spar/spar.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e1e1abfd9d2fd00bd96a693a9466a13e0b7aef15677f0506941f662094a340a1
+-- hash: a0e25b55baaade0d8e5c5317b255ef5191d861abfde4369ef34ffb6d77bc8e0d
 
 name:           spar
 version:        0.1
@@ -499,6 +499,7 @@ test-suite spec
       Test.Spar.Intra.BrigSpec
       Test.Spar.Roundtrip.ByteString
       Test.Spar.ScimSpec
+      Test.Spar.Sem.IdPSpec
       Test.Spar.TypesSpec
       Paths_spar
   hs-source-dirs:
@@ -547,6 +548,7 @@ test-suite spec
     , network-uri
     , optparse-applicative
     , polysemy
+    , polysemy-check
     , polysemy-plugin
     , raw-strings-qq
     , retry

services/spar/src/Spar/API.hs

@@ -461,7 +461,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons
     when (stiIdP == Just idpid) $ ScimTokenStore.delete team stiId
   -- Delete IdP config
   do
-    IdPEffect.deleteConfig idpid issuer team
+    IdPEffect.deleteConfig idp
     IdPEffect.deleteRawMetadata idpid
   return NoContent
   where

services/spar/src/Spar/App.hs

@@ -763,10 +763,9 @@ deleteTeam team = do
   -- used by the team, and remove everything related to those IdPs, too.
   idps <- IdPEffect.getConfigsByTeam team
   for_ idps $ \idp -> do
-    let idpid = idp ^. SAML.idpId
-        issuer = idp ^. SAML.idpMetadata . SAML.edIssuer
+    let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer
     SAMLUserStore.deleteByIssuer issuer
-    IdPEffect.deleteConfig idpid issuer team
+    IdPEffect.deleteConfig idp
 
 sparToServerErrorWithLogging :: Member Reporter r => SparError -> Sem r ServerError
 sparToServerErrorWithLogging err = do

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

@@ -18,26 +18,31 @@ data GetIdPResult a
   | -- | An IdP was found, but it lives in another team than the one you were looking for.
     --   This should be handled similarly to NotFound in most cases.
     GetIdPWrongTeam SAML.IdPId
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
 
 newtype Replaced = Replaced SAML.IdPId
+  deriving (Eq, Ord, Show)
 
 newtype Replacing = Replacing SAML.IdPId
+  deriving (Eq, Ord, Show)
 
 data IdP m a where
   StoreConfig :: IP.IdP -> IdP m ()
   GetConfig :: SAML.IdPId -> IdP m (Maybe IP.IdP)
   GetIdByIssuerWithoutTeam :: SAML.Issuer -> IdP m (GetIdPResult SAML.IdPId)
   GetIdByIssuerWithTeam :: SAML.Issuer -> TeamId -> IdP m (Maybe SAML.IdPId)
   GetConfigsByTeam :: TeamId -> IdP m [IP.IdP]
-  DeleteConfig :: SAML.IdPId -> SAML.Issuer -> TeamId -> IdP m ()
+  DeleteConfig :: IP.IdP -> IdP m ()
+  -- 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 wher       e
+  -- 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)
+
 -- TODO(sandy): Inline this definition --- no TH
 makeSem ''IdP

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

@@ -1,10 +1,13 @@
 module Spar.Sem.IdP.Cassandra where
 
 import Cassandra
+import Control.Lens ((^.))
 import Imports
 import Polysemy
+import qualified SAML2.WebSSO.Types as SAML
 import qualified Spar.Data as Data
 import Spar.Sem.IdP
+import Wire.API.User.IdentityProvider (wiTeam)
 
 idPToCassandra ::
   forall m r a.
@@ -19,7 +22,11 @@ idPToCassandra =
       GetIdByIssuerWithoutTeam i -> Data.getIdPIdByIssuerWithoutTeam i
       GetIdByIssuerWithTeam i t -> Data.getIdPIdByIssuerWithTeam i t
       GetConfigsByTeam itlt -> Data.getIdPConfigsByTeam itlt
-      DeleteConfig i i11 itlt -> Data.deleteIdPConfig i i11 itlt
+      DeleteConfig idp ->
+        let idpid = idp ^. SAML.idpId
+            issuer = idp ^. SAML.idpMetadata . SAML.edIssuer
+            team = idp ^. SAML.idpExtraInfo . wiTeam
+         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

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

@@ -1,8 +1,7 @@
 {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
 
-module Spar.Sem.IdP.Mem (idPToMem) where
+module Spar.Sem.IdP.Mem (idPToMem, IS) where
 
-import Control.Exception (assert)
 import Control.Lens ((%~), (.~), (^.), _1, _2)
 import Data.Id (TeamId)
 import qualified Data.Map as M
@@ -22,11 +21,11 @@ type RawState = Map SAML.IdPId Text
 idPToMem ::
   forall r a.
   Sem (Eff.IdP ': r) a ->
-  Sem r a
+  Sem r (IS, a)
 idPToMem = evState . evEff
   where
-    evState :: Sem (State IS : r) a -> Sem r a
-    evState = evalState mempty
+    evState :: Sem (State IS : r) a -> Sem r (IS, a)
+    evState = runState mempty
 
     evEff :: Sem (Eff.IdP ': r) a -> Sem (State IS ': r) a
     evEff = reinterpret @_ @(State IS) $ \case
@@ -40,8 +39,8 @@ idPToMem = evState . evEff
         gets (getIdByIssuerWithTeam iss team . (^. _1))
       Eff.GetConfigsByTeam team ->
         gets (getConfigsByTeam team . (^. _1))
-      Eff.DeleteConfig i iss team ->
-        modify' (_1 %~ deleteConfig i iss team)
+      Eff.DeleteConfig idp ->
+        modify' (_1 %~ deleteConfig idp)
       Eff.SetReplacedBy (Eff.Replaced replaced) (Eff.Replacing replacing) ->
         modify' (_1 %~ ((updateReplacedBy (Just replacing) replaced) <$>))
       Eff.ClearReplacedBy (Eff.Replaced replaced) ->
@@ -55,14 +54,14 @@ idPToMem = evState . evEff
 
 storeConfig :: IP.IdP -> TypedState -> TypedState
 storeConfig iw =
-  M.filter
-    ( \iw' ->
-        or
-          [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer,
-            iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam
-          ]
-    )
-    . M.insert (iw ^. SAML.idpId) iw
+  M.insert (iw ^. SAML.idpId) iw
+    . M.filter
+      ( \iw' ->
+          or
+            [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer,
+              iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam
+            ]
+      )
 
 getConfig :: SAML.IdPId -> TypedState -> Maybe IP.IdP
 getConfig = M.lookup
@@ -95,17 +94,12 @@ getConfigsByTeam team =
     fl :: IP.IdP -> Bool
     fl idp = idp ^. SAML.idpExtraInfo . IP.wiTeam == team
 
-deleteConfig :: SAML.IdPId -> SAML.Issuer -> TeamId -> TypedState -> TypedState
-deleteConfig i iss team =
+deleteConfig :: IP.IdP -> TypedState -> TypedState
+deleteConfig idp =
   M.filter fl
   where
     fl :: IP.IdP -> Bool
-    fl idp =
-      assert -- calling this function with inconsistent values will crash hard.
-        ( idp ^. SAML.idpMetadata . SAML.edIssuer == iss
-            && idp ^. SAML.idpExtraInfo . IP.wiTeam == team
-        )
-        (idp ^. SAML.idpId /= i)
+    fl idp' = idp' ^. SAML.idpId /= idp ^. SAML.idpId
 
 updateReplacedBy :: Maybe SAML.IdPId -> SAML.IdPId -> IP.IdP -> IP.IdP
 updateReplacedBy mbReplacing replaced idp =

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

@@ -200,7 +200,7 @@ spec = do
         do
           midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId)
           liftIO $ midp `shouldBe` Just idp
-        () <- runSpar $ IdPEffect.deleteConfig (idp ^. idpId) (idp ^. idpMetadata . edIssuer) teamid
+        () <- runSpar $ IdPEffect.deleteConfig idp
         do
           midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId)
           liftIO $ midp `shouldBe` Nothing

services/spar/test/Arbitrary.hs

@@ -23,15 +23,18 @@
 module Arbitrary where
 
 import Data.Aeson
-import Data.Id ()
+import Data.Id (TeamId)
 import Data.Proxy
 import Data.String.Conversions (cs)
 import Data.Swagger hiding (Header (..))
 import Imports
 import SAML2.WebSSO.Test.Arbitrary ()
+import SAML2.WebSSO.Types
 import Servant.API.ContentTypes
 import Spar.Scim
+import qualified Spar.Sem.IdP as E
 import Test.QuickCheck
+import URI.ByteString
 import Wire.API.User.IdentityProvider
 import Wire.API.User.Saml
 
@@ -85,3 +88,30 @@ instance ToJSON NoContent where
 
 instance ToSchema NoContent where
   declareNamedSchema _ = declareNamedSchema (Proxy @String)
+
+instance Arbitrary E.Replacing where
+  arbitrary = E.Replacing <$> arbitrary
+
+instance Arbitrary E.Replaced where
+  arbitrary = E.Replaced <$> arbitrary
+
+instance CoArbitrary a => CoArbitrary (E.GetIdPResult a)
+
+instance CoArbitrary IdPId
+
+instance CoArbitrary WireIdP
+
+instance CoArbitrary WireIdPAPIVersion
+
+instance CoArbitrary TeamId
+
+instance CoArbitrary Issuer where
+  coarbitrary (Issuer ur) = coarbitrary $ show ur
+
+instance CoArbitrary a => CoArbitrary (URIRef a) where
+  coarbitrary = coarbitrary . show
+
+instance CoArbitrary (IdPConfig WireIdP)
+
+instance CoArbitrary IdPMetadata where
+  coarbitrary = coarbitrary . show