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