Abstract SQL table structure from database queries
This commit is contained in:
parent
d2f1b07922
commit
3942d547e0
GPG Key ID:
257D284A2A1D3A32
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue