.gitignore

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

.guix/modules/datarekisteri-service.scm

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

@@ -1,36 +0,0 @@
--- 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

@@ -1,16 +0,0 @@
--- 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

@@ -0,0 +1,335 @@
+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,7 +68,8 @@ dbUserToUser user = let id = entityToID user
                         , homeplace = pure homeplace
                         , registered = pure dBUserRegistered
                         , accepted = pure dBUserAccepted
-                        , isMember = pure $ isJust dBUserAccepted
+                        , seceded = pure dBUserSeceded
+                        , isMember = pure $ isJust dBUserAccepted && not (isJust dBUserSeceded)
                         , permissions = pure dBUserPermissions
                         , application = pure application
                         }
@@ -105,6 +106,7 @@ 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
@@ -114,37 +116,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
-        , dBEmailVid = Just verification
+        , dBEmailVerificationSecret = Just secret
         }
     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
-    case maybeDBEmail of
+    let email = dBEmailEmail <$> maybeDBEmail
-      Nothing -> pure Unit
+        secret = dBEmailVerificationSecret =<< maybeDBEmail
-      Just dbEmail -> do
+        args = (,) <$> secret <*> email
-          case dBEmailVid dbEmail of
+    maybe (pure ()) (uncurry sendVerificationEmail) args
-            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, MonadTime m) =>
+updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) =>
     UserID -> UpdateData -> m UserID
 updateUser user (UpdateData {..}) = do
     hash <- sequence $ hashPassword <$> password
@@ -198,9 +200,8 @@ acceptApplication user = void $ do
       Nothing -> throwError $ "No valid application for " <> show user <> "!"
       Just email -> do
           time <- currentTime
-          applicationAccepted <- markAsAccepted user time
+          markAsAccepted user time
-          when applicationAccepted $
+          void $ sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
-              sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
 
 rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
 rejectApplication user = void $ do
@@ -208,9 +209,9 @@ rejectApplication user = void $ do
     case maybeEmail of
       Nothing -> throwError $ "No valid application for " <> show user <> "!"
       Just email -> do
-          applicationDeleted <- deleteApplication user
+          time <- currentTime
-          when applicationDeleted $
+          markAsRejected user time
-              sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
+          void $ sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
 
 resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
 resolveQuery = Query
@@ -237,7 +238,7 @@ resolveMutation = Mutation
         maybeUser <- getByID userID
         user <- fromMaybeFail "" maybeUser
         pure $ dbUserToUser user
-    , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (not x) $ throwError "Invalid verification secret"
+    , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (x < 1) $ throwError "Invalid verification secret"
     , resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
         maybe (pure Unit) (sendVerificationSecret . entityKey)
     , update = \updateData (Arg id) -> targetUser id >>= \user ->
@@ -273,6 +274,7 @@ 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,6 +29,9 @@ 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)
@@ -36,21 +39,15 @@ DBUser sql=users
 DBEmail sql=emails
   uid DBUserId
   email Email sqltype=varchar(320)
-  vid (Maybe DBEmailVerificationId) sql=verification
+  verificationSecret (Maybe Text)
 
-  UniqueUserVerified uid vid
+  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 but it's too complicated for persistent to understand.
+  -- verification secret but it's too complicated for persistent to understand.
 
   UniqueEmail email
-  UniqueVerification vid
+  UniqueVerification verificationSecret
-
-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,11 +11,10 @@ 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
@@ -78,7 +77,7 @@ applicants = runQuery $ select $ do
     pure $ users
 
 isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool)
-isVerified email = isNothing (email ^. DBEmailVid)
+isVerified email = isNothing (email ^. DBEmailVerificationSecret)
 
 hasVerifiedEmail :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool)
 hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
@@ -89,26 +88,21 @@ 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_ $ isApplicant user
+isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded)
 
-verifyEmailSecret :: MonadDB m => Text -> m Bool
+verifyEmailSecret :: MonadDB m => Text -> m Integer
-verifyEmailSecret secret = runQuery $ do
+verifyEmailSecret secret = fmap fromIntegral $ runQuery $ updateCount $ \email -> do
-    update $ \email -> do
+    set email [DBEmailVerificationSecret =. val Nothing]
-        verification <- from $ table @DBEmailVerification
+    where_ $ email ^. DBEmailVerificationSecret ==. val (Just secret)
-        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 ^. DBEmailVid) ==. val verified
+        &&. isNothing (email ^. DBEmailVerificationSecret) ==. val verified
     pure email
 
 getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
@@ -120,32 +114,8 @@ getUserPendingEmail user = getUserEmail' user False
 addEmail :: MonadDB m => DBEmail -> m (Key DBEmail)
 addEmail = runQuery . insert
 
-getExpireTime :: MonadTime m => m Time
+updateEmail :: MonadDB m => UserID -> Email -> Text -> m (Key DBEmail)
-getExpireTime = addTime (7 * nominalDay) <$> currentTime
+updateEmail user email secret = runQuery $ do
-
-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)
@@ -156,25 +126,20 @@ updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do
         pure dbEmail
     case verifiedEmail of
       Just (Entity key _) -> pure key
-      Nothing -> do
+      Nothing -> insert DBEmail
-          verificationId <- insert DBEmailVerification
+          { dBEmailUid = toDBKey user
-              { dBEmailVerificationSecret = secret
+          , dBEmailEmail = email
-              , dBEmailVerificationExpires = expires
+          , dBEmailVerificationSecret = Just secret
-              }
+          }
-          insert DBEmail
-              { dBEmailUid = toDBKey user
-              , dBEmailEmail = email
-              , dBEmailVid = Just verificationId
-              }
 
-markAsAccepted :: MonadDB m => UserID -> Time -> m Bool
+markAsAccepted :: MonadDB m => UserID -> Time -> m ()
-markAsAccepted userID time = fmap (> 0) $ runQuery $ updateCount $ \user -> do
+markAsAccepted userID time = runQuery $ update $ \user -> do
     set user [DBUserAccepted =. just (val time)]
     where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
 
-deleteApplication :: MonadDB m => UserID -> m Bool
+markAsRejected :: MonadDB m => UserID -> Time -> m ()
-deleteApplication userID = fmap (> 0) $ runQuery $ deleteCount $ do
+markAsRejected userID time = runQuery $ update $ \user -> do
-    user <- from $ table @DBUser
+    set user [DBUserRejected =. just (val time)]
     where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
 
 updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID

backend/src/Datarekisteri/CLI.hs

@@ -24,49 +24,32 @@ main :: IO ()
 main = do
     CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
     runCLIM optionsDBUrl $ case optionsSubCommand of
-      (AddUser addUserOpts) -> addUserMain addUserOpts
+      AddUser {..} -> do
-      GCEmails -> gcEmailsMain
+          time <- currentTime
-      GCApplications -> gcApplicationsMain
+          passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
-      GCAll -> gcAllMain
+          userID <- addUser $ DBUser
-
+              { dBUserRegistered = time
-addUserMain :: AddUserOpts -> CLIM ()
+              , dBUserToBeDeleted = Nothing
-addUserMain AddUserOpts {..} = do
+              , dBUserPasswordCrypt = passwordHash
-    time <- currentTime
+              , dBUserPermissions = show addUserPermissions
-    passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
+              , dBUserAccepted = Just time
-    userID <- addUser $ DBUser
+              , dBUserSeceded = Nothing
-        { dBUserRegistered = time
+              , dBUserRejected = Nothing
-        , dBUserPasswordCrypt = passwordHash
+              , dBUserMemberData = toJSON $ MemberData
-        , dBUserPermissions = show addUserPermissions
+                  { nickname = addUserNickname
-        , dBUserAccepted = Just time
+                  , name = addUserName
-        , dBUserMemberData = toJSON $ MemberData
+                  , birthdate = addUserBirthdate
-            { nickname = addUserNickname
+                  , homeplace = addUserHomeplace
-            , name = addUserName
+                  , application = addUserApplication
-            , birthdate = addUserBirthdate
+                  , phoneNumber = addUserPhoneNumber
-            , homeplace = addUserHomeplace
+                  }
-            , application = addUserApplication
+              }
-            , phoneNumber = addUserPhoneNumber
+          _ <- addEmail $ DBEmail
-            }
+              { dBEmailUid = toDBKey userID
-        }
+              , dBEmailEmail = addUserEmail
-    _ <- addEmail $ DBEmail
+              , dBEmailVerificationSecret = Nothing
-        { dBEmailUid = toDBKey userID
+              }
-        , dBEmailEmail = addUserEmail
+          pure ()
-        , 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
@@ -76,12 +59,9 @@ 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 = fmap AddUser $ AddUserOpts
+addUserCommand = AddUser
     <$> 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")
@@ -101,21 +81,16 @@ data CLIOptions = CLIOptions
     , optionsSubCommand :: CLISubCommand
     }
 
-data CLISubCommand = AddUser AddUserOpts
+data CLISubCommand = AddUser
-                   | GCEmails
+    { addUserNickname :: Maybe Text
-                   | GCApplications
+    , addUserName :: Text
-                   | GCAll
+    , addUserBirthdate :: Date
-
+    , addUserHomeplace :: Text
-data AddUserOpts = AddUserOpts
+    , addUserPhoneNumber :: PhoneNumber
-        { addUserNickname :: Maybe Text
+    , addUserEmail :: Email
-        , addUserName :: Text
+    , addUserPermissions :: Map Scope Permission
-        , addUserBirthdate :: Date
+    , addUserApplication :: Text
-        , 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,6 +50,7 @@ type User {
   homeplace: String!
   registered: Time!
   accepted: Time
+  seceded: Time
   permissions: String!
   isMember: Boolean!
   application: String!
@@ -75,3 +76,4 @@ type Mutation {
   accept(user: UserID!): Unit!
   reject(user: UserID!): Unit!
 }
+