From cbf619c3708d7184d18437072b364fd4f2f6e3c3 Mon Sep 17 00:00:00 2001
From: Saku Laesvuori <saku@laesvuori.fi>
Date: Fri, 20 Jan 2023 09:20:06 +0200
Subject: [PATCH] Initial commit

---
 Client.hs                                |  30 +
 Client/ApiRequests.hs                    |  56 ++
 Client/Auth.hs                           |  65 ++
 Client/FormFields.hs                     |  46 ++
 Client/Handlers.hs                       |  34 ++
 Client/Handlers/Applications.hs          | 117 ++++
 Client/Handlers/Apply.hs                 |  89 +++
 Client/Handlers/Profile.hs               | 134 +++++
 Client/Handlers/VerifyEmail.hs           |  50 ++
 Client/Types.hs                          | 330 ++++++++++
 PrintSchema.hs                           |   6 +
 README.md                                |  26 +
 Server.hs                                | 157 +++++
 Server/API.hs                            | 333 +++++++++++
 Server/DB.hs                             |  95 +++
 Server/DB/Queries.hs                     | 115 ++++
 Server/Email.hs                          |  17 +
 Server/Types.hs                          | 245 ++++++++
 Server/Utils.hs                          |  20 +
 Setup.hs                                 |   4 +
 datarekisteri.cabal                      |  14 +
 db/migrations/20221208114323_init-db.sql |  53 ++
 db/schema.sql                            | 283 +++++++++
 guix.scm                                 | 728 +++++++++++++++++++++++
 schema.gql                               |  76 +++
 25 files changed, 3123 insertions(+)
 create mode 100644 Client.hs
 create mode 100644 Client/ApiRequests.hs
 create mode 100644 Client/Auth.hs
 create mode 100644 Client/FormFields.hs
 create mode 100644 Client/Handlers.hs
 create mode 100644 Client/Handlers/Applications.hs
 create mode 100644 Client/Handlers/Apply.hs
 create mode 100644 Client/Handlers/Profile.hs
 create mode 100644 Client/Handlers/VerifyEmail.hs
 create mode 100644 Client/Types.hs
 create mode 100644 PrintSchema.hs
 create mode 100644 README.md
 create mode 100644 Server.hs
 create mode 100644 Server/API.hs
 create mode 100644 Server/DB.hs
 create mode 100644 Server/DB/Queries.hs
 create mode 100644 Server/Email.hs
 create mode 100644 Server/Types.hs
 create mode 100644 Server/Utils.hs
 create mode 100644 Setup.hs
 create mode 100644 datarekisteri.cabal
 create mode 100644 db/migrations/20221208114323_init-db.sql
 create mode 100644 db/schema.sql
 create mode 100644 guix.scm
 create mode 100644 schema.gql

diff --git a/Client.hs b/Client.hs
new file mode 100644
index 0000000..b5b3423
--- /dev/null
+++ b/Client.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import Relude hiding (get)
+
+import Yesod
+import Yesod.Auth
+import Client.Types
+import Client.Handlers
+import Client.Auth ()
+import Yesod.Static (static, Static)
+import System.Directory (createDirectoryIfMissing)
+
+mkYesodDispatch "DataIdClient" resourcesDataIdClient
+
+main :: IO ()
+main = getStaticDir "/tmp/data-id" >>= warp 3000 . DataIdClient
+
+getStaticDir :: FilePath -> IO Static
+getStaticDir dir = createDirectoryIfMissing True dir >> static dir
diff --git a/Client/ApiRequests.hs b/Client/ApiRequests.hs
new file mode 100644
index 0000000..b17df29
--- /dev/null
+++ b/Client/ApiRequests.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.ApiRequests where
+
+import Relude
+
+import Data.Morpheus.Client
+import Yesod hiding (Header)
+import Yesod.Auth
+
+type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)
+-- From Data.Morpheus.Client.Fetch.RequestType
+type Header = (Text, Text)
+-- From Data.Morpheus.Client.Fetch.GQLClient
+-- No clue why these are not exported
+
+type RequestConstraint a site = (ClientTypeConstraint a, ApiRequest site)
+
+type Authorization = Text
+
+class YesodAuth site => ApiRequest site where
+    getApiUrl :: HandlerFor site Text
+    authIdToAuthorization :: site -> AuthId site -> Authorization
+
+apiRequest' :: RequestConstraint a site => [Header] -> Bool -> Args a -> HandlerFor site a
+apiRequest' extraHeaders authRequired args = do
+    yesod <- liftHandler getYesod
+    auth <- fmap (authIdToAuthorization yesod) <$> if authRequired then Just <$> requireAuthId else maybeAuthId
+    apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args >>= handleErrors
+
+apiRequestAuth :: RequestConstraint a site =>
+    [Header] -> Maybe Authorization -> Args a -> HandlerFor site (GQLClientResult a)
+apiRequestAuth extraHeaders auth args = do
+    apiUrl <- getApiUrl
+    stream <- liftIO $ request (fromString (toString apiUrl) `withHeaders` headers) args
+    single stream
+        where headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders
+
+apiRequest :: RequestConstraint a site => Bool -> Args a -> HandlerFor site a
+apiRequest authRequired = apiRequest' [] authRequired
+
+handleErrors :: RequestConstraint a site => GQLClientResult a -> HandlerFor site a
+handleErrors (Right a) = pure a
+handleErrors (Left (FetchErrorParseFailure s)) = error $ "GQL parse failure: " <> toText s
+handleErrors (Left (FetchErrorProducedErrors errs Nothing)) = error $ "GQL errors: " <> show errs
+handleErrors (Left (FetchErrorProducedErrors _ (Just a))) = pure a -- TODO log the errors?
+handleErrors (Left (FetchErrorNoResult)) = error $ "GQL no results"
diff --git a/Client/Auth.hs b/Client/Auth.hs
new file mode 100644
index 0000000..470e509
--- /dev/null
+++ b/Client/Auth.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.Auth where
+
+import Relude
+
+import Server.Types
+import Data.Morpheus.Client
+import Yesod
+import Yesod.Auth
+import qualified Data.ByteString.Base64 as B64 (encode)
+import qualified Yesod.Auth.Message as Msg
+
+pluginName = "externalBasic"
+
+loginR = PluginR pluginName ["login"]
+
+type Authorization = Text
+type CredsIdent = Text
+
+postLoginR :: YesodAuth master =>
+    (Authorization -> HandlerFor master (Maybe CredsIdent)) -> AuthHandler master TypedContent
+postLoginR authReq = do
+    res <- runInputPostResult $ (\x y -> x <> ":" <> y)
+        <$> ireq textField "email" <*> ireq textField "password"
+    case res of
+      FormSuccess auth -> do
+          maybeAuth <- liftHandler $ authReq $ ("Basic " <> ) $ decodeUtf8 $ B64.encode $ encodeUtf8 auth
+          case maybeAuth of
+            Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided -- invalid creds
+            Just txt -> do
+                setCredsRedirect Creds {credsPlugin = pluginName, credsIdent = txt, credsExtra = []}
+      _ -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
+
+authExternalBasic :: forall site. YesodAuth site =>
+    (Authorization -> HandlerFor site (Maybe CredsIdent)) -> AuthPlugin site
+authExternalBasic authReq = AuthPlugin pluginName dispatch loginForm
+    where dispatch :: YesodAuth site => Text -> [Text] -> AuthHandler site TypedContent
+          dispatch "POST" ["login"] = postLoginR authReq >>= sendResponse
+          dispatch _ _ = notFound
+
+loginForm :: YesodAuth site => (Route Auth -> Route site) -> WidgetFor site ()
+loginForm toParent = do
+    emailId <- newIdent
+    passwordId <- newIdent
+    [whamlet|
+<h1>Kirjaudu
+<form action=@{toParent loginR} method=post>
+    <label for="#{emailId}">
+        Sähköposti
+    <input id="#{emailId}" name="email" type="text" autofocus>
+    <label for="#{passwordId}">
+        Salasana
+    <input id="#{passwordId}" name="password" type="password">
+    <input type="submit" value="Kirjaudu">
+|]
diff --git a/Client/FormFields.hs b/Client/FormFields.hs
new file mode 100644
index 0000000..a611111
--- /dev/null
+++ b/Client/FormFields.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.FormFields where
+
+import Relude
+
+import Yesod
+import Client.Types
+import Server.Types
+
+emailField :: Field Handler Email
+emailField = Field
+    { fieldParse = \rawValues _ ->
+        case rawValues of
+          [] -> pure $ Right Nothing
+          [x] -> pure $ maybe (Left "could not parse as an email address") (Right . Just) $ toEmail x
+          _ -> pure $ Left $ "Expected one value"
+    , fieldView = \id name otherAttributes result isRequired ->
+        let result' = either (\x -> x) renderEmail result
+        in [whamlet|
+               <input type="email" id="#{id}" name="#{name}" value="#{result'}" *{otherAttributes} :isRequired:required="">
+           |]
+    , fieldEnctype = UrlEncoded
+    }
+
+verifiedPasswordField :: Field Handler Text
+verifiedPasswordField = Field
+    { fieldParse = \rawValues _ ->
+        case rawValues of
+          [] -> pure $ Right Nothing
+          [x,y]
+            | x == y -> pure $ Right $ Just x
+            | otherwise -> pure $ Left "Salasanat eivät täsmää"
+          _ -> pure $ Left "Expected two values"
+    , fieldView = \id name otherAttributes _ isRequired ->
+        [whamlet|
+          <input type="password" id="#{id}" name="#{name}" :isRequired:required="true" *{otherAttributes}>
+          <label for="#{id}-confirm">
+            Toista salasana
+          <input type="password" id="#{id}-confirm" name="#{name}" :isRequired:required="true" *{otherAttributes}>
+        |]
+    , fieldEnctype = UrlEncoded
+    }
diff --git a/Client/Handlers.hs b/Client/Handlers.hs
new file mode 100644
index 0000000..41edb43
--- /dev/null
+++ b/Client/Handlers.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.Handlers
+    ( module Client.Handlers.Profile
+    , module Client.Handlers.Apply
+    , module Client.Handlers.Applications
+    , module Client.Handlers.VerifyEmail
+    , getHomeR
+    , postApiR
+    ) where
+
+import Relude
+
+import Client.Handlers.Profile
+import Client.Handlers.Apply
+import Client.Handlers.Applications
+import Client.Handlers.VerifyEmail
+import Client.Types
+import Yesod
+import Yesod.Auth
+import Server (serverApp)
+
+getHomeR :: Handler Html
+getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
+
+postApiR :: Handler ()
+postApiR = sendWaiApplication =<< liftIO serverApp
diff --git a/Client/Handlers/Applications.hs b/Client/Handlers/Applications.hs
new file mode 100644
index 0000000..890970f
--- /dev/null
+++ b/Client/Handlers/Applications.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.Handlers.Applications where
+
+import Relude hiding (id)
+
+import Client.ApiRequests
+import Client.Types
+import Data.Morpheus.Client
+import Server.Types hiding (Applications)
+import Yesod hiding (emailField)
+import Yesod.Auth
+import Client.FormFields
+import Data.Time (Day)
+import Data.Maybe (fromJust)
+
+declareLocalTypesInline "schema.gql" [raw|
+query Applications {
+  applications {
+    id
+    name
+    nickname
+    email
+    homeplace
+    birthdate
+    application
+  }
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation Reject($user: UserID!) {
+  reject(user: $user)
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation Accept($user: UserID!) {
+  accept(user: $user)
+}
+|]
+
+resolveApplicationForm :: Maybe UserID -> Form UserID
+resolveApplicationForm user = renderDivs $ areq hiddenField "" user
+
+applicationsW :: [ApplicationsApplications] -> Widget
+applicationsW applications = do
+    setTitle "Jäsenhakemukset"
+    [whamlet|<h1>Käsiteltävät jäsenhakemukset|]
+    when (null applications) $ [whamlet|<p>Ei jäsenhakemuksia.|]
+    rejectRoute <- handlerToWidget $ maybeAuthorized RejectR True
+    acceptRoute <- handlerToWidget $ maybeAuthorized AcceptR True
+    forM_ applications $ \ApplicationsApplications {..} -> do
+        (widget, enctype) <- handlerToWidget $ generateFormPost $ resolveApplicationForm $ Just id
+        [whamlet|
+<details>
+    <summary>
+        <h2>#{name}
+    <article>
+        <h3>Hakemus
+        <p>#{Textarea application}
+        <table>
+            <tr>
+                <th scope="row">Nimi
+                <td>#{name}
+            <tr>
+                <th scope="row">Kutsumanimi
+                <td>#{nickname}
+            <tr>
+                <th scope="row">Kotipaikka
+                <td>#{homeplace}
+            <tr>
+                <th scope="row">Syntymäaika
+                <td>#{renderDate $ birthdate}
+            <tr>
+                <th scope="row">Sähköposti
+                <td>#{renderEmail $ fromJust $ email}
+    $maybe route <- acceptRoute
+        <form action="@{route}" method="post" enctype="#{enctype}">
+            ^{widget}
+            <input type="submit" value="Hyväksy">
+    $maybe route <- rejectRoute
+        <form action="@{route}" method="post" enctype="#{enctype}">
+            ^{widget}
+            <input type="submit" value="Hylkää" class="reject-button">
+|]
+
+getApplicationsR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+getApplicationsR = do
+    Applications applications <- apiRequest @Applications True ()
+    defaultLayout $ applicationsW applications
+
+postAcceptR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postAcceptR = do
+    ((result, _), _) <- runFormPost $ resolveApplicationForm Nothing
+    case result of
+      FormSuccess user -> void $ apiRequest @Accept True $ AcceptArgs user
+      _ -> pure ()
+    redirect ApplicationsR
+
+postRejectR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postRejectR = do
+    ((result, _), _) <- runFormPost $ resolveApplicationForm Nothing
+    case result of
+      FormSuccess user -> void $ apiRequest @Reject True $ RejectArgs user
+      _ -> pure ()
+    redirect ApplicationsR
diff --git a/Client/Handlers/Apply.hs b/Client/Handlers/Apply.hs
new file mode 100644
index 0000000..0f2ebe2
--- /dev/null
+++ b/Client/Handlers/Apply.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.Handlers.Apply where
+
+import Relude hiding (id)
+
+import Client.ApiRequests
+import Client.Types
+import Data.Morpheus.Client
+import Server.Types
+import Yesod hiding (emailField)
+import Yesod.Auth
+import Client.FormFields
+import Data.Time (Day)
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation Apply($name: String!, $nickname: String, $homeplace: String!,
+    $birthdate: Date!, $email: Email!, $password: String!, $application: String!) {
+  apply(email: $email, password: $password, name: $name, nickname: $nickname,
+      birthdate: $birthdate, homeplace: $homeplace, application: $application) {
+    id
+    name
+    nickname
+    email
+    pendingEmail
+    homeplace
+    birthdate
+  }
+}
+|]
+
+applyForm :: Html -> MForm Handler (FormResult ApplyArgs, Widget)
+applyForm = renderDivs $ ApplyArgs
+    <$> areq textField nameSettings Nothing
+    <*> aopt textField nicknameSettings Nothing
+    <*> areq textField homeplaceSettings Nothing
+    <*> areq dayField' birthdateSettings Nothing
+    <*> areq emailField emailSettings Nothing
+    <*> areq verifiedPasswordField "Salasana" Nothing
+    <*> areq textareaField' applicationSettings Nothing
+        where dayField' :: Field Handler Date
+              dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
+                  (\(Date x) -> x) dayField
+              textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
+                  Textarea textareaField
+              nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
+              nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
+              homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}
+              birthdateSettings = "Syntymäaika" {fsAttrs = [("placeholder","2000-01-01")]}
+              emailSettings = "Sähköposti" {fsAttrs = [("placeholder","erkki.juhani@esimerkki.fi")]}
+              applicationSettings = "Hakemus (eli miksi olet data)"
+                  {fsAttrs = [("placeholder","Aloitin opiskelun Otaniemen datalla vuonna 2020.")]}
+
+applyW :: (Widget, Enctype) -> Widget
+applyW (applyWidget, applyEnctype) = do
+    setTitle "Jäsenhakemus"
+    [whamlet|
+<h1>
+    Jäsenhakemus
+<form action="@{ApplyR}" method="post" enctype="#{applyEnctype}">
+    ^{applyWidget}
+    <p>
+        Lähettämällä jäsenhakemuksen vakuutat antamiesi tietojen oikeellisuuden ja puuttettomuuden
+        sekä sitoudut pitämään ne ajan tasalla.
+    <input type="submit" value="Hae jäseneksi">
+|]
+
+getApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+getApplyR = do
+    applyForm <- liftHandler $ generateFormPost applyForm
+    defaultLayout $ applyW applyForm
+
+postApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postApplyR = do
+    ((result, widget), enctype) <- runFormPost applyForm
+    case result of
+      FormSuccess application -> apiRequest @Apply False application >>= \x -> redirect $ ProfileR $ id (apply x :: ApplyApply)
+      _ -> do
+          defaultLayout $ applyW (widget, enctype)
diff --git a/Client/Handlers/Profile.hs b/Client/Handlers/Profile.hs
new file mode 100644
index 0000000..910b47a
--- /dev/null
+++ b/Client/Handlers/Profile.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.Handlers.Profile where
+
+import Relude hiding (id)
+
+import Client.ApiRequests
+import Client.Types
+import Client.FormFields
+import Data.Morpheus.Client
+import Server.Types
+import Yesod hiding (emailField)
+import Yesod.Auth
+
+declareLocalTypesInline "schema.gql" [raw|
+query ProfilePage($id: UserID) {
+  user(id: $id) {
+    id
+    name
+    nickname
+    email
+    pendingEmail
+    homeplace
+    birthdate
+  }
+  permissions
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email) {
+  update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email) {
+    id
+  }
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation UpdatePassword($user: UserID, $password: String!) {
+  update(user: $user, password: $password) {
+    id
+  }
+}
+|]
+
+passwordForm :: Form Text
+passwordForm = renderDivs $ areq verifiedPasswordField "Uusi salasana" Nothing
+
+profileForm :: (Maybe UserID) -> (Maybe ProfilePageUser) -> Form UpdateProfileArgs
+profileForm userID user extraHtml = do
+    (nameRes, nameView) <- mopt textField "Nimi" (Just $ maybe Nothing (\x -> Just $ name (x ::ProfilePageUser)) user)
+    (homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ maybe Nothing (\x -> Just $ homeplace (x :: ProfilePageUser)) user)
+    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ maybe Nothing (\x -> Just $ nickname (x :: ProfilePageUser)) user)
+    (emailRes, emailView) <- mopt emailField "Sähköposti" (maybe Nothing (\x -> Just $ email (x :: ProfilePageUser)) user)
+    let profileUpdateRes = UpdateProfileArgs userID <$> nameRes <*> homeRes <*> nicknameRes <*> emailRes
+        maybePendingEmail = user >>= \x -> pendingEmail (x :: ProfilePageUser)
+        inputField FieldView {..} = [whamlet|
+            <label for="#{fvId}">
+                ^{fvLabel}
+                ^{fvInput}
+            |]
+        widget = [whamlet|
+            #{extraHtml}
+            ^{inputField nameView}
+            ^{inputField homeView}
+            ^{inputField nicknameView}
+            ^{inputField emailView}
+            $maybe pendingEmail <- maybePendingEmail
+                <p>Päivitys osoitteeseen #
+                    <a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
+                    odottaa vahvistusta. #
+                    <a href="@{VerifyEmailR}">Siirry vahvistamaan
+            |]
+    return (profileUpdateRes, widget)
+
+profile :: UserID -> (Widget, Enctype) -> (Widget, Enctype) -> Widget
+profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) = do
+    setTitle "Muokkaa profiilia"
+    passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR user) True
+    [whamlet|
+    <h1>
+        Omat tiedot
+    <form action="@{ProfileR user}" method="post" enctype="#{profileEnctype}">
+        ^{profileWidget}
+        <input type="submit" value="Päivitä tiedot">
+    $maybe route <- passwordRoute
+        <form action="@{route}" method="post" enctype="#{passwordEnctype}">
+            ^{passwordWidget}
+            <input type="submit" value="Vaihda salasana">
+|]
+
+getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html
+getProfile userID = do
+    ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
+    passwordForm <- liftHandler $ generateFormPost passwordForm
+    profileForm <- liftHandler $ generateFormPost $
+        profileForm ((\x -> id (x :: ProfilePageUser)) <$> user) user
+    defaultLayout $ profile ((\x -> id (x :: ProfilePageUser)) $ fromJust user) profileForm passwordForm
+        where fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
+
+getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+getOwnProfileR = getProfile Nothing
+
+getProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
+getProfileR = getProfile . Just
+
+postProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
+postProfileR userID = do
+    ((result, widget), enctype) <- runFormPost $ profileForm (Just userID) Nothing
+    case result of
+      FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
+      _ -> do
+          passwordForm <- liftHandler $ generateFormPost passwordForm
+          defaultLayout $ profile userID (widget, enctype) passwordForm
+
+postUpdatePasswordR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
+postUpdatePasswordR userID = do
+    ((result, widget), enctype) <- runFormPost passwordForm
+    case result of
+      FormSuccess new ->
+          apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID)
+      _ -> do
+          profileForm <- liftHandler $ generateFormPost $ profileForm (Just userID) Nothing
+          defaultLayout $ profile userID profileForm (widget, enctype)
diff --git a/Client/Handlers/VerifyEmail.hs b/Client/Handlers/VerifyEmail.hs
new file mode 100644
index 0000000..fc7c473
--- /dev/null
+++ b/Client/Handlers/VerifyEmail.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.Handlers.VerifyEmail where
+
+import Relude
+
+import Client.ApiRequests
+import Client.Types
+import Server.Types
+import Data.Morpheus.Client
+import Yesod
+import Yesod.Auth
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation VerifyEmail($secret: String!) {
+  verifyEmail(secret: $secret)
+}
+|]
+
+getVerifyEmailR = do
+    codeForm <- generateFormPost verifyForm
+    defaultLayout $ verifyEmailW codeForm
+
+postVerifyEmailR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postVerifyEmailR = do
+    ((result, widget), enctype) <- runFormPost verifyForm
+    case result of
+      FormSuccess verify -> apiRequest @VerifyEmail False verify >> setMessage "Sähköpostiosoite vahvistettu" >> redirect OwnProfileR
+      _ -> defaultLayout $ verifyEmailW (widget, enctype)
+
+verifyEmailW (codeWidget, codeEnctype) = do
+    setTitle "Vahvista sähköpostiosoite"
+    [whamlet|
+<h1>
+    Vahvista sähköpostiosoite
+<form action="@{VerifyEmailR}" method="post" enctype="#{codeEnctype}">
+    ^{codeWidget}
+    <input type="submit" value="Vahvista">
+|]
+
+verifyForm = renderDivs $ VerifyEmailArgs <$> areq textField "Vahvistuskoodi" Nothing
diff --git a/Client/Types.hs b/Client/Types.hs
new file mode 100644
index 0000000..fe97906
--- /dev/null
+++ b/Client/Types.hs
@@ -0,0 +1,330 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.Types where
+
+import Relude hiding (id)
+import Relude.Extra.Foldable1 (maximum1)
+
+import Yesod
+import Yesod.Core.Handler (getCurrentRoute)
+import Yesod.Default.Util (addStaticContentExternal)
+import Yesod.Auth
+import Yesod.Static
+import Server.Types (UserID(..), Scope(..), Permission(..))
+import Data.Time (getCurrentTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Client.Auth
+import Client.ApiRequests
+import Data.Morpheus.Client
+import Server (readPermission)
+import Data.Map (findWithDefault)
+
+data DataIdClient = DataIdClient { getStatic :: Static }
+
+mkYesodData "DataIdClient" [parseRoutes|
+/ HomeR GET
+
+/profile OwnProfileR GET
+/profile/#UserID ProfileR GET POST
+/update-password/#UserID UpdatePasswordR POST
+/verify-email VerifyEmailR GET POST
+
+/applications ApplicationsR GET
+/accept AcceptR POST
+/reject RejectR POST
+
+/apply ApplyR GET POST
+
+/api ApiR POST
+/auth AuthR Auth getAuth
+/static StaticR Static getStatic
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+query GetPermissions {
+  permissions
+  user {
+    id
+  }
+}
+|]
+
+withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult
+withAuthenticated m = maybeAuthId >>= maybe (pure AuthenticationRequired) m
+
+hasPermission :: Scope -> Permission -> Handler Bool
+hasPermission scope permission = do
+    GetPermissions {..} <- apiRequest @GetPermissions False ()
+    let permissionMap = fromMaybe mempty $ readPermission permissions
+        findPermission scope = findWithDefault None scope permissionMap
+        userID = (\x -> id (x :: GetPermissionsUser)) <$> user
+        scopes = scope :| case scope of
+            Tokens uid | Just uid == userID -> [OwnTokens]
+            Profile uid | Just uid == userID -> [OwnProfile]
+            _ -> []
+            -- TODO add Members and Applications to Profile Scopes if profile owner is member/applicant
+    pure $ (>= permission) $ maximum1 $ findPermission <$> scopes
+
+requirePermission :: Scope -> Permission -> Handler AuthResult
+requirePermission scope permission = ifM (hasPermission scope permission)
+    (pure Authorized)
+    (pure $ Unauthorized $ "Toiminto vaatii " <> renderPermission permission <> " " <> renderScope scope)
+        where renderPermission ReadWrite = "kirjoitusoikeuden"
+              renderPermission ReadOnly = "lukuoikeuden"
+              renderPermission None = "nollaoikeuden"
+              renderScope OwnProfile = "omaan profiliin"
+              renderScope (Profile user) = "käyttäjän '" <> show user <> "' profiliin"
+              renderScope OwnTokens = "omiin tokeneihin" -- TODO kunnon suomennos
+              renderScope (Tokens user) = "käyttäjän '" <> show user <> "' tokeneihin" -- TODO kunnon suomennos
+              renderScope Members = "kaikkiin jäseniin"
+              renderScope Applications = "jäsenhakemuksiin"
+
+authorizedHelper :: Scope -> Bool -> Handler AuthResult
+authorizedHelper scope True = requirePermission scope ReadWrite
+authorizedHelper scope False = requirePermission scope ReadOnly
+
+instance Yesod DataIdClient where
+    authRoute = const $ Just $ AuthR LoginR
+    approot = ApprootStatic "http://localhost:3000"
+    makeSessionBackend = const $ sslOnlySessions $ laxSameSiteSessions $
+        Just <$> defaultClientSessionBackend (60*24*7) "client_session_key.aes"
+    isAuthorized (AuthR _) _ = pure Authorized
+    isAuthorized (StaticR _) _ = pure Authorized
+    isAuthorized HomeR _ = pure Authorized
+    isAuthorized ApiR _ = pure Authorized
+    isAuthorized ApplyR _ = pure Authorized
+    isAuthorized VerifyEmailR _ = pure Authorized
+    isAuthorized OwnProfileR isWrite = withAuthenticated $ const $ authorizedHelper OwnProfile isWrite
+    isAuthorized (ProfileR user) isWrite = withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
+    isAuthorized (UpdatePasswordR user) isWrite =
+        withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
+    isAuthorized ApplicationsR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
+    isAuthorized AcceptR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
+    isAuthorized RejectR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
+    errorHandler NotFound = fmap toTypedContent $ defaultLayout $ defaultMessageWidget "Sivua ei löytynyt" $
+        [hamlet|<p>Pyytämästäsi osoitteesta ei löytynyt sivua|]
+    errorHandler (InternalError e) = do
+        $logErrorS "yesod-core" e
+        selectRep $ do
+            provideRep $ defaultLayout $ do
+                currentTime <- liftIO getCurrentTime
+                defaultMessageWidget "Palvelinvirhe" [hamlet|
+<p>
+    Pyynnön käsittelyssä tapahtui virhe. #
+    Ole yhteydessä ylläpitäjiin ja kerro heille palvelimen kellonaika virheen tapahtuessa #
+    #{iso8601Show currentTime}
+|]
+    errorHandler x = defaultErrorHandler x
+    addStaticContent = addStaticContentExternal Right base64md5 "/tmp/data-id" (StaticR . flip StaticRoute [])
+    defaultLayout widget = do
+        msgs <- getMessages
+        applicationsRoute <- maybeAuthorized ApplicationsR False
+        profileRoute <- maybeAuthorized OwnProfileR False
+        currentRoute <- getCurrentRoute
+        loggedIn <- isJust <$> maybeAuthId
+        p <- widgetToPageContent $ do
+            [whamlet|
+                <header>
+                  <nav>
+                    <ul>
+                      $maybe route <- profileRoute
+                        <li :Just route == currentRoute:class="active-nav">
+                          <a href="@{route}">Profiili
+                      $maybe route <- applicationsRoute
+                        <li :Just route == currentRoute:class="active-nav">
+                          <a href="@{route}">Hakemukset
+                      $if loggedIn
+                        <li class="left-nav">
+                          <a href="@{AuthR LogoutR}">Kirjaudu ulos
+                      $else
+                        <li :Just (AuthR LoginR) == currentRoute:class="active-nav" class="left-nav">
+                          <a href="@{AuthR LoginR}">Kirjaudu sisään
+                        <li :Just ApplyR == currentRoute:class="active-nav" class="left-nav">
+                          <a href="@{ApplyR}">Hae jäseneksi
+                <main>
+                  $if not $ null msgs
+                    <aside class="messages">
+                      <ul>
+                        $forall (_, msg) <- msgs
+                          <li class="message">#{msg}
+                  ^{widget}
+            |] :: Widget
+            toWidget $ [lucius|
+                :root {
+                  --bg-colour: #ffffff;
+                  --fg-colour: #181c22;
+                }
+                html {
+                  font-family: "Fira Sans", sans-serif;
+                  height: 100%;
+                }
+                th {
+                  text-align: right;
+                }
+                body {
+                  background-color: #e8eaef;
+                  color: var(--fg-colour);
+                  margin: 0;
+                  height: 100%;
+                }
+                label {
+                  display: block;
+                  padding-top: 0.3em;
+                  padding-bottom: 0.3em;
+                }
+                input {
+                  width: 100%;
+                  padding: 0.4em;
+                  margin-top: 0.3em;
+                  margin-bottom: 0.3em;
+                  border-radius: 0.25em;
+                }
+                textarea {
+                  width: 100%;
+                  padding: 0.4em;
+                  margin-top: 0.3em;
+                  margin-bottom: 0.3em;
+                }
+                form {
+                  max-width: 20em;
+                }
+                summary > h2 {
+                  display: inline-block;
+                  margin-top: 0;
+                  margin-bottom: 0;
+                }
+                details > table th {
+                  text-align: left;
+                  padding-left: 0;
+                }
+                details {
+                  padding: 1.3em;
+                  margin: 0.6em;
+                  border-color: #00838a;
+                  border-width: 0 0 0 0.6em;
+                  border-style: solid;
+                  border-radius: 0.4em;
+                  background-color: #f6f8f8;
+                }
+                details[open] {
+                  border-color: #339ca1;
+                }
+                details > article {
+                    margin-bottom: 1.5em
+                }
+                input[type="submit"] {
+                  background-color: #00838a;
+                  color: #ffffff;
+                  padding: 0.5em 1em;
+                  border: 0;
+                  cursor: pointer;
+                  font-weight: bold;
+                }
+                input[type="submit"]:hover {
+                  background-color: #339ca1;
+                }
+                input[type="submit"].reject-button {
+                  background-color: #8a003a;
+                }
+                input[type="submit"].reject-button:hover {
+                  background-color: #aa3968;
+                }
+                nav {
+                  display: block;
+                  position: fixed;
+                  top: 0;
+                  width: 100%;
+                  padding: 0;
+                  background-color: var(--fg-colour);
+                }
+                nav ul {
+                  list-style-type: none;
+                  margin: 0;
+                  padding: 0;
+                }
+                nav li {
+                  display: block;
+                  float: left;
+                  padding: 0;
+                  margin: 0;
+                }
+                nav li a {
+                  color: var(--bg-colour);
+                  text-decoration: none;
+                  display: inline-block;
+                  padding: 0.7em 1em;
+                }
+                nav li a:hover {
+                  background-color: #00838a;
+                  color: #ffffff;
+                }
+                .active-nav {
+                  font-weight: 500;
+                }
+                .left-nav {
+                  float: right;
+                }
+                main {
+                  margin: 0 auto;
+                  max-width: 50em;
+                  padding: 5em 1em 3em 1em;
+                  background-color: var(--bg-colour);
+                  min-height: 100%;
+                  box-sizing: border-box;
+                }
+                |]
+        withUrlRenderer [hamlet|
+            $doctype 5
+            <html>
+              <head>
+                <title>#{pageTitle p}
+                ^{pageHead p}
+              <body>
+                ^{pageBody p}
+            |]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation GetWebUIToken {
+  newToken(comment: "id.datat.fi webui") {
+    tokenData
+  }
+}
+|]
+
+instance YesodAuth DataIdClient where
+    type AuthId DataIdClient = Text
+    maybeAuthId = lookupSession credsKey
+    loginDest = const HomeR
+    logoutDest = const HomeR
+    authPlugins = const $
+        [ authExternalBasic $
+            fmap (fmap (tokenData . newToken) . rightToMaybe) .
+                flip (apiRequestAuth @GetWebUIToken []) () . Just
+        ]
+    authenticate = pure . Authenticated . credsIdent
+
+instance ApiRequest DataIdClient where
+    getApiUrl = ($ ApiR) <$> getUrlRender
+    authIdToAuthorization = flip const
+
+instance RenderMessage DataIdClient FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+instance PathPiece UserID where
+    toPathPiece (UserID id) = show id
+    fromPathPiece s = UserID <$> readMaybe (toString s)
+
+type Form a = Html -> MForm Handler (FormResult a, Widget)
diff --git a/PrintSchema.hs b/PrintSchema.hs
new file mode 100644
index 0000000..64a22ca
--- /dev/null
+++ b/PrintSchema.hs
@@ -0,0 +1,6 @@
+import Data.Morpheus.Types (render, App)
+import Server.API (coreApp)
+import qualified Data.ByteString.Lazy.Char8 as C8
+import Server (APIM)
+
+main = C8.putStrLn $ render (coreApp :: App () APIM)
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..ea4c3c7
--- /dev/null
+++ b/README.md
@@ -0,0 +1,26 @@
+# Reverse proxy configuration
+
+A CSP should be defined to block all scripts as the app doesn't need any client
+side scripting. Content-Type-Options prevent misidentifying files as
+stylesheets or scripts.
+
+```
+Content-Security-Policy: default-src 'self'; scrip-src 'none'; object-src 'none'
+X-Content-Type-Options: nosniff
+```
+
+The reverse proxy must also enforce https, which can be done by redirecting all
+http requests to https and setting the Strict-Transport-Security header.
+
+# DOS-attack mitigation
+
+The app doesn't do anything against DOS-attacks. You should as a bare minimum
+rate limit the app's endpoint.
+
+```
+$ iptables -A INPUT -p tcp -m tcp --syn -m hashlimit \
+  --hashlimit-upto 10/sec --hashlimit-burst 10 --hashlimit-mode srcip,dstport \
+  --hashlimit-name conn-srcip-dport-rate-limit -j ACCEPT
+```
+
+This, for example, would rate limit tcp connections.
diff --git a/Server.hs b/Server.hs
new file mode 100644
index 0000000..af6d15b
--- /dev/null
+++ b/Server.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Server where
+
+import Relude
+
+import "cryptonite" Crypto.Random (MonadRandom(..))
+import Control.Monad.Logger (runStderrLoggingT)
+import Data.Map (findWithDefault)
+import Data.Text (toLower, breakOn, stripPrefix)
+import Database.Persist (entityVal)
+import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
+import Network.Mail.Mime (renderSendMail, Address(..))
+import Network.Wai (Application)
+import Network.Wai.Handler.Warp (run)
+import Network.Wai.Middleware.Cors
+import Network.Wai.Middleware.Gzip
+import Server.API
+import Server.DB
+import Server.DB.Queries (getUserByEmail, getPermissions, getToken)
+import Server.Types
+import Server.Utils (checkPassword)
+import Web.Scotty.Trans hiding (readEither)
+import qualified Data.ByteString.Base64 as B64 (decode)
+
+main :: IO ()
+main = run 3100 =<< serverApp
+
+serverApp :: IO Application
+serverApp = scottyAppT runAPIM $ do
+    middleware $ gzip def
+    middleware $ cors $ const $ Just CorsResourcePolicy
+        { corsOrigins = Nothing -- all
+        , corsMethods = ["POST"]
+        , corsRequestHeaders = ["Authorization"]
+        , corsExposedHeaders = Nothing
+        , corsMaxAge = Just (60*60*24)
+        , corsVaryOrigin = False
+        , corsRequireOrigin = False
+        , corsIgnoreFailures = False
+        }
+    post "/api" $ do
+        maybeAuthorization <- fmap toText <$> header "Authorization"
+        let maybeBasic = parseBasic maybeAuthorization
+            maybeBearer = parseBearer maybeAuthorization
+            auth = case maybeBasic of
+                     Just _ -> authBasic maybeBasic
+                     Nothing -> authBearer maybeBearer
+        auth $ do
+            setHeader "Content-Type" "text/json"
+            body >>= lift . runApp coreApp >>= raw
+
+data BasicAuth = BasicAuth { emailAddress :: Email, password :: Text } deriving (Show)
+
+data BearerToken = BearerToken Text deriving (Show)
+
+parseBearer :: Maybe Text -> Maybe BearerToken
+parseBearer auth = do
+    [authType, authData] <- words <$> auth
+    guard $ toLower authType == "bearer"
+    pure $ BearerToken authData
+
+authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
+authBearer Nothing m = m
+authBearer (Just (BearerToken bearer)) m = do
+    token <- lift $ getToken bearer
+    let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal
+    flip local m $ \state -> state
+        { stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token
+        , statePermissions = permissions
+        }
+
+parseBasic :: Maybe Text -> Maybe BasicAuth
+parseBasic txt = do
+    [authType, authData] <- words <$> txt
+    guard $ toLower authType == "basic"
+    (email, password) <- rightToMaybe $
+        breakOn' ":" . decodeUtf8 <$> B64.decode (encodeUtf8 authData)
+    emailAddress <- toEmail email
+    pure $ BasicAuth {..}
+        where breakOn' x xs = let (fst, snd) = breakOn x xs
+                              in (fst, fromMaybe "" $ stripPrefix x snd)
+
+
+authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
+authBasic Nothing m = m
+authBasic (Just basic) m = do
+    user <- verifyBasic basic
+    permissions <- maybe (pure mempty)
+        (fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user
+    flip local m $ \state -> state
+        { stateCurrentUser = user
+        , statePermissions = permissions
+        }
+
+-- TODO Refact, no need to convert to id and rerequest permissions
+verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID)
+verifyBasic BasicAuth {..} = do
+    user <- lift $ getUserByEmail emailAddress
+    if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user
+       then pure $ entityToID <$> user
+       else pure Nothing
+
+newtype APIM a = APIM (ReaderT RequestState IO a)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)
+
+data RequestState = RequestState
+    { stateCurrentUser :: Maybe UserID
+    , statePermissions :: Map Scope Permission
+    }
+
+
+instance MonadTime APIM where
+    currentTime = liftIO currentTime
+
+instance MonadDB APIM where
+    runQuery = liftIO . runStderrLoggingT . withPostgresqlConn "postgres:///id.rekisteri" . runSqlConn
+
+instance MonadEmail APIM where
+    sendEmail = liftIO . renderSendMail
+    fromAddress = pure $ Address Nothing "id@datat.fi"
+
+instance MonadRequest APIM where
+    currentUser = asks stateCurrentUser
+
+instance MonadRandom APIM where
+    getRandomBytes = liftIO . getRandomBytes
+
+instance MonadPermissions APIM where
+    currentPermissions = show <$> asks statePermissions
+    defaultPermissions = pure $ show $ (fromList [(OwnProfile, ReadWrite)] :: Map Scope Permission)
+    toPermissions = pure . fmap show . readPermission
+    hasPermission scope permission = (>= permission) <$> findPermission scope
+        where findPermission :: Scope -> APIM Permission
+              findPermission scope@(Profile user) = selfPermissions scope user OwnProfile
+              findPermission scope@(Tokens user) = selfPermissions scope user OwnTokens
+              findPermission scope = findPermission' scope <$> asks statePermissions
+              findPermission' :: Scope -> Map Scope Permission -> Permission
+              findPermission' = findWithDefault None
+              selfPermissions :: Scope -> UserID -> Scope -> APIM Permission
+              selfPermissions scope user own = do
+                  isSelf <- (Just user ==) <$> currentUser
+                  let f = if isSelf then max <$> findPermission' own <*> findPermission' scope
+                                    else findPermission' scope
+
+                  f <$> asks statePermissions
+
+readPermission :: Text -> Maybe (Map Scope Permission)
+readPermission = rightToMaybe . readEither . toString 
+
+runAPIM :: APIM a -> IO a
+runAPIM (APIM m) = runReaderT m RequestState { stateCurrentUser = Nothing, statePermissions = fromList [] }
diff --git a/Server/API.hs b/Server/API.hs
new file mode 100644
index 0000000..3302d25
--- /dev/null
+++ b/Server/API.hs
@@ -0,0 +1,333 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Server.API (coreApp, runApp, resolver) where
+
+import Relude hiding (Undefined, void, when)
+
+import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
+import Control.Monad.Except (MonadError, throwError)
+import Data.Aeson (fromJSON, Result(..), toJSON)
+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, (=.))
+import Server.DB
+import Server.DB.Queries
+import Server.Email (sendVerificationEmail)
+import Server.Types
+import Server.Utils
+import qualified Data.ByteString.Base64 as B64 (encode)
+import qualified Data.Text as T (null, chunksOf, intercalate)
+
+-- General functions, maybe migrate to Utils or API.Utils
+
+targetUser :: (MonadError GQLError m, MonadRequest m) => Maybe UserID -> m UserID
+targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) pure
+
+fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a
+fromMaybeFail txt = maybe (throwError txt) pure 
+
+void :: Monad m => m a -> m Unit
+void m = m >> pure Unit
+
+when :: Monad m => Bool -> m a -> m Unit
+when b m = if b then void m else pure Unit
+
+dbUserToUser :: Monad m => Entity DBUser -> User m
+dbUserToUser user = let id = entityToID user
+                        DBUser {..} = entityVal user
+                        Success (MemberData {..}) = fromJSON dBUserMemberData
+                        -- Explodes if database doesn't contain needed data
+                    in User
+                        { id = pure id
+                        , email = pure dBUserEmail
+                        , pendingEmail = pure dBUserPendingEmail
+                        , name = pure name
+                        , nickname = pure $ fromMaybe (error "db contains empty name") $
+                            maybe (viaNonEmpty head $ words $ name) Just nickname
+                        , birthdate = pure birthdate
+                        , homeplace = pure homeplace
+                        , registered = pure dBUserRegistered
+                        , accepted = pure dBUserAccepted
+                        , seceded = pure dBUserSeceded
+                        , isMember = pure $ isJust dBUserAccepted && not (isJust dBUserSeceded)
+                        , permissions = pure dBUserPermissions
+                        , application = pure application
+                        }
+
+dbKeyToPGPKey :: (MonadDB m, MonadError GQLError m) => Entity DBKey -> PGPKey m
+dbKeyToPGPKey key = let id = entityToID key
+                        DBKey {..} = entityVal key
+                    in PGPKey
+                        { id = pure id
+                        , user = getByID (fromDBKey dBKeyUid :: UserID)
+                              >>= fmap dbUserToUser . fromMaybeFail ""
+                        , pgpKeyData = pure $ base64Encode dBKeyData
+                        , expires = pure dBKeyExpires
+                        , uploaded = pure dBKeyUploaded
+                        , comment = pure dBKeyComment
+                        }
+
+dbTokenToToken :: (MonadDB m, MonadError GQLError m) => Entity DBToken -> Token m
+dbTokenToToken token = let id = entityToID token
+                           DBToken {..} = entityVal token
+                       in Token
+                           { id = pure id
+                           , user = getByID (fromDBKey dBTokenUid :: UserID)
+                                 >>= fmap dbUserToUser . fromMaybeFail ""
+                           , name = pure dBTokenName
+                           , tokenData = pure dBTokenData
+                           , comment = pure dBTokenComment
+                           , issued = pure dBTokenIssued
+                           , expires = pure dBTokenExpires
+                           , permissions = pure dBTokenPermissions
+                           }
+
+newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
+    ApplicationData -> m UserID
+newUser (ApplicationData {..}) = do
+    time <- currentTime
+    verificationExpires <- verificationExpireTime
+    secret <- genVerificationSecret
+    passwordHash <- hashPassword password
+    permissions <- defaultPermissions
+    when (T.null name) $ throwError "Name must not be empty"
+    when (T.null password) $ throwError "Password must not be empty"
+    when (T.null homeplace) $ throwError "Homeplace must not be empty"
+    let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
+    user <- addUser $ DBUser
+        { dBUserEmail = Nothing
+        , dBUserPendingEmail = Just email
+        , dBUserRegistered = time
+        , dBUserToBeDeleted = Just $ verificationExpires
+        , dBUserPasswordCrypt = passwordHash
+        , dBUserPermissions = permissions
+        , dBUserAccepted = Nothing
+        , dBUserSeceded = Nothing
+        , dBUserRejected = Nothing
+        , dBUserMemberData = toJSON memberData
+        , dBUserEmailVerificationSecret = Just secret
+        }
+    sendVerificationSecret user
+    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) => UserID -> m Unit
+sendVerificationSecret user = void $ do
+    maybeDBUser <- fmap entityVal <$> getByID user
+    let email = dBUserPendingEmail =<< maybeDBUser
+        secret = dBUserEmailVerificationSecret =<< maybeDBUser
+        args = (,) <$> email <*> secret
+    maybe (pure ()) (uncurry sendVerificationEmail) args
+
+updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) =>
+    UserID -> UpdateData -> m UserID
+updateUser user (UpdateData {..}) = do
+    hash <- sequence $ hashPassword <$> password
+    -- assert stuff valid
+    verificationSecretUpdate <- maybe (pure Nothing)
+        (const $ Just . (DBUserEmailVerificationSecret =. ) . Just <$> genVerificationSecret) email
+    user <- updateUserData user
+        (catMaybes [(DBUserPendingEmail =. ) . Just <$> email, verificationSecretUpdate,
+            (DBUserPasswordCrypt =.) <$> hash])
+        (catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname, SetUserHomeplace <$> homeplace])
+    when (isJust email) $ sendVerificationSecret user
+    return user
+
+makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
+    NewTokenArgs -> UserID -> m TokenID
+makeNewToken (NewTokenArgs {..}) user = do
+    tokenData <- decodeUtf8 . B64.encode <$> getRandomBytes 128
+    time <- currentTime
+    permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
+    addToken $ DBToken
+        { dBTokenUid = toDBKey user
+        , dBTokenName = name
+        , dBTokenData = tokenData
+        , dBTokenComment = fromMaybe "" comment
+        , dBTokenIssued = time
+        , dBTokenExpires = Nothing
+        , dBTokenPermissions = permissions
+        }
+
+makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
+    KeyData -> UserID -> m KeyID
+makeNewKey (KeyData {..}) user = do
+    time <- currentTime
+    keyData' <- fromMaybeFail "" $ base64Decode keyData
+    addKey $ DBKey
+        { dBKeyUid = toDBKey user
+        , dBKeyData = keyData'
+        , dBKeyExpires = expires
+        , dBKeyUploaded = time
+        , dBKeyComment = fromMaybe "" comment
+        , dBKeyIsPrimaryEncryptionKey = True
+        }
+
+acceptApplication :: (MonadDB m, MonadTime m) => UserID -> m Unit
+acceptApplication user = void $ do
+    time <- currentTime
+    markAsAccepted user time
+
+rejectApplication :: (MonadDB m, MonadTime m) => UserID -> m Unit
+rejectApplication user = void $ do
+    time <- currentTime
+    markAsRejected user time
+
+resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
+resolveQuery = Query
+    { users = requirePermission Members ReadOnly >> map (dbUserToUser) <$> getAllUsers
+    , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
+        fmap dbUserToUser <$> getByID user
+    , tokens = \(Arg id) -> targetUser id >>= \user ->
+        requirePermission (Tokens user) ReadOnly >> map dbTokenToToken <$> getUserTokens user
+    , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> applicants
+    , keys = \(Arg id) -> targetUser id >>= \user ->
+        requirePermission (Profile user) ReadOnly >> map dbKeyToPGPKey <$> getKeys user
+    --, key = \(Arg id) -> resolve (pure id)
+    -- TODO is this actually useful
+    , primaryKey = \(Arg id) -> targetUser id >>= \user ->
+        requirePermission (Profile user) ReadOnly >> getPrimaryKey user >>= pure . fmap dbKeyToPGPKey
+    , permissions = currentPermissions
+    }
+
+resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
+    MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
+resolveMutation = Mutation
+    { apply = \x -> do
+        userID <- newUser x
+        maybeUser <- getByID userID
+        user <- fromMaybeFail "" maybeUser
+        pure $ dbUserToUser user
+    , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (x < 1) $ throwError "Invalid verification secret"
+    , resendVerificationEmail = \(Arg id) -> targetUser id >>= sendVerificationSecret
+    , update = \updateData (Arg id) -> targetUser id >>= \user ->
+        requirePermission (Profile user) ReadWrite >>
+            updateUser user updateData >> getByID user >>= fmap dbUserToUser . fromMaybeFail ""
+    , newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
+        requirePermission (Profile user) ReadWrite >> makeNewToken args user >>=
+            getByID >>= fmap dbTokenToToken . fromMaybeFail ""
+    , newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
+        requirePermission (Profile user) ReadWrite >> makeNewKey args user >>=
+            getByID >>= fmap dbKeyToPGPKey . fromMaybeFail ""
+    , accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id
+    , reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id
+    }
+
+-- ScopedTypeVariables requires explicit forall m.
+coreApp :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
+    MonadTime m, MonadDB m, MonadPermissions m) => App () m
+coreApp = deriveApp resolver
+
+resolver :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
+    MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined
+resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation }
+
+data User m = User
+    { id :: m UserID
+    , email :: m (Maybe Email)
+    , pendingEmail :: m (Maybe Email)
+    , name :: m Text
+    , nickname :: m Text
+    , birthdate :: m Date
+    , homeplace :: m Text
+    , registered :: m Time
+    , accepted :: m (Maybe Time)
+    , seceded :: m (Maybe Time)
+    , permissions :: m Text
+    , isMember :: m Bool
+    , application :: m Text
+    } deriving (Generic, GQLType)
+
+data PGPKey m = PGPKey
+    { id :: m KeyID
+    , user :: m (User m)
+    , pgpKeyData :: m Base64
+    , expires :: m (Maybe Time)
+    , uploaded :: m Time
+    , comment :: m Text
+    } deriving (Generic, GQLType)
+
+data Token m = Token
+    { id :: m TokenID
+    , user :: m (User m)
+    , name :: m (Maybe Text)
+    , tokenData :: m Text
+    , comment :: m Text
+    , issued :: m Time
+    , expires :: m (Maybe Time)
+    , permissions :: m Text
+    } deriving (Generic, GQLType)
+
+data ApplicationData = ApplicationData
+    { email :: Email
+    , password :: Text
+    , name :: Text
+    , nickname :: Maybe Text
+    , birthdate :: Date
+    , homeplace :: Text
+    , application :: Text
+    } deriving (Generic, GQLType, Eq, Show)
+
+data UpdateData = UpdateData
+    { email :: Maybe Email
+    , password :: Maybe Text
+    , name :: Maybe Text
+    , nickname :: Maybe Text
+    , homeplace :: Maybe Text
+    } deriving (Generic, GQLType, Eq, Show)
+
+data KeyData = KeyData { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
+    deriving (Generic, GQLType, Eq, Show)
+
+newtype Cursor = Cursor Text
+    deriving (Generic, GQLType, Eq, Show)
+
+data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
+    deriving (Generic, GQLType)
+
+data NewTokenArgs = NewTokenArgs
+    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
+    deriving (Generic, GQLType)
+
+data Query m = Query
+    { users :: m [User m]
+    , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
+    , applications :: m [User m]
+    , tokens :: Arg "user" (Maybe UserID) -> m [Token m]
+    , keys :: Arg "user" (Maybe UserID) -> m [PGPKey m]
+    , permissions :: m Text
+    --, key :: Arg "id" KeyID -> m (PGPKey m)
+    , primaryKey :: Arg "user" (Maybe UserID) -> m (Maybe (PGPKey m))
+    } deriving (Generic, GQLType)
+
+data Mutation m = Mutation
+    { apply :: ApplicationData -> m (User m)
+    , verifyEmail :: Arg "secret" Text -> m Unit
+    , resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
+    , update :: UpdateData -> Arg "user" (Maybe UserID) -> m (User m)
+    , newToken :: NewTokenArgs -> m (Token m)
+    , newKey :: KeyData -> m (PGPKey m)
+    , accept :: Arg "user" UserID -> m Unit
+    , reject :: Arg "user" UserID -> m Unit
+    } deriving (Generic, GQLType)
diff --git a/Server/DB.hs b/Server/DB.hs
new file mode 100644
index 0000000..2443bd5
--- /dev/null
+++ b/Server/DB.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Server.DB where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
+import Database.Persist (Entity, Key, entityKey, PersistEntity)
+import Database.Persist.Sql (fromSqlKey, toSqlKey)
+import Database.Persist.Postgresql.JSON (Value)
+import Server.Types
+
+mkPersist sqlSettings [persistUpperCase|
+DBUser sql=users
+  email (Maybe Email) sqltype=varchar(255)
+  pendingEmail (Maybe Email) sqltype=varchar(255)
+  emailVerificationSecret (Maybe Text)
+  registered Time
+  passwordCrypt PasswordHash
+  permissions Text
+  accepted (Maybe Time)
+  rejected (Maybe Time)
+  seceded (Maybe Time)
+  toBeDeleted (Maybe Time)
+  memberData Value sqltype=jsonb
+
+  UniqueEmail email
+  UniquePendingEmail pendingEmail
+  UniqueVerification emailVerificationSecret
+
+  deriving (Show)
+
+DBKey sql=keys
+  uid DBUserId
+  data ByteString
+  expires (Maybe Time)
+  uploaded Time
+  comment Text
+  isPrimaryEncryptionKey Bool
+
+DBToken sql=tokens
+  uid DBUserId
+  name (Maybe Text)
+  data Text
+  comment Text
+  issued Time
+  expires (Maybe Time)
+  permissions Text
+
+  UniqueNameUid name uid
+  UniqueData data
+|]
+
+entityToID :: FromDBKey a => Entity (DB a) -> a
+entityToID = fromDBKey . entityKey
+
+class PersistEntity (DB a) =>  FromDBKey a where
+    type DB a
+    fromDBKey :: Key (DB a) -> a
+
+instance FromDBKey UserID where
+    type DB UserID = DBUser
+    fromDBKey = UserID . fromSqlKey
+
+instance FromDBKey TokenID where
+    type DB TokenID = DBToken
+    fromDBKey = TokenID . fromSqlKey
+
+instance FromDBKey KeyID where
+    type DB KeyID = DBKey
+    fromDBKey = KeyID . fromSqlKey
+
+class FromDBKey a => ToDBKey a where
+    toDBKey :: a -> Key (DB a)
+
+instance ToDBKey UserID where
+    toDBKey (UserID x) = toSqlKey x
+
+instance ToDBKey KeyID where
+    toDBKey (KeyID x) = toSqlKey x
+
+instance ToDBKey TokenID where
+    toDBKey (TokenID x) = toSqlKey x
diff --git a/Server/DB/Queries.hs b/Server/DB/Queries.hs
new file mode 100644
index 0000000..289ad46
--- /dev/null
+++ b/Server/DB/Queries.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Server.DB.Queries where
+
+import Server.DB as DB
+import Server.Types
+import Data.Text (Text)
+import Database.Esqueleto.Experimental
+import qualified Database.Persist as Persist (update, (=.))
+import qualified Database.Persist.Types as Persist (Update)
+import Data.Maybe (listToMaybe, isJust)
+import Data.Aeson (fromJSON, toJSON, Result(..))
+import GHC.Int (Int64)
+
+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
+
+getUserByEmail :: MonadDB m => Email -> m (Maybe (Entity DBUser))
+getUserByEmail email = runQuery $ getBy (UniqueEmail $ Just email) >>=
+    maybe ((>>= guardUnconfirmed) <$> getBy (UniquePendingEmail $ Just email)) (pure . Just)
+        where guardUnconfirmed user
+                | isJust (dBUserEmail $ entityVal user) = Nothing
+                | otherwise = Just user
+
+addUser :: MonadDB m => DBUser -> m UserID
+addUser = fmap fromDBKey . runQuery . insert
+
+getKeys :: MonadDB m => UserID -> m [Entity DBKey]
+getKeys user = runQuery $ select $ do
+    keys <- from $ table @DBKey
+    where_ $ keys ^. DBKeyUid ==. val (toDBKey user)
+    pure $ keys
+
+getPermissions :: MonadDB m => UserID -> m (Maybe Text)
+getPermissions user = fmap (fmap dBUserPermissions) $ runQuery $ get (toDBKey user)
+
+setPermissions :: MonadDB m => UserID -> Text -> m ()
+setPermissions user txt = updateUserData user [DB.DBUserPermissions Persist.=. txt] [] >> return ()
+
+getPrimaryKey :: MonadDB m => UserID -> m (Maybe (Entity DBKey))
+getPrimaryKey user = fmap listToMaybe $ runQuery $ select $ do
+    keys <- from $ table @DBKey
+    where_ $ keys ^. DBKeyIsPrimaryEncryptionKey &&. keys ^. DBKeyUid ==. val (toDBKey user)
+    pure $ keys
+
+getUserTokens :: MonadDB m => UserID -> m [Entity DBToken]
+getUserTokens user = runQuery $ select $ do 
+    tokens <- from $ table @DBToken
+    where_ $ tokens ^. DBTokenUid ==. val (toDBKey user)
+    pure $ tokens
+
+addToken :: MonadDB m => DBToken -> m TokenID
+addToken = fmap fromDBKey . runQuery . insert
+
+getToken :: MonadDB m => Text -> m (Maybe (Entity DBToken))
+getToken = runQuery . getBy . UniqueData
+
+addKey :: MonadDB m => DBKey -> m KeyID
+addKey = fmap fromDBKey . runQuery . insert
+
+getAllUsers :: MonadDB m => m [Entity DBUser]
+getAllUsers = runQuery $ select $ do
+    users <- from $ table @DBUser
+    where_ $ isMember users
+    pure $ users
+
+applicants :: MonadDB m => m [Entity DBUser]
+applicants = runQuery $ select $ do
+    users <- from $ table @DBUser
+    where_ $ isApplicant users
+    pure $ users
+
+isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
+isApplicant user = isNothing (user ^. DBUserAccepted) &&. not_ (isNothing (user ^. DBUserEmail)) &&. isNothing (user ^. DBUserRejected)
+
+isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
+isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded)
+
+verifyEmailSecret :: MonadDB m => Text -> m Int64
+verifyEmailSecret secret = runQuery $ updateCount $ \user -> do
+    set user [ DBUserEmailVerificationSecret =. val Nothing
+             , DBUserEmail =. user ^. DBUserPendingEmail
+             , DBUserPendingEmail =. val Nothing
+             ]
+    where_ $ user ^. DBUserEmailVerificationSecret ==. just (val secret)
+
+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
+
+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
+updateUserData user updates memberDataUpdates = runQuery $ do
+    let key = toDBKey user
+    Just userData <- get key
+    let (Success memberData) = fromJSON $ dBUserMemberData userData :: Result MemberData
+        userUpdates = [DBUserMemberData Persist.=. (toJSON $ foldr updateData memberData memberDataUpdates)]
+        updateData (SetUserName x) memberData = memberData { name = x }
+        updateData (SetUserNickname x) memberData = memberData { nickname = x }
+        updateData (SetUserHomeplace x) memberData = memberData { homeplace = x }
+    Persist.update key (userUpdates <> updates)
+    pure user
+
+data UserUpdate = SetUserName Text
+                | SetUserNickname (Maybe Text)
+                | SetUserHomeplace Text
diff --git a/Server/Email.hs b/Server/Email.hs
new file mode 100644
index 0000000..25a43a6
--- /dev/null
+++ b/Server/Email.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Server.Email where
+
+import Server.Types
+import Data.Text (Text)
+import Data.Text.Lazy (fromStrict)
+import Network.Mail.Mime
+
+sendVerificationEmail :: MonadEmail m => Email -> Text -> m ()
+sendVerificationEmail to secret = do
+    from <- fromAddress
+    sendEmail $ simpleMail' (Address Nothing $ renderEmail to) from
+        "Sähköpostin vahvistuskoodi" $ fromStrict $
+        "Vahvista sähköpostisi syöttämällä alla oleva koodi rekisteriin:\n\n"
+        <> secret <> "\n\n"
+        <> "Mikäli et odottanut tätä viestiä, voit jättää sen turvallisesti huomiotta."
diff --git a/Server/Types.hs b/Server/Types.hs
new file mode 100644
index 0000000..ed55744
--- /dev/null
+++ b/Server/Types.hs
@@ -0,0 +1,245 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PackageImports #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Server.Types where
+
+import Relude
+
+import Control.Monad.Except (throwError)
+import Control.Monad.Logger (LoggingT)
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import Data.ByteArray (ByteArray, ByteArrayAccess)
+import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation)
+import Data.Morpheus.Server.Types (SCALAR)
+import Data.Morpheus.Types (GQLType, DecodeScalar(..), KIND, EncodeScalar(..),
+    ScalarValue(..), MonadError, GQLError)
+import Data.Morpheus.Types.GQLScalar (scalarToJSON, scalarFromJSON)
+import Data.Time (UTCTime, getCurrentTime, NominalDiffTime, addUTCTime, Day)
+import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
+import Database.Persist.Class (PersistField(..))
+import Database.Persist.PersistValue (PersistValue(..))
+import Database.Persist.Sql (PersistFieldSql(..), SqlBackend)
+import Network.Mail.Mime (Mail, Address(..))
+import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
+import qualified Data.ByteString.Base64 as B64 (encode, decode)
+import "cryptonite" Crypto.Random (MonadRandom(..))
+
+base64Encode :: ByteString -> Base64
+base64Encode = Base64 . decodeUtf8 . B64.encode
+
+base64Decode :: Base64 -> Maybe ByteString
+base64Decode (Base64 x) = either (const Nothing) Just $ B64.decode $ encodeUtf8 x
+
+toEmail :: Text -> Maybe Email
+toEmail = fmap Email . emailAddress . encodeUtf8
+
+renderEmail :: Email -> Text
+renderEmail (Email x) = decodeUtf8 $ toByteString x
+
+renderTime :: Time -> Text
+renderTime (Time x) = toText $ iso8601Show x
+
+toTime :: Text -> Maybe Time
+toTime = fmap Time . iso8601ParseM . toString
+
+toDate :: Text -> Maybe Date
+toDate = fmap Date . iso8601ParseM . toString
+
+renderDate :: Date -> Text
+renderDate (Date x) = toText $ iso8601Show x
+
+addTime :: NominalDiffTime -> Time -> Time
+addTime diff (Time time) = Time $ addUTCTime diff time
+
+forward :: Monad m => [a] -> m [Maybe a]
+forward = pure . map Just
+
+requirePermission :: (MonadPermissions m, MonadError GQLError m) => Scope -> Permission -> m ()
+requirePermission scope permission = unlessM (hasPermission scope permission) $
+    throwError $ "Insufficient permissions, " <> show permission <> " for "
+        <> show scope <> " required."
+
+data Scope = OwnProfile
+           | OwnTokens
+           | Profile UserID
+           | Tokens UserID
+           | Members
+           | Applications
+           deriving (Show, Eq, Ord, Read)
+
+data Permission = None
+                | ReadOnly
+                | ReadWrite
+                deriving (Show, Eq, Ord, Read)
+
+data MemberData = MemberData
+    { name :: Text
+    , nickname :: Maybe Text
+    , birthdate :: Date
+    , homeplace :: Text
+    , application :: Text
+    } deriving (Show, Eq, Generic)
+
+instance FromJSON MemberData
+instance ToJSON MemberData
+
+newtype UserID = UserID Int64 deriving (Eq, Show, Generic, Ord, Read)
+
+instance DecodeScalar UserID where
+    decodeScalar (String s) = first (const $ "invalid UserID: \"" <> s <> "\"") $
+        UserID <$> readEither (toString s)
+    decodeScalar _ = Left "Invalid type for UserID, should be string"
+
+instance EncodeScalar UserID where
+    encodeScalar (UserID x) = String $ show x
+
+instance GQLType UserID where type KIND UserID = SCALAR
+instance ToJSON UserID where toJSON = scalarToJSON
+instance FromJSON UserID where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype KeyID = KeyID Int64 deriving (Eq, Show, Generic)
+
+instance DecodeScalar KeyID where
+    decodeScalar (String s) = first (const $ "invalid KeyID: \"" <> s <> "\"") $
+        KeyID <$> readEither (toString s)
+    decodeScalar _ = Left "Invalid type for KeyID, should be string"
+
+instance EncodeScalar KeyID where
+    encodeScalar (KeyID s) = String $ show s
+
+instance GQLType KeyID where type KIND KeyID = SCALAR
+instance ToJSON KeyID where toJSON = scalarToJSON
+instance FromJSON KeyID where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype TokenID = TokenID Int64 deriving (Eq, Show, Generic)
+
+instance DecodeScalar TokenID where
+    decodeScalar (String s) = first (const $ "invalid TokenID: \"" <> s <> "\"") $
+        TokenID <$> readEither (toString s)
+    decodeScalar _ = Left "Invalid type for TokenID, should be string"
+
+instance EncodeScalar TokenID where
+    encodeScalar (TokenID s) = String $ show s
+
+instance GQLType TokenID where type KIND TokenID = SCALAR
+instance ToJSON TokenID where toJSON = scalarToJSON
+instance FromJSON TokenID where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype Base64 = Base64 Text
+    deriving (Eq, Show, ToJSON, FromJSON, Generic, DecodeScalar, EncodeScalar)
+
+instance GQLType Base64 where type KIND Base64 = SCALAR
+
+newtype Email = Email EmailAddress deriving (Eq, Show)
+
+instance DecodeScalar Email where
+    decodeScalar (String s) = maybe (Left $ "Couldn't parse \"" <> s <> "\" as an email address") (Right . Email) $ emailAddress $ encodeUtf8 s
+    decodeScalar _ = Left "Invalid type for Email, should be string"
+
+instance EncodeScalar Email where
+    encodeScalar = String . renderEmail
+
+instance GQLType Email where type KIND Email = SCALAR
+instance ToJSON Email where toJSON = scalarToJSON
+instance FromJSON Email where parseJSON = scalarFromJSON <=< parseJSON 
+
+instance PersistField Email where
+    toPersistValue = PersistText . renderEmail
+    fromPersistValue (PersistText email) =
+        second Email $ first toText $ validate $ encodeUtf8 email
+    fromPersistValue x = Left $ "Wrong type for Email: " <> show x
+
+newtype Time = Time UTCTime deriving (Eq, Show, PersistField, PersistFieldSql)
+
+instance DecodeScalar Time where
+    decodeScalar (String s) = maybe
+        (Left $ "Couldn't parse \"" <> s <> "\" as an ISO8601 timestamp")
+        (Right) $ toTime s
+    decodeScalar _ = Left "Invalid type for Time, should be string"
+
+instance EncodeScalar Time where
+    encodeScalar  = String . renderTime
+
+instance GQLType Time where type KIND Time = SCALAR
+instance ToJSON Time where toJSON = scalarToJSON
+instance FromJSON Time where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype Date = Date Day deriving (Eq, Show, PersistField, Generic)
+
+instance DecodeScalar Date where
+    decodeScalar (String s) = maybe
+        (Left $ "Couldn't parse \"" <> s <> "\" as an ISO8601 date")
+        (Right) $ toDate s
+    decodeScalar _ = Left "Invalid type for Date, should be string"
+
+instance EncodeScalar Date where
+    encodeScalar = String . renderDate
+
+instance GQLType Date where type KIND Date = SCALAR
+instance ToJSON Date where toJSON = scalarToJSON
+instance FromJSON Date where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype PasswordHash = PasswordHash ByteString
+    deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray,
+        PersistField, PersistFieldSql)
+
+class Monad m => MonadTime m where
+    currentTime :: m Time
+
+instance MonadTime IO where
+    currentTime = Time <$> getCurrentTime
+
+class Monad m => MonadDB m where
+    runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a
+    -- TODO refactor so that it is possible to define a IO-less db, for safety and testability.
+    --      Is there a way to do this that doesn't require moving all db calls to the class?
+    --      Probably not :(
+
+class Monad m => MonadEmail m where
+    sendEmail :: Mail -> m ()
+    fromAddress :: m Address
+
+class Monad m => MonadRequest m where
+    currentUser :: m (Maybe UserID)
+
+class Monad m => MonadPermissions m where
+    hasPermission :: Scope -> Permission -> m Bool
+    currentPermissions :: m Text
+    defaultPermissions :: m Text
+    toPermissions :: Text -> m (Maybe Text)
+
+instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
+    runQuery = lift . runQuery
+
+instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where
+    currentUser = lift currentUser
+
+instance (MonadPermissions m, LiftOperation o) => MonadPermissions (Resolver o () m) where
+    hasPermission scope permission = lift $ hasPermission scope permission
+    defaultPermissions = lift defaultPermissions
+    currentPermissions = lift currentPermissions
+    toPermissions = lift . toPermissions
+
+instance (MonadEmail m, LiftOperation o) => MonadEmail (Resolver o () m) where
+    sendEmail = lift . sendEmail
+    fromAddress = lift fromAddress
+
+instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where
+    getRandomBytes = lift . getRandomBytes
+
+instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
+    currentTime = lift currentTime
+
+data Unit = Unit | Unit2 deriving (Eq, Generic, Show)
+
+instance GQLType Unit
+instance ToJSON Unit
+instance FromJSON Unit
diff --git a/Server/Utils.hs b/Server/Utils.hs
new file mode 100644
index 0000000..d632d76
--- /dev/null
+++ b/Server/Utils.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE PackageImports #-}
+
+module Server.Utils where
+
+import Data.ByteArray.Encoding (convertToBase, Base(..))
+import Data.ByteString (ByteString)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text (Text)
+import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
+import "cryptonite" Crypto.Random (MonadRandom)
+import Server.Types
+
+base32 :: ByteString -> Text
+base32 = decodeUtf8 . convertToBase Base32
+
+hashPassword :: MonadRandom m => Text -> m PasswordHash
+hashPassword = Crypt.hashPassword 12 . encodeUtf8
+
+checkPassword :: Text -> PasswordHash -> Bool
+checkPassword password = Crypt.validatePassword $ encodeUtf8 password
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..00bfe1f
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/datarekisteri.cabal b/datarekisteri.cabal
new file mode 100644
index 0000000..425c522
--- /dev/null
+++ b/datarekisteri.cabal
@@ -0,0 +1,14 @@
+cabal-version: 2.4
+name: datarekisteri
+version: 0.0.1
+author: Saku Laesvuori
+license: AGPL-3.0-or-later
+license-file: COPYING.md
+build-type: Simple
+stability: alpha
+
+executable datarekisteri
+  build-depends: aeson, base, base64-bytestring, cryptonite, email-validate, esqueleto, memory, mime-mail, monad-logger, morpheus-graphql, morpheus-graphql-app, morpheus-graphql-client, morpheus-graphql-core, morpheus-graphql-server, mtl, persistent, persistent-postgresql, relude, scotty, smtp-mail, text, time, yesod, yesod-auth
+  main-is: Client.hs
+  hs-source-dirs: .
+  default-language: Haskell2010
diff --git a/db/migrations/20221208114323_init-db.sql b/db/migrations/20221208114323_init-db.sql
new file mode 100644
index 0000000..ee9fe22
--- /dev/null
+++ b/db/migrations/20221208114323_init-db.sql
@@ -0,0 +1,53 @@
+-- migrate:up
+
+create table "users" (
+    "id" serial primary key,
+    "email" varchar(255) unique,
+    "pendingEmail" varchar(255) unique,
+    "emailVerificationSecret" varchar(255) unique,
+    "registered" timestamp not null,
+    "passwordCrypt" bytea not null,
+    "permissions" text not null,
+    "accepted" timestamp,
+    "rejected" timestamp,
+    "seceded" timestamp,
+    "toBeDeleted" timestamp,
+    "memberData" jsonb not null
+);
+
+create index "users_memberData_index" on "users" using gin ("memberData");
+
+create table "keys" (
+    "id" serial primary key,
+    "uid" integer not null references "users" on delete cascade,
+    "data" bytea not null,
+    "expires" timestamp,
+    "uploaded" timestamp not null,
+    "comment" text not null,
+    "isPrimaryEncryptionKey" bool not null
+);
+
+create unique index "keys_isPrimaryEncryptionKey_constraint" on "keys" ("uid")
+where "isPrimaryEncryptionKey";
+
+create index "keys_uid_index" on "keys" ("uid");
+
+create table "tokens" (
+    "id" serial primary key,
+    "uid" integer not null references "users" on delete cascade,
+    "name" text,
+    "data" text unique not null,
+    "comment" text not null,
+    "issued" timestamp not null,
+    "expires" timestamp,
+    "permissions" text,
+    unique ("name", "uid")
+);
+
+create index "tokens_data_index" on "tokens" ("data");
+
+-- migrate:down
+
+drop table "tokens";
+drop table "keys";
+drop table "users";
diff --git a/db/schema.sql b/db/schema.sql
new file mode 100644
index 0000000..788c52e
--- /dev/null
+++ b/db/schema.sql
@@ -0,0 +1,283 @@
+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: 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,
+    email character varying(255),
+    "pendingEmail" character varying(255),
+    "emailVerificationSecret" character varying(255),
+    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: 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: 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_emailVerificationSecret_key; Type: CONSTRAINT; Schema: public; Owner: -
+--
+
+ALTER TABLE ONLY public.users
+    ADD CONSTRAINT "users_emailVerificationSecret_key" UNIQUE ("emailVerificationSecret");
+
+
+--
+-- Name: users users_email_key; Type: CONSTRAINT; Schema: public; Owner: -
+--
+
+ALTER TABLE ONLY public.users
+    ADD CONSTRAINT users_email_key UNIQUE (email);
+
+
+--
+-- Name: users users_pendingEmail_key; Type: CONSTRAINT; Schema: public; Owner: -
+--
+
+ALTER TABLE ONLY public.users
+    ADD CONSTRAINT "users_pendingEmail_key" UNIQUE ("pendingEmail");
+
+
+--
+-- Name: users users_pkey; Type: CONSTRAINT; Schema: public; Owner: -
+--
+
+ALTER TABLE ONLY public.users
+    ADD CONSTRAINT users_pkey PRIMARY KEY (id);
+
+
+--
+-- 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: 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');
diff --git a/guix.scm b/guix.scm
new file mode 100644
index 0000000..533e71e
--- /dev/null
+++ b/guix.scm
@@ -0,0 +1,728 @@
+; also load guix.scm for id-rekisteri
+(use-modules ((guix licenses) #:prefix license:)
+             (guix packages)
+             (guix)
+             (guix download)
+             (guix build-system haskell)
+             (gnu packages haskell)
+             (gnu packages haskell-xyz)
+             (gnu packages haskell-crypto)
+             (gnu packages haskell-check)
+             (gnu packages haskell-web))
+
+(define-public datarekisteri
+  (package
+    (name "datarekisteri")
+    (version "0.0.1")
+    (source (origin
+              (method url-fetch)
+              (uri "file:///home/saku/koodi/rekisteri/datarekisteri")
+              (sha256
+                (base32
+                  "1lpggpdzgjk23mq7aa64yylds5dbm4ynhcvbarqihjxabvh7xmz1"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-base64-bytestring
+                  ghc-cryptonite
+                  ghc-email-validate
+                  ghc-esqueleto
+                  ghc-mime-mail
+                  ghc-morpheus-graphql
+                  ghc-morpheus-graphql-client
+                  ghc-persistent
+                  ghc-persistent-postgresql
+                  ghc-scotty
+                  ghc-smtp-mail
+                  ghc-wai-cors
+                  ghc-wai-extra
+                  ghc-yesod
+                  ghc-yesod-static
+                  ghc-yesod-auth))
+    (home-page "")
+    (synopsis "")
+    (description "")
+    (license license:agpl3+)))
+
+(define-public ghc-authenticate
+  (package
+    (name "ghc-authenticate")
+    (version "1.3.5.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "authenticate" version))
+              (sha256
+               (base32
+                "1rhbvdgwdr68gp13p5piddfdqf3l9lmx4w7k249lc98y23780c3x"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-http-conduit
+                  ghc-case-insensitive
+                  ghc-http-types
+                  ghc-xml-conduit
+                  ghc-blaze-builder
+                  ghc-attoparsec
+                  ghc-unordered-containers
+                  ghc-conduit
+                  ghc-html-conduit
+                  ghc-resourcet
+                  ghc-network-uri))
+    (home-page "http://github.com/yesodweb/authenticate")
+    (synopsis "Authentication methods for Haskell web applications.")
+    (description "API docs and the README are available at
+<http://www.stackage.org/package/authenticate>.")
+    (license license:expat)))
+
+(define-public ghc-yesod-auth
+  (package
+    (name "ghc-yesod-auth")
+    (version "1.6.11")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "yesod-auth" version))
+              (sha256
+               (base32
+                "0fdahk5mc63g0zsafk8axry01qaxahmclpmmwygp2lhfsjy8mby2"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-authenticate
+                  ghc-base16-bytestring
+                  ghc-base64-bytestring
+                  ghc-blaze-builder
+                  ghc-blaze-html
+                  ghc-blaze-markup
+                  ghc-conduit
+                  ghc-conduit-extra
+                  ghc-cryptonite
+                  ghc-data-default
+                  ghc-email-validate
+                  ghc-file-embed
+                  ghc-http-client
+                  ghc-http-client-tls
+                  ghc-http-conduit
+                  ghc-http-types
+                  ghc-memory
+                  ghc-nonce
+                  ghc-persistent
+                  ghc-random
+                  ghc-safe
+                  ghc-shakespeare
+                  ghc-unliftio
+                  ghc-unliftio-core
+                  ghc-unordered-containers
+                  ghc-wai
+                  ghc-yesod-core
+                  ghc-yesod-form
+                  ghc-yesod-persistent
+                  ghc-network-uri))
+    (home-page "http://www.yesodweb.com/")
+    (synopsis "Authentication for Yesod.")
+    (description "API docs and the README are available at
+<http://www.stackage.org/package/yesod-auth>")
+    (license license:expat)))
+
+(define-public ghc-scotty
+  (package
+    (name "ghc-scotty")
+    (version "0.12")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "scotty" version))
+              (sha256
+               (base32
+                "1lpggpdzgjk23mq7aa64yylds5dbm4ynhcvbarqihjxabvh7xmz1"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-base-compat-batteries
+                  ghc-blaze-builder
+                  ghc-case-insensitive
+                  ghc-data-default-class
+                  ghc-fail
+                  ghc-http-types
+                  ghc-monad-control
+                  ghc-nats
+                  ghc-network
+                  ghc-regex-compat
+                  ghc-transformers-base
+                  ghc-transformers-compat
+                  ghc-wai
+                  ghc-wai-extra
+                  ghc-warp))
+    (native-inputs (list ghc-async ghc-hspec ghc-hspec-wai ghc-lifted-base hspec-discover))
+    (arguments
+     `(#:cabal-revision ("7"
+                         "1i8icc612w4dbmqmnf99drqpmjvhjnkmqgk9xr63amj8jkz5lp4m")))
+    (home-page "https://github.com/scotty-web/scotty")
+    (synopsis
+     "Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp")
+    (description
+     "This package provides a Haskell web framework inspired by Ruby's Sinatra, using
+WAI and Warp. . @ &#123;-&#35; LANGUAGE OverloadedStrings &#35;-&#125; .  import
+Web.Scotty .  import Data.Monoid (mconcat) .  main = scotty 3000 $ &#32;&#32;get
+&#34;/:word&#34; $ do &#32;&#32;&#32;&#32;beam <- param &#34;word&#34;
+&#32;&#32;&#32;&#32;html $ mconcat [&#34;&#60;h1&#62;Scotty, &#34;, beam, &#34;
+me up!&#60;/h1&#62;&#34;] @ . .  Scotty is the cheap and cheerful way to write
+RESTful, declarative web applications. . * A page is as simple as defining the
+verb, url pattern, and Text content. . * It is template-language agnostic.
+Anything that returns a Text value will do. . * Conforms to WAI Application
+interface. . * Uses very fast Warp webserver by default. .  As for the name:
+Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
+[Warp] <http://hackage.haskell.org/package/warp>")
+    (license license:bsd-3)))
+
+(define-public ghc-hspec-wai
+  (package
+    (name "ghc-hspec-wai")
+    (version "0.11.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "hspec-wai" version))
+              (sha256
+               (base32
+                "03wiksic5y9a2g6a86nsxrnajdgdvpv17w02h5qla0zp9zs6pa1j"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-quickcheck
+                  ghc-base-compat
+                  ghc-case-insensitive
+                  ghc-hspec-core
+                  ghc-hspec-expectations
+                  ghc-http-types
+                  ghc-wai
+                  ghc-wai-extra))
+    (native-inputs (list ghc-hspec hspec-discover))
+    (home-page "https://github.com/hspec/hspec-wai#readme")
+    (synopsis "Experimental Hspec support for testing WAI applications")
+    (description "Experimental Hspec support for testing WAI applications")
+    (license license:expat)))
+
+(define-public ghc-morpheus-graphql
+  (package
+    (name "ghc-morpheus-graphql")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql" version))
+              (sha256
+               (base32
+                "1d2wk0zw3qb22skv7g4xagl04las5xnh9f4223c4as9cf39pcrp9"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-morpheus-graphql-app
+                  ghc-morpheus-graphql-code-gen
+                  ghc-morpheus-graphql-core
+                  ghc-morpheus-graphql-server
+                  ghc-relude
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-morpheus-graphql-subscriptions
+                         ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+(define-public ghc-morpheus-graphql-code-gen
+  (package
+    (name "ghc-morpheus-graphql-code-gen")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-code-gen" version))
+              (sha256
+               (base32
+                "0aw9fl0hzl657w2arybyk0zqxvbdz897kiqwsv52r50dnb5x2izf"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-file-embed
+                  ghc-morpheus-graphql-code-gen-utils
+                  ghc-morpheus-graphql-core
+                  ghc-morpheus-graphql-server
+                  ghc-prettyprinter
+                  ghc-relude
+                  ghc-unordered-containers
+                  ghc-glob
+                  ghc-morpheus-graphql-client
+                  ghc-optparse-applicative
+                  ghc-yaml))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL CLI")
+    (description "code generator for Morpheus GraphQL")
+    (license license:bsd-3)))
+
+
+(define-public ghc-morpheus-graphql-core
+  (package
+    (name "ghc-morpheus-graphql-core")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-core" version))
+              (sha256
+               (base32
+                "0001pq7zj5rpjcg0jasd3vklisan2i8nxyk8d7xa31d4f1grn5ff"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-hashable
+                  ghc-megaparsec
+                  ghc-relude
+                  ghc-scientific
+                  ghc-th-lift-instances
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Core")
+    (description "Build GraphQL APIs with your favorite functional language!")
+    (license license:expat)))
+
+
+(define-public ghc-morpheus-graphql-app
+  (package
+    (name "ghc-morpheus-graphql-app")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-app" version))
+              (sha256
+               (base32
+                "0mg12a8s2zcxcbm1zm5a4gn6vz8d9d1qdhk930zddxqbll5gq7nq"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-hashable
+                  ghc-megaparsec
+                  ghc-morpheus-graphql-core
+                  ghc-relude
+                  ghc-scientific
+                  ghc-th-lift-instances
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL App")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+
+(define-public ghc-morpheus-graphql-subscriptions
+  (package
+    (name "ghc-morpheus-graphql-subscriptions")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-subscriptions" version))
+              (sha256
+               (base32
+                "138fcganlaj4fyq1aygiyy6f4hhw58n26ldrdkxhd66hr1mqv6j9"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-morpheus-graphql-app
+                  ghc-morpheus-graphql-core
+                  ghc-relude
+                  ghc-unliftio-core
+                  ghc-unordered-containers
+                  ghc-uuid
+                  ghc-websockets))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Subscriptions")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+
+(define-public ghc-morpheus-graphql-client
+  (package
+    (name "ghc-morpheus-graphql-client")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-client" version))
+              (sha256
+               (base32
+                "120414v0rcvzgm9dc2fx8598d88dqnpvhkc8zh3y2gl3b1bl31jb"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-file-embed
+                  ghc-modern-uri
+                  ghc-morpheus-graphql-code-gen-utils
+                  ghc-morpheus-graphql-core
+                  ghc-morpheus-graphql-subscriptions
+                  ghc-prettyprinter
+                  ghc-relude
+                  ghc-req
+                  ghc-unliftio-core
+                  ghc-unordered-containers
+                  ghc-websockets
+                  ghc-wuss))
+    (native-inputs (list ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Client")
+    (description "Build GraphQL APIs with your favorite functional language!")
+    (license license:expat)))
+
+
+(define-public ghc-morpheus-graphql-tests
+  (package
+    (name "ghc-morpheus-graphql-tests")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-tests" version))
+              (sha256
+               (base32
+                "1h6nri73s5ibzidhwrkxffldardx6khq9kvhmqklm06cilwr56xi"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson ghc-relude ghc-tasty ghc-tasty-hunit
+                  ghc-unordered-containers))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Test")
+    (description "")
+    (license license:expat)))
+
+
+(define-public ghc-morpheus-graphql-server
+  (package
+    (name "ghc-morpheus-graphql-server")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-server" version))
+              (sha256
+               (base32
+                "0cd6qczbb5cm12xv181pzq6d62nv7nf4w1yd3gmhzjfrks62lhwy"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-morpheus-graphql-app
+                  ghc-morpheus-graphql-core
+                  ghc-relude
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-file-embed ghc-morpheus-graphql-subscriptions
+                         ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+(define-public ghc-relude
+  (package
+    (name "ghc-relude")
+    (version "1.1.0.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "relude" version))
+              (sha256
+               (base32
+                "02dn99v2qmykj0l1qmn15k36hyxccy71b7iqavfk24zgjf5g07dm"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-hashable ghc-unordered-containers))
+    (native-inputs (list ghc-hedgehog ghc-doctest-20 ghc-glob))
+    (home-page "https://github.com/kowainik/relude")
+    (synopsis
+     "Safe, performant, user-friendly and lightweight Haskell Standard Library")
+    (description
+     "@__relude__@ is an alternative prelude library.  If you find the default
+@Prelude@ unsatisfying, despite its advantages, consider using @relude@ instead.
+== Relude goals and design principles * __Productivity.__ You can be more
+productive with a \"non-standard\" standard library, and @relude@ helps you with
+writing safer and more efficient code faster. * __Total programming__.  Usage of
+[/partial
+functions/](https://www.reddit.com/r/haskell/comments/5n51u3/why_are_partial_functions_as_in_head_tail_bad/)
+can lead to unexpected bugs and runtime exceptions in pure code.  The types of
+partial functions lie about their behaviour.  And even if it is not always
+possible to rely only on total functions, @relude@ strives to encourage
+best-practices and reduce the chances of introducing a bug.
++---------------------------------+--------------------------------------------+
+| __Partial__                     | __Total__                                  |
++=================================+============================================+
+| @head :: [a] -> a@              | @head :: NonEmpty a -> a@                  |
++---------------------------------+--------------------------------------------+
+| @tail :: [a] -> [a]@            | @tail :: NonEmpty a -> [a]@                |
++---------------------------------+--------------------------------------------+
+| @read :: Read a => String -> a@ | @readMaybe :: Read a => String -> Maybe a@ |
++---------------------------------+--------------------------------------------+
+| @fromJust :: Maybe a -> a@      | @fromMaybe :: a -> Maybe a -> a@           |
++---------------------------------+--------------------------------------------+
+* __Type-safety__.  We use the /\"make invalid states unrepresentable\"/ motto as
+one of our guiding principles.  If it is possible, we express this concept
+through the types. /Example:/ @ whenNotNull :: Applicative f => [a] -> (NonEmpty
+a -> f ()) -> f () @ * __Performance.__ We prefer @Text@ over
+@[String](https://www.reddit.com/r/haskell/comments/29jw0s/whats_wrong_with_string/)@,
+use space-leaks-free functions (e.g.  our custom performant @sum@ and
+@product@), introduce @\\{\\-\\# INLINE \\#\\-\\}@ and @\\{\\-\\# SPECIALIZE \\#\\-\\}@
+pragmas where appropriate, and make efficient container types (e.g. @Map@,
+@HashMap@, @Set@) more accessible. * __Minimalism__ (low number of
+dependencies).  We do not force users of @relude@ to stick to any specific lens
+or text formatting or logging library.  Where possible, @relude@ depends only on
+boot libraries.  The [Dependency
+graph](https://raw.githubusercontent.com/kowainik/relude/main/relude-dependency-graph.png)
+of @relude@ can give you a clearer picture. * __Convenience__.  Despite
+minimalism, we want to bring commonly used types and functions into scope, and
+make available functions easier to use.  Some examples of conveniences: 1.  No
+need to add @containers@, @unordered-containers@, @text@ and @bytestring@ to
+dependencies in your @.cabal@ file to use the main API of these libraries 2.  No
+need to import types like @NonEmpty@, @Text@, @Set@, @Reader[T]@, @MVar@, @STM@
+3.  Functions like @liftIO@, @fromMaybe@, @sortWith@ are available by default as
+well 4. @IO@ actions are lifted to @MonadIO@ * __Excellent documentation.__ 1.
+Tutorial 2.  Migration guide from @Prelude@ 3.  Haddock for every function with
+examples tested by [doctest](http://hackage.haskell.org/package/doctest).  4.
+Documentation regarding [internal module
+structure](http://hackage.haskell.org/package/relude/docs/Relude.html) 5.
+@relude@-specific [HLint](http://hackage.haskell.org/package/hlint) rules:
+@[.hlint.yaml](https://github.com/kowainik/relude/blob/main/.hlint.yaml)@ *
+__User-friendliness.__ Anyone should be able to quickly migrate to @relude@.
+Only some basic familiarity with the common libraries like @text@ and
+@containers@ should be enough (but not necessary). * __Exploration.__ We have
+space to experiment with new ideas and proposals without introducing breaking
+changes. @relude@ uses the approach with @Extra.*@ modules which are not
+exported by default.  The chosen approach makes it quite easy for us to provide
+new functionality without breaking anything and let the users decide to use it
+or not.")
+    (license license:expat)))
+
+(define-public ghc-doctest-20
+  (package
+    (name "ghc-doctest-20")
+    (version "0.20.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "doctest" version))
+              (sha256
+               (base32
+                "0sk50b8zxq4hvc8qphlmfha1lsv3xha7q7ka081jgswf1qpg34y4"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-base-compat ghc-code-page ghc-paths ghc-syb))
+    (native-inputs (list ghc-hunit
+                         ghc-quickcheck
+                         ghc-hspec
+                         hspec-discover
+                         ghc-hspec-core
+                         ghc-mockery
+                         ghc-setenv
+                         ghc-silently
+                         ghc-stringbuilder))
+    (arguments
+     `(#:cabal-revision ("5"
+                         "0d7xgi71zdfbg3an6v2ss4lj6lvlmvq36hy788nd94ja2bgfsmpx")))
+    (home-page "https://github.com/sol/doctest#readme")
+    (synopsis "Test interactive Haskell examples")
+    (description
+     "`doctest` is a tool that checks
+  [examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744)
+  and
+  [properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856)
+  in Haddock comments.  It is similar in spirit to the [popular Python module with
+  the same name](https://docs.python.org/3/library/doctest.html). .  Documentation
+  is at <https://github.com/sol/doctest#readme>.")
+    (license license:expat)))
+
+(define-public ghc-morpheus-graphql-code-gen-utils
+  (package
+    (name "ghc-morpheus-graphql-code-gen-utils")
+    (version "0.27.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-code-gen-utils" version))
+              (sha256
+               (base32
+                "1d5v3b63v9yf47a5hh2am6v09hwm4sfxls38iwvlxva3km0s1qgn"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-morpheus-graphql-core ghc-prettyprinter ghc-relude
+                  ghc-unordered-containers))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL CLI")
+    (description "code generator for Morpheus GraphQL")
+    (license license:bsd-3)))
+
+(define-public ghc-wuss
+  (package
+    (name "ghc-wuss")
+    (version "2.0.0.2")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "wuss" version))
+              (sha256
+               (base32
+                "04jqq3blzyxqyymhcjsm5z89whk5y7cvnd9dw6nlc40vq4w4v802"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-connection ghc-network ghc-websockets))
+    (home-page "http://hackage.haskell.org/package/wuss")
+    (synopsis "Secure WebSocket (WSS) clients")
+    (description
+     "Wuss is a library that lets you easily create secure WebSocket clients over the
+WSS protocol.  It is a small addition to
+<https://hackage.haskell.org/package/websockets the websockets package> and is
+adapted from existing solutions by <https://gist.github.com/jaspervdj/7198388
+@@jaspervdj>, <https://gist.github.com/mpickering/f1b7ba3190a4bb5884f3
+@@mpickering>, and <https://gist.github.com/elfenlaid/7b5c28065e67e4cf0767
+@@elfenlaid>.")
+    (license license:expat)))
+
+(define-public ghc-rsa
+  (package
+    (name "ghc-rsa")
+    (version "2.4.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "RSA" version))
+              (sha256
+               (base32
+                "0hchsqrxpfw7mqrqwscfy8ig1w2di6w3nxpzi873w0gibv2diibj"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-crypto-api ghc-crypto-pubkey-types ghc-sha))
+    (native-inputs (list ghc-quickcheck ghc-tagged ghc-test-framework
+                         ghc-test-framework-quickcheck2))
+    (home-page "http://hackage.haskell.org/package/RSA")
+    (synopsis
+     "Implementation of RSA, using the padding schemes of PKCS#1 v2.1.")
+    (description
+     "This library implements the RSA encryption and signature algorithms for
+arbitrarily-sized ByteStrings.  While the implementations work, they are not
+necessarily the fastest ones on the planet.  Particularly key generation.  The
+algorithms included are based of RFC 3447, or the Public-Key Cryptography
+Standard for RSA, version 2.1 (a.k.a, PKCS#1 v2.1).")
+    (license license:bsd-3)))
+
+(define-public ghc-crypto-pubkey-types
+  (package
+    (name "ghc-crypto-pubkey-types")
+    (version "0.4.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "crypto-pubkey-types" version))
+              (sha256
+               (base32
+                "0q0wlzjmpx536h1zcdzrpxjkvqw8abj8z0ci38138kpch4igbnby"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-asn1-types ghc-asn1-encoding))
+    (home-page "http://github.com/vincenthz/hs-crypto-pubkey-types")
+    (synopsis "Generic cryptography Public keys algorithm types")
+    (description "Generic cryptography public keys algorithm types")
+    (license license:bsd-3)))
+
+(define-public ghc-authenticate-oauth
+  (package
+    (name "ghc-authenticate-oauth")
+    (version "1.7")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "authenticate-oauth" version))
+              (sha256
+               (base32
+                "0y4v46rn0cvm0sr1v8qq1zgzllrlrr3ji5gij1xprgf1zsazcvvl"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-http-client
+                  ghc-crypto-pubkey-types
+                  ghc-rsa
+                  ghc-data-default
+                  ghc-sha
+                  ghc-random
+                  ghc-http-types
+                  ghc-blaze-builder
+                  ghc-transformers-compat))
+    (home-page "http://github.com/yesodweb/authenticate")
+    (synopsis
+     "Library to authenticate with OAuth for Haskell web applications.")
+    (description "API docs and the README are available at
+<http://www.stackage.org/package/authenticate-oauth>.")
+    (license license:bsd-3)))
+
+(define-public ghc-req
+  (package
+    (name "ghc-req")
+    (version "3.12.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "req" version))
+              (sha256
+               (base32
+                "1gwdqmqmj3acim5r8c4sjzcvr3hvlbcjwkrpcsvq95ckr1wmzpqp"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-authenticate-oauth
+                  ghc-blaze-builder
+                  ghc-case-insensitive
+                  ghc-connection
+                  ghc-http-api-data
+                  ghc-http-client
+                  ghc-http-client-tls
+                  ghc-http-types
+                  ghc-modern-uri
+                  ghc-monad-control
+                  ghc-retry
+                  ghc-transformers-base
+                  ghc-unliftio-core))
+    (native-inputs (list ghc-quickcheck ghc-hspec hspec-discover ghc-hspec-core
+                         ghc-quickcheck ghc-hspec))
+    (arguments '(#:tests? #f))
+    (home-page "https://github.com/mrkkrp/req")
+    (synopsis "HTTP client library")
+    (description "HTTP client library.")
+    (license license:bsd-3)))
+
+(define-public ghc-modern-uri
+  (package
+    (name "ghc-modern-uri")
+    (version "0.3.4.4")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "modern-uri" version))
+              (sha256
+               (base32
+                "19fffy7kb7ibajagdryjy872x56045zi6c1div8wvr8aisd55qsz"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-quickcheck
+                  ghc-contravariant
+                  ghc-hashable
+                  ghc-megaparsec
+                  ghc-profunctors
+                  ghc-reflection
+                  ghc-tagged))
+    (native-inputs (list ghc-hspec hspec-discover ghc-hspec-megaparsec))
+    (home-page "https://github.com/mrkkrp/modern-uri")
+    (synopsis "Modern library for working with URIs")
+    (description "Modern library for working with URIs.")
+    (license license:bsd-3)))
+
+(define-public ghc-mime-mail
+  (package
+    (name "ghc-mime-mail")
+    (version "0.5.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "mime-mail" version))
+              (sha256
+               (base32
+                "1s1wp8v1xlvw3r4qk1lv9zpm99ihka7a785zjl6i3fq1maqq955g"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-base64-bytestring ghc-random ghc-blaze-builder))
+    (native-inputs (list ghc-hspec hspec-discover))
+    (home-page "http://github.com/snoyberg/mime-mail")
+    (synopsis "Compose MIME email messages.")
+    (description
+     "Hackage documentation generation is not reliable.  For up to date documentation,
+please see: <http://www.stackage.org/package/mime-mail>.")
+    (license license:expat)))
+
+(define-public ghc-smtp-mail
+  (package
+    (name "ghc-smtp-mail")
+    (version "0.3.0.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "smtp-mail" version))
+              (sha256
+               (base32
+                "0q81m4mi43cd0f1azm6984xw3qw2s6ygszdn86j5z3g5sjj5dax4"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-base16-bytestring
+                  ghc-base64-bytestring
+                  ghc-connection
+                  ghc-mime-mail
+                  ghc-network
+                  ghc-network-bsd
+                  ghc-cryptonite
+                  ghc-memory))
+    (home-page "http://github.com/jhickner/smtp-mail")
+    (synopsis "Simple email sending via SMTP")
+    (description
+     "This packages provides a simple interface for mail over SMTP.  PLease see the
+README for more information.")
+    (license license:bsd-3)))
+
+datarekisteri
diff --git a/schema.gql b/schema.gql
new file mode 100644
index 0000000..860a62c
--- /dev/null
+++ b/schema.gql
@@ -0,0 +1,76 @@
+scalar Base64
+
+scalar Date
+
+scalar Email
+
+scalar KeyID
+
+scalar Time
+
+scalar TokenID
+
+scalar UserID
+
+enum Unit {
+  Unit
+  Unit2
+}
+
+type PGPKey {
+  id: KeyID!
+  user: User!
+  pgpKeyData: Base64!
+  expires: Time
+  uploaded: Time!
+  comment: String!
+}
+
+type Token {
+  id: TokenID!
+  user: User!
+  name: String
+  tokenData: String!
+  comment: String!
+  issued: Time!
+  expires: Time
+  permissions: String!
+}
+
+type User {
+  id: UserID!
+  email: Email
+  pendingEmail: Email
+  name: String!
+  nickname: String!
+  birthdate: Date!
+  homeplace: String!
+  registered: Time!
+  accepted: Time
+  seceded: Time
+  permissions: String!
+  isMember: Boolean!
+  application: String!
+}
+
+type Query {
+  users: [User!]!
+  user(id: UserID): User
+  applications: [User!]!
+  tokens(user: UserID): [Token!]!
+  keys(user: UserID): [PGPKey!]!
+  permissions: String!
+  primaryKey(user: UserID): PGPKey
+}
+
+type Mutation {
+  apply(email: Email!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
+  verifyEmail(secret: String!): Unit!
+  resendVerificationEmail(user: UserID): Unit!
+  update(email: Email, password: String, name: String, nickname: String, homeplace: String, user: UserID): User!
+  newToken(comment: String, name: String, permissions: String): Token!
+  newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
+  accept(user: UserID!): Unit!
+  reject(user: UserID!): Unit!
+}
+