From 92ff99a36ef941d2ff888d7e3a5381e1d8a11f46 Mon Sep 17 00:00:00 2001 From: "Jost, Steffen" Date: Wed, 26 Mar 2025 16:58:07 +0100 Subject: [PATCH] chore(tutorial): granting qualification automatically picks better expiry date Previously, the form for granting tutorial users a qualification suggested the minimum of all expiry dates, if there where several course qualficiations. This lead to some users being granted driving licences being valid for only one month. The expiry date can now be left blank, using the validDuration of the selected qualification instead. The default is blank, if there are more than one course qualification having disagreeing qualification dates. --- .../courses/tutorial/de-de-formal.msg | 6 ++- .../categories/courses/tutorial/en-eu.msg | 7 +-- src/Handler/Qualification.hs | 11 +++-- src/Handler/Tutorial/Users.hs | 46 +++++++++++-------- src/Utils.hs | 3 ++ 5 files changed, 43 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 21d9960f2..875139f6c 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -47,9 +47,11 @@ TutorialUserDeregister: Vom Kurs abmelden TutorialUserSendMail: Mitteilung verschicken TutorialUserPrintQualification: Zertifikat drucken TutorialUserGrantQualification: Qualifikation vergeben +TutorialUserGrantQualificationDateTooltip: Leer lassen, um das Ablaufdatum auf das heutige Datum plus Standardgültigkeitsdauer zu setzen. +TutorialUserGrantQualificationDateError qsh@QualificationShorthand: Qualifikation #{qsh} hat keine Standardgültigkeitsdauer, daher ist ein explizites Ablaufdatum erforderlich! TutorialUserRenewQualification: Qualifikation regulär verlängern -TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert -TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben +TutorialUserRenewedQualification qsh@QualificationShorthand n@Int: Qualifikation #{qsh} für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert. +TutorialUserGrantedQualification qsh@QualificationShorthand day@Text n@Int: Qualifikation #{qsh} bis #{day} erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben. TutorialUserAssignExam: Zur Prüfung einteilen TutorialUserExamAssignedFor n@Int m@Int p@Text: #{n}/#{m} zur Prüfung #{p} eingeteilt CommTutorial: Kursmitteilung diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 7d3a8468d..4315f700b 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -43,14 +43,15 @@ TutorInviteHeading tutn: Invitation to be instructor for #{tutn} TutorInviteExplanation: You were invited to be a instructor. TutorCorrectorInvitationAccepted shn: You are now a corrector for #{shn} TutorialUsersDeregistered count: Successfully deregistered #{show count} participants from course - TutorialUserDeregister: Deregister from course TutorialUserSendMail: Send mail TutorialUserPrintQualification: Print certificate TutorialUserGrantQualification: Grant qualification +TutorialUserGrantQualificationDateTooltip: Leave blank for expiry on today's date plus standard qualification valid duration. +TutorialUserGrantQualificationDateError qsh@QualificationShorthand: Qualification #{qsh} has no standard valid duration. Please provide an explicit expiry date! TutorialUserRenewQualification: Renew qualification -TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} course #{pluralEN n "user" "users"} -TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} course #{pluralEN n "user" "users"} +TutorialUserRenewedQualification qsh n: Successfully renewed #{qsh} qualification for #{pluralENsN n "course participant"} +TutorialUserGrantedQualification qsh day n: Successfully granted #{qsh} qualification until #{day} to #{pluralENsN n "course participant"} TutorialUserAssignExam: Register for examination TutorialUserExamAssignedFor n@Int m@Int p@Text: #{n}/#{m} enrolled for exam #{p} CommTutorial: Course message diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 0c0970a26..d65491264 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -614,14 +614,15 @@ postQualificationR sid qsh = do (noks,nterm) <- runDB $ (,) <$> renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing selUsrs <*> terminateLms (LmsOrphanReasonManualRenewal renewReason) qid selUsrs - addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks + addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks when (nterm >0) $ addMessageI Warning $ MsgLmsActTerminated nterm reloadKeepGetParams $ QualificationR sid qsh - (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do + (QualificationActGrantData grantValidDay, selectedUsers) | isAdmin -> do + grantValidDayText <- formatTime SelFormatDate grantValidDay nterm <- runDB $ do - forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin" - terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidday) qid $ Set.toList selectedUsers - addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers + forM_ selectedUsers $ upsertQualificationUser qid now grantValidDay Nothing "Admin" + terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidDay) qid $ Set.toList selectedUsers + addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh grantValidDayText $ Set.size selectedUsers when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm reloadKeepGetParams $ QualificationR sid qsh (QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index e1489e808..fc2715e72 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -57,7 +57,7 @@ data TutorialUserActionData { tuQualification :: QualificationId } | TutorialUserGrantQualificationData { tuQualification :: QualificationId - , tuValidUntil :: Day + , tuValidUntil :: Maybe Day } | TutorialUserSendMailData | TutorialUserDeregisterData @@ -116,6 +116,7 @@ postTUsersR tid ssh csh tutn = do let heading = prependCourseTitle tid ssh csh $ CI.original tutn croute = CTutorialR tid ssh csh tutn TUsersR now <- liftIO getCurrentTime + let nowaday = utctDay now isAdmin <- hasReadAccessTo AdminR (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, dbegin, hasExams, exmFltr, exOccs) <- runDB do trm <- get404 tid @@ -123,9 +124,9 @@ postTUsersR tid ssh csh tutn = do -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn (cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid - let nowaday = utctDay now - minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays - dayExpiry = flip computeNewValidDate nowaday <$> minDur + let dayExpiry = case nubOrd (mapMaybe qualificationValidDuration qualifications) of + [oneDuration] -> Just $ Just $ computeNewValidDate qvd nowaday -- suggest end day only if it is unique for all course qualifications + _ -> Nothing -- using the minimum here causes confusion, better leave blank! colChoices = mconcat $ [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR @@ -173,7 +174,7 @@ postTUsersR tid ssh csh tutn = do , ( TutorialUserGrantQualification , TutorialUserGrantQualificationData <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing - <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry + <*> aopt dayField (fslI MsgLmsQualificationValidUntil & setTooltip MsgTutorialUserGrantQualificationDateTooltip) dayExpiry ) ] ) ++ @@ -184,7 +185,7 @@ postTUsersR tid ssh csh tutn = do table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) return (tutEnt, table, qualifications, dbegin, hasExams, exmFltr, exOccs) - let courseQids = Set.fromList (entityKey <$> qualifications) + let courseQids = entities2map qualifications tcontent <- formResultMaybe participantRes $ \case (TutorialUserPrintQualificationData, selectedUsers) -> do rcvr <- requireAuth @@ -204,25 +205,30 @@ postTUsersR tid ssh csh tutn = do -- typePDF = "application/pdf" -- sendResponse (typePDF, toContent pdf) (TutorialUserGrantQualificationData{..}, selectedUsers) - | tuQualification `Set.member` courseQids -> do - -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - today <- liftIO getCurrentTime - let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn - selUsrs = Set.toList selectedUsers - nterm <- runDB $ do - forM_ selUsrs $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason - terminateLms (LmsOrphanReasonManualGrant [st|bis #{tshow tuValidUntil}, #{reason}|]) tuQualification selUsrs - addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers - when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm - reloadKeepGetParams croute + | Just grantQual <- Map.lookup tuQualification courseQids -> + case tuValidUntil <|> (flip computeNewValidDate nowaday <$> qualificationValidDuration grantQual) of + Nothing -> do -- TODO: change QualificationUser to have an optionnal validUntil for idefinitely valid qualifications + addMessageI Error $ MsgTutorialUserGrantQualificationDateError $ qualificationShorthand grantQual + (Just expiryDay) -> do + let qsh = qualificationShorthand grantQual + reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn + selUsrs = Set.toList selectedUsers + expiryDayText <- formatTime SelFormatDate expiryDay + nterm <- runDB $ do + forM_ selUsrs $ upsertQualificationUser tuQualification now expiryDay Nothing reason + terminateLms (LmsOrphanReasonManualGrant [st|bis #{expiryDayText}, #{reason}|]) tuQualification selUsrs + addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh expiryDayText $ Set.size selectedUsers + when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm + reloadKeepGetParams croute (TutorialUserRenewQualificationData{..}, selectedUsers) - | tuQualification `Set.member` courseQids -> do - let selUsrs = Set.toList selectedUsers + | Just grantQual <- Map.lookup tuQualification courseQids -> do + let qsh = qualificationShorthand grantQual + selUsrs = Set.toList selectedUsers mr <- getMessageRender (noks,nterm) <- runDB $ (,) <$> renewValidQualificationUsers tuQualification Nothing Nothing selUsrs <*> terminateLms (LmsOrphanReasonManualGrant $ mr heading) tuQualification selUsrs - addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks + addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm reloadKeepGetParams croute (TutorialUserSendMailData, selectedUsers) -> do diff --git a/src/Utils.hs b/src/Utils.hs index 285740f6a..508d40e4a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -927,6 +927,9 @@ mapFromSetM = (sequenceA .) . Map.fromSet setToMap :: (Ord k) => (v -> k) -> Set v -> Map k v setToMap mkKey = Map.fromList . fmap (\x -> (mkKey x, x)) . Set.toList +mapFromFoldable :: (Ord k, Foldable t) => (v -> k) -> t v -> Map k v +mapFromFoldable getKey = foldMap (Map.singleton =<< getKey) + mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v) mapFM = sequenceA . mapF