fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into test

Browse Source
This commit is contained in:
Steffen Jost 2023-11-03 15:36:04 +00:00
commit e63c8751eb
10 changed files with 89 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
CHANGELOG.md
View File

@ -2,9 +2,9 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.46...t27.4.47) (2023-10-27)
## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03)
## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.35...t27.4.46) (2023-10-26)
## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03)
### Bug Fixes
@ -28,6 +28,7 @@ All notable changes to this project will be documented in this file. See [standa
* **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b))
* **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6))
* **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22))
* **course:** grant qualifications now issues and unblocks ([5d8d8cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5d8d8cf17e634ecb950a1c329c859fb93f94ef77))
* **users:** allow prefer postal setting for users with fraport department ([a9d56c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a9d56c51dcc727f8637b09a0e849372e75032f5e))
## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)

1
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationGrantReason: Erteilungsbegründung
QualificationRenewReason: Verlängerungsbegründung
QualificationBlockReason: Entzugsbegründung
QualificationBlockNotify: Benachrichtigung verschicken
QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen

1
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Will there be a notification, if this quali
QualificationUserNoRenewal: Expires without further notification
QualificationUserNone: No registered qualifications for this person.
QualificationGrantReason: Reason for granting
QualificationRenewReason: Reason for renewal
QualificationBlockReason: Reason for revoking
QualificationBlockNotify: Send notification
QualificationBlockRemoveSupervisor: Remove all supervisors

16
models/lms.model
View File

@ -146,7 +146,7 @@ LmsUser
-- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history
-- deriving Generic
-- LmsUserlist stores LMS upload for later processing only
-- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only
LmsUserlist
qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent
@ -155,7 +155,7 @@ LmsUserlist
UniqueLmsUserlist qualification ident
deriving Generic Show
-- LmsResult stores LMS upload for later processing only
-- DEPRECATED V1 LmsResult stores LMS upload for later processing only
LmsResult
qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent
@ -164,6 +164,7 @@ LmsResult
UniqueLmsResult qualification ident -- required by DBTable
deriving Generic
-- V2 Stores LMS upload for processing in Background Job
LmsReport
qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent
@ -172,4 +173,15 @@ LmsReport
lock Bool -- (0|1)
timestamp UTCTime default=now()
UniqueLmsReport qualification ident -- required by DBTable
deriving Generic
-- LmsAudit removed by commit 71cde92a
-- due to frequent transmit errors, a separate lms tranmission log is necessary again
LmsReportLog
qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent
date UTCTime Maybe -- BEWARE: timezone is local as submitted by LMS
result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success]
lock Bool -- (0|1)
timestamp UTCTime default=now()
deriving Generic

1
src/Audit/Types.hs
View File

@ -216,6 +216,7 @@ data Transaction
, transactionQualification :: QualificationId
, transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
, transactionNote :: Maybe Text
}
| TransactionQualificationUserDelete
{ transactionUser :: UserId

9
src/Handler/Qualification.hs
View File

@ -296,7 +296,7 @@ data QualificationTableActionData
| QualificationActBlockSupervisorData
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
| QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
| QualificationActRenewData
| QualificationActRenewData { qualTableActChangeReason :: Text}
| QualificationActGrantData { qualTableActGrantUntil :: Day }
deriving (Eq, Ord, Show, Generic)
@ -573,7 +573,8 @@ postQualificationR sid qsh = do
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
, singletonMap QualificationActRenew $ pure QualificationActRenewData
, singletonMap QualificationActRenew $ QualificationActRenewData
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing
, singletonMap QualificationActGrant $ QualificationActGrantData
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
<* aformMessage msgGrantWarning
@ -608,8 +609,8 @@ postQualificationR sid qsh = do
return (tbl, qent)
formResult lmsRes $ \case
(QualificationActRenewData, selectedUsers) | isAdmin -> do
noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
(QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ 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

2
src/Handler/Tutorial/Users.hs
View File

@ -146,7 +146,7 @@ postTUsersR tid ssh csh tutn = do
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserRenewQualificationData{..}, selectedUsers)
| tuQualification `Set.member` courseQids -> do
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing $ Set.toList selectedUsers
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserSendMailData{}, selectedUsers) -> do

18
src/Handler/Utils/Qualification.hs
View File

@ -24,10 +24,10 @@ statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificati
-- needs refactoring, probbably no longer helpful
mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
where
qualificationUserBlockReason = qualificationBlockedReasonText reason
qualificationUserBlockReason = tshow reason
qualificationUserBlockUnblock = False
qualificationUserBlockBlocker = Nothing
@ -158,6 +158,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = qualificationUserValidUntil
, transactionQualificationScheduleRenewal = mbScheduleRenewal
, transactionNote = canonical $ Just reason
}
-- | Renew an existing valid qualification, ignoring all blocks otherwise
@ -174,8 +175,8 @@ renewValidQualificationUsers ::
, HasAppSettings (HandlerSite m)
, MonadHandler m
, MonadCatch m
) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
renewValidQualificationUsers qid renewalTime uids =
) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
renewValidQualificationUsers qid reason renewalTime uids =
-- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
-- E.update $ \qu -> do
-- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
@ -199,6 +200,7 @@ renewValidQualificationUsers qid renewalTime uids =
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = newValidTo
, transactionQualificationScheduleRenewal = Nothing
, transactionNote = qualificationChangeReasonText <$> reason
}
return $ length quEnts
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
@ -217,8 +219,8 @@ qualificationUserBlocking ::
, MonadHandler m
, MonadCatch m
, Num n
) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do
) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do
$logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify]
authUsr <- liftHandler maybeAuthId
now <- liftIO getCurrentTime
@ -269,8 +271,8 @@ qualificationUserUnblockByReason ::
, MonadHandler m
, MonadCatch m
, Num n
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
toUnblock <- E.select $ do
quser <- E.from $ E.table @QualificationUser

34
src/Jobs/Handler/LMS.hs
View File

@ -256,6 +256,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
-- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
@ -316,7 +317,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
procBlock (Entity luid luser, Entity _ lreport) = do
let repDay = lmsReportDate lreport <|> Just now
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
return $ Sum ok_block
in lrepQry lrFltrBlock
@ -326,12 +327,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
procRenew (Entity luid luser, Entity _ lreport) = do
let repDay = lmsReportDate lreport <|> Just now
reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser
-- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
-- END LMS WORKAROUND 2
ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
-- END LMS WORKAROUND 2
ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
return $ Sum ok_renew
in lrepQry lrFltrSuccess
@ -377,7 +379,25 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
updateReceivedLocked True
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
-- G) Truncate LmsReport for qid and log
-- G) Truncate LmsReport for qid, after updating log
E.insertSelect $ do
lreport <- E.from $ E.table @LmsReport
let samelog = E.subSelect $ do
lrl <- E.from $ E.table @LmsReportLog
E.where_ $ lrl E.^. LmsReportLogQualification E.==. E.val qid
E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent
E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. E.not_ (E.isTrue samelog)
return (LmsReportLog
E.<# (lreport E.^. LmsReportQualification)
E.<&> (lreport E.^. LmsReportIdent )
E.<&> (lreport E.^. LmsReportDate )
E.<&> (lreport E.^. LmsReportResult )
E.<&> (lreport E.^. LmsReportLock )
E.<&> (lreport E.^. LmsReportTimestamp ))
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
@ -415,11 +435,11 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
then do
-- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent)
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log
when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
_ok_renew <- renewValidQualificationUsers qid Nothing [qualificationUserUser] -- only unblocked are renewed
_ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed
-- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
update luid

42
src/Model/Types/Lms.hs
View File

@ -12,8 +12,8 @@ module Model.Types.Lms
) where
import Import.NoModel
import qualified Data.Map as Map
import Data.Map ((!))
-- import qualified Data.Map as Map
-- import Data.Map ((!))
import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E
import qualified Data.Csv as Csv
@ -56,27 +56,37 @@ instance Csv.ToField LmsStatus where
-- | Default Block/Unblock reasons
data QualificationBlockStandardReason
= QualificationBlockFailedELearning
data QualificationStandardReason
= QualificationRenewELearningBy LmsIdent
| QualificationBlockFailedELearningBy LmsIdent
| QualificationBlockFailedELearning
| QualificationBlockReturnedByCompany
| QualificationBlockExpired
deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
-- deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
instance Show QualificationBlockStandardReason where
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
show QualificationBlockExpired = "Abgelaufen"
qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
instance Show QualificationStandardReason where
show (QualificationRenewELearningBy lid) = "E-Learning bestanden für " <> show lid
show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
show QualificationBlockExpired = "Abgelaufen"
{-
qualificationBlockedReasonText :: QualificationStandardReason -> Text
qualificationBlockedReasonText =
let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
in (dictionary !) -- cannot fail due to universeF
type QualificationBlockReason = Either Text QualificationBlockStandardReason
qualificationBlockedReasonText :: QualificationStandardReason -> Text
qualificationBlockedReasonText = tshow
-}
qualificationBlockReasonText :: QualificationBlockReason -> Text
qualificationBlockReasonText (Left reason) = reason
qualificationBlockReasonText (Right stdreason) = qualificationBlockedReasonText stdreason
type QualificationChangeReason = Either Text QualificationStandardReason
qualificationChangeReasonText :: QualificationChangeReason -> Text
qualificationChangeReasonText (Left reason) = reason
qualificationChangeReasonText (Right stdreason) = tshow stdreason
-- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool }