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 "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
import Control.Monad.Except (MonadError, throwError) import Control.Monad.Except (MonadError, throwError)
import Data.Aeson (fromJSON, Result(..), toJSON) import Data.Aeson (fromJSON, Result(..), toJSON)
import Data.Maybe (fromJust)
import Data.Morpheus.Server (deriveApp, runApp) import Data.Morpheus.Server (deriveApp, runApp)
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined) import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App) import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
@ -124,10 +125,11 @@ newUser (ApplicationData {..}) = do
, dBUserRejected = Nothing , dBUserRejected = Nothing
, dBUserMemberData = toJSON memberData , dBUserMemberData = toJSON memberData
} }
verification <- addEmailVerification secret
email <- addEmail $ DBEmail email <- addEmail $ DBEmail
{ dBEmailUid = toDBKey user { dBEmailUid = toDBKey user
, dBEmailEmail = email , dBEmailEmail = email
, dBEmailVerificationSecret = Just secret , dBEmailVid = Just verification
} }
sendVerificationSecret email sendVerificationSecret email
return user 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 :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
sendVerificationSecret email = void $ do sendVerificationSecret email = void $ do
maybeDBEmail <- runQuery $ get email maybeDBEmail <- runQuery $ get email
let email = dBEmailEmail <$> maybeDBEmail case maybeDBEmail of
secret = dBEmailVerificationSecret =<< maybeDBEmail Nothing -> pure Unit
args = (,) <$> secret <*> email Just dbEmail -> do
maybe (pure ()) (uncurry sendVerificationEmail) args 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 UserID -> UpdateData -> m UserID
updateUser user (UpdateData {..}) = do updateUser user (UpdateData {..}) = do
hash <- sequence $ hashPassword <$> password hash <- sequence $ hashPassword <$> password
@ -238,7 +245,7 @@ resolveMutation = Mutation
maybeUser <- getByID userID maybeUser <- getByID userID
user <- fromMaybeFail "" maybeUser user <- fromMaybeFail "" maybeUser
pure $ dbUserToUser user 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 >>= , resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
maybe (pure Unit) (sendVerificationSecret . entityKey) maybe (pure Unit) (sendVerificationSecret . entityKey)
, update = \updateData (Arg id) -> targetUser id >>= \user -> , update = \updateData (Arg id) -> targetUser id >>= \user ->

View File

@ -39,15 +39,21 @@ DBUser sql=users
DBEmail sql=emails DBEmail sql=emails
uid DBUserId uid DBUserId
email Email sqltype=varchar(320) 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 -- 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 -- 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 UniqueEmail email
UniqueVerification verificationSecret UniqueVerification vid
DBEmailVerification sql=emailVerifications
secret Text sqltype=varchar(255)
expires Time
UniqueVerificationSecret secret
DBKey sql=keys DBKey sql=keys
uid DBUserId uid DBUserId

View File

@ -11,10 +11,11 @@ import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Data.Text (Text) import Data.Text (Text)
import Database.Esqueleto.Experimental 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 qualified Database.Persist.Types as Persist (Update)
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Data.Aeson (fromJSON, toJSON, Result(..)) 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 :: (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 getByID id = let key = toDBKey id in runQuery $ fmap (Entity key) <$> get key
@ -77,7 +78,7 @@ applicants = runQuery $ select $ do
pure $ users pure $ users
isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool) 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 :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool)
hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
@ -93,16 +94,22 @@ isApplicant user = isNothing (user ^. DBUserAccepted)
isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool) isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded) isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded)
verifyEmailSecret :: MonadDB m => Text -> m Integer verifyEmailSecret :: MonadDB m => Text -> m Bool
verifyEmailSecret secret = fmap fromIntegral $ runQuery $ updateCount $ \email -> do verifyEmailSecret secret = runQuery $ do
set email [DBEmailVerificationSecret =. val Nothing] update $ \email -> do
where_ $ email ^. DBEmailVerificationSecret ==. val (Just secret) 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' :: MonadDB m => UserID -> Bool -> m (Maybe (Entity DBEmail))
getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do
email <- from $ table @DBEmail email <- from $ table @DBEmail
where_ $ email ^. DBEmailUid ==. val (toDBKey user) where_ $ email ^. DBEmailUid ==. val (toDBKey user)
&&. isNothing (email ^. DBEmailVerificationSecret) ==. val verified &&. isNothing (email ^. DBEmailVid) ==. val verified
pure email pure email
getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail)) 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 :: MonadDB m => DBEmail -> m (Key DBEmail)
addEmail = runQuery . insert addEmail = runQuery . insert
updateEmail :: MonadDB m => UserID -> Email -> Text -> m (Key DBEmail) getExpireTime :: MonadTime m => m Time
updateEmail user email secret = runQuery $ do 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 delete $ do
dbEmail <- from $ table @DBEmail dbEmail <- from $ table @DBEmail
where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail) where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail)
@ -126,10 +144,15 @@ updateEmail user email secret = runQuery $ do
pure dbEmail pure dbEmail
case verifiedEmail of case verifiedEmail of
Just (Entity key _) -> pure key Just (Entity key _) -> pure key
Nothing -> insert DBEmail Nothing -> do
verificationId <- insert DBEmailVerification
{ dBEmailVerificationSecret = secret
, dBEmailVerificationExpires = expires
}
insert DBEmail
{ dBEmailUid = toDBKey user { dBEmailUid = toDBKey user
, dBEmailEmail = email , dBEmailEmail = email
, dBEmailVerificationSecret = Just secret , dBEmailVid = Just verificationId
} }
markAsAccepted :: MonadDB m => UserID -> Time -> m () markAsAccepted :: MonadDB m => UserID -> Time -> m ()