Compare commits

..

No commits in common. "09a318ae32d0aa260485cf77ba58a3c20883a293" and "7f64d8f9268c520cf2432d263c5de6a67260ebfb" have entirely different histories.

10 changed files with 429 additions and 216 deletions

1
.gitignore vendored
View File

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

View File

@ -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)
(service-extension shepherd-root-service-type frontend-shepherd-service)))
(list (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)
(service-extension mcron-service-type backend-mcron-jobs)
(service-extension postgresql-role-service-type backend-postgresql-roles)
(list (service-extension postgresql-role-service-type backend-postgresql-roles)
(service-extension account-service-type backend-accounts)
(service-extension profile-service-type backend-profile)
(service-extension shepherd-root-service-type backend-shepherd-service)))
(description "Run the datarekisteri backend HTTP server")))

View File

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

View File

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

335
backend/db/schema.sql Normal file
View File

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

View File

@ -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
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
let email = dBEmailEmail <$> maybeDBEmail
secret = dBEmailVerificationSecret =<< maybeDBEmail
args = (,) <$> secret <*> email
maybe (pure ()) (uncurry sendVerificationEmail) args
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
when applicationAccepted $
sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
markAsAccepted user time
void $ 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
when applicationDeleted $
sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
time <- currentTime
markAsRejected user time
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

View File

@ -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
DBEmailVerification sql=emailVerifications
secret Text sqltype=varchar(255)
expires Time
UniqueVerificationSecret secret
UniqueVerification verificationSecret
DBKey sql=keys
uid DBUserId

View File

@ -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 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
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 ^. 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
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
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)
@ -156,25 +126,20 @@ updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do
pure dbEmail
case verifiedEmail of
Just (Entity key _) -> pure key
Nothing -> do
verificationId <- insert DBEmailVerification
{ dBEmailVerificationSecret = secret
, dBEmailVerificationExpires = expires
}
insert DBEmail
{ dBEmailUid = toDBKey user
, dBEmailEmail = email
, dBEmailVid = Just verificationId
}
Nothing -> insert DBEmail
{ dBEmailUid = toDBKey user
, dBEmailEmail = email
, dBEmailVerificationSecret = Just secret
}
markAsAccepted :: MonadDB m => UserID -> Time -> m Bool
markAsAccepted userID time = fmap (> 0) $ runQuery $ updateCount $ \user -> do
markAsAccepted :: MonadDB m => UserID -> Time -> m ()
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
deleteApplication userID = fmap (> 0) $ runQuery $ deleteCount $ do
user <- from $ table @DBUser
markAsRejected :: MonadDB m => UserID -> Time -> m ()
markAsRejected userID time = runQuery $ update $ \user -> do
set user [DBUserRejected =. just (val time)]
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID

View File

@ -24,49 +24,32 @@ main :: IO ()
main = do
CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
runCLIM optionsDBUrl $ case optionsSubCommand of
(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
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 ()
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
| 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
}
data CLISubCommand = AddUser
{ 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)

View File

@ -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!
}