diff --git a/backend/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/backend/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 21d9960f2..875139f6c 100644 --- a/backend/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/backend/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/backend/messages/uniworx/categories/courses/tutorial/en-eu.msg b/backend/messages/uniworx/categories/courses/tutorial/en-eu.msg index 7d3a8468d..4315f700b 100644 --- a/backend/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/backend/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/backend/src/Handler/Qualification.hs b/backend/src/Handler/Qualification.hs index 0c0970a26..d65491264 100644 --- a/backend/src/Handler/Qualification.hs +++ b/backend/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/backend/src/Handler/Tutorial/Users.hs b/backend/src/Handler/Tutorial/Users.hs index e1489e808..fc2715e72 100644 --- a/backend/src/Handler/Tutorial/Users.hs +++ b/backend/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