275 lines
16 KiB
Haskell
275 lines
16 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.Utils.Qualification
|
|
( module Handler.Utils.Qualification
|
|
) where
|
|
|
|
import Import
|
|
|
|
-- import Data.Time.Calendar (CalendarDiffDays(..))
|
|
-- import Database.Persist.Sql (updateWhereCount)
|
|
import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Handler.Utils.DateTime (toMidnight)
|
|
import Handler.Utils.Widgets (statusHtml)
|
|
|
|
statusQualificationBlock :: Bool -> Html
|
|
statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s
|
|
|
|
|
|
-- needs refactoring, probbably no longer helpful
|
|
mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
|
|
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
|
|
where
|
|
qualificationUserBlockReason = qualificationBlockedReasonText reason
|
|
qualificationUserBlockUnblock = False
|
|
qualificationUserBlockBlocker = Nothing
|
|
|
|
-- somewhat dangerous, if not used with latest effective block
|
|
isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool
|
|
isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld
|
|
,qu ^. hasQualificationUser . _qualificationUserValidUntil)
|
|
&& all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb
|
|
|
|
------------------
|
|
-- SQL Snippets --
|
|
------------------
|
|
|
|
-- | Recently became invalid or blocked and not yet notified
|
|
quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
|
|
quserToNotify quser cutoff = -- recently invalid or...
|
|
( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
|
|
E.&&. E.notExists (do
|
|
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
|
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
|
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified
|
|
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
|
E.&&. E.notExists (do -- block is the most recent block
|
|
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
|
|
E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)
|
|
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
|
|
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
|
)
|
|
)
|
|
) E.||. E.exists (do -- ...recently blocked
|
|
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
|
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) -- block is not an unblock
|
|
E.&&. E.day (qualUserBlock E.^. QualificationUserBlockFrom) E.<. quser E.^. QualificationUserValidUntil -- block was essential during validity
|
|
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified -- block has not yet been communicated
|
|
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff -- block is already active
|
|
E.&&. E.notExists (do -- block is the most recent block
|
|
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
|
|
E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock))
|
|
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
|
|
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
|
)
|
|
)
|
|
|
|
-- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
|
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
|
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
|
|
newerBlock <- E.from $ E.table @QualificationUserBlock
|
|
E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
|
|
E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom
|
|
E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
|
)
|
|
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
|
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
|
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
|
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
|
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
|
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
|
|
E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
|
|
E.&&. E.notExists (do
|
|
qualUserUnblock <- E.from $ E.table @QualificationUserBlock
|
|
E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock)
|
|
E.&&. checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser)
|
|
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. cutoff
|
|
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
|
|
)
|
|
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
|
|
|
|
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
|
|
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
|
quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing
|
|
|
|
-- | Variant of `isBlocked` for outer joins
|
|
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
|
quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing
|
|
|
|
qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
|
|
qualificationValid = flip validQualification
|
|
|
|
validQualification :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
|
validQualification cutoff qualUser =
|
|
(E.val (utctDay cutoff) `E.between` (qualUser E.^. QualificationUserFirstHeld
|
|
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
|
E.&&. quserBlock False cutoff qualUser
|
|
|
|
-- | Variant of `validQualification` for outer joins
|
|
validQualification' :: UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
|
validQualification' cutoff qualUser =
|
|
(E.justVal (utctDay cutoff) `E.between` (qualUser E.?. QualificationUserFirstHeld
|
|
,qualUser E.?. QualificationUserValidUntil)) -- currently valid
|
|
E.&&. quserBlock' False cutoff qualUser
|
|
|
|
selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser]
|
|
selectValidQualifications qid mbUids cutoff =
|
|
-- cutoff <- utctDay <$> liftIO getCurrentTime
|
|
E.select $ do
|
|
qUser <- E.from $ E.table @QualificationUser
|
|
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
|
|
E.&&. validQualification cutoff qUser
|
|
-- E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
|
|
whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids)
|
|
pure qUser
|
|
|
|
selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock))
|
|
selectRelevantBlock cutoff quid =
|
|
selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom]
|
|
|
|
------------------------
|
|
-- Complete Functions --
|
|
------------------------
|
|
|
|
|
|
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
|
|
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
|
|
Entity quid _ <- upsert
|
|
QualificationUser
|
|
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
|
, qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal
|
|
, qualificationUserLastNotified = toMidnight qualificationUserLastRefresh
|
|
, ..
|
|
}
|
|
(
|
|
[ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal]
|
|
] ++
|
|
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
|
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
|
]
|
|
)
|
|
|
|
audit TransactionQualificationUserEdit
|
|
{ transactionQualificationUser = quid
|
|
, transactionQualification = qualificationUserQualification
|
|
, transactionUser = qualificationUserUser
|
|
, transactionQualificationValidUntil = qualificationUserValidUntil
|
|
, transactionQualificationScheduleRenewal = mbScheduleRenewal
|
|
}
|
|
|
|
-- | Renew an existing qualification, ignoring all blocks
|
|
renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
|
|
renewValidQualificationUsers qid uids =
|
|
-- This code works in principle, but it does not allow audit log entries.
|
|
-- E.update $ \qu -> do
|
|
-- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
|
|
-- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
|
|
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
|
|
get qid >>= \case
|
|
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
|
|
now <- liftIO getCurrentTime
|
|
quEntsAll <- selectValidQualifications qid (Just uids) now
|
|
let nowaday = utctDay now
|
|
maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
|
|
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
|
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
|
let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
|
|
update quId [ QualificationUserValidUntil =. newValidTo
|
|
, QualificationUserLastRefresh =. nowaday
|
|
]
|
|
audit TransactionQualificationUserEdit
|
|
{ transactionQualificationUser = quId
|
|
, transactionQualification = qualificationUserQualification
|
|
, transactionUser = qualificationUserUser
|
|
, transactionQualificationValidUntil = newValidTo
|
|
, transactionQualificationScheduleRenewal = Nothing
|
|
}
|
|
return $ length quEnts
|
|
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
|
|
|
-- | Block or unblock some users for a given reason
|
|
qualificationUserBlocking ::
|
|
( AuthId (HandlerSite m) ~ Key User
|
|
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
|
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
|
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
|
|
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
|
|
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
|
|
, HasInstanceID (HandlerSite m) InstanceId
|
|
, YesodAuthPersist (HandlerSite m)
|
|
, HasAppSettings (HandlerSite m)
|
|
, MonadHandler m
|
|
, MonadCatch m
|
|
, Num n
|
|
) => QualificationId -> [UserId] -> Bool -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
|
qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reason) notify = do
|
|
authUsr <- liftHandler maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
-- -- Code would work, but problematic
|
|
-- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
|
|
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
|
|
-- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
|
|
-- E.&&. quserBlock (not unblock) nowaday qualificationUser -- only unblock blocked qualification and vice versa
|
|
-- return $ QualificationUserBlock
|
|
-- E.<# qualificationUser E.^. QualificationUserId
|
|
-- E.<&> E.val unblock
|
|
-- E.<&> E.val nowaday
|
|
-- E.<&> E.val reason
|
|
-- E.<&> E.val authUsr
|
|
toChange' <- E.select $ do
|
|
qualUser <- E.from $ E.table @QualificationUser
|
|
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
|
|
E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids
|
|
E.&&. quserBlock (not unblock) now qualUser -- only unblock blocked qualification and vice versa
|
|
return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
|
|
let toChange = E.unValue . fst <$> toChange'
|
|
E.insertMany_ $ map (\quid -> QualificationUserBlock
|
|
{ qualificationUserBlockQualificationUser = quid
|
|
, qualificationUserBlockUnblock = unblock
|
|
, qualificationUserBlockFrom = now
|
|
, qualificationUserBlockReason = reason
|
|
, qualificationUserBlockBlocker = authUsr
|
|
}) toChange
|
|
|
|
unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now]
|
|
|
|
forM_ toChange' $ \(_, E.Value uid) -> do
|
|
audit TransactionQualificationUserBlocking
|
|
{ -- transactionQualificationUser = quid
|
|
transactionQualification = qid
|
|
, transactionUser = uid
|
|
, transactionQualificationBlock = error "TODO" -- CONTINUE HERE
|
|
}
|
|
return $ fromIntegral $ length toChange
|
|
|
|
|
|
qualificationUserUnblockByReason ::
|
|
( AuthId (HandlerSite m) ~ Key User
|
|
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
|
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
|
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
|
|
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
|
|
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
|
|
, HasInstanceID (HandlerSite m) InstanceId
|
|
, YesodAuthPersist (HandlerSite m)
|
|
, HasAppSettings (HandlerSite m)
|
|
, MonadHandler m
|
|
, MonadCatch m
|
|
, Num n
|
|
) => QualificationId -> [UserId] -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
|
qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reason) undo_reason notify = do
|
|
now <- liftIO getCurrentTime
|
|
toUnblock <- E.select $ do
|
|
quser <- E.from $ E.table @QualificationUser
|
|
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
|
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
|
|
E.&&. quserBlockAux True (E.val now) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
|
return $ quser E.^. QualificationUserUser
|
|
qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify
|