Abstract SQL table structure from database queries

This commit is contained in:
Saku Laesvuori 2023-10-02 17:45:56 +03:00
parent d2f1b07922
commit 3942d547e0
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
10 changed files with 984 additions and 570 deletions

View File

@ -18,6 +18,7 @@ executable datarekisteri-backend
datarekisteri-core,
email-validate,
esqueleto,
http-types,
memory,
mime-mail,
monad-logger,
@ -45,7 +46,9 @@ executable datarekisteri-backend
other-modules:
Datarekisteri.Backend.API,
Datarekisteri.Backend.DB,
Datarekisteri.Backend.DB.Queries,
Datarekisteri.Backend.Sql,
Datarekisteri.Backend.Sql.Types,
Datarekisteri.Backend.Sql.Queries,
Datarekisteri.Backend.Email,
Datarekisteri.Backend.Types,
Datarekisteri.Backend.Utils,
@ -82,8 +85,9 @@ executable datarekisteri-cli
time
main-is: Datarekisteri/CLI.hs
other-modules:
Datarekisteri.Backend.DB,
Datarekisteri.Backend.DB.Queries,
Datarekisteri.Backend.Sql,
Datarekisteri.Backend.Sql.Types,
Datarekisteri.Backend.Sql.Queries,
Datarekisteri.Backend.Types,
Datarekisteri.Backend.Utils,
hs-source-dirs: src

View File

@ -9,24 +9,25 @@ import Relude
import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Logger (runStderrLoggingT)
import Control.Monad.Except (catchError)
import Data.Map (findWithDefault)
import Data.Text (toLower, breakOn, stripPrefix)
import Database.Persist (entityVal)
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.Wai (Application)
import Network.Wai.Handler.Warp (Port, run)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.Gzip
import Datarekisteri.Backend.API
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries (getUserByEmail, getPermissions, getToken)
import qualified Datarekisteri.Backend.Sql as Sql
import Datarekisteri.Backend.Sql (MonadSql)
import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils (checkPassword)
import System.Directory (findExecutable)
import System.Process (callProcess)
import Options.Applicative hiding (header)
import Options.Applicative hiding (Success, header)
import qualified Options.Applicative as O
import Web.Scotty.Trans hiding (readEither)
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
@ -101,10 +102,15 @@ parseBearer auth = do
authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
authBearer Nothing m = m
authBearer (Just (BearerToken bearer)) m = do
token <- lift $ getToken bearer
let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal
let getUserPermissions = do
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
{ stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token
{ stateCurrentUser = user
, statePermissions = permissions
}
@ -123,21 +129,23 @@ parseBasic txt = do
authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
authBasic Nothing m = m
authBasic (Just basic) m = do
user <- verifyBasic basic
permissions <- maybe (pure mempty)
(fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user
DBUser {..} <- verifyBasic basic
permissions <- readPermission <$> lift dbUserPermissions >>=
fromMaybeFail status500 "Internal server error"
userID <- lift dbUserId
flip local m $ \state -> state
{ stateCurrentUser = user
{ stateCurrentUser = Just userID
, statePermissions = permissions
}
-- TODO Refact, no need to convert to id and rerequest permissions
verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID)
verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM)
verifyBasic BasicAuth {..} = do
user <- lift $ getUserByEmail emailAddress
if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user
then pure $ entityToID <$> user
else pure Nothing
Right user@DBUser {..} <- lift $ dbGetUserByEmail emailAddress
correctPassword <- checkPassword password <$> lift dbUserPasswordHash
if correctPassword
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)
deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)
@ -158,10 +166,29 @@ data Config = Config
instance MonadTime APIM where
currentTime = liftIO currentTime
instance MonadDB APIM where
instance MonadSql APIM where
runQuery query = do
dbUrl <- asks $ configDbUrl . stateConfig
liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query
dbUrl <- fmap encodeUtf8 $ asks $ configDbUrl . stateConfig
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
dbGetUserTokens = Sql.dbGetUserTokens
dbGetUserKeys = Sql.dbGetUserKeys
dbGetUserPrimaryKey = Sql.dbGetUserPrimaryKey
dbGetApplications = Sql.dbGetApplications
dbGetEmailVerificationSecret = Sql.dbGetEmailVerificationSecret
dbGetTokenBySecret = Sql.dbGetTokenBySecret
instance MonadEmail APIM where
sendEmail email = do
@ -200,3 +227,6 @@ runAPIM config (APIM m) = runReaderT m RequestState
, statePermissions = fromList []
, stateConfig = config
}
fromMaybeFail status err Nothing = raiseStatus status err
fromMaybeFail _ _ (Just x) = pure x

View File

@ -18,21 +18,17 @@
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 Control.Monad.Except (MonadError, throwError)
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.Types (defaultRootResolver, RootResolver(..), Undefined)
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
import Database.Persist (Entity, entityVal, entityKey, get, (=.))
import Datarekisteri.Core.Types
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries
import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
import Datarekisteri.Backend.Types
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.Utils
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
import qualified Data.Text as T (null, chunksOf, intercalate)
@ -45,210 +41,142 @@ targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) p
fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a
fromMaybeFail txt = maybe (throwError txt) pure
void :: Monad m => m a -> m Unit
void m = m >> pure Unit
voidU :: Monad m => m a -> m Unit
voidU m = m >> pure Unit
when :: Monad m => Bool -> m a -> m Unit
when b m = if b then void m else pure Unit
liftDBEither :: MonadError GQLError m => DBEither a -> m a
liftDBEither = either (throwError . fromString) pure
dbUserToUser :: MonadDB m => Entity DBUser -> User m
dbUserToUser user = let id = entityToID user
DBUser {..} = entityVal user
Success (MemberData {..}) = fromJSON dBUserMemberData
-- XXX: Explodes if database doesn't contain needed data
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
applicationArgsToData :: (MonadTime m, MonadRandom m, MonadPermissions m, MonadError GQLError m) =>
ApplicationArgs -> m ApplicationData
applicationArgsToData ApplicationArgs {..} = do
registered <- currentTime
verificationSecret <- genVerificationSecret
passwordHash <- hashPassword password
permissions <- defaultPermissions
when (T.null name) $ throwError "Name must not be empty"
when (T.null password) $ throwError "Password must not be empty"
when (T.null homeplace) $ throwError "Homeplace must not be empty"
let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
user <- addUser $ DBUser
{ dBUserRegistered = time
, dBUserPasswordCrypt = passwordHash
, dBUserPermissions = permissions
, dBUserAccepted = Nothing
, dBUserMemberData = toJSON memberData
}
verification <- addEmailVerification secret
email <- addEmail $ DBEmail
{ dBEmailUid = toDBKey user
, dBEmailEmail = email
, dBEmailVid = Just verification
}
sendVerificationSecret email
return user
pure ApplicationData {..}
newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
ApplicationArgs -> m (User m)
newUser args = do
applicationData <- applicationArgsToData args
user <- dbAddUser applicationData >>= liftDBEither
sendVerificationSecret user >>= flip unless (throwError "Sending email verification failed!")
return $ dbUserToUser user
genVerificationSecret :: MonadRandom m => m Text
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
sendVerificationSecret email = void $ do
maybeDBEmail <- runQuery $ get email
case maybeDBEmail of
Nothing -> pure Unit
Just dbEmail -> do
case dBEmailVid dbEmail of
Nothing -> pure Unit
Just dbVerificationId -> do
secret <- fmap (dBEmailVerificationSecret . fromJust) $ runQuery $ get dbVerificationId
let email = dBEmailEmail dbEmail
void $ sendVerificationEmail secret email
sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => DBUser m -> m Bool
sendVerificationSecret DBUser {..} = do
secret <- dbUserId >>= dbGetEmailVerificationSecret >>= liftDBEither
pendingEmail <- dbUserPendingEmail
case (secret, pendingEmail) of
(Just secret', Just pendingEmail') ->
sendVerificationEmail secret' pendingEmail' >> pure True
_ -> pure False
updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m) =>
UpdateArgs -> UserID -> m UpdateData
updateArgsToData UpdateArgs {..} user = do
when (maybe False T.null name) $ throwError "Name must not be empty"
when (maybe False T.null password) $ throwError "Password must not be empty"
when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
passwordHash <- sequence $ hashPassword <$> password
updateTime <- currentTime
verificationSecret <- genVerificationSecret
pure UpdateData {..}
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
UserID -> UpdateData -> m UserID
updateUser user (UpdateData {..}) = do
hash <- sequence $ hashPassword <$> password
-- TODO: assert stuff valid
user <- updateUserData user
(catMaybes [(DBUserPasswordCrypt =.) <$> hash])
(catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber])
case email of
Nothing -> pure Unit
Just email' -> do
verificationSecret <- genVerificationSecret
emailKey <- updateEmail user email' verificationSecret
sendVerificationSecret emailKey
return user
UserID -> UpdateArgs -> m (User m)
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) =>
NewTokenArgs -> UserID -> m TokenID
makeNewToken (NewTokenArgs {..}) user = do
tokenData <- B64.encodeBase64 <$> getRandomBytes 128
time <- currentTime
permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
addToken $ DBToken
{ dBTokenUid = toDBKey user
, dBTokenName = name
, dBTokenData = tokenData
, dBTokenComment = fromMaybe "" comment
, dBTokenIssued = time
, dBTokenExpires = Nothing
, dBTokenPermissions = permissions
}
NewTokenArgs -> UserID -> m (Token m)
makeNewToken args user = do
tokenData <- newTokenArgsToData args user
fmap dbTokenToToken $ dbAddToken tokenData >>= liftDBEither
newKeyArgsToData :: (MonadTime m, MonadError GQLError m) => NewKeyArgs -> UserID -> m NewKeyData
newKeyArgsToData NewKeyArgs {..} user = do
uploaded <- currentTime
keyData <- maybe (throwError "Invalid base64") pure $ base64Decode keyData
pure NewKeyData {..}
makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
KeyData -> UserID -> m KeyID
makeNewKey (KeyData {..}) user = do
time <- currentTime
keyData' <- fromMaybeFail "" $ base64Decode keyData
addKey $ DBKey
{ dBKeyUid = toDBKey user
, dBKeyData = keyData'
, dBKeyExpires = expires
, dBKeyUploaded = time
, dBKeyComment = fromMaybe "" comment
, dBKeyIsPrimaryEncryptionKey = True
}
NewKeyArgs -> UserID -> m (PGPKey m)
makeNewKey args user = do
newKeyData <- newKeyArgsToData args user
fmap dbPGPKeyToPGPKey $ dbAddKey newKeyData >>= liftDBEither
acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
acceptApplication user = void $ do
maybeEmail <- getUserEmail user
acceptApplication user = voidU $ do
maybeEmail <- dbGetUserEmail user >>= liftDBEither
case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do
time <- currentTime
applicationAccepted <- markAsAccepted user time
when applicationAccepted $
sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
dbAcceptApplication user time >>= liftDBEither
sendApplicationAcceptedEmail email
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
rejectApplication user = void $ do
maybeEmail <- getUserEmail user
rejectApplication user = voidU $ do
maybeEmail <- dbGetUserEmail user >>= liftDBEither
case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do
applicationDeleted <- deleteApplication user
when applicationDeleted $
sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
dbRejectApplication user
sendApplicationRejectedEmail email
resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
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 >>
fmap dbUserToUser <$> getByID user
, tokens = \(Arg id) -> targetUser id >>= \user ->
requirePermission (Tokens user) ReadOnly >> map dbTokenToToken <$> getUserTokens user
, applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> applicants
, keys = \(Arg id) -> targetUser id >>= \user ->
requirePermission (Profile user) ReadOnly >> map dbKeyToPGPKey <$> getKeys user
(Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
, tokens = \(Arg id) -> targetUser id >>= \user -> do
requirePermission (Tokens user) ReadOnly
map dbTokenToToken <$> (dbGetUserTokens user >>= liftDBEither)
, applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
, keys = \(Arg id) -> targetUser id >>= \user -> do
requirePermission (Profile user) ReadOnly
map dbPGPKeyToPGPKey <$> (dbGetUserKeys user >>= liftDBEither)
--, 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
, primaryKey = \(Arg id) -> targetUser id >>= \user -> do
requirePermission (Profile user) ReadOnly
fmap dbPGPKeyToPGPKey <$> (dbGetUserPrimaryKey user >>= liftDBEither)
, permissions = currentPermissions
}
resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
resolveMutation = Mutation
{ apply = \x -> do
userID <- newUser x
maybeUser <- getByID userID
user <- fromMaybeFail "" maybeUser
pure $ dbUserToUser user
, verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (not x) $ throwError "Invalid verification secret"
, 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 ""
{ apply = newUser
, verifyEmail = \(Arg secret) -> voidU $ dbVerifyEmail secret
, resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
, update = \updateArgs (Arg id) -> targetUser id >>= \user ->
requirePermission (Profile user) ReadWrite >> updateUser user updateArgs
, newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
requirePermission (Profile user) ReadWrite >> makeNewToken args user >>=
getByID >>= fmap dbTokenToToken . fromMaybeFail ""
requirePermission (Profile user) ReadWrite >> makeNewToken args user
, newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
requirePermission (Profile user) ReadWrite >> makeNewKey args user >>=
getByID >>= fmap dbKeyToPGPKey . fromMaybeFail ""
requirePermission (Profile user) ReadWrite >> makeNewKey args user
, accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id
, reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id
}
@ -262,6 +190,33 @@ resolver :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined
resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation }
data 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
} 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
{ id :: m UserID
, email :: m (Maybe Email)
@ -298,39 +253,6 @@ data Token m = Token
, permissions :: m Text
} 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
{ users :: m [User m]
, user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
@ -343,12 +265,51 @@ data Query m = Query
} deriving (Generic, GQLType)
data Mutation m = Mutation
{ apply :: ApplicationData -> m (User m)
{ apply :: ApplicationArgs -> m (User m)
, verifyEmail :: Arg "secret" Text -> m Unit
, resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
, update :: UpdateData -> Arg "user" (Maybe UserID) -> m (User m)
, update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m)
, newToken :: NewTokenArgs -> m (Token m)
, newKey :: KeyData -> m (PGPKey m)
, newKey :: NewKeyArgs -> m (PGPKey m)
, accept :: Arg "user" UserID -> m Unit
, reject :: Arg "user" UserID -> m Unit
} deriving (Generic, GQLType)
dbUserToUser :: Monad 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
}
dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m
dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
{ id = dbPGPKeyId
, user = dbUserToUser <$> dbPGPKeyUser
, pgpKeyData = dbPGPKeyData
, expires = dbPGPKeyExpires
, uploaded = dbPGPKeyUploaded
, comment = dbPGPKeyComment
}
dbTokenToToken :: Monad m => DBToken m -> Token m
dbTokenToToken DBToken {..} = Token
{ id = dbTokenId
, user = dbUserToUser <$> dbTokenUser
, name = dbTokenName
, tokenData = dbTokenData
, comment = dbTokenComment
, issued = dbTokenIssued
, expires = dbTokenExpires
, permissions = dbTokenPermissions
}

View File

@ -1,105 +1,24 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Backend.DB where
import Data.ByteString (ByteString)
import Data.Text (Text)
import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
import Database.Persist (Entity, Key, entityKey, PersistEntity)
import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Database.Persist.Postgresql.JSON (Value)
import Datarekisteri.Core.Types
import Relude
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
mkPersist sqlSettings [persistUpperCase|
DBUser sql=users
registered Time
passwordCrypt PasswordHash
permissions Text
accepted (Maybe Time)
memberData Value sqltype=jsonb
dbGetUserEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
dbGetUserEmail userID = do
userOrErr <- dbGetUser userID
case userOrErr of
Left err -> pure $ Left err
Right DBUser {..} -> Right <$> dbUserEmail
deriving (Show)
DBEmail sql=emails
uid DBUserId
email Email sqltype=varchar(320)
vid (Maybe DBEmailVerificationId) 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
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
dbGetUserPendingEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
dbGetUserPendingEmail userID = do
userOrErr <- dbGetUser userID
case userOrErr of
Left err -> pure $ Left err
Right DBUser {..} -> Right <$> dbUserPendingEmail

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

@ -0,0 +1,209 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Backend.Sql where
import Relude
import Data.Time (nominalDay)
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Sql.Queries (SqlM, UserUpdate(..))
import qualified Datarekisteri.Backend.Sql.Queries as Sql
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
import Database.Persist (Entity(..), (=.))
import Data.Aeson (Result(..), fromJSON, toJSON)
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
]
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
}
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
, dbPGPKeyUser =
let userID = toID sqlKeyUid
in fmap (sqlUserToDBUser userID . fromMaybe (error "Inconsistent DB at sqlKeyToDBKey!")) $
runQuery $ Sql.getUser userID
, dbPGPKeyData = pure $ base64Encode sqlKeyData
, dbPGPKeyExpires = pure sqlKeyExpires
, dbPGPKeyUploaded = pure sqlKeyUploaded
, dbPGPKeyComment = pure sqlKeyComment
}

View File

@ -0,0 +1,234 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Datarekisteri.Backend.Sql.Queries where
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Types (MemberData(..))
import Datarekisteri.Core.Types
import Data.Text (Text)
import Database.Esqueleto.Experimental
import Control.Monad.Logger (LoggingT)
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(..))
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 }
Persist.update key (userUpdates <> updates)
data UserUpdate = SetUserName Text
| SetUserNickname (Maybe Text)
| SetUserHomeplace Text
| SetUserPhoneNumber PhoneNumber

View File

@ -0,0 +1,97 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Datarekisteri.Backend.Sql.Types where
import Data.ByteString (ByteString)
import Data.Text (Text)
import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
import Database.Persist (Entity, Key, entityKey, PersistEntity)
import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Database.Persist.Postgresql.JSON (Value)
import 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 FlexibleInstances #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
@ -14,15 +19,14 @@ module Datarekisteri.Backend.Types where
import Relude
import Control.Monad.Except (throwError)
import Control.Monad.Logger (LoggingT)
import Datarekisteri.Core.Types
import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.ByteArray (ByteArray, ByteArrayAccess)
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 Database.Persist.Class (PersistField(..))
import Database.Persist.Sql (PersistFieldSql(..), SqlBackend)
import Database.Persist.Sql (PersistFieldSql(..))
import Network.Mail.Mime (Mail, Address(..))
import "cryptonite" Crypto.Random (MonadRandom(..))
@ -46,9 +50,99 @@ data MemberData = MemberData
instance FromJSON 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
, 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
deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray,
PersistField, PersistFieldSql)
deriving newtype (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess,
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
}
data DBPGPKey m = DBPGPKey
{ dbPGPKeyId :: m KeyID
, dbPGPKeyUser :: m (DBUser m)
, 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
currentTime :: m Time
@ -56,11 +150,25 @@ class Monad m => MonadTime m where
instance MonadTime IO where
currentTime = Time <$> getCurrentTime
type DBEither a = Either String a
class Monad m => MonadDB m where
runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a
-- TODO refactor so that it is possible to define a IO-less db, for safety and testability.
-- Is there a way to do this that doesn't require moving all db calls to the class?
-- Probably not :(
dbUpdateUser :: UpdateData -> m (DBEither (DBUser m))
dbAddUser :: ApplicationData -> m (DBEither (DBUser m))
dbAcceptApplication :: UserID -> Time -> m (DBEither ())
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]
dbGetUserTokens :: UserID -> m (DBEither [DBToken m])
dbGetUserKeys :: UserID -> m (DBEither [DBPGPKey m])
dbGetUserPrimaryKey :: UserID -> m (DBEither (Maybe (DBPGPKey m)))
dbGetApplications :: m [DBUser m]
dbGetTokenBySecret :: Text -> m (DBEither (DBToken m))
dbGetEmailVerificationSecret :: UserID -> m (DBEither (Maybe Text))
class Monad m => MonadEmail m where
sendEmail :: Mail -> m ()
@ -76,7 +184,22 @@ class Monad m => MonadPermissions m where
toPermissions :: Text -> m (Maybe Text)
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
dbGetUserTokens = fmap (fmap (map liftToken)) . lift . dbGetUserTokens
dbGetUserKeys = fmap (fmap (map liftKey)) . lift . dbGetUserKeys
dbGetUserPrimaryKey = fmap (fmap (fmap liftKey)) . lift . dbGetUserPrimaryKey
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
currentUser = lift currentUser
@ -96,3 +219,42 @@ instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where
instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
currentTime = lift currentTime
liftUser :: (MonadTrans t, Monad 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
}
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
, dbPGPKeyUser = fmap liftUser $ lift dbPGPKeyUser
, dbPGPKeyData = lift dbPGPKeyData
, dbPGPKeyExpires = lift dbPGPKeyExpires
, dbPGPKeyUploaded = lift dbPGPKeyUploaded
, dbPGPKeyComment = lift dbPGPKeyComment
}

View File

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