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 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")))
|
||||
|
|
|
@ -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 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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!
|
||||
}
|
||||
|
||||
|
|
Loading…
Reference in New Issue