Run all GC jobs periodically

.gitignore

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

.guix/modules/datarekisteri-service.scm

@@ -7,6 +7,7 @@
   #:use-module (gnu services certbot)
   #:use-module (gnu services configuration)
   #:use-module (gnu services databases)
+  #:use-module (gnu services mcron)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services web)
   #:use-module (gnu system shadow)
@@ -66,8 +67,8 @@
   (service-type
    (name 'plain-datarekisteri-frontend)
    (extensions
-     (list (service-extension shepherd-root-service-type frontend-shepherd-service)
-           (service-extension account-service-type frontend-accounts)))
+     (list (service-extension account-service-type frontend-accounts)
+           (service-extension shepherd-root-service-type frontend-shepherd-service)))
    (description "Run the datarekisteri HTTP frontend server")))
 
 (define (file-like-or-string? x)
@@ -131,12 +132,21 @@
     (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
   (service-type
    (name 'plain-datarekisteri-backend)
    (extensions
-     (list (service-extension postgresql-role-service-type backend-postgresql-roles)
-           (service-extension account-service-type backend-accounts)
+     (list (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 shepherd-root-service-type backend-shepherd-service)))
    (description "Run the datarekisteri backend HTTP server")))

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

backend/db/migrations/20230928115610_remove-deletion-times.sql

@@ -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;

backend/db/schema.sql

@@ -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');

backend/src/Datarekisteri/Backend/API.hs

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

backend/src/Datarekisteri/Backend/DB.hs

@@ -29,9 +29,6 @@ DBUser sql=users
   passwordCrypt PasswordHash
   permissions Text
   accepted (Maybe Time)
-  rejected (Maybe Time)
-  seceded (Maybe Time)
-  toBeDeleted (Maybe Time)
   memberData Value sqltype=jsonb
 
   deriving (Show)
@@ -39,15 +36,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

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
@@ -88,21 +89,26 @@ hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
 isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
 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)
+isMember user = not_ $ isApplicant user
 
-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 +120,32 @@ 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
+        }
+
+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
         dbEmail <- from $ table @DBEmail
         where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail)
@@ -126,20 +156,25 @@ 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
+markAsAccepted :: MonadDB m => UserID -> Time -> m Bool
+markAsAccepted userID time = fmap (> 0) $ runQuery $ updateCount $ \user -> do
     set user [DBUserAccepted =. just (val time)]
     where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
 
-markAsRejected :: MonadDB m => UserID -> Time -> m ()
-markAsRejected userID time = runQuery $ update $ \user -> do
-    set user [DBUserRejected =. just (val time)]
+deleteApplication :: MonadDB m => UserID -> m Bool
+deleteApplication userID = fmap (> 0) $ runQuery $ deleteCount $ do
+    user <- from $ table @DBUser
     where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
 
 updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID

backend/src/Datarekisteri/CLI.hs

@@ -24,32 +24,49 @@ main :: IO ()
 main = do
     CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
     runCLIM optionsDBUrl $ case optionsSubCommand of
-      AddUser {..} -> do
-          time <- currentTime
-          passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
-          userID <- addUser $ DBUser
-              { dBUserRegistered = time
-              , dBUserToBeDeleted = Nothing
-              , dBUserPasswordCrypt = passwordHash
-              , dBUserPermissions = show addUserPermissions
-              , dBUserAccepted = Just time
-              , dBUserSeceded = Nothing
-              , dBUserRejected = Nothing
-              , dBUserMemberData = toJSON $ MemberData
-                  { nickname = addUserNickname
-                  , name = addUserName
-                  , birthdate = addUserBirthdate
-                  , homeplace = addUserHomeplace
-                  , application = addUserApplication
-                  , phoneNumber = addUserPhoneNumber
-                  }
-              }
-          _ <- addEmail $ DBEmail
-              { dBEmailUid = toDBKey userID
-              , dBEmailEmail = addUserEmail
-              , dBEmailVerificationSecret = Nothing
-              }
-          pure ()
+      (AddUser addUserOpts) -> addUserMain addUserOpts
+      GCEmails -> gcEmailsMain
+      GCApplications -> gcApplicationsMain
+      GCAll -> gcAllMain
+
+addUserMain :: AddUserOpts -> CLIM ()
+addUserMain AddUserOpts {..} = do
+    time <- currentTime
+    passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
+    userID <- addUser $ DBUser
+        { dBUserRegistered = time
+        , dBUserPasswordCrypt = passwordHash
+        , dBUserPermissions = show addUserPermissions
+        , dBUserAccepted = Just time
+        , dBUserMemberData = toJSON $ MemberData
+            { nickname = addUserNickname
+            , name = addUserName
+            , birthdate = addUserBirthdate
+            , homeplace = addUserHomeplace
+            , application = addUserApplication
+            , phoneNumber = addUserPhoneNumber
+            }
+        }
+    _ <- addEmail $ DBEmail
+        { dBEmailUid = toDBKey userID
+        , 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 = CLIOptions
@@ -59,9 +76,12 @@ cliOptions = CLIOptions
 cliCommandParser :: Parser CLISubCommand
 cliCommandParser = hsubparser
     $ 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 = AddUser
+addUserCommand = fmap AddUser $ AddUserOpts
     <$> optional (strOption (long "nickname" <> metavar "NAME"))
     <*> strOption (long "name" <> metavar "NAME")
     <*> 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
     }
 
-data CLISubCommand = AddUser
-    { addUserNickname :: Maybe Text
-    , addUserName :: Text
-    , addUserBirthdate :: Date
-    , addUserHomeplace :: Text
-    , addUserPhoneNumber :: PhoneNumber
-    , addUserEmail :: Email
-    , addUserPermissions :: Map Scope Permission
-    , addUserApplication :: Text
-    }
+data CLISubCommand = AddUser AddUserOpts
+                   | GCEmails
+                   | GCApplications
+                   | GCAll
+
+data AddUserOpts = AddUserOpts
+        { addUserNickname :: Maybe Text
+        , addUserName :: Text
+        , addUserBirthdate :: Date
+        , addUserHomeplace :: Text
+        , addUserPhoneNumber :: PhoneNumber
+        , addUserEmail :: Email
+        , addUserPermissions :: Map Scope Permission
+        , addUserApplication :: Text
+        }
 
 newtype CLIM a = CLIM (ReaderT String IO a)
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader String)

frontend/schema.gql

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