Add expiry time to email verification secrets

backend/db/migrations/20230928083120_add-expiry-time-to-emails.sql

@@ -0,0 +1,36 @@
+-- migrate:up
+
+create table "emailVerifications" (
+    "id" serial primary key,
+    "secret" varchar(255) unique not null,
+    "expires" timestamp not null
+);
+
+alter table "emails" add "verification" integer unique references "emailVerifications" on delete cascade;
+
+insert into "emailVerifications" ("secret", "expires")
+    select "verificationSecret", (localtimestamp + '7 days') as "expires" from "emails"
+        where "verificationSecret" is not null;
+
+update "emails" set
+    "verification" = (select "id" from "emailVerifications" where "secret" = "verificationSecret");
+
+alter table "emails" drop "verificationSecret" cascade;
+
+create unique index "emails_uid_verified" on "emails" ("uid", ("verification" is not null));
+-- at most one verified and one pending email per user
+
+-- migrate:down
+
+alter table "emails" add "verificationSecret" varchar(255) unique;
+
+update "emails" set
+    "verificationSecret" = (select "secret" from "emailVerifications"
+        where "emailVerifications"."id" = "emails"."verification");
+
+alter table "emails" drop "verification";
+
+drop table "emailVerifications";
+
+create unique index "emails_uid_verified" on "emails" ("uid", ("verificationSecret" is not null));
+-- at most one verified and one pending email per user

backend/src/Datarekisteri/Backend/API.hs

@@ -23,6 +23,7 @@ import Relude hiding (Undefined, void, when, get)
 import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
 import Control.Monad.Except (MonadError, throwError)
 import Data.Aeson (fromJSON, Result(..), toJSON)
+import Data.Maybe (fromJust)
 import Data.Morpheus.Server (deriveApp, runApp)
 import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
 import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
@@ -124,10 +125,11 @@ newUser (ApplicationData {..}) = do
         , dBUserRejected = Nothing
         , dBUserMemberData = toJSON memberData
         }
+    verification <- addEmailVerification secret
     email <- addEmail $ DBEmail
         { dBEmailUid = toDBKey user
         , dBEmailEmail = email
-        , dBEmailVerificationSecret = Just secret
+        , dBEmailVid = Just verification
         }
     sendVerificationSecret email
     return user
@@ -141,12 +143,17 @@ genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomB
 sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
 sendVerificationSecret email = void $ do
     maybeDBEmail <- runQuery $ get email
-    let email = dBEmailEmail <$> maybeDBEmail
-        secret = dBEmailVerificationSecret =<< maybeDBEmail
-        args = (,) <$> secret <*> email
-    maybe (pure ()) (uncurry sendVerificationEmail) args
+    case maybeDBEmail of
+      Nothing -> pure Unit
+      Just dbEmail -> do
+          case dBEmailVid dbEmail of
+            Nothing -> pure Unit
+            Just dbVerificationId -> do
+                secret <- fmap (dBEmailVerificationSecret . fromJust) $ runQuery $ get dbVerificationId
+                let email = dBEmailEmail dbEmail
+                void $ sendVerificationEmail secret email
 
-updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) =>
+updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
     UserID -> UpdateData -> m UserID
 updateUser user (UpdateData {..}) = do
     hash <- sequence $ hashPassword <$> password
@@ -238,7 +245,7 @@ resolveMutation = Mutation
         maybeUser <- getByID userID
         user <- fromMaybeFail "" maybeUser
         pure $ dbUserToUser user
-    , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (x < 1) $ throwError "Invalid verification secret"
+    , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (not x) $ throwError "Invalid verification secret"
     , resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
         maybe (pure Unit) (sendVerificationSecret . entityKey)
     , update = \updateData (Arg id) -> targetUser id >>= \user ->

backend/src/Datarekisteri/Backend/DB.hs

@@ -39,15 +39,21 @@ DBUser sql=users
 DBEmail sql=emails
   uid DBUserId
   email Email sqltype=varchar(320)
-  verificationSecret (Maybe Text)
+  vid (Maybe DBEmailVerificationId) sql=verification
 
-  UniqueUserVerified uid verificationSecret
+  UniqueUserVerified uid vid
   -- 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.
+  -- verification but it's too complicated for persistent to understand.
 
   UniqueEmail email
-  UniqueVerification verificationSecret
+  UniqueVerification vid
+
+DBEmailVerification sql=emailVerifications
+  secret Text sqltype=varchar(255)
+  expires Time
+
+  UniqueVerificationSecret secret
 
 DBKey sql=keys
   uid DBUserId

backend/src/Datarekisteri/Backend/DB/Queries.hs

@@ -11,10 +11,11 @@ import Datarekisteri.Backend.Types
 import Datarekisteri.Core.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)
 import Data.Aeson (fromJSON, toJSON, Result(..))
+import Data.Time (nominalDay)
 
 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
@@ -77,7 +78,7 @@ applicants = runQuery $ select $ do
     pure $ users
 
 isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool)
-isVerified email = isNothing (email ^. DBEmailVerificationSecret)
+isVerified email = isNothing (email ^. DBEmailVid)
 
 hasVerifiedEmail :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool)
 hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
@@ -93,16 +94,22 @@ isApplicant user = isNothing (user ^. DBUserAccepted)
 isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
 isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded)
 
-verifyEmailSecret :: MonadDB m => Text -> m Integer
-verifyEmailSecret secret = fmap fromIntegral $ runQuery $ updateCount $ \email -> do
-    set email [DBEmailVerificationSecret =. val Nothing]
-    where_ $ email ^. DBEmailVerificationSecret ==. val (Just secret)
+verifyEmailSecret :: MonadDB m => Text -> m Bool
+verifyEmailSecret secret = runQuery $ do
+    update $ \email -> do
+        verification <- from $ table @DBEmailVerification
+        set email [DBEmailVid =. val Nothing]
+        where_ $ email ^. DBEmailVid ==. just (verification ^. DBEmailVerificationId)
+            &&. verification ^. DBEmailVerificationSecret ==. val secret
+    fmap (> 0) $ deleteCount $ do
+        verification <- from (table @DBEmailVerification) 
+        where_ $ verification ^. DBEmailVerificationSecret ==. val secret
 
 getUserEmail' :: MonadDB m => UserID -> Bool -> m (Maybe (Entity DBEmail))
 getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do
     email <- from $ table @DBEmail
     where_ $ email ^. DBEmailUid ==. val (toDBKey user)
-        &&. isNothing (email ^. DBEmailVerificationSecret) ==. val verified
+        &&. isNothing (email ^. DBEmailVid) ==. val verified
     pure email
 
 getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
@@ -114,8 +121,19 @@ 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
+getExpireTime :: MonadTime m => m Time
+getExpireTime = addTime (7 * nominalDay) <$> currentTime
+
+addEmailVerification :: (MonadDB m, MonadTime m) => Text -> m (Key DBEmailVerification)
+addEmailVerification secret = do
+    expires <- getExpireTime
+    runQuery $ insert $ DBEmailVerification
+        { dBEmailVerificationSecret = secret
+        , dBEmailVerificationExpires = expires
+        }
+
+updateEmail :: (MonadDB m, MonadTime m) => UserID -> Email -> Text -> m (Key DBEmail)
+updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do
     delete $ do
         dbEmail <- from $ table @DBEmail
         where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail)
@@ -126,11 +144,16 @@ updateEmail user email secret = runQuery $ do
         pure dbEmail
     case verifiedEmail of
       Just (Entity key _) -> pure key
-      Nothing -> insert DBEmail
-          { dBEmailUid = toDBKey user
-          , dBEmailEmail = email
-          , dBEmailVerificationSecret = Just secret
-          }
+      Nothing -> do
+          verificationId <- insert DBEmailVerification
+              { dBEmailVerificationSecret = secret
+              , dBEmailVerificationExpires = expires
+              }
+          insert DBEmail
+              { dBEmailUid = toDBKey user
+              , dBEmailEmail = email
+              , dBEmailVid = Just verificationId
+              }
 
 markAsAccepted :: MonadDB m => UserID -> Time -> m ()
 markAsAccepted userID time = runQuery $ update $ \user -> do