chore(qualification): Fix #46 by add qualification grant act to qualification view

2023-05-04 10:58:55 +00:00 · 2023-05-04 10:58:55 +00:00 · a64a2368db
commit a64a2368db
parent 4161c92d12
6 changed files with 53 additions and 14 deletions
--- a/messages/uniworx/categories/courses/tutorial/en-eu.msg
+++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg
@ -46,8 +46,8 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
 TutorialUserDeregister: Deregister from tutorial
 TutorialUserSendMail: Send mail
 TutorialUserPrintQualification: Print certificate
-TutorialUserGrantQualification: Grant Qualification
-TutorialUserRenewQualification: Renew Qualification
+TutorialUserGrantQualification: Grant qualification
+TutorialUserRenewQualification: Renew qualification
 TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 CommTutorial: Tutorial message
--- a/messages/uniworx/categories/qualification/de-de-formal.msg
+++ b/messages/uniworx/categories/qualification/de-de-formal.msg
@ -86,6 +86,7 @@ QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung un
 QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung
 QualificationActBlock: Entziehen
 QualificationActUnblock: Entzug löschen
+QualificationActGrant: Qualifikation vergeben
 QualificationActRenew: Qualifikation regulär verlängern
 QualificationStatusBlock   l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
 QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
--- a/messages/uniworx/categories/qualification/en-eu.msg
+++ b/messages/uniworx/categories/qualification/en-eu.msg
@ -65,13 +65,13 @@ CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom
 CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
 CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
 CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
-LmsUserlistInsert: New LMS User
-LmsUserlistUpdate: Update of LMS User
+LmsUserlistInsert: New LMS user
+LmsUserlistUpdate: Update of LMS user
 LmsResultInsert: New LMS result
 LmsResultUpdate: Update of LMS result
 LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
 LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
-LmsDirectUpload: Direct upload for automated Systems
+LmsDirectUpload: Direct upload for automated systems
 LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
 MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
 MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
@ -86,7 +86,8 @@ QualificationSetUnexpire n: Expiry notification and e‑learning activated for #
 QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately
 QualificationActBlock: Revoke
 QualificationActUnblock: Clear revocation
-QualificationActRenew: Renew Qualification
+QualificationActGrant: Grant qualification
+QualificationActRenew: Renew qualification
 QualificationStatusBlock   l n m: #{n}/#{m} #{l} revoked
 QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
 LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@ -249,6 +249,7 @@ data QualificationTableAction
  | QualificationActBlock
  | QualificationActUnblock
  | QualificationActRenew
+  | QualificationActGrant
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)  

 instance Universe QualificationTableAction
@ -268,9 +269,10 @@ data QualificationTableActionData
  = QualificationActExpireData 
  | QualificationActUnexpireData  
  | QualificationActBlockSupervisorData
-  | QualificationActBlockData              { qualTableActBlockReason :: Text}
+  | QualificationActBlockData           { qualTableActBlockReason :: Text }
  | QualificationActUnblockData
  | QualificationActRenewData
+  | QualificationActGrantData           { qualTableActGrantUntil  :: Day }   
  deriving (Eq, Ord, Read, Show, Generic)  

 isExpiryAct :: QualificationTableActionData -> Bool
@ -468,9 +470,16 @@ getQualificationR,  postQualificationR :: SchoolId -> QualificationShorthand ->
 getQualificationR = postQualificationR
 postQualificationR sid qsh = do  
  isAdmin <- hasReadAccessTo AdminR  
+  now <- liftIO getCurrentTime
+  let nowaday = utctDay now
  ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
-    qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
-    let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
+    qent@Entity{entityVal=Qualification{
+        qualificationAuditDuration=auditMonths
+      , qualificationValidDuration=validMonths
+      }} <- getBy404 $ SchoolQualificationShort sid qsh
+
+    let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
+        acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
        acts = mconcat $
          [ singletonMap QualificationActExpire   $ pure QualificationActExpireData
          , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData          
@ -480,6 +489,8 @@ postQualificationR sid qsh = do
          , singletonMap QualificationActBlock           $      QualificationActBlockData 
              <$> apreq textField (fslI MsgQualificationBlockReason) Nothing
          , singletonMap QualificationActRenew           $ pure QualificationActRenewData
+          , singletonMap QualificationActGrant           
+              (QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry)
          ] isAdmin
        linkLmsUser     = toMaybe isAdmin LmsUserR
        linkUserName    = bool ForProfileR                      ForProfileDataR          isAdmin
@ -520,6 +531,10 @@ postQualificationR sid qsh = do
      noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers      
      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
+      addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
+      reloadKeepGetParams $ QualificationR sid qsh
    (action, selectedUsers) | isExpiryAct action -> do
      let isUnexpire = action == QualificationActUnexpireData
      upd <- runDB $ updateWhereCount
@ -529,10 +544,8 @@ postQualificationR sid qsh = do
          msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
      addMessageI msgKind msgVal
      reloadKeepGetParams $ QualificationR sid qsh
-    (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do
-      now <- liftIO getCurrentTime
-      let nowaday = utctDay now 
-          selUserIds = Set.toList selectedUsers
+    (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do      
+      let selUserIds = Set.toList selectedUsers
          qubr = case action of 
              QualificationActUnblockData         -> Nothing
              QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
--- a/src/Handler/Tutorial/Users.hs
+++ b/src/Handler/Tutorial/Users.hs
@ -66,7 +66,7 @@ postTUsersR tid ssh csh tutn = do
    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn    
    qualifications <- getCourseQualifications cid
    now <- liftIO getCurrentTime
-    let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications)  -- no instance Ord CalendarDiffDays        
+    let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications  -- no instance Ord CalendarDiffDays
        dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
        colChoices  = mconcat $ catMaybes
          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
--- a/src/Handler/Utils/Qualification.hs
+++ b/src/Handler/Utils/Qualification.hs
@ -137,4 +137,28 @@ qualificationUserBlocking qid uids qb = do
      , transactionUser               = uid
      , transactionQualificationBlock = qb
      }
+  return $ fromIntegral oks
+
+qualificationUserUnblockByReason :: 
+  ( AuthId (HandlerSite m) ~ Key User
+  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
+  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
+  , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
+  , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
+  , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
+  , HasInstanceID (HandlerSite m) InstanceId
+  , YesodAuthPersist (HandlerSite m)
+  , HasAppSettings (HandlerSite m)
+  , MonadHandler m
+  , MonadCatch m
+  , Num n
+  ) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
+qualificationUserUnblockByReason qid uids reason = do
+  blockUsers <- selectList [ QualificationUserQualification ==. qid
+                           , QualificationUserBlockedDue !=. Nothing
+                           , QualificationUserUser <-. uids
+                           ] [Asc QualificationUserId]
+  let toUnblock = filter (\quent -> reason == quent ^. _entityVal . _qualificationUserBlockedDue . _qualificationBlockedReason) blockUsers
+  oks <- updateWhereCount  [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
+                           [ QualificationUserBlockedDue =. Nothing ]
  return $ fromIntegral oks