fix(course): grant qualifications now issues and unblocks

src/Handler/Admin/Avs.hs

@@ -431,8 +431,7 @@ getProblemAvsSynchR = do
           <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
 
   now <- liftIO getCurrentTime
-  let nowaday = utctDay now
+  let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
-      procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
       procRes aLic (LicenceTableChangeAvsData       , apids) = do
         oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
         let no_req = Set.size apids
@@ -458,7 +457,7 @@ getProblemAvsSynchR = do
           uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
           -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
           void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
-          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
+          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
           (length uids,) <$> get404 licenceTableChangeFDriveQId
         addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
         redirect ProblemAvsSynchR -- must be outside runDB

src/Handler/LMS.hs

@@ -739,7 +739,7 @@ postLmsR sid qsh = do
             , QualificationUserUser <-. usersList            
             , QualificationUserValidUntil <. cutoff
             ] []          
-          forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
+          forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
 
         fromIntegral <$> (if isReset
             then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective

src/Handler/Qualification.hs

@@ -617,7 +617,7 @@ postQualificationR sid qsh = do
       addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
       reloadKeepGetParams $ QualificationR sid qsh
     (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      
-      runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
+      runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
       addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       reloadKeepGetParams $ QualificationR sid qsh
     (action, selectedUsers) | isExpiryAct action -> do

src/Handler/Tutorial/Users.hs

@@ -139,8 +139,9 @@ postTUsersR tid ssh csh tutn = do
     (TutorialUserGrantQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
-        today <- utctDay <$> liftIO getCurrentTime
+        today <- liftIO getCurrentTime
-        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
+        let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
+        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
         addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers)

src/Handler/Utils/Qualification.hs

@@ -133,8 +133,9 @@ selectRelevantBlock cutoff quid =
 ------------------------
 
 
-upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
+upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
+upsertQualificationUser  qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do
+  let qualificationUserLastRefresh = utctDay startTime
   Entity quid _ <- upsert
     QualificationUser
       { qualificationUserFirstHeld        = qualificationUserLastRefresh      
@@ -149,7 +150,8 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
       ]
     )
-  
+  authUsr <- liftHandler maybeAuthId
+  insert_ $ QualificationUserBlock quid True startTime reason authUsr
   audit TransactionQualificationUserEdit
     { transactionQualificationUser            = quid
     , transactionQualification                = qualificationUserQualification