190 lines
7.8 KiB
Haskell
190 lines
7.8 KiB
Haskell
{-# 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
|
|
verification <- from $ table @DBEmailVerification
|
|
set email [DBEmailVid =. val Nothing]
|
|
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
|
|
|
|
|
|
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
|