Compare commits

...

8 Commits

29 changed files with 1157 additions and 693 deletions

1
.gitignore vendored
View File

@ -1 +1,2 @@
**/db/schema.sql **/db/schema.sql
**/client_session_key.aes

View File

@ -30,6 +30,7 @@
ghc-base64 ghc-base64
ghc-cryptonite ghc-cryptonite
ghc-datarekisteri-core ghc-datarekisteri-core
ghc-data-default
ghc-echo ghc-echo
ghc-email-validate ghc-email-validate
ghc-esqueleto ghc-esqueleto

View File

@ -1,6 +1,6 @@
import Data.Morpheus.Types (render, App) import Data.Morpheus.Types (render, App)
import Server.API (coreApp) import Datarekisteri.Backend.API (coreApp)
import qualified Data.ByteString.Lazy.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as C8
import Server (APIM) import Datarekisteri.Backend (APIM)
main = C8.putStrLn $ render (coreApp :: App () APIM) main = C8.putStrLn $ render (coreApp :: App () APIM)

View File

@ -16,8 +16,10 @@ executable datarekisteri-backend
base64, base64,
cryptonite, cryptonite,
datarekisteri-core, datarekisteri-core,
data-default,
email-validate, email-validate,
esqueleto, esqueleto,
http-types,
memory, memory,
mime-mail, mime-mail,
monad-logger, monad-logger,
@ -41,11 +43,14 @@ executable datarekisteri-backend
wai-cors, wai-cors,
wai-extra, wai-extra,
directory directory
main-is: Datarekisteri/Backend.hs main-is: Main.hs
other-modules: other-modules:
Datarekisteri.Backend,
Datarekisteri.Backend.API, Datarekisteri.Backend.API,
Datarekisteri.Backend.DB, Datarekisteri.Backend.DB,
Datarekisteri.Backend.DB.Queries, Datarekisteri.Backend.Sql,
Datarekisteri.Backend.Sql.Types,
Datarekisteri.Backend.Sql.Queries,
Datarekisteri.Backend.Email, Datarekisteri.Backend.Email,
Datarekisteri.Backend.Types, Datarekisteri.Backend.Types,
Datarekisteri.Backend.Utils, Datarekisteri.Backend.Utils,
@ -82,8 +87,9 @@ executable datarekisteri-cli
time time
main-is: Datarekisteri/CLI.hs main-is: Datarekisteri/CLI.hs
other-modules: other-modules:
Datarekisteri.Backend.DB, Datarekisteri.Backend.Sql,
Datarekisteri.Backend.DB.Queries, Datarekisteri.Backend.Sql.Types,
Datarekisteri.Backend.Sql.Queries,
Datarekisteri.Backend.Types, Datarekisteri.Backend.Types,
Datarekisteri.Backend.Utils, Datarekisteri.Backend.Utils,
hs-source-dirs: src hs-source-dirs: src

View File

@ -5,31 +5,42 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Backend where
import Relude import Relude
import "cryptonite" Crypto.Random (MonadRandom(..)) import "cryptonite" Crypto.Random (MonadRandom(..))
import qualified "base64" Data.ByteString.Base64 as B64
import Control.Monad.Except (catchError)
import Control.Monad.Logger (runStderrLoggingT) import Control.Monad.Logger (runStderrLoggingT)
import Data.Default (def)
import Data.Map (findWithDefault) import Data.Map (findWithDefault)
import Data.Text (toLower, breakOn, stripPrefix) import Data.Text (toLower, breakOn, stripPrefix)
import Database.Persist (entityVal)
import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn) import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
import Datarekisteri.Core.Types import Network.HTTP.Types.Status (status500, status401)
import Network.Mail.Mime (renderSendMailCustom, Address(..)) import Network.Mail.Mime (renderSendMailCustom, Address(..))
import Network.Wai (Application) import Network.Wai (Application)
import Network.Wai.Handler.Warp (Port, run) import Network.Wai.Handler.Warp (Port, run)
import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Cors (CorsResourcePolicy(..), cors)
import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Gzip (gzip)
import Datarekisteri.Backend.API
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries (getUserByEmail, getPermissions, getToken)
import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils (checkPassword)
import System.Directory (findExecutable) import System.Directory (findExecutable)
import System.Process (callProcess) import System.Process (callProcess)
import Options.Applicative hiding (header)
import qualified Options.Applicative as O import qualified Options.Applicative as O
import Options.Applicative hiding (Success, header)
import Web.Scotty.Trans hiding (readEither) import Web.Scotty.Trans hiding (readEither)
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
import Datarekisteri.Backend.Sql (MonadSql)
import Datarekisteri.Backend.Utils (checkPassword)
import qualified Datarekisteri.Backend.Sql as Sql
import Datarekisteri.Backend.API
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
import Paths_datarekisteri_backend import Paths_datarekisteri_backend
main :: IO () main :: IO ()
@ -101,10 +112,15 @@ parseBearer auth = do
authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
authBearer Nothing m = m authBearer Nothing m = m
authBearer (Just (BearerToken bearer)) m = do authBearer (Just (BearerToken bearer)) m = do
token <- lift $ getToken bearer let getUserPermissions = do
let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal Right DBToken {..} <- lift $ dbGetTokenBySecret bearer
permissions' <- fromMaybe mempty . readPermission <$> lift dbTokenPermissions
DBUser {..} <- lift dbTokenUser
userID <- lift dbUserId
pure (Just userID, permissions')
(user, permissions) <- getUserPermissions `catchError` const (pure (Nothing, mempty))
flip local m $ \state -> state flip local m $ \state -> state
{ stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token { stateCurrentUser = user
, statePermissions = permissions , statePermissions = permissions
} }
@ -123,21 +139,23 @@ parseBasic txt = do
authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
authBasic Nothing m = m authBasic Nothing m = m
authBasic (Just basic) m = do authBasic (Just basic) m = do
user <- verifyBasic basic DBUser {..} <- verifyBasic basic
permissions <- maybe (pure mempty) permissions <- readPermission <$> lift dbUserPermissions >>=
(fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user fromMaybeFail status500 "Internal server error"
userID <- lift dbUserId
flip local m $ \state -> state flip local m $ \state -> state
{ stateCurrentUser = user { stateCurrentUser = Just userID
, statePermissions = permissions , statePermissions = permissions
} }
-- TODO Refact, no need to convert to id and rerequest permissions verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM)
verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID)
verifyBasic BasicAuth {..} = do verifyBasic BasicAuth {..} = do
user <- lift $ getUserByEmail emailAddress Right user@DBUser {..} <- lift $ dbGetUserByEmail emailAddress
if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user correctPassword <- checkPassword password <$> lift dbUserPasswordHash
then pure $ entityToID <$> user if correctPassword
else pure Nothing then pure user
else do setHeader "WWW-Authenticate" "Basic realm=\"GraphQL API\", Bearer realm\"GraphQL API\""
raiseStatus status401 "Wrong password or email"
newtype APIM a = APIM (ReaderT RequestState IO a) newtype APIM a = APIM (ReaderT RequestState IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState) deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)
@ -158,10 +176,26 @@ data Config = Config
instance MonadTime APIM where instance MonadTime APIM where
currentTime = liftIO currentTime currentTime = liftIO currentTime
instance MonadDB APIM where instance MonadSql APIM where
runQuery query = do runQuery query = do
dbUrl <- asks $ configDbUrl . stateConfig dbUrl <- fmap encodeUtf8 $ asks $ configDbUrl . stateConfig
liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query liftIO $ runStderrLoggingT $ withPostgresqlConn dbUrl $ runSqlConn query
-- TODO: Catch database exceptions into Left values
instance MonadDB APIM where
dbUpdateUser = Sql.dbUpdateUser
dbAddUser = Sql.dbAddUser
dbAcceptApplication = Sql.dbAcceptApplication
dbRejectApplication = Sql.dbRejectApplication
dbVerifyEmail = Sql.dbVerifyEmail
dbAddToken = Sql.dbAddToken
dbAddKey = Sql.dbAddKey
dbGetUser = Sql.dbGetUser
dbGetUserByEmail = Sql.dbGetUserByEmail
dbGetUsers = Sql.dbGetUsers
dbGetApplications = Sql.dbGetApplications
dbGetEmailVerificationSecret = Sql.dbGetEmailVerificationSecret
dbGetTokenBySecret = Sql.dbGetTokenBySecret
instance MonadEmail APIM where instance MonadEmail APIM where
sendEmail email = do sendEmail email = do
@ -200,3 +234,6 @@ runAPIM config (APIM m) = runReaderT m RequestState
, statePermissions = fromList [] , statePermissions = fromList []
, stateConfig = config , stateConfig = config
} }
fromMaybeFail status err Nothing = raiseStatus status err
fromMaybeFail _ _ (Just x) = pure x

View File

@ -8,9 +8,9 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
@ -18,24 +18,23 @@
module Datarekisteri.Backend.API (coreApp, runApp, resolver) where module Datarekisteri.Backend.API (coreApp, runApp, resolver) where
import Relude hiding (Undefined, void, when, get) import Relude hiding (Undefined, get)
import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom) import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
import Control.Monad.Except (MonadError, throwError) import qualified "base64" Data.ByteString.Base64 as B64
import Data.Aeson (fromJSON, Result(..), toJSON)
import Data.Maybe (fromJust) import Control.Monad.Except (MonadError, throwError, catchError)
import Data.Morpheus.Server (deriveApp, runApp) import Data.Morpheus.Server (deriveApp, runApp)
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined) import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App) import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
import Database.Persist (Entity, entityVal, entityKey, get, (=.))
import Datarekisteri.Core.Types import qualified Data.Text as T
import Datarekisteri.Backend.Email
import Datarekisteri.Backend.DB import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries
import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils import Datarekisteri.Backend.Utils
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64) import Datarekisteri.Core.Types
import qualified Data.Text as T (null, chunksOf, intercalate)
-- General functions, maybe migrate to Utils or API.Utils -- General functions, maybe migrate to Utils or API.Utils
@ -43,212 +42,135 @@ targetUser :: (MonadError GQLError m, MonadRequest m) => Maybe UserID -> m UserI
targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) pure targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) pure
fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a
fromMaybeFail txt = maybe (throwError txt) pure fromMaybeFail txt = maybe (throwError txt) pure
void :: Monad m => m a -> m Unit voidU :: Monad m => m a -> m Unit
void m = m >> pure Unit voidU m = m >> pure Unit
when :: Monad m => Bool -> m a -> m Unit liftDBEither :: MonadError GQLError m => DBEither a -> m a
when b m = if b then void m else pure Unit liftDBEither = either (throwError . fromString) pure
dbUserToUser :: MonadDB m => Entity DBUser -> User m applicationArgsToData :: (MonadTime m, MonadRandom m, MonadPermissions m, MonadError GQLError m) =>
dbUserToUser user = let id = entityToID user ApplicationArgs -> m ApplicationData
DBUser {..} = entityVal user applicationArgsToData ApplicationArgs {..} = do
Success (MemberData {..}) = fromJSON dBUserMemberData registered <- currentTime
-- XXX: Explodes if database doesn't contain needed data verificationSecret <- genVerificationSecret
in User
{ id = pure id
, email = fmap (dBEmailEmail . entityVal) <$> getUserEmail id
, pendingEmail = fmap (dBEmailEmail . entityVal) <$> getUserPendingEmail id
, phoneNumber = pure phoneNumber
, 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
, isMember = pure $ isJust dBUserAccepted
, 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
secret <- genVerificationSecret
passwordHash <- hashPassword password passwordHash <- hashPassword password
permissions <- defaultPermissions permissions <- defaultPermissions
when (T.null name) $ throwError "Name must not be empty" when (T.null name) $ throwError "Name must not be empty"
when (T.null password) $ throwError "Password must not be empty" when (T.null password) $ throwError "Password must not be empty"
when (T.null homeplace) $ throwError "Homeplace 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, ..} pure ApplicationData {..}
user <- addUser $ DBUser
{ dBUserRegistered = time newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
, dBUserPasswordCrypt = passwordHash ApplicationArgs -> m (User m)
, dBUserPermissions = permissions newUser args = do
, dBUserAccepted = Nothing applicationData <- applicationArgsToData args
, dBUserMemberData = toJSON memberData user <- dbAddUser applicationData >>= liftDBEither
} sendVerificationSecret user >>= flip unless (throwError "Sending email verification failed!")
verification <- addEmailVerification secret return $ dbUserToUser user
email <- addEmail $ DBEmail
{ dBEmailUid = toDBKey user
, dBEmailEmail = email
, dBEmailVid = Just verification
}
sendVerificationSecret email
return user
genVerificationSecret :: MonadRandom m => m Text genVerificationSecret :: MonadRandom m => m Text
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10 genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => DBUser m -> m Bool
sendVerificationSecret email = void $ do sendVerificationSecret DBUser {..} = do
maybeDBEmail <- runQuery $ get email secret <- dbUserId >>= dbGetEmailVerificationSecret >>= liftDBEither
case maybeDBEmail of pendingEmail <- dbUserPendingEmail
Nothing -> pure Unit case (secret, pendingEmail) of
Just dbEmail -> do (Just secret', Just pendingEmail') ->
case dBEmailVid dbEmail of sendVerificationEmail secret' pendingEmail' >> pure True
Nothing -> pure Unit _ -> pure False
Just dbVerificationId -> do
secret <- fmap (dBEmailVerificationSecret . fromJust) $ runQuery $ get dbVerificationId
let email = dBEmailEmail dbEmail
void $ sendVerificationEmail secret email
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) => updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
UserID -> UpdateData -> m UserID UpdateArgs -> UserID -> m UpdateData
updateUser user (UpdateData {..}) = do updateArgsToData UpdateArgs {..} user = do
hash <- sequence $ hashPassword <$> password when (maybe False T.null name) $ throwError "Name must not be empty"
-- TODO: assert stuff valid when (maybe False T.null password) $ throwError "Password must not be empty"
user <- updateUserData user when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
(catMaybes [(DBUserPasswordCrypt =.) <$> hash]) isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
(catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname, when (isMember && isJust application) $ throwError "Members can't update their applications"
SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber]) passwordHash <- sequence $ hashPassword <$> password
case email of updateTime <- currentTime
Nothing -> pure Unit verificationSecret <- genVerificationSecret
Just email' -> do pure UpdateData {..}
verificationSecret <- genVerificationSecret
emailKey <- updateEmail user email' verificationSecret updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
sendVerificationSecret emailKey MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
return user updateUser user args = do
updateData@(UpdateData {..}) <- updateArgsToData args user
updatedUser <- dbUpdateUser updateData >>= liftDBEither
when (isJust email) $ void $ sendVerificationSecret updatedUser
pure $ dbUserToUser updatedUser
newTokenArgsToData :: (MonadRandom m, MonadTime m, MonadPermissions m) =>
NewTokenArgs -> UserID -> m NewTokenData
newTokenArgsToData NewTokenArgs {..} user = do
tokenData <- B64.encodeBase64 <$> getRandomBytes 128
issued <- currentTime
permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
let expires = Nothing
pure NewTokenData {..}
makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) => makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
NewTokenArgs -> UserID -> m TokenID NewTokenArgs -> UserID -> m (Token m)
makeNewToken (NewTokenArgs {..}) user = do makeNewToken args user = do
tokenData <- B64.encodeBase64 <$> getRandomBytes 128 tokenData <- newTokenArgsToData args user
time <- currentTime fmap dbTokenToToken $ dbAddToken tokenData >>= liftDBEither
permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
addToken $ DBToken newKeyArgsToData :: (MonadTime m, MonadError GQLError m) => NewKeyArgs -> UserID -> m NewKeyData
{ dBTokenUid = toDBKey user newKeyArgsToData NewKeyArgs {..} user = do
, dBTokenName = name uploaded <- currentTime
, dBTokenData = tokenData keyData <- maybe (throwError "Invalid base64") pure $ base64Decode keyData
, dBTokenComment = fromMaybe "" comment pure NewKeyData {..}
, dBTokenIssued = time
, dBTokenExpires = Nothing
, dBTokenPermissions = permissions
}
makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) => makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
KeyData -> UserID -> m KeyID NewKeyArgs -> UserID -> m (PGPKey m)
makeNewKey (KeyData {..}) user = do makeNewKey args user = do
time <- currentTime newKeyData <- newKeyArgsToData args user
keyData' <- fromMaybeFail "" $ base64Decode keyData fmap dbPGPKeyToPGPKey $ dbAddKey newKeyData >>= liftDBEither
addKey $ DBKey
{ dBKeyUid = toDBKey user
, dBKeyData = keyData'
, dBKeyExpires = expires
, dBKeyUploaded = time
, dBKeyComment = fromMaybe "" comment
, dBKeyIsPrimaryEncryptionKey = True
}
acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
acceptApplication user = void $ do acceptApplication user = voidU $ do
maybeEmail <- getUserEmail user maybeEmail <- dbGetUserEmail user >>= liftDBEither
case maybeEmail of case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!" Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do Just email -> do
time <- currentTime time <- currentTime
applicationAccepted <- markAsAccepted user time dbAcceptApplication user time >>= liftDBEither
when applicationAccepted $ sendApplicationAcceptedEmail email
sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
rejectApplication user = void $ do rejectApplication user = voidU $ do
maybeEmail <- getUserEmail user maybeEmail <- dbGetUserEmail user >>= liftDBEither
case maybeEmail of case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!" Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do Just email -> do
applicationDeleted <- deleteApplication user dbRejectApplication user
when applicationDeleted $ sendApplicationRejectedEmail email
sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
resolveQuery = Query resolveQuery = Query
{ users = requirePermission Members ReadOnly >> map (dbUserToUser) <$> getAllUsers { users = requirePermission Members ReadOnly >> map dbUserToUser <$> dbGetUsers
, user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >> , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
fmap dbUserToUser <$> getByID user (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
, tokens = \(Arg id) -> targetUser id >>= \user -> , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
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 , permissions = currentPermissions
} }
resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m, resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
resolveMutation = Mutation resolveMutation = Mutation
{ apply = \x -> do { apply = newUser
userID <- newUser x , verifyEmail = \(Arg secret) -> voidU $ dbVerifyEmail secret
maybeUser <- getByID userID , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
user <- fromMaybeFail "" maybeUser maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
pure $ dbUserToUser user , update = \updateArgs (Arg id) -> targetUser id >>= \user ->
, verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (not x) $ throwError "Invalid verification secret" requirePermission (Profile user) ReadWrite >> updateUser user updateArgs
, resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
maybe (pure Unit) (sendVerificationSecret . entityKey)
, update = \updateData (Arg id) -> targetUser id >>= \user ->
requirePermission (Profile user) ReadWrite >>
updateUser user updateData >> getByID user >>= fmap dbUserToUser . fromMaybeFail ""
, newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user -> , newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
requirePermission (Profile user) ReadWrite >> makeNewToken args user >>= requirePermission (Profile user) ReadWrite >> makeNewToken args user
getByID >>= fmap dbTokenToToken . fromMaybeFail ""
, newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user -> , newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
requirePermission (Profile user) ReadWrite >> makeNewKey args user >>= requirePermission (Profile user) ReadWrite >> makeNewKey args user
getByID >>= fmap dbKeyToPGPKey . fromMaybeFail ""
, accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id , accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id
, reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id , reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id
} }
@ -262,6 +184,34 @@ resolver :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined
resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation } resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation }
data ApplicationArgs = ApplicationArgs
{ email :: Email
, phoneNumber :: PhoneNumber
, password :: Text
, name :: Text
, nickname :: Maybe Text
, birthdate :: Date
, homeplace :: Text
, application :: Text
} deriving (Generic, GQLType, Eq, Show)
data UpdateArgs = UpdateArgs
{ email :: Maybe Email
, phoneNumber :: Maybe PhoneNumber
, password :: Maybe Text
, name :: Maybe Text
, nickname :: Maybe Text
, homeplace :: Maybe Text
, application :: Maybe Text
} deriving (Generic, GQLType, Eq, Show)
data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
deriving (Generic, GQLType, Eq, Show)
data NewTokenArgs = NewTokenArgs
{ comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
deriving (Generic, GQLType)
data User m = User data User m = User
{ id :: m UserID { id :: m UserID
, email :: m (Maybe Email) , email :: m (Maybe Email)
@ -276,11 +226,13 @@ data User m = User
, permissions :: m Text , permissions :: m Text
, isMember :: m Bool , isMember :: m Bool
, application :: m Text , application :: m Text
, tokens :: m [Token m]
, keys :: m [PGPKey m]
, primaryKey :: m (Maybe (PGPKey m))
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
data PGPKey m = PGPKey data PGPKey m = PGPKey
{ id :: m KeyID { id :: m KeyID
, user :: m (User m)
, pgpKeyData :: m Base64 , pgpKeyData :: m Base64
, expires :: m (Maybe Time) , expires :: m (Maybe Time)
, uploaded :: m Time , uploaded :: m Time
@ -289,7 +241,6 @@ data PGPKey m = PGPKey
data Token m = Token data Token m = Token
{ id :: m TokenID { id :: m TokenID
, user :: m (User m)
, name :: m (Maybe Text) , name :: m (Maybe Text)
, tokenData :: m Text , tokenData :: m Text
, comment :: m Text , comment :: m Text
@ -298,57 +249,60 @@ data Token m = Token
, permissions :: m Text , permissions :: m Text
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
data ApplicationData = ApplicationData
{ email :: Email
, phoneNumber :: PhoneNumber
, password :: Text
, name :: Text
, nickname :: Maybe Text
, birthdate :: Date
, homeplace :: Text
, application :: Text
} deriving (Generic, GQLType, Eq, Show)
data UpdateData = UpdateData
{ email :: Maybe Email
, phoneNumber :: Maybe PhoneNumber
, 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 data Query m = Query
{ users :: m [User m] { users :: m [User m]
, user :: Arg "id" (Maybe UserID) -> m (Maybe (User m)) , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
, applications :: m [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 , permissions :: m Text
--, key :: Arg "id" KeyID -> m (PGPKey m)
, primaryKey :: Arg "user" (Maybe UserID) -> m (Maybe (PGPKey m))
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
data Mutation m = Mutation data Mutation m = Mutation
{ apply :: ApplicationData -> m (User m) { apply :: ApplicationArgs -> m (User m)
, verifyEmail :: Arg "secret" Text -> m Unit , verifyEmail :: Arg "secret" Text -> m Unit
, resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit , resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
, update :: UpdateData -> Arg "user" (Maybe UserID) -> m (User m) , update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m)
, newToken :: NewTokenArgs -> m (Token m) , newToken :: NewTokenArgs -> m (Token m)
, newKey :: KeyData -> m (PGPKey m) , newKey :: NewKeyArgs -> m (PGPKey m)
, accept :: Arg "user" UserID -> m Unit , accept :: Arg "user" UserID -> m Unit
, reject :: Arg "user" UserID -> m Unit , reject :: Arg "user" UserID -> m Unit
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
dbUserToUser :: (MonadPermissions m, MonadError GQLError m) => DBUser m -> User m
dbUserToUser DBUser {..} = User
{ id = dbUserId
, email = dbUserEmail
, pendingEmail = dbUserPendingEmail
, name = dbUserName
, nickname = dbUserNickname
, phoneNumber = dbUserPhoneNumber
, birthdate = dbUserBirthdate
, homeplace = dbUserHomeplace
, registered = dbUserRegistered
, accepted = dbUserAccepted
, permissions = dbUserPermissions
, isMember = isJust <$> dbUserAccepted
, application = dbUserApplication
, tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
, keys = map dbPGPKeyToPGPKey <$> dbUserKeys
, primaryKey = fmap dbPGPKeyToPGPKey <$> dbUserPrimaryKey
}
dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m
dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
{ id = dbPGPKeyId
, pgpKeyData = dbPGPKeyData
, expires = dbPGPKeyExpires
, uploaded = dbPGPKeyUploaded
, comment = dbPGPKeyComment
}
dbTokenToToken :: Monad m => DBToken m -> Token m
dbTokenToToken DBToken {..} = Token
{ id = dbTokenId
, name = dbTokenName
, tokenData = dbTokenData
, comment = dbTokenComment
, issued = dbTokenIssued
, expires = dbTokenExpires
, permissions = dbTokenPermissions
}

View File

@ -1,105 +1,24 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Datarekisteri.Backend.DB where module Datarekisteri.Backend.DB where
import Data.ByteString (ByteString) import Relude
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 Datarekisteri.Core.Types
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
mkPersist sqlSettings [persistUpperCase| dbGetUserEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
DBUser sql=users dbGetUserEmail userID = do
registered Time userOrErr <- dbGetUser userID
passwordCrypt PasswordHash case userOrErr of
permissions Text Left err -> pure $ Left err
accepted (Maybe Time) Right DBUser {..} -> Right <$> dbUserEmail
memberData Value sqltype=jsonb
deriving (Show) dbGetUserPendingEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
dbGetUserPendingEmail userID = do
DBEmail sql=emails userOrErr <- dbGetUser userID
uid DBUserId case userOrErr of
email Email sqltype=varchar(320) Left err -> pure $ Left err
vid (Maybe DBEmailVerificationId) sql=verification Right DBUser {..} -> Right <$> dbUserPendingEmail
UniqueUserVerified uid vid
-- This enables using persistent functions to get unique verified emails. The real
-- constraint is stricter and doesn't allow having more than one null and one non-null
-- verification but it's too complicated for persistent to understand.
UniqueEmail email
UniqueVerification vid
DBEmailVerification sql=emailVerifications
secret Text sqltype=varchar(255)
expires Time
UniqueVerificationSecret secret
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 . fromIntegral . fromSqlKey
instance FromDBKey TokenID where
type DB TokenID = DBToken
fromDBKey = TokenID . fromIntegral . fromSqlKey
instance FromDBKey KeyID where
type DB KeyID = DBKey
fromDBKey = KeyID . fromIntegral . fromSqlKey
class FromDBKey a => ToDBKey a where
toDBKey :: a -> Key (DB a)
instance ToDBKey UserID where
toDBKey (UserID x) = toSqlKey $ fromIntegral x
instance ToDBKey KeyID where
toDBKey (KeyID x) = toSqlKey $ fromIntegral x
instance ToDBKey TokenID where
toDBKey (TokenID x) = toSqlKey $ fromIntegral x

View File

@ -1,204 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Datarekisteri.Backend.DB.Queries where
import Datarekisteri.Backend.DB as DB
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
import Data.Text (Text)
import Database.Esqueleto.Experimental
import qualified Database.Persist as Persist (update, (=.))
import qualified Database.Persist.Types as Persist (Update)
import Data.Maybe (listToMaybe)
import Data.Aeson (fromJSON, toJSON, Result(..))
import Data.Time (nominalDay)
getByID :: (MonadDB m, ToDBKey k, PersistEntityBackend (DB k) ~ SqlBackend) => k -> m (Maybe (Entity (DB k)))
getByID id = let key = toDBKey id in runQuery $ fmap (Entity key) <$> get key
getUserByEmail :: MonadDB m => Email -> m (Maybe (Entity DBUser))
getUserByEmail email = fmap listToMaybe $ runQuery $ select $ do
(dbUser :& dbEmail) <- from $ table @DBUser `crossJoin` table @DBEmail
where_ $ dbEmail ^. DBEmailEmail ==. val email &&. dbUser ^. DBUserId ==. dbEmail ^. DBEmailUid
-- There is only one row in DBEmail with a given email (unique constraint) and a DBEmail only
-- has one user id and there is only row in DBUser with a given user id (primary key). Thus
-- there is at most one combination of rows from DBEmail and DBUser that satisfy this query.
pure dbUser
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
isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool)
isVerified email = isNothing (email ^. DBEmailVid)
hasVerifiedEmail :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool)
hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
emails <- from $ table @DBEmail
where_ $ emails ^. DBEmailUid ==. userId &&. isVerified emails
pure $ val True -- This is not used anywhere, there just isn't a PersistField instance for ()
isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
isApplicant user = isNothing (user ^. DBUserAccepted)
&&. hasVerifiedEmail (user ^. DBUserId)
isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
isMember user = not_ $ isApplicant user
verifyEmailSecret :: MonadDB m => Text -> m Bool
verifyEmailSecret secret = runQuery $ do
update $ \email -> do
set email [DBEmailVid =. val Nothing]
where_ $ (>. val (0 :: Int)) $ subSelectCount $ do
verification <- from $ table @DBEmailVerification
where_ $ email ^. DBEmailVid ==. just (verification ^. DBEmailVerificationId)
&&. verification ^. DBEmailVerificationSecret ==. val secret
fmap (> 0) $ deleteCount $ do
verification <- from (table @DBEmailVerification)
where_ $ verification ^. DBEmailVerificationSecret ==. val secret
getUserEmail' :: MonadDB m => UserID -> Bool -> m (Maybe (Entity DBEmail))
getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do
email <- from $ table @DBEmail
where_ $ email ^. DBEmailUid ==. val (toDBKey user)
&&. isNothing (email ^. DBEmailVid) ==. val verified
pure email
getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
getUserEmail user = getUserEmail' user True
getUserPendingEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail))
getUserPendingEmail user = getUserEmail' user False
addEmail :: MonadDB m => DBEmail -> m (Key DBEmail)
addEmail = runQuery . insert
getExpireTime :: MonadTime m => m Time
getExpireTime = addTime (7 * nominalDay) <$> currentTime
addEmailVerification :: (MonadDB m, MonadTime m) => Text -> m (Key DBEmailVerification)
addEmailVerification secret = do
expires <- getExpireTime
runQuery $ insert $ DBEmailVerification
{ dBEmailVerificationSecret = secret
, dBEmailVerificationExpires = expires
}
deleteExpiredEmails :: MonadDB m => Time -> m ()
deleteExpiredEmails time = runQuery $ delete $ do
verification <- from $ table @DBEmailVerification
where_ $ verification ^. DBEmailVerificationExpires <=. val time
deleteOrphanedVerifications :: MonadDB m => m ()
deleteOrphanedVerifications = runQuery $ delete $ do
verification <- from $ table @DBEmailVerification
where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
email <- from $ table @DBEmail
where_ $ email ^. DBEmailVid ==. just (verification ^. DBEmailVerificationId)
deleteUsersWithoutEmail :: MonadDB m => m ()
deleteUsersWithoutEmail = runQuery $ delete $ do
user <- from $ table @DBUser
where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
email <- from $ table @DBEmail
where_ $ email ^. DBEmailUid ==. user ^. DBUserId
pure $ email ^. DBEmailId -- Not used anywhere
updateEmail :: (MonadDB m, MonadTime m) => UserID -> Email -> Text -> m (Key DBEmail)
updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do
delete $ do
dbEmail <- from $ table @DBEmail
where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail)
verifiedEmail <- fmap listToMaybe $ select $ do
dbEmail <- from $ table @DBEmail
where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user)
&&. dbEmail ^. DBEmailEmail ==. val email
pure dbEmail
case verifiedEmail of
Just (Entity key _) -> pure key
Nothing -> do
verificationId <- insert DBEmailVerification
{ dBEmailVerificationSecret = secret
, dBEmailVerificationExpires = expires
}
insert DBEmail
{ dBEmailUid = toDBKey user
, dBEmailEmail = email
, dBEmailVid = Just verificationId
}
markAsAccepted :: MonadDB m => UserID -> Time -> m Bool
markAsAccepted userID time = fmap (> 0) $ runQuery $ updateCount $ \user -> do
set user [DBUserAccepted =. just (val time)]
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
deleteApplication :: MonadDB m => UserID -> m Bool
deleteApplication userID = fmap (> 0) $ runQuery $ deleteCount $ do
user <- from $ table @DBUser
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 }
updateData (SetUserPhoneNumber x) memberData = memberData { phoneNumber = x }
Persist.update key (userUpdates <> updates)
pure user
data UserUpdate = SetUserName Text
| SetUserNickname (Maybe Text)
| SetUserHomeplace Text
| SetUserPhoneNumber PhoneNumber

View File

@ -2,11 +2,12 @@
module Datarekisteri.Backend.Email where module Datarekisteri.Backend.Email where
import Datarekisteri.Backend.Types
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Lazy (fromStrict) import Data.Text.Lazy (fromStrict)
import Network.Mail.Mime (Address(..), simpleMail')
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Network.Mail.Mime
sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m () sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m ()
sendDatarekisteriEmail subject content to = do sendDatarekisteriEmail subject content to = do

View File

@ -0,0 +1,212 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Backend.Sql where
import Relude
import Data.Aeson (Result(..), fromJSON, toJSON)
import Data.Time (nominalDay)
import Database.Persist (Entity(..), (=.))
import Datarekisteri.Backend.Sql.Queries (SqlM, UserUpdate(..))
import qualified Datarekisteri.Backend.Sql.Queries as Sql
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
class Monad m => MonadSql m where
runQuery :: SqlM a -> m a
dbUpdateUser :: MonadSql m => UpdateData -> m (DBEither (DBUser m))
dbUpdateUser UpdateData {..} = do
let memberDataUpdates = catMaybes
[ SetUserName <$> name
, SetUserNickname . Just <$> nickname
, SetUserHomeplace <$> homeplace
, SetUserPhoneNumber <$> phoneNumber
, SetUserApplication <$> application
]
userUpdates = maybeToList $ (SqlUserPasswordCrypt =.) <$> passwordHash
sqlUser <- runQuery $ do
Sql.updateUserData user userUpdates memberDataUpdates
case email of
Nothing -> pure ()
Just newEmail -> do
Sql.deleteUnverifiedEmail user
maybeOldEmail <- fmap (sqlEmailEmail . entityVal) <$> Sql.getUserEmail user
when (maybe True (/= newEmail) maybeOldEmail) $ do
verificationID <- Sql.addEmailVerification verificationSecret updateTime
void $ Sql.addEmail SqlEmail
{ sqlEmailUid = fromID user
, sqlEmailEmail = newEmail
, sqlEmailVid = Just verificationID
}
fromMaybe (error "Inconsistent DB at APIM dbUpdateUser!") <$> Sql.getUser user
pure $ Right $ sqlUserToDBUser user sqlUser
dbAddUser :: MonadSql m => ApplicationData -> m (DBEither (DBUser m))
dbAddUser ApplicationData {..} = runQuery $ do
userID <- Sql.addUser SqlUser
{ sqlUserRegistered = registered
, sqlUserPasswordCrypt = passwordHash
, sqlUserPermissions = permissions
, sqlUserAccepted = Nothing
, sqlUserMemberData = toJSON $ MemberData {..}
}
verificationID <- Sql.addEmailVerification verificationSecret (addTime (7*nominalDay) registered)
void $ Sql.addEmail SqlEmail
{ sqlEmailUid = fromID userID
, sqlEmailEmail = email
, sqlEmailVid = Just verificationID
}
Right . sqlUserToDBUser userID . fromMaybe (error "") <$> Sql.getUser userID
dbAcceptApplication :: MonadSql m => UserID -> Time -> m (DBEither ())
dbAcceptApplication userID time = do
marked <- runQuery $ Sql.markAsAccepted userID time
if marked
then pure $ Right ()
else pure $ Left $ "No application with id " <> show userID <> " found!"
dbRejectApplication :: MonadSql m => UserID -> m (DBEither ())
dbRejectApplication userID = do
deleted <- runQuery $ Sql.deleteApplication userID
if deleted
then pure $ Right ()
else pure $ Left $ "No application with id " <> show userID <> " found!"
dbVerifyEmail :: MonadSql m => Text -> m (DBEither ())
dbVerifyEmail secret = do
verified <- runQuery $ Sql.verifyEmailSecret secret
if verified
then pure $ Right ()
else pure $ Left $ "Invalid verification secret"
dbAddToken :: MonadSql m => NewTokenData -> m (DBEither (DBToken m))
dbAddToken NewTokenData {..} = do
(sqlTokenID, sqlToken) <- runQuery $ do
tokenID <- Sql.addToken SqlToken
{ sqlTokenUid = fromID user
, sqlTokenName = name
, sqlTokenData = tokenData
, sqlTokenComment = fromMaybe "" comment
, sqlTokenIssued = issued
, sqlTokenExpires = expires
, sqlTokenPermissions = permissions
}
token <- fromMaybe (error "Inconsistent DB at APIM dbAddToken!") <$> Sql.getToken tokenID
pure (tokenID, token)
pure $ Right $ sqlTokenToDBToken sqlTokenID sqlToken
dbAddKey :: MonadSql m => NewKeyData -> m (DBEither (DBPGPKey m))
dbAddKey NewKeyData {..} = do
(keyID, sqlKey) <- runQuery $ do
keyID <- Sql.addKey SqlKey
{ sqlKeyUid = fromID user
, sqlKeyData = keyData
, sqlKeyExpires = expires
, sqlKeyUploaded = uploaded
, sqlKeyComment = fromMaybe "" comment
, sqlKeyIsPrimaryEncryptionKey = False
}
sqlKey <- fromMaybe (error "Inconsistent DB at APIM dbAddKey") <$> Sql.getKey keyID
pure (keyID, sqlKey)
pure $ Right $ sqlKeyToDBKey keyID sqlKey
dbGetUser :: MonadSql m => UserID -> m (DBEither (DBUser m))
dbGetUser userID = do
maybeUser <- runQuery $ Sql.getUser userID
pure $ case maybeUser of
Nothing -> Left $ "Invalid user ID"
Just sqlUser -> Right $ sqlUserToDBUser userID sqlUser
dbGetUserByEmail :: MonadSql m => Email -> m (DBEither (DBUser m))
dbGetUserByEmail email = do
maybeUser <- runQuery $ Sql.getUserByEmail email
pure $ case maybeUser of
Nothing -> Left $ "No user with such email"
Just userEntity -> Right $ entityToDBUser userEntity
dbGetUsers :: MonadSql m => m [DBUser m]
dbGetUsers = map entityToDBUser <$> runQuery Sql.getAllUsers
dbGetUserTokens :: MonadSql m => UserID -> m (DBEither [DBToken m])
dbGetUserTokens userID = Right . map entityToDBToken <$> runQuery (Sql.getUserTokens userID)
dbGetUserKeys :: MonadSql m => UserID -> m (DBEither [DBPGPKey m])
dbGetUserKeys userID = Right . map entityToDBKey <$> runQuery (Sql.getKeys userID)
dbGetUserPrimaryKey :: MonadSql m => UserID -> m (DBEither (Maybe (DBPGPKey m)))
dbGetUserPrimaryKey userID = Right . fmap entityToDBKey <$> runQuery (Sql.getPrimaryKey userID)
dbGetApplications :: MonadSql m => m [DBUser m]
dbGetApplications = map entityToDBUser <$> runQuery Sql.getApplicants
dbGetEmailVerificationSecret :: MonadSql m => UserID -> m (DBEither (Maybe Text))
dbGetEmailVerificationSecret userID = fmap Right $ runQuery $ Sql.getEmailVerificationSecret userID
dbGetTokenBySecret :: MonadSql m => Text -> m (DBEither (DBToken m))
dbGetTokenBySecret secret = maybe (Left "Invalid secret") Right . fmap entityToDBToken <$>
runQuery (Sql.getTokenBySecret secret)
entityToDBUser :: MonadSql m => Entity SqlUser -> DBUser m
entityToDBUser (Entity userKey sqlUser) = sqlUserToDBUser (toID userKey) sqlUser
sqlUserToDBUser :: MonadSql m => UserID -> SqlUser -> DBUser m
sqlUserToDBUser userID SqlUser {..} =
let Success MemberData {..} = fromJSON sqlUserMemberData
in DBUser
{ dbUserId = pure userID
, dbUserEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $ Sql.getUserEmail userID
, dbUserPendingEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $
Sql.getUserPendingEmail userID
, dbUserName = pure name
, dbUserNickname = pure $ fromMaybe (fromMaybe (error "Invalid name in the database") $
viaNonEmpty head $ words name) nickname
, dbUserBirthdate = pure birthdate
, dbUserHomeplace = pure homeplace
, dbUserApplication = pure application
, dbUserPhoneNumber = pure phoneNumber
, dbUserRegistered = pure sqlUserRegistered
, dbUserAccepted = pure sqlUserAccepted
, dbUserPermissions = pure sqlUserPermissions
, dbUserPasswordHash = pure sqlUserPasswordCrypt
, dbUserTokens = fmap (map entityToDBToken) $ runQuery $ Sql.getUserTokens userID
, dbUserKeys = fmap (map entityToDBKey) $ runQuery $ Sql.getKeys userID
, dbUserPrimaryKey = fmap (fmap entityToDBKey) $ runQuery $ Sql.getPrimaryKey userID
}
entityToDBToken :: MonadSql m => Entity SqlToken -> DBToken m
entityToDBToken (Entity tokenKey sqlToken) = sqlTokenToDBToken (toID tokenKey) sqlToken
sqlTokenToDBToken :: MonadSql m => TokenID -> SqlToken -> DBToken m
sqlTokenToDBToken tokenID SqlToken {..} = DBToken
{ dbTokenId = pure tokenID
, dbTokenUser =
let userID = toID sqlTokenUid
in fmap (sqlUserToDBUser userID . fromMaybe (error "Inconsistent DB at sqlTokenToDBToken!")) $
runQuery $ Sql.getUser userID
, dbTokenName = pure sqlTokenName
, dbTokenData = pure sqlTokenData
, dbTokenComment = pure sqlTokenComment
, dbTokenIssued = pure sqlTokenIssued
, dbTokenExpires = pure sqlTokenExpires
, dbTokenPermissions = pure sqlTokenPermissions
}
entityToDBKey :: MonadSql m => Entity SqlKey -> DBPGPKey m
entityToDBKey (Entity keyKey sqlKey) = sqlKeyToDBKey (toID keyKey) sqlKey
sqlKeyToDBKey :: MonadSql m => KeyID -> SqlKey -> DBPGPKey m
sqlKeyToDBKey keyID SqlKey {..} = DBPGPKey
{ dbPGPKeyId = pure keyID
, dbPGPKeyData = pure $ base64Encode sqlKeyData
, dbPGPKeyExpires = pure sqlKeyExpires
, dbPGPKeyUploaded = pure sqlKeyUploaded
, dbPGPKeyComment = pure sqlKeyComment
}

View File

@ -0,0 +1,239 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Datarekisteri.Backend.Sql.Queries where
import Control.Monad.Logger (LoggingT)
import Data.Aeson (fromJSON, toJSON, Result(..))
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Database.Persist as Persist
import Database.Esqueleto.Experimental
import Datarekisteri.Backend.Types (MemberData(..))
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Core.Types
type SqlM a = SqlPersistT (LoggingT IO) a
getUserByEmail :: Email -> SqlM (Maybe (Entity SqlUser))
getUserByEmail email = fmap listToMaybe $ select $ do
(dbUser :& dbEmail) <- from $ table @SqlUser `crossJoin` table @SqlEmail
where_ $ dbEmail ^. SqlEmailEmail ==. val email &&. dbUser ^. SqlUserId ==. dbEmail ^. SqlEmailUid
-- There is only one row in SqlEmail with a given email (unique constraint) and a SqlEmail only
-- has one user id and there is only row in SqlUser with a given user id (primary key). Thus
-- there is at most one combination of rows from SqlEmail and SqlUser that satisfy this query.
pure dbUser
addUser :: SqlUser -> SqlM UserID
addUser = fmap toID . insert
getUser :: UserID -> SqlM (Maybe SqlUser)
getUser = get . fromID
getKeys :: UserID -> SqlM [Entity SqlKey]
getKeys user = select $ do
keys <- from $ table @SqlKey
where_ $ keys ^. SqlKeyUid ==. val (fromID user)
pure $ keys
getKey :: KeyID -> SqlM (Maybe SqlKey)
getKey = get . fromID
getPermissions :: UserID -> SqlM (Maybe Text)
getPermissions user = fmap (fmap sqlUserPermissions) $ get $ fromID user
setPermissions :: UserID -> Text -> SqlM ()
setPermissions user txt = updateUserData user [SqlUserPermissions Persist.=. txt] [] >> return ()
getPrimaryKey :: UserID -> SqlM (Maybe (Entity SqlKey))
getPrimaryKey user = fmap listToMaybe $ select $ do
keys <- from $ table @SqlKey
where_ $ keys ^. SqlKeyIsPrimaryEncryptionKey &&. keys ^. SqlKeyUid ==. val (fromID user)
pure $ keys
getUserTokens :: UserID -> SqlM [Entity SqlToken]
getUserTokens user = select $ do
tokens <- from $ table @SqlToken
where_ $ tokens ^. SqlTokenUid ==. val (fromID user)
pure $ tokens
addToken :: SqlToken -> SqlM TokenID
addToken = fmap toID . insert
getToken :: TokenID -> SqlM (Maybe SqlToken)
getToken = get . fromID
getTokenBySecret :: Text -> SqlM (Maybe (Entity SqlToken))
getTokenBySecret = getBy . UniqueData
addKey :: SqlKey -> SqlM KeyID
addKey = fmap toID . insert
getAllUsers :: SqlM [Entity SqlUser]
getAllUsers = select $ do
users <- from $ table @SqlUser
where_ $ isMember users
pure $ users
getApplicants :: SqlM [Entity SqlUser]
getApplicants = select $ do
users <- from $ table @SqlUser
where_ $ isApplicant users
pure $ users
isVerified :: SqlExpr (Entity SqlEmail) -> SqlExpr (Value Bool)
isVerified email = isNothing $ email ^. SqlEmailVid
hasVerifiedEmail :: SqlExpr (Value SqlUserId) -> SqlExpr (Value Bool)
hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
emails <- from $ table @SqlEmail
where_ $ emails ^. SqlEmailUid ==. userId &&. isVerified emails
pure $ val True -- This is not used anywhere, there just isn't a PersistField instance for ()
isApplicant :: SqlExpr (Entity SqlUser) -> SqlExpr (Value Bool)
isApplicant user = isNothing (user ^. SqlUserAccepted)
&&. hasVerifiedEmail (user ^. SqlUserId)
isMember :: SqlExpr (Entity SqlUser) -> SqlExpr (Value Bool)
isMember user = not_ $ isApplicant user
verifyEmailSecret :: Text -> SqlM Bool
verifyEmailSecret secret = do
pendingEmail <- selectOne $ do
email <- from $ table @SqlEmail
where_ $ (>. val (0 :: Int)) $ subSelectCount $ do
verification <- from $ table @SqlEmailVerification
where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
&&. verification ^. SqlEmailVerificationSecret ==. val secret
pure email
case pendingEmail of
Nothing -> pure False
Just (Entity _ SqlEmail {..}) -> do
delete $ do
email <- from $ table @SqlEmail
where_ $ val sqlEmailUid ==. email ^. SqlEmailUid &&. isVerified email
update $ \email -> do
set email [SqlEmailVid =. val Nothing]
where_ $ (>. val (0 :: Int)) $ subSelectCount $ do
verification <- from $ table @SqlEmailVerification
where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
&&. verification ^. SqlEmailVerificationSecret ==. val secret
fmap (> 0) $ deleteCount $ do
verification <- from (table @SqlEmailVerification)
where_ $ verification ^. SqlEmailVerificationSecret ==. val secret
getUserEmail' :: UserID -> Bool -> SqlM (Maybe (Entity SqlEmail))
getUserEmail' user verified = fmap listToMaybe $ select $ do
email <- from $ table @SqlEmail
where_ $ email ^. SqlEmailUid ==. val (fromID user)
&&. isNothing (email ^. SqlEmailVid) ==. val verified
pure email
getUserEmail :: UserID -> SqlM (Maybe (Entity SqlEmail))
getUserEmail user = getUserEmail' user True
getUserPendingEmail :: UserID -> SqlM (Maybe (Entity SqlEmail))
getUserPendingEmail user = getUserEmail' user False
addEmail :: SqlEmail -> SqlM (Key SqlEmail)
addEmail = insert
addEmailVerification :: Text -> Time -> SqlM (Key SqlEmailVerification)
addEmailVerification secret expires = do
insert $ SqlEmailVerification
{ sqlEmailVerificationSecret = secret
, sqlEmailVerificationExpires = expires
}
getEmailVerificationSecret :: UserID -> SqlM (Maybe Text)
getEmailVerificationSecret userID = fmap (listToMaybe . fmap unValue) $ select $ do
verification <- from $ table @SqlEmailVerification
where_ $ (>. val (0 :: Int)) $ subSelectCount $ do
email <- from $ table @SqlEmail
where_ $ email ^. SqlEmailUid ==. val (fromID userID) &&.
email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
pure $ verification ^. SqlEmailVerificationSecret
deleteExpiredEmails :: Time -> SqlM ()
deleteExpiredEmails time = delete $ do
verification <- from $ table @SqlEmailVerification
where_ $ verification ^. SqlEmailVerificationExpires <=. val time
deleteUnverifiedEmail :: UserID -> SqlM ()
deleteUnverifiedEmail user = delete $ do
email <- from $ table @SqlEmail
where_ $ email ^. SqlEmailUid ==. val (fromID user) &&. not_ (isVerified email)
deleteOrphanedVerifications :: SqlM ()
deleteOrphanedVerifications = delete $ do
verification <- from $ table @SqlEmailVerification
where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
email <- from $ table @SqlEmail
where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
deleteUsersWithoutEmail :: SqlM ()
deleteUsersWithoutEmail = delete $ do
user <- from $ table @SqlUser
where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
email <- from $ table @SqlEmail
where_ $ email ^. SqlEmailUid ==. user ^. SqlUserId
pure $ email ^. SqlEmailId -- Not used anywhere
updateEmail :: UserID -> Email -> Text -> Time -> SqlM (Key SqlEmail)
updateEmail user email secret expires = do
delete $ do
dbEmail <- from $ table @SqlEmail
where_ $ dbEmail ^. SqlEmailUid ==. val (fromID user) &&. not_ (isVerified dbEmail)
verifiedEmail <- fmap listToMaybe $ select $ do
dbEmail <- from $ table @SqlEmail
where_ $ dbEmail ^. SqlEmailUid ==. val (fromID user)
&&. dbEmail ^. SqlEmailEmail ==. val email
pure dbEmail
case verifiedEmail of
Just (Entity key _) -> pure key
Nothing -> do
verificationId <- insert SqlEmailVerification
{ sqlEmailVerificationSecret = secret
, sqlEmailVerificationExpires = expires
}
insert SqlEmail
{ sqlEmailUid = fromID user
, sqlEmailEmail = email
, sqlEmailVid = Just verificationId
}
markAsAccepted :: UserID -> Time -> SqlM Bool
markAsAccepted userID time = fmap (> 0) $ updateCount $ \user -> do
set user [SqlUserAccepted =. just (val time)]
where_ $ user ^. SqlUserId ==. val (fromID userID) &&. isApplicant user
deleteApplication :: UserID -> SqlM Bool
deleteApplication userID = fmap (> 0) $ deleteCount $ do
user <- from $ table @SqlUser
where_ $ user ^. SqlUserId ==. val (fromID userID) &&. isApplicant user
updateUserData :: UserID -> [Persist.Update SqlUser] -> [UserUpdate] -> SqlM ()
updateUserData user updates memberDataUpdates = do
let key = fromID user
Just userData <- get key
let Success memberData = fromJSON $ sqlUserMemberData userData :: Result MemberData
userUpdates = [SqlUserMemberData 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 }
updateData (SetUserPhoneNumber x) memberData = memberData { phoneNumber = x }
updateData (SetUserApplication x) memberData = memberData { application = x }
Persist.update key (userUpdates <> updates)
data UserUpdate = SetUserName Text
| SetUserNickname (Maybe Text)
| SetUserHomeplace Text
| SetUserPhoneNumber PhoneNumber
| SetUserApplication Text

View File

@ -0,0 +1,98 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Datarekisteri.Backend.Sql.Types where
import Data.ByteString (ByteString)
import Data.Text (Text)
import Database.Persist (Entity, Key, entityKey, PersistEntity)
import Database.Persist.Postgresql.JSON (Value)
import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
import Datarekisteri.Core.Types
import Datarekisteri.Backend.Types
mkPersist sqlSettings [persistUpperCase|
SqlUser sql=users
registered Time
passwordCrypt PasswordHash
permissions Text
accepted (Maybe Time)
memberData Value sqltype=jsonb
deriving (Show)
SqlEmail sql=emails
uid SqlUserId
email Email sqltype=varchar(320)
vid (Maybe SqlEmailVerificationId) sql=verification
UniqueUserVerified uid vid
-- This enables using persistent functions to get unique verified emails. The real
-- constraint is stricter and doesn't allow having more than one null and one non-null
-- verification but it's too complicated for persistent to understand.
UniqueEmail email
UniqueVerification vid
SqlEmailVerification sql=emailVerifications
secret Text sqltype=varchar(255)
expires Time
UniqueVerificationSecret secret
SqlKey sql=keys
uid SqlUserId
data ByteString
expires (Maybe Time)
uploaded Time
comment Text
isPrimaryEncryptionKey Bool
SqlToken sql=tokens
uid SqlUserId
name (Maybe Text)
data Text
comment Text
issued Time
expires (Maybe Time)
permissions Text
UniqueNameUid name uid
UniqueData data
|]
entityToID :: EntityID a => Entity (DB a) -> a
entityToID = toID . entityKey
class PersistEntity (DB a) => EntityID a where
type DB a
toID :: Key (DB a) -> a
fromID :: a -> Key (DB a)
instance EntityID UserID where
type DB UserID = SqlUser
toID = UserID . fromIntegral . fromSqlKey
fromID (UserID x) = toSqlKey $ fromIntegral x
instance EntityID TokenID where
type DB TokenID = SqlToken
toID = TokenID . fromIntegral . fromSqlKey
fromID (TokenID x) = toSqlKey $ fromIntegral x
instance EntityID KeyID where
type DB KeyID = SqlKey
toID = KeyID . fromIntegral . fromSqlKey
fromID (KeyID x) = toSqlKey $ fromIntegral x

View File

@ -1,11 +1,16 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -13,18 +18,19 @@ module Datarekisteri.Backend.Types where
import Relude import Relude
import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Control.Monad.Logger (LoggingT)
import Datarekisteri.Core.Types
import Data.Aeson (ToJSON(..), FromJSON(..)) import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.ByteArray (ByteArray, ByteArrayAccess) import Data.ByteArray (ByteArray, ByteArrayAccess)
import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation) import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation)
import Data.Morpheus.Types (MonadError, GQLError) import Data.Morpheus.Types (MonadError, GQLError, GQLType)
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import Database.Persist.Class (PersistField(..)) import Database.Persist.Class (PersistField(..))
import Database.Persist.Sql (PersistFieldSql(..), SqlBackend) import Database.Persist.Sql (PersistFieldSql(..))
import Network.Mail.Mime (Mail, Address(..)) import Network.Mail.Mime (Mail, Address(..))
import "cryptonite" Crypto.Random (MonadRandom(..))
import Datarekisteri.Core.Types
forward :: Monad m => [a] -> m [Maybe a] forward :: Monad m => [a] -> m [Maybe a]
forward = pure . map Just forward = pure . map Just
@ -46,9 +52,102 @@ data MemberData = MemberData
instance FromJSON MemberData instance FromJSON MemberData
instance ToJSON MemberData instance ToJSON MemberData
data ApplicationData = ApplicationData
{ email :: Email
, phoneNumber :: PhoneNumber
, password :: Text
, name :: Text
, nickname :: Maybe Text
, birthdate :: Date
, homeplace :: Text
, application :: Text
, registered :: Time
, verificationSecret :: Text
, passwordHash :: PasswordHash
, permissions :: Text
} deriving (Generic, Eq, Show)
data UpdateData = UpdateData
{ email :: Maybe Email
, phoneNumber :: Maybe PhoneNumber
, passwordHash :: Maybe PasswordHash
, name :: Maybe Text
, nickname :: Maybe Text
, homeplace :: Maybe Text
, application :: Maybe Text
, user :: UserID
, updateTime :: Time
, verificationSecret :: Text
} deriving (Generic, Eq, Show)
data NewKeyData = NewKeyData
{ comment :: Maybe Text
, keyData :: ByteString
, expires :: Maybe Time
, uploaded :: Time
, user :: UserID
}
deriving (Generic, Eq, Show)
newtype Cursor = Cursor Text
deriving (Generic, Eq, Show)
deriving anyclass GQLType
data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
deriving (Generic, GQLType)
data NewTokenData = NewTokenData
{ comment :: Maybe Text
, name :: Maybe Text
, permissions :: Text
, tokenData :: Text
, issued :: Time
, expires :: Maybe Time
, user :: UserID
}
deriving (Generic, Eq, Show)
newtype PasswordHash = PasswordHash ByteString newtype PasswordHash = PasswordHash ByteString
deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray, deriving newtype (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess,
PersistField, PersistFieldSql) ByteArray, PersistField, PersistFieldSql)
data DBUser m = DBUser
{ dbUserId :: m UserID
, dbUserEmail :: m (Maybe Email)
, dbUserPendingEmail :: m (Maybe Email)
, dbUserName :: m Text
, dbUserNickname :: m Text
, dbUserPhoneNumber :: m PhoneNumber
, dbUserBirthdate :: m Date
, dbUserHomeplace :: m Text
, dbUserRegistered :: m Time
, dbUserAccepted :: m (Maybe Time)
, dbUserPermissions :: m Text
, dbUserApplication :: m Text
, dbUserPasswordHash :: m PasswordHash
, dbUserTokens :: m [DBToken m]
, dbUserKeys :: m [DBPGPKey m]
, dbUserPrimaryKey :: m (Maybe (DBPGPKey m))
}
data DBPGPKey m = DBPGPKey
{ dbPGPKeyId :: m KeyID
, dbPGPKeyData :: m Base64
, dbPGPKeyExpires :: m (Maybe Time)
, dbPGPKeyUploaded :: m Time
, dbPGPKeyComment :: m Text
}
data DBToken m = DBToken
{ dbTokenId :: m TokenID
, dbTokenUser :: m (DBUser m)
, dbTokenName :: m (Maybe Text)
, dbTokenData :: m Text
, dbTokenComment :: m Text
, dbTokenIssued :: m Time
, dbTokenExpires :: m (Maybe Time)
, dbTokenPermissions :: m Text
}
class Monad m => MonadTime m where class Monad m => MonadTime m where
currentTime :: m Time currentTime :: m Time
@ -56,11 +155,22 @@ class Monad m => MonadTime m where
instance MonadTime IO where instance MonadTime IO where
currentTime = Time <$> getCurrentTime currentTime = Time <$> getCurrentTime
type DBEither a = Either String a
class Monad m => MonadDB m where class Monad m => MonadDB m where
runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a dbUpdateUser :: UpdateData -> m (DBEither (DBUser m))
-- TODO refactor so that it is possible to define a IO-less db, for safety and testability. dbAddUser :: ApplicationData -> m (DBEither (DBUser m))
-- Is there a way to do this that doesn't require moving all db calls to the class? dbAcceptApplication :: UserID -> Time -> m (DBEither ())
-- Probably not :( dbRejectApplication :: UserID -> m (DBEither ())
dbVerifyEmail :: Text -> m (DBEither ())
dbAddToken :: NewTokenData -> m (DBEither (DBToken m))
dbAddKey :: NewKeyData -> m (DBEither (DBPGPKey m))
dbGetUser :: UserID -> m (DBEither (DBUser m))
dbGetUserByEmail :: Email -> m (DBEither (DBUser m)) -- XXX should this be Maybe instead
dbGetUsers :: m [DBUser m]
dbGetApplications :: m [DBUser m]
dbGetTokenBySecret :: Text -> m (DBEither (DBToken m))
dbGetEmailVerificationSecret :: UserID -> m (DBEither (Maybe Text))
class Monad m => MonadEmail m where class Monad m => MonadEmail m where
sendEmail :: Mail -> m () sendEmail :: Mail -> m ()
@ -76,7 +186,19 @@ class Monad m => MonadPermissions m where
toPermissions :: Text -> m (Maybe Text) toPermissions :: Text -> m (Maybe Text)
instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
runQuery = lift . runQuery dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser
dbAddUser = fmap (fmap liftUser) . lift . dbAddUser
dbAcceptApplication user = lift . dbAcceptApplication user
dbRejectApplication = lift . dbRejectApplication
dbVerifyEmail = lift . dbVerifyEmail
dbAddToken = fmap (fmap liftToken) . lift . dbAddToken
dbAddKey = fmap (fmap liftKey) . lift . dbAddKey
dbGetUser = fmap (fmap liftUser) . lift . dbGetUser
dbGetUserByEmail = fmap (fmap liftUser) . lift . dbGetUserByEmail
dbGetUsers = fmap (map liftUser) $ lift $ dbGetUsers
dbGetApplications = fmap (map liftUser) $ lift $ dbGetApplications
dbGetEmailVerificationSecret = lift . dbGetEmailVerificationSecret
dbGetTokenBySecret = fmap (fmap liftToken) . lift . dbGetTokenBySecret
instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where
currentUser = lift currentUser currentUser = lift currentUser
@ -96,3 +218,44 @@ instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where
instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
currentTime = lift currentTime currentTime = lift currentTime
liftUser :: (MonadTrans t, Monad m, Monad (t m)) => DBUser m -> DBUser (t m)
liftUser DBUser {..} = DBUser
{ dbUserId = lift dbUserId
, dbUserEmail = lift dbUserEmail
, dbUserPendingEmail = lift dbUserPendingEmail
, dbUserName = lift dbUserName
, dbUserNickname = lift dbUserNickname
, dbUserPhoneNumber = lift dbUserPhoneNumber
, dbUserBirthdate = lift dbUserBirthdate
, dbUserHomeplace = lift dbUserHomeplace
, dbUserRegistered = lift dbUserRegistered
, dbUserAccepted = lift dbUserAccepted
, dbUserPermissions = lift dbUserPermissions
, dbUserApplication = lift dbUserApplication
, dbUserPasswordHash = lift dbUserPasswordHash
, dbUserTokens = map liftToken <$> lift dbUserTokens
, dbUserKeys = map liftKey <$> lift dbUserKeys
, dbUserPrimaryKey = fmap liftKey <$> lift dbUserPrimaryKey
}
liftToken :: (MonadTrans t, Monad m, Monad (t m)) => DBToken m -> DBToken (t m)
liftToken DBToken {..} = DBToken
{ dbTokenId = lift dbTokenId
, dbTokenUser = fmap liftUser $ lift dbTokenUser
, dbTokenName = lift dbTokenName
, dbTokenData = lift dbTokenData
, dbTokenComment = lift dbTokenComment
, dbTokenIssued = lift dbTokenIssued
, dbTokenExpires = lift dbTokenExpires
, dbTokenPermissions = lift dbTokenPermissions
}
liftKey :: (MonadTrans t, Monad m, Monad (t m)) => DBPGPKey m -> DBPGPKey (t m)
liftKey DBPGPKey {..} = DBPGPKey
{ dbPGPKeyId = lift dbPGPKeyId
, dbPGPKeyData = lift dbPGPKeyData
, dbPGPKeyExpires = lift dbPGPKeyExpires
, dbPGPKeyUploaded = lift dbPGPKeyUploaded
, dbPGPKeyComment = lift dbPGPKeyComment
}

View File

@ -2,12 +2,15 @@
module Datarekisteri.Backend.Utils where module Datarekisteri.Backend.Utils where
import "cryptonite" Crypto.Random (MonadRandom)
import Data.ByteArray.Encoding (convertToBase, Base(..)) import Data.ByteArray.Encoding (convertToBase, Base(..))
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword) import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
import "cryptonite" Crypto.Random (MonadRandom)
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
base32 :: ByteString -> Text base32 :: ByteString -> Text

View File

@ -12,13 +12,18 @@ import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Logger (runStderrLoggingT) import Control.Monad.Logger (runStderrLoggingT)
import Data.Aeson (toJSON) import Data.Aeson (toJSON)
import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn) import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
import Datarekisteri.Backend.DB import System.IO.Echo (withoutInputEcho)
import Datarekisteri.Backend.DB.Queries
import Options.Applicative
import Datarekisteri.Backend.Sql (MonadSql, runQuery)
import qualified Datarekisteri.Backend.Sql.Queries as Sql
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils import Datarekisteri.Backend.Utils
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Options.Applicative
import System.IO.Echo (withoutInputEcho)
main :: IO () main :: IO ()
main = do main = do
@ -33,36 +38,36 @@ addUserMain :: AddUserOpts -> CLIM ()
addUserMain AddUserOpts {..} = do addUserMain AddUserOpts {..} = do
time <- currentTime time <- currentTime
passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword
userID <- addUser $ DBUser runQuery $ do
{ dBUserRegistered = time userID <- Sql.addUser $ SqlUser
, dBUserPasswordCrypt = passwordHash { sqlUserRegistered = time
, dBUserPermissions = show addUserPermissions , sqlUserPasswordCrypt = passwordHash
, dBUserAccepted = Just time , sqlUserPermissions = show addUserPermissions
, dBUserMemberData = toJSON $ MemberData , sqlUserAccepted = Just time
{ nickname = addUserNickname , sqlUserMemberData = toJSON $ MemberData
, name = addUserName { nickname = addUserNickname
, birthdate = addUserBirthdate , name = addUserName
, homeplace = addUserHomeplace , birthdate = addUserBirthdate
, application = addUserApplication , homeplace = addUserHomeplace
, phoneNumber = addUserPhoneNumber , application = addUserApplication
, phoneNumber = addUserPhoneNumber
}
}
void $ Sql.addEmail $ SqlEmail
{ sqlEmailUid = fromID userID
, sqlEmailEmail = addUserEmail
, sqlEmailVid = Nothing
} }
}
_ <- addEmail $ DBEmail
{ dBEmailUid = toDBKey userID
, dBEmailEmail = addUserEmail
, dBEmailVid = Nothing
}
pure ()
gcEmailsMain :: CLIM () gcEmailsMain :: CLIM ()
gcEmailsMain = do gcEmailsMain = do
time <- currentTime time <- currentTime
deleteExpiredEmails time runQuery $ do
deleteOrphanedVerifications Sql.deleteExpiredEmails time
Sql.deleteOrphanedVerifications
gcApplicationsMain :: CLIM () gcApplicationsMain :: CLIM ()
gcApplicationsMain = do gcApplicationsMain = runQuery $ Sql.deleteUsersWithoutEmail
deleteUsersWithoutEmail
gcAllMain :: CLIM () gcAllMain :: CLIM ()
gcAllMain = do gcAllMain = do
@ -124,7 +129,7 @@ newtype CLIM a = CLIM (ReaderT String IO a)
instance MonadTime CLIM where instance MonadTime CLIM where
currentTime = liftIO currentTime currentTime = liftIO currentTime
instance MonadDB CLIM where instance MonadSql CLIM where
runQuery query = do runQuery query = do
dbUrl <- ask dbUrl <- ask
liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query

4
backend/src/Main.hs Normal file
View File

@ -0,0 +1,4 @@
import qualified Datarekisteri.Backend as Backend
main :: IO ()
main = Backend.main

View File

@ -1,14 +1,17 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Core.Types where module Datarekisteri.Core.Types where
import Relude import Relude
import qualified "base64" Data.ByteString.Base64 as B64
import Data.Aeson (ToJSON(..), FromJSON(..)) import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Morpheus.Server.Types (SCALAR) import Data.Morpheus.Server.Types (SCALAR)
@ -21,7 +24,6 @@ import Database.Persist.PersistValue (PersistValue(..))
import Database.Persist.Sql (PersistFieldSql(..)) import Database.Persist.Sql (PersistFieldSql(..))
import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress) import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64, decodeBase64)
import qualified Data.Text as T import qualified Data.Text as T
base64Encode :: ByteString -> Base64 base64Encode :: ByteString -> Base64

View File

@ -21,7 +21,6 @@ enum Unit {
type PGPKey { type PGPKey {
id: KeyID! id: KeyID!
user: User!
pgpKeyData: Base64! pgpKeyData: Base64!
expires: Time expires: Time
uploaded: Time! uploaded: Time!
@ -30,7 +29,6 @@ type PGPKey {
type Token { type Token {
id: TokenID! id: TokenID!
user: User!
name: String name: String
tokenData: String! tokenData: String!
comment: String! comment: String!
@ -53,23 +51,23 @@ type User {
permissions: String! permissions: String!
isMember: Boolean! isMember: Boolean!
application: String! application: String!
tokens: [Token!]!
keys: [PGPKey!]!
primaryKey: PGPKey
} }
type Query { type Query {
users: [User!]! users: [User!]!
user(id: UserID): User user(id: UserID): User
applications: [User!]! applications: [User!]!
tokens(user: UserID): [Token!]!
keys(user: UserID): [PGPKey!]!
permissions: String! permissions: String!
primaryKey(user: UserID): PGPKey
} }
type Mutation { type Mutation {
apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User! apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
verifyEmail(secret: String!): Unit! verifyEmail(secret: String!): Unit!
resendVerificationEmail(user: UserID): Unit! resendVerificationEmail(user: UserID): Unit!
update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, user: UserID): User! update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, user: UserID): User!
newToken(comment: String, name: String, permissions: String): Token! newToken(comment: String, name: String, permissions: String): Token!
newKey(comment: String, keyData: Base64!, expires: Time): PGPKey! newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
accept(user: UserID!): Unit! accept(user: UserID!): Unit!

View File

@ -1,26 +1,27 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
import Relude hiding (get) import Relude hiding (get)
import Yesod import System.Directory (createDirectoryIfMissing)
import Yesod.Auth import Yesod.Static (static, Static)
import Yesod (mkYesodDispatch, warp)
import Yesod.Auth (getAuth)
import Options.Applicative
import Datarekisteri.Frontend.Types import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.Handlers import Datarekisteri.Frontend.Handlers
import Datarekisteri.Frontend.Auth ()
import Yesod.Static (static, Static)
import Options.Applicative
import System.Directory (createDirectoryIfMissing)
mkYesodDispatch "DataIdClient" resourcesDataIdClient mkYesodDispatch "DataIdClient" resourcesDataIdClient

View File

@ -13,9 +13,10 @@ module Datarekisteri.Frontend.ApiRequests where
import Relude import Relude
import Data.Morpheus.Client import Data.Aeson (ToJSON, FromJSON)
import Yesod hiding (Header) import Data.Morpheus.Client (RequestType, RequestArgs, Args, GQLClientResult, FetchError(..), single, request, withHeaders)
import Yesod.Auth import Yesod (HandlerFor, getYesod, liftHandler)
import Yesod.Auth (YesodAuth, AuthId, requireAuthId, maybeAuthId)
type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a) type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)
-- From Data.Morpheus.Client.Fetch.RequestType -- From Data.Morpheus.Client.Fetch.RequestType

View File

@ -1,12 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -14,11 +14,11 @@ module Datarekisteri.Frontend.Auth where
import Relude import Relude
import Datarekisteri.Core.Types import qualified "base64" Data.ByteString.Base64 as B64
import Data.Morpheus.Client
import Yesod import Yesod
import Yesod.Auth import Yesod.Auth
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
pluginName = "externalBasic" pluginName = "externalBasic"

View File

@ -1,5 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -8,14 +8,16 @@ module Datarekisteri.Frontend.FormFields where
import Relude import Relude
import Yesod import Yesod
import Datarekisteri.Frontend.Types
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Datarekisteri.Frontend.Types
emailField :: Field Handler Email emailField :: Field Handler Email
emailField = Field emailField = Field
{ fieldParse = \rawValues _ -> { fieldParse = \rawValues _ ->
case rawValues of case rawValues of
[] -> pure $ Right Nothing [] -> pure $ Right Nothing
[""] -> pure $ Right Nothing
[x] -> pure $ maybe (Left "could not parse as an email address") (Right . Just) $ toEmail x [x] -> pure $ maybe (Left "could not parse as an email address") (Right . Just) $ toEmail x
_ -> pure $ Left $ "Expected one value" _ -> pure $ Left $ "Expected one value"
, fieldView = \id name otherAttributes result isRequired -> , fieldView = \id name otherAttributes result isRequired ->
@ -41,6 +43,9 @@ telephoneField = Field
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
Textarea textareaField
verifiedPasswordField :: Field Handler Text verifiedPasswordField :: Field Handler Text
verifiedPasswordField = Field verifiedPasswordField = Field
{ fieldParse = \rawValues _ -> { fieldParse = \rawValues _ ->

View File

@ -1,31 +1,33 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Frontend.Handlers module Datarekisteri.Frontend.Handlers
( module Datarekisteri.Frontend.Handlers.Profile ( module Datarekisteri.Frontend.Handlers.Profile
, module Datarekisteri.Frontend.Handlers.Apply
, module Datarekisteri.Frontend.Handlers.Applications , module Datarekisteri.Frontend.Handlers.Applications
, module Datarekisteri.Frontend.Handlers.VerifyEmail , module Datarekisteri.Frontend.Handlers.Apply
, module Datarekisteri.Frontend.Handlers.Members , module Datarekisteri.Frontend.Handlers.Members
, module Datarekisteri.Frontend.Handlers.VerifyEmail
, getHomeR , getHomeR
) where ) where
import Relude import Relude
import Yesod
import Yesod.Auth
import Datarekisteri.Frontend.Handlers.Profile import Datarekisteri.Frontend.Handlers.Profile
import Datarekisteri.Frontend.Handlers.Apply import Datarekisteri.Frontend.Handlers.Apply
import Datarekisteri.Frontend.Handlers.Applications import Datarekisteri.Frontend.Handlers.Applications
import Datarekisteri.Frontend.Handlers.VerifyEmail import Datarekisteri.Frontend.Handlers.VerifyEmail
import Datarekisteri.Frontend.Handlers.Members import Datarekisteri.Frontend.Handlers.Members
import Datarekisteri.Frontend.Types import Datarekisteri.Frontend.Types
import Yesod
import Yesod.Auth
getHomeR :: Handler Html getHomeR :: Handler Html
getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR) getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)

View File

@ -1,12 +1,12 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -14,15 +14,17 @@ module Datarekisteri.Frontend.Handlers.Applications where
import Relude hiding (id) import Relude hiding (id)
import Datarekisteri.Frontend.ApiRequests import Data.Maybe (fromJust)
import Datarekisteri.Frontend.Types import Data.Time (Day)
import Data.Morpheus.Client import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Datarekisteri.Core.Types hiding (Applications)
import Yesod hiding (emailField) import Yesod hiding (emailField)
import Yesod.Auth import Yesod.Auth
import Datarekisteri.Core.Types hiding (Applications)
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.FormFields import Datarekisteri.Frontend.FormFields
import Data.Time (Day) import Datarekisteri.Frontend.Types
import Data.Maybe (fromJust)
declareLocalTypesInline "schema.gql" [raw| declareLocalTypesInline "schema.gql" [raw|
query Applications { query Applications {

View File

@ -1,12 +1,12 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -14,14 +14,16 @@ module Datarekisteri.Frontend.Handlers.Apply where
import Relude hiding (id) import Relude hiding (id)
import Datarekisteri.Frontend.ApiRequests import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Datarekisteri.Frontend.Types import Data.Time (Day)
import Data.Morpheus.Client
import Datarekisteri.Core.Types
import Yesod hiding (emailField) import Yesod hiding (emailField)
import Yesod.Auth import Yesod.Auth
import Datarekisteri.Core.Types
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.FormFields import Datarekisteri.Frontend.FormFields
import Data.Time (Day) import Datarekisteri.Frontend.Types
declareLocalTypesInline "schema.gql" [raw| declareLocalTypesInline "schema.gql" [raw|
mutation Apply($name: String!, $nickname: String, $homeplace: String!, mutation Apply($name: String!, $nickname: String, $homeplace: String!,
@ -46,8 +48,6 @@ applyForm = renderDivs $ ApplyArgs
where dayField' :: Field Handler Date where dayField' :: Field Handler Date
dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date)) dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
(\(Date x) -> x) dayField (\(Date x) -> x) dayField
textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
Textarea textareaField
nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]} nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]} nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]} homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}

View File

@ -12,12 +12,14 @@ module Datarekisteri.Frontend.Handlers.Members where
import Relude hiding (id) import Relude hiding (id)
import Data.Morpheus.Client import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod
import Yesod.Auth
import Datarekisteri.Frontend.Types import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Yesod
import Yesod.Auth
declareLocalTypesInline "schema.gql" [raw| declareLocalTypesInline "schema.gql" [raw|
query MembersPage { query MembersPage {

View File

@ -1,12 +1,12 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -14,14 +14,16 @@ module Datarekisteri.Frontend.Handlers.Profile where
import Relude hiding (id) import Relude hiding (id)
import Data.Maybe (fromJust)
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod hiding (emailField)
import Yesod.Auth
import Datarekisteri.Core.Types
import Datarekisteri.Frontend.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.Types import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.FormFields import Datarekisteri.Frontend.FormFields
import Data.Morpheus.Client
import Datarekisteri.Core.Types
import Data.Maybe (fromJust)
import Yesod hiding (emailField)
import Yesod.Auth
declareLocalTypesInline "schema.gql" [raw| declareLocalTypesInline "schema.gql" [raw|
query ProfilePage($id: UserID) { query ProfilePage($id: UserID) {
@ -35,14 +37,15 @@ query ProfilePage($id: UserID) {
birthdate birthdate
phoneNumber phoneNumber
isMember isMember
application
} }
permissions permissions
} }
|] |]
declareLocalTypesInline "schema.gql" [raw| declareLocalTypesInline "schema.gql" [raw|
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber) { mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber, $application: String) {
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber) { update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber, application: $application) {
id id
} }
} }
@ -71,9 +74,12 @@ profileForm userID user extraHtml = do
(maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user) (maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user)
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero" (phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in phoneNumber) user) (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in phoneNumber) user)
(applicationRes, applicationView) <- mopt textareaField' "Jäsenhakemus"
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in application) user)
let profileUpdateRes = UpdateProfileArgs userID <$> let profileUpdateRes = UpdateProfileArgs userID <$>
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes <*> applicationRes
maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
canUpdateApplication = maybe False (\x -> let ProfilePageUser {..} = x in not isMember) user
inputField FieldView {..} = [whamlet| inputField FieldView {..} = [whamlet|
<label for="#{fvId}"> <label for="#{fvId}">
^{fvLabel} ^{fvLabel}
@ -91,6 +97,8 @@ profileForm userID user extraHtml = do
<a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail} <a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
odottaa vahvistusta. # odottaa vahvistusta. #
<a href="@{VerifyEmailR}">Siirry vahvistamaan <a href="@{VerifyEmailR}">Siirry vahvistamaan
$if canUpdateApplication
^{inputField applicationView}
|] |]
return (profileUpdateRes, widget) return (profileUpdateRes, widget)

View File

@ -1,11 +1,11 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -13,12 +13,14 @@ module Datarekisteri.Frontend.Handlers.VerifyEmail where
import Relude import Relude
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod
import Yesod.Auth
import Datarekisteri.Frontend.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.Types import Datarekisteri.Frontend.Types
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Data.Morpheus.Client
import Yesod
import Yesod.Auth
declareLocalTypesInline "schema.gql" [raw| declareLocalTypesInline "schema.gql" [raw|
mutation VerifyEmail($secret: String!) { mutation VerifyEmail($secret: String!) {

View File

@ -16,20 +16,22 @@
module Datarekisteri.Frontend.Types where module Datarekisteri.Frontend.Types where
import Relude hiding (id) import Relude hiding (id)
import Relude.Extra.Foldable1 (maximum1)
import Yesod import Data.Map (findWithDefault)
import Yesod.Core.Handler (getCurrentRoute) import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Auth
import Yesod.Static
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show) import Data.Time.Format.ISO8601 (iso8601Show)
import Datarekisteri.Frontend.Auth import Relude.Extra.Foldable1 (maximum1)
import Yesod.Core.Handler (getCurrentRoute)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod
import Yesod.Auth
import Yesod.Static
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
import Datarekisteri.Frontend.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Data.Morpheus.Client import Datarekisteri.Frontend.Auth
import Data.Map (findWithDefault)
data DataIdClient = DataIdClient data DataIdClient = DataIdClient
{ getStatic :: Static { getStatic :: Static