datarekisteri/Server/DB/Queries.hs

{-# 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