Compare commits
10 Commits
7f64d8f926
...
09a318ae32
Author | SHA1 | Date |
---|---|---|
Saku Laesvuori | 09a318ae32 | |
Saku Laesvuori | aa7d4826b3 | |
Saku Laesvuori | 1ca82b4907 | |
Saku Laesvuori | 47c6ebf9a1 | |
Saku Laesvuori | 72b3e25913 | |
Saku Laesvuori | eeba024c1f | |
Saku Laesvuori | b5ef36a1bb | |
Saku Laesvuori | 4f8705d681 | |
Saku Laesvuori | 3211296e9c | |
Saku Laesvuori | ae3f33f8c1 |
|
@ -0,0 +1 @@
|
||||||
|
**/db/schema.sql
|
|
@ -7,6 +7,7 @@
|
||||||
#:use-module (gnu services certbot)
|
#:use-module (gnu services certbot)
|
||||||
#:use-module (gnu services configuration)
|
#:use-module (gnu services configuration)
|
||||||
#:use-module (gnu services databases)
|
#:use-module (gnu services databases)
|
||||||
|
#:use-module (gnu services mcron)
|
||||||
#:use-module (gnu services shepherd)
|
#:use-module (gnu services shepherd)
|
||||||
#:use-module (gnu services web)
|
#:use-module (gnu services web)
|
||||||
#:use-module (gnu system shadow)
|
#:use-module (gnu system shadow)
|
||||||
|
@ -66,8 +67,8 @@
|
||||||
(service-type
|
(service-type
|
||||||
(name 'plain-datarekisteri-frontend)
|
(name 'plain-datarekisteri-frontend)
|
||||||
(extensions
|
(extensions
|
||||||
(list (service-extension shepherd-root-service-type frontend-shepherd-service)
|
(list (service-extension account-service-type frontend-accounts)
|
||||||
(service-extension account-service-type frontend-accounts)))
|
(service-extension shepherd-root-service-type frontend-shepherd-service)))
|
||||||
(description "Run the datarekisteri HTTP frontend server")))
|
(description "Run the datarekisteri HTTP frontend server")))
|
||||||
|
|
||||||
(define (file-like-or-string? x)
|
(define (file-like-or-string? x)
|
||||||
|
@ -131,12 +132,21 @@
|
||||||
(datarekisteri-backend)
|
(datarekisteri-backend)
|
||||||
(list datarekisteri-backend)))
|
(list datarekisteri-backend)))
|
||||||
|
|
||||||
|
(define (backend-mcron-jobs config)
|
||||||
|
(match-record config <plain-datarekisteri-backend-configuration>
|
||||||
|
(datarekisteri-backend)
|
||||||
|
(list
|
||||||
|
#~(job '(next-minute '(0))
|
||||||
|
(string-append #$datarekisteri-backend "/bin/datarekisteri-cli gc")
|
||||||
|
#:user "datarekisteri-backend"))))
|
||||||
|
|
||||||
(define plain-datarekisteri-backend-service-type
|
(define plain-datarekisteri-backend-service-type
|
||||||
(service-type
|
(service-type
|
||||||
(name 'plain-datarekisteri-backend)
|
(name 'plain-datarekisteri-backend)
|
||||||
(extensions
|
(extensions
|
||||||
(list (service-extension postgresql-role-service-type backend-postgresql-roles)
|
(list (service-extension account-service-type backend-accounts)
|
||||||
(service-extension account-service-type backend-accounts)
|
(service-extension mcron-service-type backend-mcron-jobs)
|
||||||
|
(service-extension postgresql-role-service-type backend-postgresql-roles)
|
||||||
(service-extension profile-service-type backend-profile)
|
(service-extension profile-service-type backend-profile)
|
||||||
(service-extension shepherd-root-service-type backend-shepherd-service)))
|
(service-extension shepherd-root-service-type backend-shepherd-service)))
|
||||||
(description "Run the datarekisteri backend HTTP server")))
|
(description "Run the datarekisteri backend HTTP server")))
|
||||||
|
|
|
@ -0,0 +1,36 @@
|
||||||
|
-- migrate:up
|
||||||
|
|
||||||
|
create table "emailVerifications" (
|
||||||
|
"id" serial primary key,
|
||||||
|
"secret" varchar(255) unique not null,
|
||||||
|
"expires" timestamp not null
|
||||||
|
);
|
||||||
|
|
||||||
|
alter table "emails" add "verification" integer unique references "emailVerifications" on delete cascade;
|
||||||
|
|
||||||
|
insert into "emailVerifications" ("secret", "expires")
|
||||||
|
select "verificationSecret", (localtimestamp + '7 days') as "expires" from "emails"
|
||||||
|
where "verificationSecret" is not null;
|
||||||
|
|
||||||
|
update "emails" set
|
||||||
|
"verification" = (select "id" from "emailVerifications" where "secret" = "verificationSecret");
|
||||||
|
|
||||||
|
alter table "emails" drop "verificationSecret" cascade;
|
||||||
|
|
||||||
|
create unique index "emails_uid_verified" on "emails" ("uid", ("verification" is not null));
|
||||||
|
-- at most one verified and one pending email per user
|
||||||
|
|
||||||
|
-- migrate:down
|
||||||
|
|
||||||
|
alter table "emails" add "verificationSecret" varchar(255) unique;
|
||||||
|
|
||||||
|
update "emails" set
|
||||||
|
"verificationSecret" = (select "secret" from "emailVerifications"
|
||||||
|
where "emailVerifications"."id" = "emails"."verification");
|
||||||
|
|
||||||
|
alter table "emails" drop "verification";
|
||||||
|
|
||||||
|
drop table "emailVerifications";
|
||||||
|
|
||||||
|
create unique index "emails_uid_verified" on "emails" ("uid", ("verificationSecret" is not null));
|
||||||
|
-- at most one verified and one pending email per user
|
|
@ -0,0 +1,16 @@
|
||||||
|
-- migrate:up
|
||||||
|
|
||||||
|
delete from "users"
|
||||||
|
where "rejected" is not null or "seceded" is not null or "toBeDeleted" is not null;
|
||||||
|
|
||||||
|
alter table "users"
|
||||||
|
drop "rejected",
|
||||||
|
drop "seceded",
|
||||||
|
drop "toBeDeleted";
|
||||||
|
|
||||||
|
-- migrate:down
|
||||||
|
|
||||||
|
alter table "users"
|
||||||
|
add "rejected" timestamp,
|
||||||
|
add "seceded" timestamp,
|
||||||
|
add "toBeDeleted" timestamp;
|
|
@ -1,335 +0,0 @@
|
||||||
SET statement_timeout = 0;
|
|
||||||
SET lock_timeout = 0;
|
|
||||||
SET idle_in_transaction_session_timeout = 0;
|
|
||||||
SET client_encoding = 'UTF8';
|
|
||||||
SET standard_conforming_strings = on;
|
|
||||||
SELECT pg_catalog.set_config('search_path', '', false);
|
|
||||||
SET check_function_bodies = false;
|
|
||||||
SET xmloption = content;
|
|
||||||
SET client_min_messages = warning;
|
|
||||||
SET row_security = off;
|
|
||||||
|
|
||||||
SET default_tablespace = '';
|
|
||||||
|
|
||||||
SET default_table_access_method = heap;
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails; Type: TABLE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE TABLE public.emails (
|
|
||||||
id integer NOT NULL,
|
|
||||||
uid integer NOT NULL,
|
|
||||||
email character varying(320) NOT NULL,
|
|
||||||
"verificationSecret" character varying(255)
|
|
||||||
);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails_id_seq; Type: SEQUENCE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE SEQUENCE public.emails_id_seq
|
|
||||||
AS integer
|
|
||||||
START WITH 1
|
|
||||||
INCREMENT BY 1
|
|
||||||
NO MINVALUE
|
|
||||||
NO MAXVALUE
|
|
||||||
CACHE 1;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER SEQUENCE public.emails_id_seq OWNED BY public.emails.id;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys; Type: TABLE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE TABLE public.keys (
|
|
||||||
id integer NOT NULL,
|
|
||||||
uid integer NOT NULL,
|
|
||||||
data bytea NOT NULL,
|
|
||||||
expires timestamp without time zone,
|
|
||||||
uploaded timestamp without time zone NOT NULL,
|
|
||||||
comment text NOT NULL,
|
|
||||||
"isPrimaryEncryptionKey" boolean NOT NULL
|
|
||||||
);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys_id_seq; Type: SEQUENCE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE SEQUENCE public.keys_id_seq
|
|
||||||
AS integer
|
|
||||||
START WITH 1
|
|
||||||
INCREMENT BY 1
|
|
||||||
NO MINVALUE
|
|
||||||
NO MAXVALUE
|
|
||||||
CACHE 1;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER SEQUENCE public.keys_id_seq OWNED BY public.keys.id;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: schema_migrations; Type: TABLE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE TABLE public.schema_migrations (
|
|
||||||
version character varying(255) NOT NULL
|
|
||||||
);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens; Type: TABLE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE TABLE public.tokens (
|
|
||||||
id integer NOT NULL,
|
|
||||||
uid integer NOT NULL,
|
|
||||||
name text,
|
|
||||||
data text NOT NULL,
|
|
||||||
comment text NOT NULL,
|
|
||||||
issued timestamp without time zone NOT NULL,
|
|
||||||
expires timestamp without time zone,
|
|
||||||
permissions text
|
|
||||||
);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens_id_seq; Type: SEQUENCE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE SEQUENCE public.tokens_id_seq
|
|
||||||
AS integer
|
|
||||||
START WITH 1
|
|
||||||
INCREMENT BY 1
|
|
||||||
NO MINVALUE
|
|
||||||
NO MAXVALUE
|
|
||||||
CACHE 1;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER SEQUENCE public.tokens_id_seq OWNED BY public.tokens.id;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: users; Type: TABLE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE TABLE public.users (
|
|
||||||
id integer NOT NULL,
|
|
||||||
registered timestamp without time zone NOT NULL,
|
|
||||||
"passwordCrypt" bytea NOT NULL,
|
|
||||||
permissions text NOT NULL,
|
|
||||||
accepted timestamp without time zone,
|
|
||||||
rejected timestamp without time zone,
|
|
||||||
seceded timestamp without time zone,
|
|
||||||
"toBeDeleted" timestamp without time zone,
|
|
||||||
"memberData" jsonb NOT NULL
|
|
||||||
);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: users_id_seq; Type: SEQUENCE; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE SEQUENCE public.users_id_seq
|
|
||||||
AS integer
|
|
||||||
START WITH 1
|
|
||||||
INCREMENT BY 1
|
|
||||||
NO MINVALUE
|
|
||||||
NO MAXVALUE
|
|
||||||
CACHE 1;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: users_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER SEQUENCE public.users_id_seq OWNED BY public.users.id;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails id; Type: DEFAULT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.emails ALTER COLUMN id SET DEFAULT nextval('public.emails_id_seq'::regclass);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys id; Type: DEFAULT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.keys ALTER COLUMN id SET DEFAULT nextval('public.keys_id_seq'::regclass);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens id; Type: DEFAULT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.tokens ALTER COLUMN id SET DEFAULT nextval('public.tokens_id_seq'::regclass);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: users id; Type: DEFAULT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.users ALTER COLUMN id SET DEFAULT nextval('public.users_id_seq'::regclass);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails emails_email_key; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.emails
|
|
||||||
ADD CONSTRAINT emails_email_key UNIQUE (email);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails emails_pkey; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.emails
|
|
||||||
ADD CONSTRAINT emails_pkey PRIMARY KEY (id);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails emails_verificationSecret_key; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.emails
|
|
||||||
ADD CONSTRAINT "emails_verificationSecret_key" UNIQUE ("verificationSecret");
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys keys_pkey; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.keys
|
|
||||||
ADD CONSTRAINT keys_pkey PRIMARY KEY (id);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: schema_migrations schema_migrations_pkey; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.schema_migrations
|
|
||||||
ADD CONSTRAINT schema_migrations_pkey PRIMARY KEY (version);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens tokens_data_key; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.tokens
|
|
||||||
ADD CONSTRAINT tokens_data_key UNIQUE (data);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens tokens_name_uid_key; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.tokens
|
|
||||||
ADD CONSTRAINT tokens_name_uid_key UNIQUE (name, uid);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens tokens_pkey; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.tokens
|
|
||||||
ADD CONSTRAINT tokens_pkey PRIMARY KEY (id);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: users users_pkey; Type: CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.users
|
|
||||||
ADD CONSTRAINT users_pkey PRIMARY KEY (id);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails_uid_verified; Type: INDEX; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE UNIQUE INDEX emails_uid_verified ON public.emails USING btree (uid, (("verificationSecret" IS NOT NULL)));
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys_isPrimaryEncryptionKey_constraint; Type: INDEX; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE UNIQUE INDEX "keys_isPrimaryEncryptionKey_constraint" ON public.keys USING btree (uid) WHERE "isPrimaryEncryptionKey";
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys_uid_index; Type: INDEX; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE INDEX keys_uid_index ON public.keys USING btree (uid);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens_data_index; Type: INDEX; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE INDEX tokens_data_index ON public.tokens USING btree (data);
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: users_memberData_index; Type: INDEX; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
CREATE INDEX "users_memberData_index" ON public.users USING gin ("memberData");
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: emails emails_uid_fkey; Type: FK CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.emails
|
|
||||||
ADD CONSTRAINT emails_uid_fkey FOREIGN KEY (uid) REFERENCES public.users(id) ON DELETE CASCADE;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: keys keys_uid_fkey; Type: FK CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.keys
|
|
||||||
ADD CONSTRAINT keys_uid_fkey FOREIGN KEY (uid) REFERENCES public.users(id) ON DELETE CASCADE;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Name: tokens tokens_uid_fkey; Type: FK CONSTRAINT; Schema: public; Owner: -
|
|
||||||
--
|
|
||||||
|
|
||||||
ALTER TABLE ONLY public.tokens
|
|
||||||
ADD CONSTRAINT tokens_uid_fkey FOREIGN KEY (uid) REFERENCES public.users(id) ON DELETE CASCADE;
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- PostgreSQL database dump complete
|
|
||||||
--
|
|
||||||
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Dbmate schema migrations
|
|
||||||
--
|
|
||||||
|
|
||||||
INSERT INTO public.schema_migrations (version) VALUES
|
|
||||||
('20221208114323'),
|
|
||||||
('20230917064352');
|
|
|
@ -23,10 +23,10 @@ import Relude hiding (Undefined, void, when, get)
|
||||||
import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
|
import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
|
||||||
import Control.Monad.Except (MonadError, throwError)
|
import Control.Monad.Except (MonadError, throwError)
|
||||||
import Data.Aeson (fromJSON, Result(..), toJSON)
|
import Data.Aeson (fromJSON, Result(..), toJSON)
|
||||||
|
import Data.Maybe (fromJust)
|
||||||
import Data.Morpheus.Server (deriveApp, runApp)
|
import Data.Morpheus.Server (deriveApp, runApp)
|
||||||
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
|
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
|
||||||
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
|
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
|
||||||
import Data.Time (nominalDay)
|
|
||||||
import Database.Persist (Entity, entityVal, entityKey, get, (=.))
|
import Database.Persist (Entity, entityVal, entityKey, get, (=.))
|
||||||
import Datarekisteri.Core.Types
|
import Datarekisteri.Core.Types
|
||||||
import Datarekisteri.Backend.DB
|
import Datarekisteri.Backend.DB
|
||||||
|
@ -68,8 +68,7 @@ dbUserToUser user = let id = entityToID user
|
||||||
, homeplace = pure homeplace
|
, homeplace = pure homeplace
|
||||||
, registered = pure dBUserRegistered
|
, registered = pure dBUserRegistered
|
||||||
, accepted = pure dBUserAccepted
|
, accepted = pure dBUserAccepted
|
||||||
, seceded = pure dBUserSeceded
|
, isMember = pure $ isJust dBUserAccepted
|
||||||
, isMember = pure $ isJust dBUserAccepted && not (isJust dBUserSeceded)
|
|
||||||
, permissions = pure dBUserPermissions
|
, permissions = pure dBUserPermissions
|
||||||
, application = pure application
|
, application = pure application
|
||||||
}
|
}
|
||||||
|
@ -106,7 +105,6 @@ newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLE
|
||||||
ApplicationData -> m UserID
|
ApplicationData -> m UserID
|
||||||
newUser (ApplicationData {..}) = do
|
newUser (ApplicationData {..}) = do
|
||||||
time <- currentTime
|
time <- currentTime
|
||||||
verificationExpires <- verificationExpireTime
|
|
||||||
secret <- genVerificationSecret
|
secret <- genVerificationSecret
|
||||||
passwordHash <- hashPassword password
|
passwordHash <- hashPassword password
|
||||||
permissions <- defaultPermissions
|
permissions <- defaultPermissions
|
||||||
|
@ -116,37 +114,37 @@ newUser (ApplicationData {..}) = do
|
||||||
let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
|
let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
|
||||||
user <- addUser $ DBUser
|
user <- addUser $ DBUser
|
||||||
{ dBUserRegistered = time
|
{ dBUserRegistered = time
|
||||||
, dBUserToBeDeleted = Just $ verificationExpires
|
|
||||||
, dBUserPasswordCrypt = passwordHash
|
, dBUserPasswordCrypt = passwordHash
|
||||||
, dBUserPermissions = permissions
|
, dBUserPermissions = permissions
|
||||||
, dBUserAccepted = Nothing
|
, dBUserAccepted = Nothing
|
||||||
, dBUserSeceded = Nothing
|
|
||||||
, dBUserRejected = Nothing
|
|
||||||
, dBUserMemberData = toJSON memberData
|
, dBUserMemberData = toJSON memberData
|
||||||
}
|
}
|
||||||
|
verification <- addEmailVerification secret
|
||||||
email <- addEmail $ DBEmail
|
email <- addEmail $ DBEmail
|
||||||
{ dBEmailUid = toDBKey user
|
{ dBEmailUid = toDBKey user
|
||||||
, dBEmailEmail = email
|
, dBEmailEmail = email
|
||||||
, dBEmailVerificationSecret = Just secret
|
, dBEmailVid = Just verification
|
||||||
}
|
}
|
||||||
sendVerificationSecret email
|
sendVerificationSecret email
|
||||||
return user
|
return user
|
||||||
|
|
||||||
verificationExpireTime :: MonadTime m => m Time
|
|
||||||
verificationExpireTime = addTime (7 * nominalDay) <$> currentTime
|
|
||||||
|
|
||||||
genVerificationSecret :: MonadRandom m => m Text
|
genVerificationSecret :: MonadRandom m => m Text
|
||||||
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
|
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
|
||||||
|
|
||||||
sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
|
sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
|
||||||
sendVerificationSecret email = void $ do
|
sendVerificationSecret email = void $ do
|
||||||
maybeDBEmail <- runQuery $ get email
|
maybeDBEmail <- runQuery $ get email
|
||||||
let email = dBEmailEmail <$> maybeDBEmail
|
case maybeDBEmail of
|
||||||
secret = dBEmailVerificationSecret =<< maybeDBEmail
|
Nothing -> pure Unit
|
||||||
args = (,) <$> secret <*> email
|
Just dbEmail -> do
|
||||||
maybe (pure ()) (uncurry sendVerificationEmail) args
|
case dBEmailVid dbEmail of
|
||||||
|
Nothing -> pure Unit
|
||||||
|
Just dbVerificationId -> do
|
||||||
|
secret <- fmap (dBEmailVerificationSecret . fromJust) $ runQuery $ get dbVerificationId
|
||||||
|
let email = dBEmailEmail dbEmail
|
||||||
|
void $ sendVerificationEmail secret email
|
||||||
|
|
||||||
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) =>
|
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
|
||||||
UserID -> UpdateData -> m UserID
|
UserID -> UpdateData -> m UserID
|
||||||
updateUser user (UpdateData {..}) = do
|
updateUser user (UpdateData {..}) = do
|
||||||
hash <- sequence $ hashPassword <$> password
|
hash <- sequence $ hashPassword <$> password
|
||||||
|
@ -200,8 +198,9 @@ acceptApplication user = void $ do
|
||||||
Nothing -> throwError $ "No valid application for " <> show user <> "!"
|
Nothing -> throwError $ "No valid application for " <> show user <> "!"
|
||||||
Just email -> do
|
Just email -> do
|
||||||
time <- currentTime
|
time <- currentTime
|
||||||
markAsAccepted user time
|
applicationAccepted <- markAsAccepted user time
|
||||||
void $ sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
|
when applicationAccepted $
|
||||||
|
sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
|
||||||
|
|
||||||
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
|
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
|
||||||
rejectApplication user = void $ do
|
rejectApplication user = void $ do
|
||||||
|
@ -209,9 +208,9 @@ rejectApplication user = void $ do
|
||||||
case maybeEmail of
|
case maybeEmail of
|
||||||
Nothing -> throwError $ "No valid application for " <> show user <> "!"
|
Nothing -> throwError $ "No valid application for " <> show user <> "!"
|
||||||
Just email -> do
|
Just email -> do
|
||||||
time <- currentTime
|
applicationDeleted <- deleteApplication user
|
||||||
markAsRejected user time
|
when applicationDeleted $
|
||||||
void $ sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
|
sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
|
||||||
|
|
||||||
resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
|
resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
|
||||||
resolveQuery = Query
|
resolveQuery = Query
|
||||||
|
@ -238,7 +237,7 @@ resolveMutation = Mutation
|
||||||
maybeUser <- getByID userID
|
maybeUser <- getByID userID
|
||||||
user <- fromMaybeFail "" maybeUser
|
user <- fromMaybeFail "" maybeUser
|
||||||
pure $ dbUserToUser user
|
pure $ dbUserToUser user
|
||||||
, verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (x < 1) $ throwError "Invalid verification secret"
|
, verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (not x) $ throwError "Invalid verification secret"
|
||||||
, resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
|
, resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
|
||||||
maybe (pure Unit) (sendVerificationSecret . entityKey)
|
maybe (pure Unit) (sendVerificationSecret . entityKey)
|
||||||
, update = \updateData (Arg id) -> targetUser id >>= \user ->
|
, update = \updateData (Arg id) -> targetUser id >>= \user ->
|
||||||
|
@ -274,7 +273,6 @@ data User m = User
|
||||||
, homeplace :: m Text
|
, homeplace :: m Text
|
||||||
, registered :: m Time
|
, registered :: m Time
|
||||||
, accepted :: m (Maybe Time)
|
, accepted :: m (Maybe Time)
|
||||||
, seceded :: m (Maybe Time)
|
|
||||||
, permissions :: m Text
|
, permissions :: m Text
|
||||||
, isMember :: m Bool
|
, isMember :: m Bool
|
||||||
, application :: m Text
|
, application :: m Text
|
||||||
|
|
|
@ -29,9 +29,6 @@ DBUser sql=users
|
||||||
passwordCrypt PasswordHash
|
passwordCrypt PasswordHash
|
||||||
permissions Text
|
permissions Text
|
||||||
accepted (Maybe Time)
|
accepted (Maybe Time)
|
||||||
rejected (Maybe Time)
|
|
||||||
seceded (Maybe Time)
|
|
||||||
toBeDeleted (Maybe Time)
|
|
||||||
memberData Value sqltype=jsonb
|
memberData Value sqltype=jsonb
|
||||||
|
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
@ -39,15 +36,21 @@ DBUser sql=users
|
||||||
DBEmail sql=emails
|
DBEmail sql=emails
|
||||||
uid DBUserId
|
uid DBUserId
|
||||||
email Email sqltype=varchar(320)
|
email Email sqltype=varchar(320)
|
||||||
verificationSecret (Maybe Text)
|
vid (Maybe DBEmailVerificationId) sql=verification
|
||||||
|
|
||||||
UniqueUserVerified uid verificationSecret
|
UniqueUserVerified uid vid
|
||||||
-- This enables using persistent functions to get unique verified emails. The real
|
-- This enables using persistent functions to get unique verified emails. The real
|
||||||
-- constraint is stricter and doesn't allow having more than one null and one non-null
|
-- constraint is stricter and doesn't allow having more than one null and one non-null
|
||||||
-- verification secret but it's too complicated for persistent to understand.
|
-- verification but it's too complicated for persistent to understand.
|
||||||
|
|
||||||
UniqueEmail email
|
UniqueEmail email
|
||||||
UniqueVerification verificationSecret
|
UniqueVerification vid
|
||||||
|
|
||||||
|
DBEmailVerification sql=emailVerifications
|
||||||
|
secret Text sqltype=varchar(255)
|
||||||
|
expires Time
|
||||||
|
|
||||||
|
UniqueVerificationSecret secret
|
||||||
|
|
||||||
DBKey sql=keys
|
DBKey sql=keys
|
||||||
uid DBUserId
|
uid DBUserId
|
||||||
|
|
|
@ -11,10 +11,11 @@ import Datarekisteri.Backend.Types
|
||||||
import Datarekisteri.Core.Types
|
import Datarekisteri.Core.Types
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Database.Esqueleto.Experimental
|
import Database.Esqueleto.Experimental
|
||||||
import qualified Database.Persist as Persist (update, (=.), (==.))
|
import qualified Database.Persist as Persist (update, (=.))
|
||||||
import qualified Database.Persist.Types as Persist (Update)
|
import qualified Database.Persist.Types as Persist (Update)
|
||||||
import Data.Maybe (listToMaybe)
|
import Data.Maybe (listToMaybe)
|
||||||
import Data.Aeson (fromJSON, toJSON, Result(..))
|
import Data.Aeson (fromJSON, toJSON, Result(..))
|
||||||
|
import Data.Time (nominalDay)
|
||||||
|
|
||||||
getByID :: (MonadDB m, ToDBKey k, PersistEntityBackend (DB k) ~ SqlBackend) => k -> m (Maybe (Entity (DB k)))
|
getByID :: (MonadDB m, ToDBKey k, PersistEntityBackend (DB k) ~ SqlBackend) => k -> m (Maybe (Entity (DB k)))
|
||||||
getByID id = let key = toDBKey id in runQuery $ fmap (Entity key) <$> get key
|
getByID id = let key = toDBKey id in runQuery $ fmap (Entity key) <$> get key
|
||||||
|
@ -77,7 +78,7 @@ applicants = runQuery $ select $ do
|
||||||
pure $ users
|
pure $ users
|
||||||
|
|
||||||
isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool)
|
isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool)
|
||||||
isVerified email = isNothing (email ^. DBEmailVerificationSecret)
|
isVerified email = isNothing (email ^. DBEmailVid)
|
||||||
|
|
||||||
hasVerifiedEmail :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool)
|
hasVerifiedEmail :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool)
|
||||||
hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
|
hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
|
||||||
|
@ -88,21 +89,26 @@ hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
|
||||||
isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
|
isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
|
||||||
isApplicant user = isNothing (user ^. DBUserAccepted)
|
isApplicant user = isNothing (user ^. DBUserAccepted)
|
||||||
&&. hasVerifiedEmail (user ^. DBUserId)
|
&&. hasVerifiedEmail (user ^. DBUserId)
|
||||||
&&. isNothing (user ^. DBUserRejected)
|
|
||||||
|
|
||||||
isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
|
isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
|
||||||
isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded)
|
isMember user = not_ $ isApplicant user
|
||||||
|
|
||||||
verifyEmailSecret :: MonadDB m => Text -> m Integer
|
verifyEmailSecret :: MonadDB m => Text -> m Bool
|
||||||
verifyEmailSecret secret = fmap fromIntegral $ runQuery $ updateCount $ \email -> do
|
verifyEmailSecret secret = runQuery $ do
|
||||||
set email [DBEmailVerificationSecret =. val Nothing]
|
update $ \email -> do
|
||||||
where_ $ email ^. DBEmailVerificationSecret ==. val (Just secret)
|
verification <- from $ table @DBEmailVerification
|
||||||
|
set email [DBEmailVid =. val Nothing]
|
||||||
|
where_ $ email ^. DBEmailVid ==. just (verification ^. DBEmailVerificationId)
|
||||||
|
&&. verification ^. DBEmailVerificationSecret ==. val secret
|
||||||
|
fmap (> 0) $ deleteCount $ do
|
||||||
|
verification <- from (table @DBEmailVerification)
|
||||||
|
where_ $ verification ^. DBEmailVerificationSecret ==. val secret
|
||||||
|
|
||||||
getUserEmail' :: MonadDB m => UserID -> Bool -> m (Maybe (Entity DBEmail))
|
getUserEmail' :: MonadDB m => UserID -> Bool -> m (Maybe (Entity DBEmail))
|
||||||
getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do
|
getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do
|
||||||
email <- from $ table @DBEmail
|
email <- from $ table @DBEmail
|
||||||
where_ $ email ^. DBEmailUid ==. val (toDBKey user)
|
where_ $ email ^. DBEmailUid ==. val (toDBKey user)
|
||||||
&&. isNothing (email ^. DBEmailVerificationSecret) ==. val verified
|
&&. isNothing (email ^. DBEmailVid) ==. val verified
|
||||||
pure email
|
pure email
|
||||||
|
|
||||||
getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
|
getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
|
||||||
|
@ -114,8 +120,32 @@ getUserPendingEmail user = getUserEmail' user False
|
||||||
addEmail :: MonadDB m => DBEmail -> m (Key DBEmail)
|
addEmail :: MonadDB m => DBEmail -> m (Key DBEmail)
|
||||||
addEmail = runQuery . insert
|
addEmail = runQuery . insert
|
||||||
|
|
||||||
updateEmail :: MonadDB m => UserID -> Email -> Text -> m (Key DBEmail)
|
getExpireTime :: MonadTime m => m Time
|
||||||
updateEmail user email secret = runQuery $ do
|
getExpireTime = addTime (7 * nominalDay) <$> currentTime
|
||||||
|
|
||||||
|
addEmailVerification :: (MonadDB m, MonadTime m) => Text -> m (Key DBEmailVerification)
|
||||||
|
addEmailVerification secret = do
|
||||||
|
expires <- getExpireTime
|
||||||
|
runQuery $ insert $ DBEmailVerification
|
||||||
|
{ dBEmailVerificationSecret = secret
|
||||||
|
, dBEmailVerificationExpires = expires
|
||||||
|
}
|
||||||
|
|
||||||
|
deleteExpiredEmails :: MonadDB m => Time -> m ()
|
||||||
|
deleteExpiredEmails time = runQuery $ delete $ do
|
||||||
|
verification <- from $ table @DBEmailVerification
|
||||||
|
where_ $ verification ^. DBEmailVerificationExpires <=. val time
|
||||||
|
|
||||||
|
deleteUsersWithoutEmail :: MonadDB m => m ()
|
||||||
|
deleteUsersWithoutEmail = runQuery $ delete $ do
|
||||||
|
user <- from $ table @DBUser
|
||||||
|
where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
|
||||||
|
email <- from $ table @DBEmail
|
||||||
|
where_ $ email ^. DBEmailUid ==. user ^. DBUserId
|
||||||
|
pure $ email ^. DBEmailId -- Not used anywhere
|
||||||
|
|
||||||
|
updateEmail :: (MonadDB m, MonadTime m) => UserID -> Email -> Text -> m (Key DBEmail)
|
||||||
|
updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do
|
||||||
delete $ do
|
delete $ do
|
||||||
dbEmail <- from $ table @DBEmail
|
dbEmail <- from $ table @DBEmail
|
||||||
where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail)
|
where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail)
|
||||||
|
@ -126,20 +156,25 @@ updateEmail user email secret = runQuery $ do
|
||||||
pure dbEmail
|
pure dbEmail
|
||||||
case verifiedEmail of
|
case verifiedEmail of
|
||||||
Just (Entity key _) -> pure key
|
Just (Entity key _) -> pure key
|
||||||
Nothing -> insert DBEmail
|
Nothing -> do
|
||||||
{ dBEmailUid = toDBKey user
|
verificationId <- insert DBEmailVerification
|
||||||
, dBEmailEmail = email
|
{ dBEmailVerificationSecret = secret
|
||||||
, dBEmailVerificationSecret = Just secret
|
, dBEmailVerificationExpires = expires
|
||||||
}
|
}
|
||||||
|
insert DBEmail
|
||||||
|
{ dBEmailUid = toDBKey user
|
||||||
|
, dBEmailEmail = email
|
||||||
|
, dBEmailVid = Just verificationId
|
||||||
|
}
|
||||||
|
|
||||||
markAsAccepted :: MonadDB m => UserID -> Time -> m ()
|
markAsAccepted :: MonadDB m => UserID -> Time -> m Bool
|
||||||
markAsAccepted userID time = runQuery $ update $ \user -> do
|
markAsAccepted userID time = fmap (> 0) $ runQuery $ updateCount $ \user -> do
|
||||||
set user [DBUserAccepted =. just (val time)]
|
set user [DBUserAccepted =. just (val time)]
|
||||||
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
|
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
|
||||||
|
|
||||||
markAsRejected :: MonadDB m => UserID -> Time -> m ()
|
deleteApplication :: MonadDB m => UserID -> m Bool
|
||||||
markAsRejected userID time = runQuery $ update $ \user -> do
|
deleteApplication userID = fmap (> 0) $ runQuery $ deleteCount $ do
|
||||||
set user [DBUserRejected =. just (val time)]
|
user <- from $ table @DBUser
|
||||||
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
|
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
|
||||||
|
|
||||||
updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID
|
updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID
|
||||||
|
|
|
@ -24,32 +24,49 @@ main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
|
CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
|
||||||
runCLIM optionsDBUrl $ case optionsSubCommand of
|
runCLIM optionsDBUrl $ case optionsSubCommand of
|
||||||
AddUser {..} -> do
|
(AddUser addUserOpts) -> addUserMain addUserOpts
|
||||||
time <- currentTime
|
GCEmails -> gcEmailsMain
|
||||||
passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
|
GCApplications -> gcApplicationsMain
|
||||||
userID <- addUser $ DBUser
|
GCAll -> gcAllMain
|
||||||
{ dBUserRegistered = time
|
|
||||||
, dBUserToBeDeleted = Nothing
|
addUserMain :: AddUserOpts -> CLIM ()
|
||||||
, dBUserPasswordCrypt = passwordHash
|
addUserMain AddUserOpts {..} = do
|
||||||
, dBUserPermissions = show addUserPermissions
|
time <- currentTime
|
||||||
, dBUserAccepted = Just time
|
passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
|
||||||
, dBUserSeceded = Nothing
|
userID <- addUser $ DBUser
|
||||||
, dBUserRejected = Nothing
|
{ dBUserRegistered = time
|
||||||
, dBUserMemberData = toJSON $ MemberData
|
, dBUserPasswordCrypt = passwordHash
|
||||||
{ nickname = addUserNickname
|
, dBUserPermissions = show addUserPermissions
|
||||||
, name = addUserName
|
, dBUserAccepted = Just time
|
||||||
, birthdate = addUserBirthdate
|
, dBUserMemberData = toJSON $ MemberData
|
||||||
, homeplace = addUserHomeplace
|
{ nickname = addUserNickname
|
||||||
, application = addUserApplication
|
, name = addUserName
|
||||||
, phoneNumber = addUserPhoneNumber
|
, birthdate = addUserBirthdate
|
||||||
}
|
, homeplace = addUserHomeplace
|
||||||
}
|
, application = addUserApplication
|
||||||
_ <- addEmail $ DBEmail
|
, phoneNumber = addUserPhoneNumber
|
||||||
{ dBEmailUid = toDBKey userID
|
}
|
||||||
, dBEmailEmail = addUserEmail
|
}
|
||||||
, dBEmailVerificationSecret = Nothing
|
_ <- addEmail $ DBEmail
|
||||||
}
|
{ dBEmailUid = toDBKey userID
|
||||||
pure ()
|
, dBEmailEmail = addUserEmail
|
||||||
|
, dBEmailVid = Nothing
|
||||||
|
}
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
gcEmailsMain :: CLIM ()
|
||||||
|
gcEmailsMain = do
|
||||||
|
time <- currentTime
|
||||||
|
deleteExpiredEmails time
|
||||||
|
|
||||||
|
gcApplicationsMain :: CLIM ()
|
||||||
|
gcApplicationsMain = do
|
||||||
|
deleteUsersWithoutEmail
|
||||||
|
|
||||||
|
gcAllMain :: CLIM ()
|
||||||
|
gcAllMain = do
|
||||||
|
gcEmailsMain
|
||||||
|
gcApplicationsMain
|
||||||
|
|
||||||
cliOptions :: Parser CLIOptions
|
cliOptions :: Parser CLIOptions
|
||||||
cliOptions = CLIOptions
|
cliOptions = CLIOptions
|
||||||
|
@ -59,9 +76,12 @@ cliOptions = CLIOptions
|
||||||
cliCommandParser :: Parser CLISubCommand
|
cliCommandParser :: Parser CLISubCommand
|
||||||
cliCommandParser = hsubparser
|
cliCommandParser = hsubparser
|
||||||
$ command "add-user" (info addUserCommand (progDesc "Add a user to datarekisteri"))
|
$ command "add-user" (info addUserCommand (progDesc "Add a user to datarekisteri"))
|
||||||
|
<> command "gc-expired-emails" (info (pure GCEmails) (progDesc "Delete emails that have not been verified in time."))
|
||||||
|
<> command "gc-applications" (info (pure GCApplications) (progDesc "Delete users without an email address"))
|
||||||
|
<> command "gc" (info (pure GCAll) (progDesc "Run all garbage collection jobs."))
|
||||||
|
|
||||||
addUserCommand :: Parser CLISubCommand
|
addUserCommand :: Parser CLISubCommand
|
||||||
addUserCommand = AddUser
|
addUserCommand = fmap AddUser $ AddUserOpts
|
||||||
<$> optional (strOption (long "nickname" <> metavar "NAME"))
|
<$> optional (strOption (long "nickname" <> metavar "NAME"))
|
||||||
<*> strOption (long "name" <> metavar "NAME")
|
<*> strOption (long "name" <> metavar "NAME")
|
||||||
<*> option (maybeReader $ toDate . toText) (long "birthdate" <> metavar "DATE" <> help "The user's birthdate, YYYY-MM-DD")
|
<*> option (maybeReader $ toDate . toText) (long "birthdate" <> metavar "DATE" <> help "The user's birthdate, YYYY-MM-DD")
|
||||||
|
@ -81,16 +101,21 @@ data CLIOptions = CLIOptions
|
||||||
, optionsSubCommand :: CLISubCommand
|
, optionsSubCommand :: CLISubCommand
|
||||||
}
|
}
|
||||||
|
|
||||||
data CLISubCommand = AddUser
|
data CLISubCommand = AddUser AddUserOpts
|
||||||
{ addUserNickname :: Maybe Text
|
| GCEmails
|
||||||
, addUserName :: Text
|
| GCApplications
|
||||||
, addUserBirthdate :: Date
|
| GCAll
|
||||||
, addUserHomeplace :: Text
|
|
||||||
, addUserPhoneNumber :: PhoneNumber
|
data AddUserOpts = AddUserOpts
|
||||||
, addUserEmail :: Email
|
{ addUserNickname :: Maybe Text
|
||||||
, addUserPermissions :: Map Scope Permission
|
, addUserName :: Text
|
||||||
, addUserApplication :: Text
|
, addUserBirthdate :: Date
|
||||||
}
|
, addUserHomeplace :: Text
|
||||||
|
, addUserPhoneNumber :: PhoneNumber
|
||||||
|
, addUserEmail :: Email
|
||||||
|
, addUserPermissions :: Map Scope Permission
|
||||||
|
, addUserApplication :: Text
|
||||||
|
}
|
||||||
|
|
||||||
newtype CLIM a = CLIM (ReaderT String IO a)
|
newtype CLIM a = CLIM (ReaderT String IO a)
|
||||||
deriving (Functor, Applicative, Monad, MonadIO, MonadReader String)
|
deriving (Functor, Applicative, Monad, MonadIO, MonadReader String)
|
||||||
|
|
|
@ -50,7 +50,6 @@ type User {
|
||||||
homeplace: String!
|
homeplace: String!
|
||||||
registered: Time!
|
registered: Time!
|
||||||
accepted: Time
|
accepted: Time
|
||||||
seceded: Time
|
|
||||||
permissions: String!
|
permissions: String!
|
||||||
isMember: Boolean!
|
isMember: Boolean!
|
||||||
application: String!
|
application: String!
|
||||||
|
@ -76,4 +75,3 @@ type Mutation {
|
||||||
accept(user: UserID!): Unit!
|
accept(user: UserID!): Unit!
|
||||||
reject(user: UserID!): Unit!
|
reject(user: UserID!): Unit!
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue