Compare commits

..

10 Commits

10 changed files with 216 additions and 429 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
**/db/schema.sql

View File

@ -7,6 +7,7 @@
#:use-module (gnu services certbot) #:use-module (gnu services certbot)
#:use-module (gnu services configuration) #:use-module (gnu services configuration)
#:use-module (gnu services databases) #:use-module (gnu services databases)
#:use-module (gnu services mcron)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu services web) #:use-module (gnu services web)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
@ -66,8 +67,8 @@
(service-type (service-type
(name 'plain-datarekisteri-frontend) (name 'plain-datarekisteri-frontend)
(extensions (extensions
(list (service-extension shepherd-root-service-type frontend-shepherd-service) (list (service-extension account-service-type frontend-accounts)
(service-extension account-service-type frontend-accounts))) (service-extension shepherd-root-service-type frontend-shepherd-service)))
(description "Run the datarekisteri HTTP frontend server"))) (description "Run the datarekisteri HTTP frontend server")))
(define (file-like-or-string? x) (define (file-like-or-string? x)
@ -131,12 +132,21 @@
(datarekisteri-backend) (datarekisteri-backend)
(list datarekisteri-backend))) (list datarekisteri-backend)))
(define (backend-mcron-jobs config)
(match-record config <plain-datarekisteri-backend-configuration>
(datarekisteri-backend)
(list
#~(job '(next-minute '(0))
(string-append #$datarekisteri-backend "/bin/datarekisteri-cli gc")
#:user "datarekisteri-backend"))))
(define plain-datarekisteri-backend-service-type (define plain-datarekisteri-backend-service-type
(service-type (service-type
(name 'plain-datarekisteri-backend) (name 'plain-datarekisteri-backend)
(extensions (extensions
(list (service-extension postgresql-role-service-type backend-postgresql-roles) (list (service-extension account-service-type backend-accounts)
(service-extension account-service-type backend-accounts) (service-extension mcron-service-type backend-mcron-jobs)
(service-extension postgresql-role-service-type backend-postgresql-roles)
(service-extension profile-service-type backend-profile) (service-extension profile-service-type backend-profile)
(service-extension shepherd-root-service-type backend-shepherd-service))) (service-extension shepherd-root-service-type backend-shepherd-service)))
(description "Run the datarekisteri backend HTTP server"))) (description "Run the datarekisteri backend HTTP server")))

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

@ -0,0 +1,16 @@
-- migrate:up
delete from "users"
where "rejected" is not null or "seceded" is not null or "toBeDeleted" is not null;
alter table "users"
drop "rejected",
drop "seceded",
drop "toBeDeleted";
-- migrate:down
alter table "users"
add "rejected" timestamp,
add "seceded" timestamp,
add "toBeDeleted" timestamp;

View File

@ -1,335 +0,0 @@
SET statement_timeout = 0;
SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0;
SET client_encoding = 'UTF8';
SET standard_conforming_strings = on;
SELECT pg_catalog.set_config('search_path', '', false);
SET check_function_bodies = false;
SET xmloption = content;
SET client_min_messages = warning;
SET row_security = off;
SET default_tablespace = '';
SET default_table_access_method = heap;
--
-- Name: emails; Type: TABLE; Schema: public; Owner: -
--
CREATE TABLE public.emails (
id integer NOT NULL,
uid integer NOT NULL,
email character varying(320) NOT NULL,
"verificationSecret" character varying(255)
);
--
-- Name: emails_id_seq; Type: SEQUENCE; Schema: public; Owner: -
--
CREATE SEQUENCE public.emails_id_seq
AS integer
START WITH 1
INCREMENT BY 1
NO MINVALUE
NO MAXVALUE
CACHE 1;
--
-- Name: emails_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
--
ALTER SEQUENCE public.emails_id_seq OWNED BY public.emails.id;
--
-- Name: keys; Type: TABLE; Schema: public; Owner: -
--
CREATE TABLE public.keys (
id integer NOT NULL,
uid integer NOT NULL,
data bytea NOT NULL,
expires timestamp without time zone,
uploaded timestamp without time zone NOT NULL,
comment text NOT NULL,
"isPrimaryEncryptionKey" boolean NOT NULL
);
--
-- Name: keys_id_seq; Type: SEQUENCE; Schema: public; Owner: -
--
CREATE SEQUENCE public.keys_id_seq
AS integer
START WITH 1
INCREMENT BY 1
NO MINVALUE
NO MAXVALUE
CACHE 1;
--
-- Name: keys_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
--
ALTER SEQUENCE public.keys_id_seq OWNED BY public.keys.id;
--
-- Name: schema_migrations; Type: TABLE; Schema: public; Owner: -
--
CREATE TABLE public.schema_migrations (
version character varying(255) NOT NULL
);
--
-- Name: tokens; Type: TABLE; Schema: public; Owner: -
--
CREATE TABLE public.tokens (
id integer NOT NULL,
uid integer NOT NULL,
name text,
data text NOT NULL,
comment text NOT NULL,
issued timestamp without time zone NOT NULL,
expires timestamp without time zone,
permissions text
);
--
-- Name: tokens_id_seq; Type: SEQUENCE; Schema: public; Owner: -
--
CREATE SEQUENCE public.tokens_id_seq
AS integer
START WITH 1
INCREMENT BY 1
NO MINVALUE
NO MAXVALUE
CACHE 1;
--
-- Name: tokens_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
--
ALTER SEQUENCE public.tokens_id_seq OWNED BY public.tokens.id;
--
-- Name: users; Type: TABLE; Schema: public; Owner: -
--
CREATE TABLE public.users (
id integer NOT NULL,
registered timestamp without time zone NOT NULL,
"passwordCrypt" bytea NOT NULL,
permissions text NOT NULL,
accepted timestamp without time zone,
rejected timestamp without time zone,
seceded timestamp without time zone,
"toBeDeleted" timestamp without time zone,
"memberData" jsonb NOT NULL
);
--
-- Name: users_id_seq; Type: SEQUENCE; Schema: public; Owner: -
--
CREATE SEQUENCE public.users_id_seq
AS integer
START WITH 1
INCREMENT BY 1
NO MINVALUE
NO MAXVALUE
CACHE 1;
--
-- Name: users_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
--
ALTER SEQUENCE public.users_id_seq OWNED BY public.users.id;
--
-- Name: emails id; Type: DEFAULT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.emails ALTER COLUMN id SET DEFAULT nextval('public.emails_id_seq'::regclass);
--
-- Name: keys id; Type: DEFAULT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.keys ALTER COLUMN id SET DEFAULT nextval('public.keys_id_seq'::regclass);
--
-- Name: tokens id; Type: DEFAULT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.tokens ALTER COLUMN id SET DEFAULT nextval('public.tokens_id_seq'::regclass);
--
-- Name: users id; Type: DEFAULT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.users ALTER COLUMN id SET DEFAULT nextval('public.users_id_seq'::regclass);
--
-- Name: emails emails_email_key; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.emails
ADD CONSTRAINT emails_email_key UNIQUE (email);
--
-- Name: emails emails_pkey; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.emails
ADD CONSTRAINT emails_pkey PRIMARY KEY (id);
--
-- Name: emails emails_verificationSecret_key; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.emails
ADD CONSTRAINT "emails_verificationSecret_key" UNIQUE ("verificationSecret");
--
-- Name: keys keys_pkey; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.keys
ADD CONSTRAINT keys_pkey PRIMARY KEY (id);
--
-- Name: schema_migrations schema_migrations_pkey; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.schema_migrations
ADD CONSTRAINT schema_migrations_pkey PRIMARY KEY (version);
--
-- Name: tokens tokens_data_key; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.tokens
ADD CONSTRAINT tokens_data_key UNIQUE (data);
--
-- Name: tokens tokens_name_uid_key; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.tokens
ADD CONSTRAINT tokens_name_uid_key UNIQUE (name, uid);
--
-- Name: tokens tokens_pkey; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.tokens
ADD CONSTRAINT tokens_pkey PRIMARY KEY (id);
--
-- Name: users users_pkey; Type: CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.users
ADD CONSTRAINT users_pkey PRIMARY KEY (id);
--
-- Name: emails_uid_verified; Type: INDEX; Schema: public; Owner: -
--
CREATE UNIQUE INDEX emails_uid_verified ON public.emails USING btree (uid, (("verificationSecret" IS NOT NULL)));
--
-- Name: keys_isPrimaryEncryptionKey_constraint; Type: INDEX; Schema: public; Owner: -
--
CREATE UNIQUE INDEX "keys_isPrimaryEncryptionKey_constraint" ON public.keys USING btree (uid) WHERE "isPrimaryEncryptionKey";
--
-- Name: keys_uid_index; Type: INDEX; Schema: public; Owner: -
--
CREATE INDEX keys_uid_index ON public.keys USING btree (uid);
--
-- Name: tokens_data_index; Type: INDEX; Schema: public; Owner: -
--
CREATE INDEX tokens_data_index ON public.tokens USING btree (data);
--
-- Name: users_memberData_index; Type: INDEX; Schema: public; Owner: -
--
CREATE INDEX "users_memberData_index" ON public.users USING gin ("memberData");
--
-- Name: emails emails_uid_fkey; Type: FK CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.emails
ADD CONSTRAINT emails_uid_fkey FOREIGN KEY (uid) REFERENCES public.users(id) ON DELETE CASCADE;
--
-- Name: keys keys_uid_fkey; Type: FK CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.keys
ADD CONSTRAINT keys_uid_fkey FOREIGN KEY (uid) REFERENCES public.users(id) ON DELETE CASCADE;
--
-- Name: tokens tokens_uid_fkey; Type: FK CONSTRAINT; Schema: public; Owner: -
--
ALTER TABLE ONLY public.tokens
ADD CONSTRAINT tokens_uid_fkey FOREIGN KEY (uid) REFERENCES public.users(id) ON DELETE CASCADE;
--
-- PostgreSQL database dump complete
--
--
-- Dbmate schema migrations
--
INSERT INTO public.schema_migrations (version) VALUES
('20221208114323'),
('20230917064352');

View File

@ -23,10 +23,10 @@ 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)
import Data.Time (nominalDay)
import Database.Persist (Entity, entityVal, entityKey, get, (=.)) import Database.Persist (Entity, entityVal, entityKey, get, (=.))
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Datarekisteri.Backend.DB import Datarekisteri.Backend.DB
@ -68,8 +68,7 @@ dbUserToUser user = let id = entityToID user
, homeplace = pure homeplace , homeplace = pure homeplace
, registered = pure dBUserRegistered , registered = pure dBUserRegistered
, accepted = pure dBUserAccepted , accepted = pure dBUserAccepted
, seceded = pure dBUserSeceded , isMember = pure $ isJust dBUserAccepted
, isMember = pure $ isJust dBUserAccepted && not (isJust dBUserSeceded)
, permissions = pure dBUserPermissions , permissions = pure dBUserPermissions
, application = pure application , application = pure application
} }
@ -106,7 +105,6 @@ newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLE
ApplicationData -> m UserID ApplicationData -> m UserID
newUser (ApplicationData {..}) = do newUser (ApplicationData {..}) = do
time <- currentTime time <- currentTime
verificationExpires <- verificationExpireTime
secret <- genVerificationSecret secret <- genVerificationSecret
passwordHash <- hashPassword password passwordHash <- hashPassword password
permissions <- defaultPermissions permissions <- defaultPermissions
@ -116,37 +114,37 @@ newUser (ApplicationData {..}) = do
let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..} let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
user <- addUser $ DBUser user <- addUser $ DBUser
{ dBUserRegistered = time { dBUserRegistered = time
, dBUserToBeDeleted = Just $ verificationExpires
, dBUserPasswordCrypt = passwordHash , dBUserPasswordCrypt = passwordHash
, dBUserPermissions = permissions , dBUserPermissions = permissions
, dBUserAccepted = Nothing , dBUserAccepted = Nothing
, dBUserSeceded = 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
verificationExpireTime :: MonadTime m => m Time
verificationExpireTime = addTime (7 * nominalDay) <$> currentTime
genVerificationSecret :: MonadRandom m => m Text genVerificationSecret :: MonadRandom m => m Text
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10 genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
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
@ -200,8 +198,9 @@ acceptApplication user = void $ do
Nothing -> throwError $ "No valid application for " <> show user <> "!" Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do Just email -> do
time <- currentTime time <- currentTime
markAsAccepted user time applicationAccepted <- markAsAccepted user time
void $ sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email when applicationAccepted $
sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
rejectApplication user = void $ do rejectApplication user = void $ do
@ -209,9 +208,9 @@ rejectApplication user = void $ do
case maybeEmail of case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!" Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do Just email -> do
time <- currentTime applicationDeleted <- deleteApplication user
markAsRejected user time when applicationDeleted $
void $ sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
resolveQuery = Query resolveQuery = Query
@ -238,7 +237,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 ->
@ -274,7 +273,6 @@ data User m = User
, homeplace :: m Text , homeplace :: m Text
, registered :: m Time , registered :: m Time
, accepted :: m (Maybe Time) , accepted :: m (Maybe Time)
, seceded :: m (Maybe Time)
, permissions :: m Text , permissions :: m Text
, isMember :: m Bool , isMember :: m Bool
, application :: m Text , application :: m Text

View File

@ -29,9 +29,6 @@ DBUser sql=users
passwordCrypt PasswordHash passwordCrypt PasswordHash
permissions Text permissions Text
accepted (Maybe Time) accepted (Maybe Time)
rejected (Maybe Time)
seceded (Maybe Time)
toBeDeleted (Maybe Time)
memberData Value sqltype=jsonb memberData Value sqltype=jsonb
deriving (Show) deriving (Show)
@ -39,15 +36,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
@ -88,21 +89,26 @@ hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool) isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
isApplicant user = isNothing (user ^. DBUserAccepted) isApplicant user = isNothing (user ^. DBUserAccepted)
&&. hasVerifiedEmail (user ^. DBUserId) &&. hasVerifiedEmail (user ^. DBUserId)
&&. isNothing (user ^. DBUserRejected)
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_ $ isApplicant user
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 +120,32 @@ 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
}
deleteExpiredEmails :: MonadDB m => Time -> m ()
deleteExpiredEmails time = runQuery $ delete $ do
verification <- from $ table @DBEmailVerification
where_ $ verification ^. DBEmailVerificationExpires <=. val time
deleteUsersWithoutEmail :: MonadDB m => m ()
deleteUsersWithoutEmail = runQuery $ delete $ do
user <- from $ table @DBUser
where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
email <- from $ table @DBEmail
where_ $ email ^. DBEmailUid ==. user ^. DBUserId
pure $ email ^. DBEmailId -- Not used anywhere
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,20 +156,25 @@ 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
{ dBEmailUid = toDBKey user verificationId <- insert DBEmailVerification
, dBEmailEmail = email { dBEmailVerificationSecret = secret
, dBEmailVerificationSecret = Just secret , dBEmailVerificationExpires = expires
} }
insert DBEmail
{ dBEmailUid = toDBKey user
, dBEmailEmail = email
, dBEmailVid = Just verificationId
}
markAsAccepted :: MonadDB m => UserID -> Time -> m () markAsAccepted :: MonadDB m => UserID -> Time -> m Bool
markAsAccepted userID time = runQuery $ update $ \user -> do markAsAccepted userID time = fmap (> 0) $ runQuery $ updateCount $ \user -> do
set user [DBUserAccepted =. just (val time)] set user [DBUserAccepted =. just (val time)]
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
markAsRejected :: MonadDB m => UserID -> Time -> m () deleteApplication :: MonadDB m => UserID -> m Bool
markAsRejected userID time = runQuery $ update $ \user -> do deleteApplication userID = fmap (> 0) $ runQuery $ deleteCount $ do
set user [DBUserRejected =. just (val time)] user <- from $ table @DBUser
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID

View File

@ -24,32 +24,49 @@ main :: IO ()
main = do main = do
CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
runCLIM optionsDBUrl $ case optionsSubCommand of runCLIM optionsDBUrl $ case optionsSubCommand of
AddUser {..} -> do (AddUser addUserOpts) -> addUserMain addUserOpts
time <- currentTime GCEmails -> gcEmailsMain
passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword GCApplications -> gcApplicationsMain
userID <- addUser $ DBUser GCAll -> gcAllMain
{ dBUserRegistered = time
, dBUserToBeDeleted = Nothing addUserMain :: AddUserOpts -> CLIM ()
, dBUserPasswordCrypt = passwordHash addUserMain AddUserOpts {..} = do
, dBUserPermissions = show addUserPermissions time <- currentTime
, dBUserAccepted = Just time passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
, dBUserSeceded = Nothing userID <- addUser $ DBUser
, dBUserRejected = Nothing { dBUserRegistered = time
, dBUserMemberData = toJSON $ MemberData , dBUserPasswordCrypt = passwordHash
{ nickname = addUserNickname , dBUserPermissions = show addUserPermissions
, name = addUserName , dBUserAccepted = Just time
, birthdate = addUserBirthdate , dBUserMemberData = toJSON $ MemberData
, homeplace = addUserHomeplace { nickname = addUserNickname
, application = addUserApplication , name = addUserName
, phoneNumber = addUserPhoneNumber , birthdate = addUserBirthdate
} , homeplace = addUserHomeplace
} , application = addUserApplication
_ <- addEmail $ DBEmail , phoneNumber = addUserPhoneNumber
{ dBEmailUid = toDBKey userID }
, dBEmailEmail = addUserEmail }
, dBEmailVerificationSecret = Nothing _ <- addEmail $ DBEmail
} { dBEmailUid = toDBKey userID
pure () , dBEmailEmail = addUserEmail
, dBEmailVid = Nothing
}
pure ()
gcEmailsMain :: CLIM ()
gcEmailsMain = do
time <- currentTime
deleteExpiredEmails time
gcApplicationsMain :: CLIM ()
gcApplicationsMain = do
deleteUsersWithoutEmail
gcAllMain :: CLIM ()
gcAllMain = do
gcEmailsMain
gcApplicationsMain
cliOptions :: Parser CLIOptions cliOptions :: Parser CLIOptions
cliOptions = CLIOptions cliOptions = CLIOptions
@ -59,9 +76,12 @@ cliOptions = CLIOptions
cliCommandParser :: Parser CLISubCommand cliCommandParser :: Parser CLISubCommand
cliCommandParser = hsubparser cliCommandParser = hsubparser
$ command "add-user" (info addUserCommand (progDesc "Add a user to datarekisteri")) $ command "add-user" (info addUserCommand (progDesc "Add a user to datarekisteri"))
<> command "gc-expired-emails" (info (pure GCEmails) (progDesc "Delete emails that have not been verified in time."))
<> command "gc-applications" (info (pure GCApplications) (progDesc "Delete users without an email address"))
<> command "gc" (info (pure GCAll) (progDesc "Run all garbage collection jobs."))
addUserCommand :: Parser CLISubCommand addUserCommand :: Parser CLISubCommand
addUserCommand = AddUser addUserCommand = fmap AddUser $ AddUserOpts
<$> optional (strOption (long "nickname" <> metavar "NAME")) <$> optional (strOption (long "nickname" <> metavar "NAME"))
<*> strOption (long "name" <> metavar "NAME") <*> strOption (long "name" <> metavar "NAME")
<*> option (maybeReader $ toDate . toText) (long "birthdate" <> metavar "DATE" <> help "The user's birthdate, YYYY-MM-DD") <*> option (maybeReader $ toDate . toText) (long "birthdate" <> metavar "DATE" <> help "The user's birthdate, YYYY-MM-DD")
@ -81,16 +101,21 @@ data CLIOptions = CLIOptions
, optionsSubCommand :: CLISubCommand , optionsSubCommand :: CLISubCommand
} }
data CLISubCommand = AddUser data CLISubCommand = AddUser AddUserOpts
{ addUserNickname :: Maybe Text | GCEmails
, addUserName :: Text | GCApplications
, addUserBirthdate :: Date | GCAll
, addUserHomeplace :: Text
, addUserPhoneNumber :: PhoneNumber data AddUserOpts = AddUserOpts
, addUserEmail :: Email { addUserNickname :: Maybe Text
, addUserPermissions :: Map Scope Permission , addUserName :: Text
, addUserApplication :: Text , addUserBirthdate :: Date
} , addUserHomeplace :: Text
, addUserPhoneNumber :: PhoneNumber
, addUserEmail :: Email
, addUserPermissions :: Map Scope Permission
, addUserApplication :: Text
}
newtype CLIM a = CLIM (ReaderT String IO a) newtype CLIM a = CLIM (ReaderT String IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadReader String) deriving (Functor, Applicative, Monad, MonadIO, MonadReader String)

View File

@ -50,7 +50,6 @@ type User {
homeplace: String! homeplace: String!
registered: Time! registered: Time!
accepted: Time accepted: Time
seceded: Time
permissions: String! permissions: String!
isMember: Boolean! isMember: Boolean!
application: String! application: String!
@ -76,4 +75,3 @@ type Mutation {
accept(user: UserID!): Unit! accept(user: UserID!): Unit!
reject(user: UserID!): Unit! reject(user: UserID!): Unit!
} }