From a64a2368dbe28edfcc72f09a9180109b89692609 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 May 2023 10:58:55 +0000 Subject: [PATCH] chore(qualification): Fix #46 by add qualification grant act to qualification view --- .../categories/courses/tutorial/en-eu.msg | 4 +-- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 9 ++++--- src/Handler/Qualification.hs | 27 ++++++++++++++----- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Utils/Qualification.hs | 24 +++++++++++++++++ 6 files changed, 53 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index cdcf22eda..d793fe028 100644 --- 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 diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 6267eff82..eae8b0e69 100644 --- 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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 6880fa3ee..77a2dfbb5 100644 --- 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. diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index dcbb42508..2a5e2c0b8 100644 --- 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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index b32f1aeb8..207bc1731 100644 --- 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)) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 1e8302ecf..89ddd3827 100644 --- 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 \ No newline at end of file