116 lines
4.7 KiB
Haskell
116 lines
4.7 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 }
|
|
Persist.update key (userUpdates <> updates)
|
|
pure user
|
|
|
|
data UserUpdate = SetUserName Text
|
|
| SetUserNickname (Maybe Text)
|
|
| SetUserHomeplace Text
|