Enforce uniqueness between pending and verified emails
This commit is contained in:
parent
c7d35146ac
commit
80993bbf8c
GPG Key ID:
257D284A2A1D3A32
|
|
@ -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";
|
||||
|
|
@ -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
|
||||
, pendingEmail = pure dBUserPendingEmail
|
||||
, email = fmap (dBEmailEmail . entityVal) <$> getUserEmail id
|
||||
, 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
|
||||
, dBUserPendingEmail = Just email
|
||||
, dBUserRegistered = time
|
||||
{ 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 user = void $ do
|
||||
maybeDBUser <- fmap entityVal <$> getByID user
|
||||
let email = dBUserPendingEmail =<< maybeDBUser
|
||||
secret = dBUserEmailVerificationSecret =<< maybeDBUser
|
||||
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 = (,) <$> 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,
|
||||
(DBUserPasswordCrypt =.) <$> hash])
|
||||
(catMaybes [(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 ""
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) >>=
|
||||
maybe ((>>= guardUnconfirmed) <$> getBy (UniquePendingEmail $ Just email)) (pure . Just)
|
||||
where guardUnconfirmed user
|
||||
| isJust (dBUserEmail $ entityVal user) = Nothing
|
||||
| otherwise = Just user
|
||||
getUserByEmail email = fmap listToMaybe $ runQuery $ select $ do
|
||||
(dbUser :& dbEmail) <- from $ table @DBUser `crossJoin` table @DBEmail
|
||||
where_ $ dbEmail ^. DBEmailEmail ==. val email &&. dbUser ^. DBUserId ==. dbEmail ^. DBEmailUid
|
||||
-- There is only one row in DBEmail with a given email (unique constraint) and a DBEmail only
|
||||
-- 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 secret = runQuery $ updateCount $ \user -> do
|
||||
set user [ DBUserEmailVerificationSecret =. val Nothing
|
||||
, DBUserEmail =. user ^. DBUserPendingEmail
|
||||
, DBUserPendingEmail =. val Nothing
|
||||
]
|
||||
where_ $ user ^. DBUserEmailVerificationSecret ==. just (val secret)
|
||||
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)
|
||||
|
||||
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
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue