diff --git a/backend/db/migrations/20230928083120_add-expiry-time-to-emails.sql b/backend/db/migrations/20230928083120_add-expiry-time-to-emails.sql new file mode 100644 index 0000000..f3cbab2 --- /dev/null +++ b/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 diff --git a/backend/src/Datarekisteri/Backend/API.hs b/backend/src/Datarekisteri/Backend/API.hs index 2c9a72a..1ef7269 100644 --- a/backend/src/Datarekisteri/Backend/API.hs +++ b/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 -> diff --git a/backend/src/Datarekisteri/Backend/DB.hs b/backend/src/Datarekisteri/Backend/DB.hs index 85a42db..a115a93 100644 --- a/backend/src/Datarekisteri/Backend/DB.hs +++ b/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 diff --git a/backend/src/Datarekisteri/Backend/DB/Queries.hs b/backend/src/Datarekisteri/Backend/DB/Queries.hs index 60f0aca..620e29e 100644 --- a/backend/src/Datarekisteri/Backend/DB/Queries.hs +++ b/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