Enforce uniqueness between pending and verified emails

db/migrations/20230917064352_split-emails-from-users.sql

@@ -0,0 +1,40 @@
+-- migrate:up
+
+create table "emails" (
+    "id" serial primary key,
+    "uid" integer not null references "users" on delete cascade,
+    "email" varchar(320) unique not null, -- local 64 + domain 255 + '@' 1 per RFC5321
+    "verificationSecret" varchar(255) unique
+);
+
+create unique index "emails_uid_verified" on "emails" ("uid", ("verificationSecret" is not null));
+-- at most one verified and one pending email per user
+
+insert into "emails" ("uid", "email", "verificationSecret")
+    select "id", "email", null as "verificationSecret" from "users" where "email" is not null;
+
+insert into "emails" ("uid", "email", "verificationSecret")
+    select "id", "pendingEmail", "emailVerificationSecret" from "users" where "pendingEmail" is not null;
+
+alter table "users"
+    drop "email" cascade,
+    drop "pendingEmail" cascade,
+    drop "emailVerificationSecret" cascade;
+
+-- migrate:down
+
+alter table "users"
+    add "email" varchar(320) unique,
+    add "pendingEmail" varchar(320) unique,
+    add "emailVerificationSecret" varchar(255) unique;
+
+update "users" set "email" = "emails"."email"
+    from "emails"
+    where "users"."id" = "emails"."uid" and "emails"."verificationSecret" is null;
+
+update "users" set "pendingEmail" = "emails"."email",
+    "emailVerificationSecret" = "emails"."verificationSecret"
+    from "emails"
+    where "users"."id" = "emails"."uid" and "emails"."verificationSecret" is not null;
+
+drop table "emails";

src/Server/API.hs

@@ -18,7 +18,7 @@
 
 module Server.API (coreApp, runApp, resolver) where
 
-import Relude hiding (Undefined, void, when)
+import Relude hiding (Undefined, void, when, get)
 
 import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
 import Control.Monad.Except (MonadError, throwError)
@@ -27,7 +27,7 @@ import Data.Morpheus.Server (deriveApp, runApp)
 import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
 import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
 import Data.Time (nominalDay)
-import Database.Persist (Entity, entityVal, (=.))
+import Database.Persist (Entity, entityVal, entityKey, get, (=.))
 import Server.DB
 import Server.DB.Queries
 import Server.Email (sendVerificationEmail)
@@ -50,15 +50,15 @@ void m = m >> pure Unit
 when :: Monad m => Bool -> m a -> m Unit
 when b m = if b then void m else pure Unit
 
-dbUserToUser :: Monad m => Entity DBUser -> User m
+dbUserToUser :: MonadDB m => Entity DBUser -> User m
 dbUserToUser user = let id = entityToID user
                         DBUser {..} = entityVal user
                         Success (MemberData {..}) = fromJSON dBUserMemberData
                         -- XXX: Explodes if database doesn't contain needed data
                     in User
                         { id = pure id
-                        , email = pure dBUserEmail
+                        , email = fmap (dBEmailEmail . entityVal) <$> getUserEmail id
-                        , pendingEmail = pure dBUserPendingEmail
+                        , pendingEmail = fmap (dBEmailEmail . entityVal) <$> getUserPendingEmail id
                         , phoneNumber = pure phoneNumber
                         , name = pure name
                         , nickname = pure $ fromMaybe (error "db contains empty name") $
@@ -114,9 +114,7 @@ newUser (ApplicationData {..}) = do
     when (T.null homeplace) $ throwError "Homeplace must not be empty"
     let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
     user <- addUser $ DBUser
-        { dBUserEmail = Nothing
+        { dBUserRegistered = time
-        , dBUserPendingEmail = Just email
-        , dBUserRegistered = time
         , dBUserToBeDeleted = Just $ verificationExpires
         , dBUserPasswordCrypt = passwordHash
         , dBUserPermissions = permissions
@@ -124,9 +122,13 @@ newUser (ApplicationData {..}) = do
         , dBUserSeceded = Nothing
         , dBUserRejected = Nothing
         , dBUserMemberData = toJSON memberData
-        , dBUserEmailVerificationSecret = Just secret
         }
-    sendVerificationSecret user
+    email <- addEmail $ DBEmail
+        { dBEmailUid = toDBKey user
+        , dBEmailEmail = email
+        , dBEmailVerificationSecret = Just secret
+        }
+    sendVerificationSecret email
     return user
 
 verificationExpireTime :: MonadTime m => m Time
@@ -135,11 +137,11 @@ verificationExpireTime = addTime (7 * nominalDay) <$> currentTime
 genVerificationSecret :: MonadRandom m => m Text
 genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
 
-sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => UserID -> m Unit
+sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
-sendVerificationSecret user = void $ do
+sendVerificationSecret email = void $ do
-    maybeDBUser <- fmap entityVal <$> getByID user
+    maybeDBEmail <- runQuery $ get email
-    let email = dBUserPendingEmail =<< maybeDBUser
+    let email = dBEmailEmail <$> maybeDBEmail
-        secret = dBUserEmailVerificationSecret =<< maybeDBUser
+        secret = dBEmailVerificationSecret =<< maybeDBEmail
         args = (,) <$> email <*> secret
     maybe (pure ()) (uncurry sendVerificationEmail) args
 
@@ -148,14 +150,16 @@ updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) =>
 updateUser user (UpdateData {..}) = do
     hash <- sequence $ hashPassword <$> password
     -- TODO: assert stuff valid
-    verificationSecretUpdate <- maybe (pure Nothing)
-        (const $ Just . (DBUserEmailVerificationSecret =. ) . Just <$> genVerificationSecret) email
     user <- updateUserData user
-        (catMaybes [(DBUserPendingEmail =. ) . Just <$> email, verificationSecretUpdate,
+        (catMaybes [(DBUserPasswordCrypt =.) <$> hash])
-            (DBUserPasswordCrypt =.) <$> hash])
         (catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
             SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber])
-    when (isJust email) $ sendVerificationSecret user
+    case email of
+      Nothing -> pure Unit
+      Just email' -> do
+          verificationSecret <- genVerificationSecret
+          emailKey <- updateEmail user email' verificationSecret
+          sendVerificationSecret emailKey
     return user
 
 makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
@@ -224,7 +228,8 @@ resolveMutation = Mutation
         user <- fromMaybeFail "" maybeUser
         pure $ dbUserToUser user
     , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (x < 1) $ throwError "Invalid verification secret"
-    , resendVerificationEmail = \(Arg id) -> targetUser id >>= sendVerificationSecret
+    , resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
+        maybe (pure Unit) (sendVerificationSecret . entityKey)
     , update = \updateData (Arg id) -> targetUser id >>= \user ->
         requirePermission (Profile user) ReadWrite >>
             updateUser user updateData >> getByID user >>= fmap dbUserToUser . fromMaybeFail ""

src/Server/DB.hs

@@ -24,9 +24,6 @@ import Server.Types
 
 mkPersist sqlSettings [persistUpperCase|
 DBUser sql=users
-  email (Maybe Email) sqltype=varchar(255)
-  pendingEmail (Maybe Email) sqltype=varchar(255)
-  emailVerificationSecret (Maybe Text)
   registered Time
   passwordCrypt PasswordHash
   permissions Text
@@ -36,12 +33,21 @@ DBUser sql=users
   toBeDeleted (Maybe Time)
   memberData Value sqltype=jsonb
 
-  UniqueEmail email
-  UniquePendingEmail pendingEmail
-  UniqueVerification emailVerificationSecret
-
   deriving (Show)
 
+DBEmail sql=emails
+  uid DBUserId
+  email Email sqltype=varchar(320)
+  verificationSecret (Maybe Text)
+
+  UniqueUserVerified uid verificationSecret
+  -- This enables using persistent functions to get unique verified emails. The real
+  -- constraint is stricter and doesn't allow having more than one null and one non-null
+  -- verification secret but it's too complicated for persistent to understand.
+
+  UniqueEmail email
+  UniqueVerification verificationSecret
+
 DBKey sql=keys
   uid DBUserId
   data ByteString

src/Server/DB/Queries.hs

@@ -10,21 +10,22 @@ import Server.DB as DB
 import Server.Types
 import Data.Text (Text)
 import Database.Esqueleto.Experimental
-import qualified Database.Persist as Persist (update, (=.))
+import qualified Database.Persist as Persist (update, (=.), (==.))
 import qualified Database.Persist.Types as Persist (Update)
-import Data.Maybe (listToMaybe, isJust)
+import Data.Maybe (listToMaybe)
 import Data.Aeson (fromJSON, toJSON, Result(..))
-import GHC.Int (Int64)
 
 getByID :: (MonadDB m, ToDBKey k, PersistEntityBackend (DB k) ~ SqlBackend) => k -> m (Maybe (Entity (DB k)))
 getByID id = let key = toDBKey id in runQuery $ fmap (Entity key) <$> get key
 
 getUserByEmail :: MonadDB m => Email -> m (Maybe (Entity DBUser))
-getUserByEmail email = runQuery $ getBy (UniqueEmail $ Just email) >>=
+getUserByEmail email = fmap listToMaybe $ runQuery $ select $ do
-    maybe ((>>= guardUnconfirmed) <$> getBy (UniquePendingEmail $ Just email)) (pure . Just)
+    (dbUser :& dbEmail) <- from $ table @DBUser `crossJoin` table @DBEmail
-        where guardUnconfirmed user
+    where_ $ dbEmail ^. DBEmailEmail ==. val email &&. dbUser ^. DBUserId ==. dbEmail ^. DBEmailUid
-                | isJust (dBUserEmail $ entityVal user) = Nothing
+    -- There is only one row in DBEmail with a given email (unique constraint) and a DBEmail only
-                | otherwise = Just user
+    -- has one user id and there is only row in DBUser with a given user id (primary key). Thus
+    -- there is at most one combination of rows from DBEmail and DBUser that satisfy this query.
+    pure dbUser
 
 addUser :: MonadDB m => DBUser -> m UserID
 addUser = fmap fromDBKey . runQuery . insert
@@ -74,19 +75,61 @@ applicants = runQuery $ select $ do
     where_ $ isApplicant users
     pure $ users
 
+isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool)
+isVerified email = isNothing (email ^. DBEmailVerificationSecret)
+
+hasVerifiedEmail :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool)
+hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
+    emails <- from $ table @DBEmail
+    where_ $ emails ^. DBEmailUid ==. userId &&. isVerified emails
+    pure $ val True -- This is not used anywhere, there just isn't a PersistField instance for ()
+
 isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
-isApplicant user = isNothing (user ^. DBUserAccepted) &&. not_ (isNothing (user ^. DBUserEmail)) &&. isNothing (user ^. DBUserRejected)
+isApplicant user = isNothing (user ^. DBUserAccepted)
+    &&. hasVerifiedEmail (user ^. DBUserId)
+    &&. isNothing (user ^. DBUserRejected)
 
 isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
 isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded)
 
-verifyEmailSecret :: MonadDB m => Text -> m Int64
+verifyEmailSecret :: MonadDB m => Text -> m Integer
-verifyEmailSecret secret = runQuery $ updateCount $ \user -> do
+verifyEmailSecret secret = fmap fromIntegral $ runQuery $ updateCount $ \email -> do
-    set user [ DBUserEmailVerificationSecret =. val Nothing
+    set email [DBEmailVerificationSecret =. val Nothing]
-             , DBUserEmail =. user ^. DBUserPendingEmail
+    where_ $ email ^. DBEmailVerificationSecret ==. val (Just secret)
-             , DBUserPendingEmail =. val Nothing
+
-             ]
+getUserEmail' :: MonadDB m => UserID -> Bool -> m (Maybe (Entity DBEmail))
-    where_ $ user ^. DBUserEmailVerificationSecret ==. just (val secret)
+getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do
+    email <- from $ table @DBEmail
+    where_ $ email ^. DBEmailUid ==. val (toDBKey user)
+        &&. isNothing (email ^. DBEmailVerificationSecret) ==. val verified
+    pure email
+
+getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
+getUserEmail user = getUserEmail' user True
+
+getUserPendingEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
+getUserPendingEmail user = getUserEmail' user False
+
+addEmail :: MonadDB m => DBEmail -> m (Key DBEmail)
+addEmail = runQuery . insert
+
+updateEmail :: MonadDB m => UserID -> Email -> Text -> m (Key DBEmail)
+updateEmail user email secret = runQuery $ do
+    delete $ do
+        dbEmail <- from $ table @DBEmail
+        where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail)
+    verifiedEmail <- fmap listToMaybe $ select $ do
+        dbEmail <- from $ table @DBEmail
+        where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user)
+            &&. dbEmail ^. DBEmailEmail ==. val email
+        pure dbEmail
+    case verifiedEmail of
+      Just (Entity key _) -> pure key
+      Nothing -> insert DBEmail
+          { dBEmailUid = toDBKey user
+          , dBEmailEmail = email
+          , dBEmailVerificationSecret = Just secret
+          }
 
 markAsAccepted :: MonadDB m => UserID -> Time -> m ()
 markAsAccepted userID time = runQuery $ update $ \user -> do