[WPB-8881] Add unit tests for new effect actions (#4331)

* Add a unit test for DeleteEmail

* Add a unit test for UpdateEmailUnvalidated

Co-authored-by: Sven Tennie <[email protected]>

* Pull out a mock interpreter function

* Add a unit test for LookupActivationCode

* Add a unit test for NewActivationCode

* Add unit tests for RemoveEmailEither

* Add unit tests for requestEmailChange

* Update a change log

---------

Co-authored-by: Sven Tennie <[email protected]>

changelog.d/5-internal/WPB-8881

@@ -1 +1 @@
-Move email update and remove operations to effects
+Move email update and remove operations to effects (#4316, ##)

libs/wire-api/src/Wire/API/User.hs

@@ -1580,6 +1580,7 @@ instance ToSchema NameUpdate where
 data ChangeEmailResponse
   = ChangeEmailResponseIdempotent
   | ChangeEmailResponseNeedsActivation
+  deriving (Eq, Show)
 
 instance
   AsUnion

libs/wire-api/src/Wire/API/User/Identity.hs

@@ -22,6 +22,7 @@
 module Wire.API.User.Identity
   ( -- * UserIdentity
     UserIdentity (..),
+    isUserSSOId,
     isSSOIdentity,
     newIdentity,
     emailIdentity,
@@ -150,6 +151,10 @@ data UserSSOId
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform UserSSOId)
 
+isUserSSOId :: UserSSOId -> Bool
+isUserSSOId (UserSSOId _) = True
+isUserSSOId (UserScimExternalId _) = False
+
 instance C.Cql UserSSOId where
   ctype = C.Tagged C.TextColumn
 

libs/wire-subsystems/src/Wire/ActivationCodeStore.hs

@@ -26,7 +26,9 @@ import Wire.API.User.Activation
 import Wire.UserKeyStore
 
 data ActivationCodeStore :: Effect where
-  LookupActivationCode :: EmailKey -> ActivationCodeStore m (Maybe (Maybe UserId, ActivationCode))
+  LookupActivationCode ::
+    EmailKey ->
+    ActivationCodeStore m (Maybe (Maybe UserId, ActivationCode))
   -- | Create a code for a new pending activation for a given 'EmailKey'
   NewActivationCode ::
     EmailKey ->

libs/wire-subsystems/test/unit/Wire/ActivationCodeStore/InterpreterSpec.hs

@@ -0,0 +1,40 @@
+module Wire.ActivationCodeStore.InterpreterSpec (spec) where
+
+import Data.Default
+import Data.Map qualified as Map
+import Imports
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+import Wire.API.User.Activation
+import Wire.ActivationCodeStore
+import Wire.MiniBackend
+import Wire.MockInterpreters.ActivationCodeStore
+
+spec :: Spec
+spec = do
+  describe "ActivationCodeStore effect" $ do
+    prop "a code can be looked up" $ \emailKey config ->
+      let c = code emailKey
+          localBackend =
+            def {activationCodes = Map.singleton emailKey (Nothing, c)}
+          result =
+            runNoFederationStack localBackend Nothing config $
+              lookupActivationCode emailKey
+       in result === Just (Nothing, c)
+    prop "a code not found in the store" $ \emailKey config ->
+      let localBackend = def
+          result =
+            runNoFederationStack localBackend Nothing config $
+              lookupActivationCode emailKey
+       in result === Nothing
+    prop "newly added code can be looked up" $ \emailKey mUid config ->
+      let c = code emailKey
+          localBackend = def
+          (actCode, lookupRes) =
+            runNoFederationStack localBackend Nothing config $ do
+              ac <-
+                (.activationCode)
+                  <$> newActivationCode emailKey undefined mUid
+              (ac,) <$> lookupActivationCode emailKey
+       in actCode === c .&&. lookupRes === Just (mUid, c)

libs/wire-subsystems/test/unit/Wire/MiniBackend.hs

@@ -21,6 +21,7 @@ module Wire.MiniBackend
     NotPendingStoredUser (..),
     NotPendingEmptyIdentityStoredUser (..),
     PendingNotEmptyIdentityStoredUser (..),
+    NotPendingSSOIdWithEmailStoredUser (..),
     PendingStoredUser (..),
   )
 where
@@ -126,6 +127,23 @@ instance Arbitrary NotPendingStoredUser where
     notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral])
     pure $ NotPendingStoredUser (user {status = notPendingStatus})
 
+newtype NotPendingSSOIdWithEmailStoredUser = NotPendingSSOIdWithEmailStoredUser StoredUser
+  deriving (Show, Eq)
+
+instance Arbitrary NotPendingSSOIdWithEmailStoredUser where
+  arbitrary = do
+    user <- arbitrary `suchThat` \user -> fmap isUserSSOId user.ssoId == Just True
+    notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral])
+    e <- arbitrary
+    pure $
+      NotPendingSSOIdWithEmailStoredUser
+        ( user
+            { activated = True,
+              status = notPendingStatus,
+              email = Just e
+            }
+        )
+
 type AllErrors =
   [ Error UserSubsystemError,
     Error FederationError,

libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs

@@ -13,6 +13,15 @@ import Wire.API.User.Activation
 import Wire.ActivationCodeStore (ActivationCodeStore (..))
 import Wire.UserKeyStore
 
+code :: EmailKey -> ActivationCode
+code =
+  ActivationCode
+    . Ascii.unsafeFromText
+    . pack
+    . printf "%06d"
+    . length
+    . show
+
 inMemoryActivationCodeStoreInterpreter ::
   ( Member (State (Map EmailKey (Maybe UserId, ActivationCode))) r
   ) =>
@@ -26,12 +35,5 @@ inMemoryActivationCodeStoreInterpreter = interpret \case
             . T.encodeUtf8
             . emailKeyUniq
             $ ek
-        code =
-          ActivationCode
-            . Ascii.unsafeFromText
-            . pack
-            . printf "%06d"
-            . length
-            . show
-            $ ek
-    modify (insert ek (uid, code)) $> Activation key code
+        c = code ek
+    modify (insert ek (uid, c)) $> Activation key c

libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs

@@ -81,7 +81,10 @@ inMemoryUserStoreInterpreter = interpret $ \case
   GetActivityTimestamps _ -> pure []
   GetRichInfo _ -> error "rich info not implemented"
   GetUserAuthenticationInfo _uid -> error "Not implemented"
-  DeleteEmail _uid -> error "Not implemented"
+  DeleteEmail uid -> modify (map doUpdate)
+    where
+      doUpdate :: StoredUser -> StoredUser
+      doUpdate u = if u.id == uid then u {email = Nothing} else u
 
 storedUserToIndexUser :: StoredUser -> IndexUser
 storedUserToIndexUser storedUser =

libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs

@@ -1,11 +1,15 @@
 module Wire.UserStoreSpec (spec) where
 
+import Data.Default
 import Imports
+import Polysemy.State
 import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck
 import Wire.API.User
+import Wire.MiniBackend
 import Wire.StoredUser
+import Wire.UserStore
 
 spec :: Spec
 spec = do
@@ -33,3 +37,21 @@ spec = do
        in if (isJust storedUser.language)
             then user.userLocale === Locale (fromJust storedUser.language) storedUser.country
             else user.userLocale === defaultLocale
+
+  describe "UserStore effect" $ do
+    prop "user self email deleted" $ \user1 user2' email2 config ->
+      let user2 = user2' {email = Just email2}
+          localBackend = def {users = [user1, user2]}
+          result =
+            runNoFederationStack localBackend Nothing config $ do
+              deleteEmail (user1.id)
+              gets users
+       in result === [user1 {email = Nothing}, user2]
+    prop "update unvalidated email" $ \user1 user2 email1 config ->
+      let updatedUser1 = user1 {emailUnvalidated = Just email1}
+          localBackend = def {users = [user1, user2]}
+          result =
+            runNoFederationStack localBackend Nothing config $ do
+              updateEmailUnvalidated (user1.id) email1
+              gets users
+       in result === [updatedUser1, user2]

libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs

@@ -814,3 +814,67 @@ spec = describe "UserSubsystem.Interpreter" do
                 . interpretNoFederationStack localBackend Nothing def config
                 $ getLocalUserAccountByUserKey (toLocalUnsafe localDomain userKey)
          in retrievedUser === Nothing
+  describe "Removing an email address" do
+    prop "Cannot remove an email of a non-existing user" $ \lusr config ->
+      let localBackend = def
+          result =
+            runNoFederationStack localBackend Nothing config $
+              removeEmailEither lusr
+       in result === Left UserSubsystemProfileNotFound
+    prop "Cannot remove an email of a no-identity user" $
+      \(locx :: Local ()) (NotPendingEmptyIdentityStoredUser user) config ->
+        let localBackend = def {users = [user]}
+            lusr = qualifyAs locx user.id
+            result =
+              runNoFederationStack localBackend Nothing config $
+                removeEmailEither lusr
+         in result === Left UserSubsystemNoIdentity
+    prop "Cannot remove an email of a last-identity user" $
+      \(locx :: Local ()) user' email sso config ->
+        let user =
+              user'
+                { activated = True,
+                  email = email,
+                  ssoId = if isNothing email then Just sso else Nothing
+                }
+            localBackend = def {users = [user]}
+            lusr = qualifyAs locx user.id
+            result =
+              runNoFederationStack localBackend Nothing config $
+                removeEmailEither lusr
+         in result === Left UserSubsystemLastIdentity
+    prop "Successfully remove an email from an SSOId user" $
+      \(locx :: Local ()) (NotPendingSSOIdWithEmailStoredUser user) config ->
+        let localBackend = def {users = [user]}
+            lusr = qualifyAs locx user.id
+            result =
+              runNoFederationStack localBackend Nothing config $ do
+                remRes <- removeEmailEither lusr
+                (remRes,) <$> gets users
+         in result === (Right (), [user {email = Nothing}])
+  describe "Changing an email address" $ do
+    prop "Idempotent email change" $
+      \(locx :: Local ()) (NotPendingStoredUser user') email config ->
+        let user = user' {email = Just email}
+            localBackend = def {users = [user]}
+            lusr = qualifyAs locx user.id
+            result =
+              runNoFederationStack localBackend Nothing config $ do
+                c <- requestEmailChange lusr email UpdateOriginWireClient
+                (c,) <$> gets users
+         in result === (ChangeEmailResponseIdempotent, [user])
+    prop "Email change needing activation" $
+      \(locx :: Local ()) (NotPendingStoredUser user') config ->
+        let email = unsafeEmailAddress "me" "example.com"
+            updatedEmail = unsafeEmailAddress "you" "example.com"
+            user = user' {email = Just email, managedBy = Nothing}
+            localBackend = def {users = [user]}
+            lusr = qualifyAs locx user.id
+            result =
+              runNoFederationStack localBackend Nothing config $ do
+                c <- requestEmailChange lusr updatedEmail UpdateOriginWireClient
+                (c,) <$> gets users
+         in result
+              === ( ChangeEmailResponseNeedsActivation,
+                    [user {emailUnvalidated = Just updatedEmail}]
+                  )

libs/wire-subsystems/wire-subsystems.cabal

@@ -232,6 +232,7 @@ test-suite wire-subsystems-tests
   -- cabal-fmt: expand test/unit
   other-modules:
     Spec
+    Wire.ActivationCodeStore.InterpreterSpec
     Wire.AuthenticationSubsystem.InterpreterSpec
     Wire.MiniBackend
     Wire.MockInterpreters