Add expiry time to email verification secrets

This commit is contained in:
Saku Laesvuori 2023-09-28 13:47:37 +03:00
parent ae3f33f8c1
commit 3211296e9c
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
4 changed files with 97 additions and 25 deletions

View File

@ -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

View File

@ -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 ->

View File

@ -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

View File

@ -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