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

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
+TutorialUserGrantQualification: Grant qualification
-TutorialUserRenewQualification: Renew 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

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

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
+LmsUserlistInsert: New LMS user
-LmsUserlistUpdate: Update of 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.

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
+    qent@Entity{entityVal=Qualification{
-    let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
+        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
+    (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do      
-      now <- liftIO getCurrentTime
+      let selUserIds = Set.toList selectedUsers
-      let nowaday = utctDay now 
-          selUserIds = Set.toList selectedUsers
           qubr = case action of 
               QualificationActUnblockData         -> Nothing
               QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday

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))

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