datarekisteri/Server/DB/Queries.hs

118 lines
4.8 KiB
Haskell

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Server.DB.Queries where
import Server.DB as DB
import Server.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, isJust)
import Data.Aeson (fromJSON, toJSON, Result(..))
import GHC.Int (Int64)
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 = runQuery $ getBy (UniqueEmail $ Just email) >>=
maybe ((>>= guardUnconfirmed) <$> getBy (UniquePendingEmail $ Just email)) (pure . Just)
where guardUnconfirmed user
| isJust (dBUserEmail $ entityVal user) = Nothing
| otherwise = Just user
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
isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
isApplicant user = isNothing (user ^. DBUserAccepted) &&. not_ (isNothing (user ^. DBUserEmail)) &&. isNothing (user ^. DBUserRejected)
isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool)
isMember user = not_ (isNothing (user ^. DBUserAccepted)) &&. isNothing (user ^. DBUserSeceded)
verifyEmailSecret :: MonadDB m => Text -> m Int64
verifyEmailSecret secret = runQuery $ updateCount $ \user -> do
set user [ DBUserEmailVerificationSecret =. val Nothing
, DBUserEmail =. user ^. DBUserPendingEmail
, DBUserPendingEmail =. val Nothing
]
where_ $ user ^. DBUserEmailVerificationSecret ==. just (val secret)
markAsAccepted :: MonadDB m => UserID -> Time -> m ()
markAsAccepted userID time = runQuery $ update $ \user -> do
set user [DBUserAccepted =. just (val time)]
where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user
markAsRejected :: MonadDB m => UserID -> Time -> m ()
markAsRejected userID time = runQuery $ update $ \user -> do
set user [DBUserRejected =. just (val time)]
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