From b3861144aabf1d121aba0c65c1a9f7ea1edd8299 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Feb 2023 13:45:34 +0100 Subject: [PATCH] chore(qualifications): renew regularly implemented --- models/lms.model | 2 +- src/Audit/Types.hs | 2 +- src/Database/Esqueleto/Utils.hs | 2 +- src/Handler/Admin/Avs.hs | 1 + src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 2 +- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Utils/Avs.hs | 21 ++------ src/Handler/Utils/Qualification.hs | 81 ++++++++++++++++++++++++------ src/Jobs/Handler/LMS.hs | 11 +++- src/Utils/Form.hs | 22 ++++++-- 11 files changed, 107 insertions(+), 41 deletions(-) diff --git a/models/lms.model b/models/lms.model index cd8b0ec75..9f04a1792 100644 --- a/models/lms.model +++ b/models/lms.model @@ -57,7 +57,7 @@ QualificationEdit QualificationUser user UserId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade - validUntil Day + validUntil Day -- addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False firstHeld Day -- first time the qualification was earned, should never change blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index fcc6a1f8f..1299a11ef 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -201,7 +201,7 @@ data Transaction | TransactionQualificationUserEdit { transactionQualificationUser :: QualificationUserId , transactionQualification :: QualificationId - , transactionUser :: UserId + , transactionUser :: UserId -- qualification holder that is updated , transactionQualificationValidUntil :: Day , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) } diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7614eff58..e46bde230 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -528,7 +528,7 @@ day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day --- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example +-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show where singleQuote = Text.Builder.singleton '\'' diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 0f44e4271..45d90bbe1 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -23,6 +23,7 @@ import qualified Data.Map as Map import Handler.Utils import Handler.Utils.Avs +-- import Handler.Utils.Qualification import Utils.Avs diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8276ca7b8..469ff0eb4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -46,7 +46,7 @@ import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! -import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below? +-- import Handler.Utils.Qualification (validQualification) -- avoids repetition of local definitions single :: (k,a) -> Map k a diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 945a27ef9..4c4efb234 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -35,7 +35,7 @@ import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH -import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below? +-- import Handler.Utils.Qualification (validQualification) -- avoids repetition of local definitions single :: (k,a) -> Map k a diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index e51d7e064..32ee7aa04 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -111,7 +111,7 @@ postTUsersR tid ssh csh tutn = do addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserRenewQualificationData{..}, selectedUsers) -> do - noks <- runDB $ renewQualificationUsers tuQualification $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index db27e663b..41e845161 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -5,9 +5,11 @@ {-# LANGUAGE TypeApplications #-} +-- Module for functions directly related to the AVS interface, +-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification + module Handler.Utils.Avs - ( validQualification, validQualification' - , guessAvsUser + ( guessAvsUser , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , AvsLicenceDifferences(..) @@ -35,6 +37,7 @@ import qualified Data.CaseInsensitive as CI import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) import Handler.Utils.Company +import Handler.Utils.Qualification import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma @@ -63,21 +66,7 @@ instance Exception AvsException Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException? -} ------------------- --- SQL Snippets -- ------------------- -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 ------------------ diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 4cba8c11f..ecb1236f4 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -13,6 +13,42 @@ import Import 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 @@ -31,20 +67,37 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef ] ) audit TransactionQualificationUserEdit - { transactionQualificationUser = quid - , transactionQualification = qualificationUserQualification - , transactionUser = qualificationUserUser - , transactionQualificationValidUntil = qualificationUserValidUntil + { transactionQualificationUser = quid + , transactionQualification = qualificationUserQualification + , transactionUser = qualificationUserUser + , transactionQualificationValidUntil = qualificationUserValidUntil , transactionQualificationScheduleRenewal = mbScheduleRenewal } -renewQualificationUsers :: QualificationId -> [UserId] -> DB Int -renewQualificationUsers qid uids = do - --TODO: user updateWhere Count instead - 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) - -- TODO: AUDIT LOG!!! - -- forM_ uids $ \quid -> audit - return (-1) \ No newline at end of file +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. \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index e3b469360..dd0d27d80 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -70,6 +70,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate + E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue) E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid @@ -208,12 +209,20 @@ dispatchJobLmsResults qid = JobHandlerAtomic act newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards note <- if saneDate && isLmsSuccess newStatus then do + -- TODO: refactor using functions from Handler.Utils.Qualification to ensure nothing is forgotten! update quid [ QualificationUserValidUntil =. newValidTo , QualificationUserLastRefresh =. lmsResultSuccess - ] + ] update luid [ LmsUserStatus =. Just newStatus , LmsUserReceived =. Just lmsResultTimestamp ] + audit TransactionQualificationUserEdit + { transactionQualificationUser = quid + , transactionQualification = qualificationUserQualification + , transactionUser = qualificationUserUser + , transactionQualificationValidUntil = newValidTo + , transactionQualificationScheduleRenewal = Nothing + } return Nothing else do let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index f5d8af0f3..449198087 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -848,12 +848,26 @@ cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s) cfCI = convertField CI.mk CI.original cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) -cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.splitOn ",") (T.intercalate ", " . Set.toList) +cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split (==',')) (T.intercalate ", " . Set.toList) + +-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) +-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList) +-- where anySeparator :: Char -> Bool +-- anySeparator c = C.isSeparator c || c == ',' || c == ';' cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) -cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList) - where anySeparator :: Char -> Bool - anySeparator c = C.isSeparator c || c == ',' || c == ';' +cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList) + where splitConditionally :: Text -> [Text] + splitConditionally t + | ';' `telem` t = T.split (==';') t + | ',' `telem` t = T.split (==',') t + | otherwise = T.split C.isSeparator t + -- Our version of Data.Text does not yet support T.elem + telem :: Char -> Text -> Bool + telem c = T.any (==c) + + + -- -- TODO: consider using package ordered-containers? -- cfAnySeparatedList :: (Functor m) => Field m Text -> Field m [Text]