ry
/
datarekisteri
6
0
Fork 0
Code Issues 10 Pull Requests Packages Projects Releases Wiki Activity

Initial commit

This commit is contained in:
Saku Laesvuori 2023-01-20 09:20:06 +02:00
commit cbf619c370
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
25 changed files with 3123 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
Client.hs Normal file
View File

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

56
Client/ApiRequests.hs Normal file
View File

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

65
Client/Auth.hs Normal file
View File

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

46
Client/FormFields.hs Normal file
View File

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

34
Client/Handlers.hs Normal file
View File

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

117
Client/Handlers/Applications.hs Normal file
View File

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

89
Client/Handlers/Apply.hs Normal file
View File

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

134
Client/Handlers/Profile.hs Normal file
View File

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

50
Client/Handlers/VerifyEmail.hs Normal file
View File

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

330
Client/Types.hs Normal file
View File

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

6
PrintSchema.hs Normal file
View File

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

26
README.md Normal file
View File

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

157
Server.hs Normal file
View File

@ -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 [] }

333
Server/API.hs Normal file
View File

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

95
Server/DB.hs Normal file
View File

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

115
Server/DB/Queries.hs Normal file
View File

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

17
Server/Email.hs Normal file
View File

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

245
Server/Types.hs Normal file
View File

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

20
Server/Utils.hs Normal file
View File

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

4
Setup.hs Normal file
View File

@ -0,0 +1,4 @@
import Distribution.Simple
main :: IO ()
main = defaultMain

14
datarekisteri.cabal Normal file
View File

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

53
db/migrations/20221208114323_init-db.sql Normal file
View File

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

283
db/schema.sql Normal file
View File

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

728
guix.scm Normal file
View File

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

76
schema.gql Normal file
View File

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