From e466f001d8be0c7464eb25ec4075df4cd5532925 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Feb 2023 19:14:25 +0100 Subject: [PATCH 1/5] chore(qualficiation): proof of concept qualification renewal code --- .../courses/tutorial/de-de-formal.msg | 2 ++ .../categories/courses/tutorial/en-eu.msg | 2 ++ src/Database/Esqueleto/Utils.hs | 12 ++++++- src/Handler/Tutorial/Users.hs | 35 ++++++++++++------- src/Handler/Utils/Qualification.hs | 27 ++++++++++---- 5 files changed, 58 insertions(+), 20 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index d9a9b7493..601183d85 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -45,5 +45,7 @@ TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium TutorialUserDeregister: Vom Tutorium Abmelden TutorialUserSendMail: Mitteilung verschicken TutorialUserGrantQualification: Qualifikation vergeben +TutorialUserRenewQualification: Qualifikation regulär verlängern +TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben CommTutorial: Tutorium-Mitteilung \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 0c889b3f1..4ecbb64e1 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -46,5 +46,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici TutorialUserDeregister: Deregister from tutorial TutorialUserSendMail: Send mail TutorialUserGrantQualification: Grant Qualification +TutorialUserRenewQualification: Renew Qualification +TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"} TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"} CommTutorial: Tutorial message diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 041af20f7..7614eff58 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -38,7 +38,7 @@ module Database.Esqueleto.Utils , unKey , selectCountRows, selectCountDistinct , selectMaybe - , day, diffDays, diffTimes + , day, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue , module Database.Esqueleto.Utils.TH @@ -65,6 +65,8 @@ import Crypto.Hash (Digest, SHA256) import Data.Coerce (Coercible) import Data.Time.Clock (NominalDiffTime) +import Data.Time.Calendar (CalendarDiffDays) +import Data.Time.Format.ISO8601 (iso8601Show) import qualified Data.Text.Lazy.Builder as Text.Builder @@ -525,6 +527,14 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) 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 . wrapSqlString . Text.Builder.fromString . iso8601Show + where + singleQuote = Text.Builder.singleton '\'' + wrapSqlString b = singleQuote <> b <> singleQuote + + infixl 6 `diffDays`, `diffTimes` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 912d0c886..e51d7e064 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -26,10 +26,11 @@ import Handler.Course.Users data TutorialUserAction - = TutorialUserGrantQualification - | TutorialUserSendMail - | TutorialUserDeregister - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + = TutorialUserRenewQualification + | TutorialUserGrantQualification + | TutorialUserSendMail + | TutorialUserDeregister + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe TutorialUserAction instance Finite TutorialUserAction @@ -37,13 +38,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''TutorialUserAction id data TutorialUserActionData - = TutorialUserGrantQualificationData - { tuQualification :: QualificationId - , tuValidUntil :: Day - } - | TutorialUserSendMailData - | TutorialUserDeregisterData{} - deriving (Eq, Ord, Read, Show, Generic) + = TutorialUserRenewQualificationData + { tuQualification :: QualificationId } + | TutorialUserGrantQualificationData + { tuQualification :: QualificationId + , tuValidUntil :: Day + } + | TutorialUserSendMailData + | TutorialUserDeregisterData{} + deriving (Eq, Ord, Read, Show, Generic) getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html @@ -85,7 +88,11 @@ postTUsersR tid ssh csh tutn = do } acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts = Map.fromList - [ ( TutorialUserGrantQualification + [ ( TutorialUserRenewQualification + , TutorialUserRenewQualificationData + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + ) + , ( TutorialUserGrantQualification , TutorialUserGrantQualificationData <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry @@ -103,6 +110,10 @@ postTUsersR tid ssh csh tutn = do runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers redirect $ CTutorialR tid ssh csh tutn TUsersR + (TutorialUserRenewQualificationData{..}, selectedUsers) -> do + noks <- runDB $ renewQualificationUsers 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 cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index cb9700ad1..4cba8c11f 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -3,16 +3,18 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later - -module Handler.Utils.Qualification +module Handler.Utils.Qualification ( module Handler.Utils.Qualification - ) where + ) 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 upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do +upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do Entity quid _ <- upsert QualificationUser { qualificationUserFirstHeld = qualificationUserLastRefresh @@ -20,18 +22,29 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef , 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 - } \ No newline at end of file + } + +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 From b3861144aabf1d121aba0c65c1a9f7ea1edd8299 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Feb 2023 13:45:34 +0100 Subject: [PATCH 2/5] 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] From 2b379a4f5e5f427000195ddb34674e53177aed70 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Feb 2023 14:42:23 +0100 Subject: [PATCH 3/5] chore(qualifications): provide supervisor-usable user link --- src/Handler/Qualification.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 4c4efb234..14ae74515 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -388,7 +388,7 @@ postQualificationR sid qsh = do ] colChoices = mconcat [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) - , colUserNameLinkHdr MsgLmsUser AdminUserR + , colUserNameLinkHdr MsgLmsUser ForProfileR , colUserEmail , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d From 1c41a4991a870186d8f48a11207aee6da20c7248 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Feb 2023 16:54:41 +0100 Subject: [PATCH 4/5] chore(qualification): allow admins to see all qualifications --- src/Handler/Qualification.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 14ae74515..5dcd6fe1a 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -269,12 +269,13 @@ mkQualificationTable :: ( Functor h, ToSortable h , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols ) - => Entity Qualification + => Bool + -> Entity Qualification -> Map QualificationTableAction (AForm Handler QualificationTableActionData) -> cols -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) -mkQualificationTable (Entity qid quali) acts cols psValidator = do +mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees now <- liftIO getCurrentTime currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute @@ -284,7 +285,7 @@ mkQualificationTable (Entity qid quali) acts cols psValidator = do csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" - fltrSvs = \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs + fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery q = qualificationTableQuery qid fltrSvs q dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjFilteredPostId @@ -379,6 +380,7 @@ getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> getQualificationR = postQualificationR postQualificationR sid qsh = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler + isAdmin <- hasReadAccessTo AdminR ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) @@ -403,10 +405,9 @@ postQualificationR sid qsh = do $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu ] psValidator = def - tbl <- mkQualificationTable qent acts colChoices psValidator + tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator return (tbl, qent) - - isAdmin <- hasReadAccessTo AdminR + formResult lmsRes $ \case _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now (action, selectedUsers) | isExpiryAct action -> do From 0cecd7e07d0acc185e470490722ec65558e02bd5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Feb 2023 17:56:05 +0100 Subject: [PATCH 5/5] chore(users): filter by avsno --- src/Handler/Users.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 25570eba1..eabf9452e 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -296,6 +296,12 @@ postUsersR = do E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId) E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) ) + , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion -> + E.from $ \usrAvs -> -- do + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^.UserId + E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` + (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) + ) ] , dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) @@ -303,6 +309,7 @@ postUsersR = do , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)