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.
This commit is contained in:
parent
9d1a97172e
commit
92ff99a36e
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user