103 lines
4.9 KiB
Haskell
103 lines
4.9 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
|
|
module Handler.Utils.Qualification
|
|
( module Handler.Utils.Qualification
|
|
) where
|
|
|
|
import Import
|
|
|
|
-- import Data.Time.Calendar (CalendarDiffDays(..))
|
|
import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
|
|
------------------
|
|
-- SQL Snippets --
|
|
------------------
|
|
|
|
-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
|
|
validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
|
validQualification nowaday = \qualUser ->
|
|
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
|
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
|
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked
|
|
|
|
validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
|
validQualification' nowaday qualUser =
|
|
(E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
|
|
,qualUser E.?. QualificationUserValidUntil)) -- currently valid
|
|
E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue) -- not blocked
|
|
|
|
|
|
selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser]
|
|
selectValidQualifications qid mbUids nowaday =
|
|
-- nowaday <- utctDay <$> liftIO getCurrentTime
|
|
E.select $ do
|
|
qUser <- E.from $ E.table @QualificationUser
|
|
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
|
|
E.&&. validQualification nowaday qUser
|
|
E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
|
|
pure qUser
|
|
|
|
|
|
------------------------
|
|
-- Complete Functions --
|
|
------------------------
|
|
|
|
|
|
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
|
|
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
|
|
Entity quid _ <- upsert
|
|
QualificationUser
|
|
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
|
, qualificationUserBlockedDue = Nothing
|
|
, qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal
|
|
, ..
|
|
}
|
|
(
|
|
[ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal]
|
|
] ++
|
|
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
|
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
|
, QualificationUserBlockedDue =. Nothing
|
|
]
|
|
)
|
|
audit TransactionQualificationUserEdit
|
|
{ transactionQualificationUser = quid
|
|
, transactionQualification = qualificationUserQualification
|
|
, transactionUser = qualificationUserUser
|
|
, transactionQualificationValidUntil = qualificationUserValidUntil
|
|
, transactionQualificationScheduleRenewal = mbScheduleRenewal
|
|
}
|
|
|
|
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
|
|
nowaday <- utctDay <$> liftIO getCurrentTime
|
|
quEntsAll <- selectValidQualifications qid (Just uids) nowaday
|
|
let 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. |