diff --git a/db/migrations/20230917064352_split-emails-from-users.sql b/db/migrations/20230917064352_split-emails-from-users.sql new file mode 100644 index 0000000..ce12b31 --- /dev/null +++ b/db/migrations/20230917064352_split-emails-from-users.sql @@ -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"; diff --git a/src/Server/API.hs b/src/Server/API.hs index 11127e5..9b50491 100644 --- a/src/Server/API.hs +++ b/src/Server/API.hs @@ -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 "" diff --git a/src/Server/DB.hs b/src/Server/DB.hs index 2443bd5..c198115 100644 --- a/src/Server/DB.hs +++ b/src/Server/DB.hs @@ -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 diff --git a/src/Server/DB/Queries.hs b/src/Server/DB/Queries.hs index 298135c..0cb8dbf 100644 --- a/src/Server/DB/Queries.hs +++ b/src/Server/DB/Queries.hs @@ -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