Initial commit
This commit is contained in:
commit
cbf619c370
GPG Key ID:
257D284A2A1D3A32
|
|
@ -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
|
||||
|
|
@ -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"
|
||||
|
|
@ -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">
|
||||
|]
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 [] }
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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."
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
import Distribution.Simple
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
|
|
@ -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
|
||||
|
|
@ -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";
|
||||
|
|
@ -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');
|
||||
|
|
@ -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. . @ {-# LANGUAGE OverloadedStrings #-} . import
|
||||
Web.Scotty . import Data.Monoid (mconcat) . main = scotty 3000 $   get
|
||||
"/:word" $ do     beam <- param "word"
|
||||
    html $ mconcat ["<h1>Scotty, ", beam, "
|
||||
me up!</h1>"] @ . . 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
|
||||
|
|
@ -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!
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue