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.

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
+TutorialUserRenewedQualification qsh@QualificationShorthand n@Int: Qualifikation #{qsh} 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
+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

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"}
+TutorialUserRenewedQualification qsh n: Successfully renewed #{qsh} qualification for #{pluralENsN n "course participant"}
-TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} course #{pluralEN n "user" "users"}
+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

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"
+        forM_ selectedUsers $ upsertQualificationUser qid now grantValidDay Nothing "Admin"
-        terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidday) qid $ Set.toList selectedUsers
+        terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidDay) qid $ Set.toList selectedUsers
-      addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size 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

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
+    let dayExpiry = case nubOrd (mapMaybe qualificationValidDuration qualifications) of 
-        minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications  -- no instance Ord CalendarDiffDays
+                      [oneDuration] -> Just $ Just $ computeNewValidDate qvd nowaday      -- suggest end day only if it is unique for all course qualifications
-        dayExpiry = flip computeNewValidDate nowaday <$> minDur
+                      _             -> 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
+      | Just grantQual  <- Map.lookup tuQualification courseQids -> 
-        -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
+        case tuValidUntil <|> (flip computeNewValidDate nowaday <$> qualificationValidDuration grantQual) of        
-        today <- liftIO getCurrentTime
+          Nothing -> do -- TODO: change QualificationUser to have an optionnal validUntil for idefinitely valid qualifications
-        let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
+            addMessageI Error $ MsgTutorialUserGrantQualificationDateError $ qualificationShorthand grantQual
-            selUsrs = Set.toList selectedUsers
+          (Just expiryDay) -> do               
-        nterm <- runDB $ do
+            let qsh     = qualificationShorthand grantQual
-          forM_ selUsrs $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
+                reason  = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
-          terminateLms (LmsOrphanReasonManualGrant [st|bis #{tshow tuValidUntil}, #{reason}|]) tuQualification selUsrs
+                selUsrs = Set.toList selectedUsers            
-        addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
+            expiryDayText <- formatTime SelFormatDate expiryDay
-        when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
+            nterm <- runDB $ do
-        reloadKeepGetParams croute
+              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
+      | Just grantQual  <- Map.lookup tuQualification courseQids -> do
-        let selUsrs = Set.toList selectedUsers
+        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

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