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