Compare commits
No commits in common. "09a318ae32d0aa260485cf77ba58a3c20883a293" and "7f64d8f9268c520cf2432d263c5de6a67260ebfb" have entirely different histories.
09a318ae32
...
7f64d8f926
|
@ -1 +0,0 @@
|
||||||
**/db/schema.sql
|
|
|
@ -7,7 +7,6 @@
|
||||||
#: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)
|
||||||
|
@ -67,8 +66,8 @@
|
||||||
(service-type
|
(service-type
|
||||||
(name 'plain-datarekisteri-frontend)
|
(name 'plain-datarekisteri-frontend)
|
||||||
(extensions
|
(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")))
|
(description "Run the datarekisteri HTTP frontend server")))
|
||||||
|
|
||||||
(define (file-like-or-string? x)
|
(define (file-like-or-string? x)
|
||||||
|
@ -132,21 +131,12 @@
|
||||||
(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 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 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")))
|
||||||
|
|
|
@ -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
|
|
|
@ -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;
|
|
|
@ -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');
|
|
@ -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,7 +68,8 @@ dbUserToUser user = let id = entityToID user
|
||||||
, homeplace = pure homeplace
|
, homeplace = pure homeplace
|
||||||
, registered = pure dBUserRegistered
|
, registered = pure dBUserRegistered
|
||||||
, accepted = pure dBUserAccepted
|
, accepted = pure dBUserAccepted
|
||||||
, isMember = pure $ isJust dBUserAccepted
|
, seceded = pure dBUserSeceded
|
||||||
|
, isMember = pure $ isJust dBUserAccepted && not (isJust dBUserSeceded)
|
||||||
, permissions = pure dBUserPermissions
|
, permissions = pure dBUserPermissions
|
||||||
, application = pure application
|
, application = pure application
|
||||||
}
|
}
|
||||||
|
@ -105,6 +106,7 @@ 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
|
||||||
|
@ -114,37 +116,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
|
||||||
, dBEmailVid = Just verification
|
, dBEmailVerificationSecret = Just secret
|
||||||
}
|
}
|
||||||
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
|
||||||
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
|
UserID -> UpdateData -> m UserID
|
||||||
updateUser user (UpdateData {..}) = do
|
updateUser user (UpdateData {..}) = do
|
||||||
hash <- sequence $ hashPassword <$> password
|
hash <- sequence $ hashPassword <$> password
|
||||||
|
@ -198,9 +200,8 @@ 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
|
||||||
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 :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
|
||||||
rejectApplication user = void $ do
|
rejectApplication user = void $ do
|
||||||
|
@ -208,9 +209,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
|
||||||
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 :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
|
||||||
resolveQuery = Query
|
resolveQuery = Query
|
||||||
|
@ -237,7 +238,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 (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 >>=
|
, 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 ->
|
||||||
|
@ -273,6 +274,7 @@ 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
|
||||||
|
|
|
@ -29,6 +29,9 @@ 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)
|
||||||
|
@ -36,21 +39,15 @@ DBUser sql=users
|
||||||
DBEmail sql=emails
|
DBEmail sql=emails
|
||||||
uid DBUserId
|
uid DBUserId
|
||||||
email Email sqltype=varchar(320)
|
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
|
-- 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 but it's too complicated for persistent to understand.
|
-- verification secret but it's too complicated for persistent to understand.
|
||||||
|
|
||||||
UniqueEmail email
|
UniqueEmail email
|
||||||
UniqueVerification vid
|
UniqueVerification verificationSecret
|
||||||
|
|
||||||
DBEmailVerification sql=emailVerifications
|
|
||||||
secret Text sqltype=varchar(255)
|
|
||||||
expires Time
|
|
||||||
|
|
||||||
UniqueVerificationSecret secret
|
|
||||||
|
|
||||||
DBKey sql=keys
|
DBKey sql=keys
|
||||||
uid DBUserId
|
uid DBUserId
|
||||||
|
|
|
@ -11,11 +11,10 @@ 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
|
||||||
|
@ -78,7 +77,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 ^. DBEmailVid)
|
isVerified email = isNothing (email ^. DBEmailVerificationSecret)
|
||||||
|
|
||||||
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
|
||||||
|
@ -89,26 +88,21 @@ 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_ $ 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' :: 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 ^. DBEmailVid) ==. val verified
|
&&. isNothing (email ^. DBEmailVerificationSecret) ==. val verified
|
||||||
pure email
|
pure email
|
||||||
|
|
||||||
getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
|
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 :: MonadDB m => DBEmail -> m (Key DBEmail)
|
||||||
addEmail = runQuery . insert
|
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
|
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)
|
||||||
|
@ -156,25 +126,20 @@ updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do
|
||||||
pure dbEmail
|
pure dbEmail
|
||||||
case verifiedEmail of
|
case verifiedEmail of
|
||||||
Just (Entity key _) -> pure key
|
Just (Entity key _) -> pure key
|
||||||
Nothing -> do
|
Nothing -> insert DBEmail
|
||||||
verificationId <- insert DBEmailVerification
|
|
||||||
{ dBEmailVerificationSecret = secret
|
|
||||||
, dBEmailVerificationExpires = expires
|
|
||||||
}
|
|
||||||
insert DBEmail
|
|
||||||
{ dBEmailUid = toDBKey user
|
{ dBEmailUid = toDBKey user
|
||||||
, dBEmailEmail = email
|
, dBEmailEmail = email
|
||||||
, dBEmailVid = Just verificationId
|
, dBEmailVerificationSecret = Just secret
|
||||||
}
|
}
|
||||||
|
|
||||||
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)]
|
set user [DBUserAccepted =. just (val time)]
|
||||||
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
|
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
|
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
|
||||||
|
|
|
@ -24,20 +24,17 @@ 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 addUserOpts) -> addUserMain addUserOpts
|
AddUser {..} -> do
|
||||||
GCEmails -> gcEmailsMain
|
|
||||||
GCApplications -> gcApplicationsMain
|
|
||||||
GCAll -> gcAllMain
|
|
||||||
|
|
||||||
addUserMain :: AddUserOpts -> CLIM ()
|
|
||||||
addUserMain AddUserOpts {..} = do
|
|
||||||
time <- currentTime
|
time <- currentTime
|
||||||
passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
|
passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
|
||||||
userID <- addUser $ DBUser
|
userID <- addUser $ DBUser
|
||||||
{ dBUserRegistered = time
|
{ dBUserRegistered = time
|
||||||
|
, dBUserToBeDeleted = Nothing
|
||||||
, dBUserPasswordCrypt = passwordHash
|
, dBUserPasswordCrypt = passwordHash
|
||||||
, dBUserPermissions = show addUserPermissions
|
, dBUserPermissions = show addUserPermissions
|
||||||
, dBUserAccepted = Just time
|
, dBUserAccepted = Just time
|
||||||
|
, dBUserSeceded = Nothing
|
||||||
|
, dBUserRejected = Nothing
|
||||||
, dBUserMemberData = toJSON $ MemberData
|
, dBUserMemberData = toJSON $ MemberData
|
||||||
{ nickname = addUserNickname
|
{ nickname = addUserNickname
|
||||||
, name = addUserName
|
, name = addUserName
|
||||||
|
@ -50,24 +47,10 @@ addUserMain AddUserOpts {..} = do
|
||||||
_ <- addEmail $ DBEmail
|
_ <- addEmail $ DBEmail
|
||||||
{ dBEmailUid = toDBKey userID
|
{ dBEmailUid = toDBKey userID
|
||||||
, dBEmailEmail = addUserEmail
|
, dBEmailEmail = addUserEmail
|
||||||
, dBEmailVid = Nothing
|
, dBEmailVerificationSecret = Nothing
|
||||||
}
|
}
|
||||||
pure ()
|
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
|
||||||
<$> strOption (short 'u' <> long "db-url" <> metavar "URL" <> value "postgres:///datarekisteri-backend")
|
<$> strOption (short 'u' <> long "db-url" <> metavar "URL" <> value "postgres:///datarekisteri-backend")
|
||||||
|
@ -76,12 +59,9 @@ 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 = fmap AddUser $ AddUserOpts
|
addUserCommand = AddUser
|
||||||
<$> 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")
|
||||||
|
@ -101,12 +81,7 @@ data CLIOptions = CLIOptions
|
||||||
, optionsSubCommand :: CLISubCommand
|
, optionsSubCommand :: CLISubCommand
|
||||||
}
|
}
|
||||||
|
|
||||||
data CLISubCommand = AddUser AddUserOpts
|
data CLISubCommand = AddUser
|
||||||
| GCEmails
|
|
||||||
| GCApplications
|
|
||||||
| GCAll
|
|
||||||
|
|
||||||
data AddUserOpts = AddUserOpts
|
|
||||||
{ addUserNickname :: Maybe Text
|
{ addUserNickname :: Maybe Text
|
||||||
, addUserName :: Text
|
, addUserName :: Text
|
||||||
, addUserBirthdate :: Date
|
, addUserBirthdate :: Date
|
||||||
|
|
|
@ -50,6 +50,7 @@ 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!
|
||||||
|
@ -75,3 +76,4 @@ type Mutation {
|
||||||
accept(user: UserID!): Unit!
|
accept(user: UserID!): Unit!
|
||||||
reject(user: UserID!): Unit!
|
reject(user: UserID!): Unit!
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue