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

refactor(qualifications): views course, admin-avs and lms-user refactored (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2023-06-29 17:05:46 +00:00
parent 8a6af742d5
commit 23bc9033e7
14 changed files with 163 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -32,6 +32,7 @@ TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versende
QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte?
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationGrantReason: Erteilungsbegründung
QualificationBlockReason: Entzugsbegründung
QualificationBlockNotify: Benachrichtigung verschicken
QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen

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

@ -32,6 +32,7 @@ TableQualificationNoRenewalTooltip: No renewal notifications will be send for th
QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?
QualificationUserNoRenewal: Expires without further notification
QualificationUserNone: No registered qualifications for this person.
QualificationGrantReason: Reason for granting
QualificationBlockReason: Reason for revoking
QualificationBlockNotify: Send notification
QualificationBlockRemoveSupervisor: Remove all supervisors

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -118,6 +118,7 @@ MenuQualifications: Qualifikationen
MenuLms !ident-ok: E‑Learning
MenuLmsEdit: Bearbeiten E‑Learning
MenuLmsUser: Benutzer Qualifikationen
MenuLmsUserAll: Alle Benutzer Qualifikationen
MenuLmsUsers: Export E‑Learning Benutzer
MenuLmsUserlist: Melden E‑Learning Benutzer
MenuLmsResult: Melden Ergebnisse E‑Learning

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -119,6 +119,7 @@ MenuQualifications: Qualifications
MenuLms: E‑Learning
MenuLmsEdit: Edit E‑Learning
MenuLmsUser: User Qualifications
MenuLmsUserAll: All User Qualifications
MenuLmsUsers: Download E‑Learning Users
MenuLmsUserlist: Upload E‑Learning Users
MenuLmsResult: Upload E‑Learning Results

42
routes
View File

@ -260,29 +260,29 @@
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
/qualification QualificationAllR GET !free
/qualification/#SchoolId QualificationSchoolR GET !free
/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free
/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement
-- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL
/qualification QualificationAllR GET !free
/qualification/#SchoolId QualificationSchoolR GET !free
/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free
-- /qualification/#SchoolId/#QualificationShorthand/#CryptoUUIDUser QualificationUserR GET -- see LmsUserR
/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement
-- LMS
/lms LmsAllR GET POST
/lms/#SchoolId LmsSchoolR GET
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS
/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter
/lmsuser/#CryptoUUIDUser LmsUserR GET
/lms LmsAllR GET POST
/lms/#SchoolId LmsSchoolR GET
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS
/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter
/lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET
/lmsuser/#CryptoUUIDUser LmsUserAllR GET
/api ApiDocsR GET !free
/swagger SwaggerR GET !free

3
src/Foundation/Navigation.hs
View File

@ -186,7 +186,8 @@ breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Jus
breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
breadcrumb (LmsUserR _) = i18nCrumb MsgMenuLmsUser $ Just LmsAllR
breadcrumb (LmsUserR _ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserAllR u
breadcrumb (LmsUserAllR _ ) = i18nCrumb MsgMenuLmsUserAll $ Just LmsAllR
-- breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing

33
src/Handler/Admin.hs
View File

@ -41,15 +41,14 @@ getAdminR = redirect AdminProblemsR
getAdminProblemsR :: Handler Html
getAdminProblemsR = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
cutOffPrintDays = 7
let cutOffPrintDays = 7
cutOffPrintJob = addLocalDays (-cutOffPrintDays) now
cutOffAvsSynch = Just $ addUTCTime (-nominalHour) now -- update at most once per hour
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,)
<$> areAllUsersReachable
<*> allDriversHaveAvsId nowaday
<*> allRDriversHaveFs nowaday
<*> allDriversHaveAvsId now
<*> allRDriversHaveFs now
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob])
diffLics <- try retrieveDifferingLicences >>= \case
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
@ -107,9 +106,8 @@ getProblemUnreachableR = do
getProblemFbutNoR :: Handler Html
getProblemFbutNoR = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF nowaday
now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
siteLayoutMsg MsgProblemsRWithoutFHeading $ do
setTitleI MsgProblemsRWithoutFHeading
[whamlet|
@ -123,9 +121,8 @@ getProblemFbutNoR = do
getProblemWithoutAvsId :: Handler Html
getProblemWithoutAvsId = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId nowaday
now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
setTitleI MsgProblemsNoAvsIdHeading
[whamlet|
@ -174,7 +171,7 @@ retrieveUnreachableUsers = do
hasInvalidEmail = isNothing . getEmailAddress . entityVal
allDriversHaveAvsId :: Day -> DB Bool
allDriversHaveAvsId :: UTCTime -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
@ -199,8 +196,8 @@ retrieveDriversWithoutAvsId' nowaday = do
-}
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId nowaday = do
retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId now = do
usr <- E.from $ E.table @User
E.where_ $
E.exists (do -- a valid avs licence
@ -209,7 +206,7 @@ retrieveDriversWithoutAvsId nowaday = do
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr & validQualification nowaday) -- currently valid
E.&&. (qualUsr & validQualification now) -- currently valid
E.&&. -- matches user
(qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
)
@ -221,13 +218,13 @@ retrieveDriversWithoutAvsId nowaday = do
return usr
allRDriversHaveFs :: Day -> DB Bool
allRDriversHaveFs :: UTCTime -> DB Bool
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversRWithoutF :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversRWithoutF nowaday = do
retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversRWithoutF now = do
usr <- E.from $ E.table @User
let hasValidQual lic = do
(qual :& qualUsr) <- E.from (E.table @Qualification
@ -235,7 +232,7 @@ retrieveDriversRWithoutF nowaday = do
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
E.&&. (qualUsr & validQualification nowaday) -- currently valid
E.&&. (qualUsr & validQualification now) -- currently valid
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
return usr

81
src/Handler/Admin/Avs.hs
View File

@ -356,6 +356,7 @@ data LicenceTableActionData = LicenceTableChangeAvsData
}
| LicenceTableGrantFDriveData
{ licenceTableChangeFDriveQId :: QualificationId
, licenceTableChangeFDriveReason :: Text
, licenceTableChangeFDriveEnd :: Day
, licenceTableChangeFDriveRenew :: Maybe Bool
}
@ -445,11 +446,7 @@ getProblemAvsSynchR = do
then return (-1)
else do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
qualificationUserBlocking licenceTableChangeFDriveQId uids licenceTableChangeFDriveNotify $
Just $ QualificationBlocked
{ qualificationBlockedDay = nowaday
, qualificationBlockedReason = licenceTableChangeFDriveReason
}
qualificationUserBlocking licenceTableChangeFDriveQId uids False (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
| oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
@ -459,6 +456,7 @@ getProblemAvsSynchR = do
(n, Qualification{qualificationShorthand}) <- runDB $ do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True (Left licenceTableChangeFDriveReason) False
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
(length uids,) <$> get404 licenceTableChangeFDriveQId
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
@ -477,21 +475,25 @@ type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs)
`E.InnerJoin` E.SqlExpr (Entity User)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
)
queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs)
queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 3 1)
queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)
queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User)
queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 3 1)
queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1)
queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser))
queryQualUser = $(E.sqlLOJproj 3 2)
queryQualUser = $(E.sqlLOJproj 4 2)
queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
queryQualification = $(E.sqlLOJproj 3 3)
queryQualification = $(E.sqlLOJproj 4 3)
type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification))
queryQualBlock :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(E.sqlLOJproj 4 4)
type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification), Maybe (Entity QualificationUserBlock))
resultUserAvs :: Lens' LicenceTableData (Entity UserAvs)
resultUserAvs = _dbrOutput . _1
@ -505,30 +507,40 @@ resultQualUser = _dbrOutput . _3 . _Just
resultQualification :: Traversal' LicenceTableData (Entity Qualification)
resultQualification = _dbrOutput . _4 . _Just
resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _5 . _Just
instance HasEntity LicenceTableData User where
hasEntity = resultUser
instance HasUser LicenceTableData where
hasUser = resultUser . _entityVal
hasUser = resultUser . _entityVal
-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
-- hasQualificationUser = resultQualUser . _entityVal
mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus dbtIdent aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
now <- liftIO getCurrentTime
let nowaday = utctDay now
avsQids = entityKey <$> avsQualifications
-- fltrLic qual = if
-- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS
-- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)
-- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution:
dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual) -> do
dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual `E.LeftOuterJoin` qblock) -> do
E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId
E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification
E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser
E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
return (usrAvs, user, qualUser, qual)
E.where_ $ fltrLic qual
E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
E.&&. qblock `isLatestBlockBefore` E.val now
return (usrAvs, user, qualUser, qual, qblock)
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here:
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
@ -536,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
, colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
-- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
@ -549,12 +561,13 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
, sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (cellMaybe (qualificationValidIconCell nowaday) . preview resultQualUser)
, sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) $ \row ->
cellMaybe (qualificationValidIconCell nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b
, sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
cellMaybe (qualificationValidReasonCell True nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
@ -567,14 +580,14 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
, single ("validity" , SortColumn $ queryQualUser >>> validQualification' nowaday)
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
, single ("validity" , SortColumn $ queryQualUser >>> validQualification' now)
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work?
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
, single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
@ -600,17 +613,37 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, optionExternalValue = tshow cQualId
}
aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
-- Block identical to Handler/Qualifications TODO: refactor
getBlockReasons unblk = E.select $ do
(quser :& qblock) <- X.from $ E.table @QualificationUser
`E.innerJoin` E.table @QualificationUserBlock
`X.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
E.where_ $ ((quser E.^. QualificationUserQualification) `E.in_` E.valList avsQids)
E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
E.groupBy (qblock E.^. QualificationUserBlockReason)
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
E.orderBy [E.desc countRows']
E.limit 7
pure (qblock E.^. QualificationUserBlockReason)
mkOption :: E.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
acts = mconcat
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
, if aLic == AvsNoLicence
then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq textField (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
<*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
<*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing
]

2
src/Handler/Course/List.hs
View File

@ -105,7 +105,7 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolSh
in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell
colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered ((spacerCell <>) . tickmarkCell)
makeCourseTable :: (ToSortable h, Functor h)

49
src/Handler/Course/Users.hs
View File

@ -18,7 +18,8 @@ import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.Course
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E
import Database.Esqueleto.Utils.TH
import Handler.Course.Register (deregisterParticipant)
@ -87,7 +88,7 @@ userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.L
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
return (user, participant, note E.?. CourseUserNoteId, subGroup)
type UserTableQualifications = [(Entity Qualification, Entity QualificationUser)]
type UserTableQualifications = [(Entity Qualification, Entity QualificationUser, Maybe (Entity QualificationUserBlock))]
type UserTableData = DBRow ( Entity User
, Entity CourseParticipant
@ -131,7 +132,9 @@ _userSheets = _dbrOutput . _7
-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications
_userQualifications :: Getter UserTableData [Entity Qualification]
_userQualifications = _dbrOutput . _8 . to (fmap fst)
_userQualifications = _dbrOutput . _8 . to (fmap fst3)
-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work
_userCourseQualifications :: Lens' UserTableData UserTableQualifications
_userCourseQualifications = _dbrOutput . _8
@ -182,18 +185,17 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points
_other -> mempty
colUserQualifications :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserQualifications = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $
\(view _userCourseQualifications -> qualis) ->
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationValidUntilCell
colUserQualificationBlocked :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserQualificationBlocked = sortable (Just "qualification-block") (i18nCell MsgTableQualificationBlockedDue) $
\(view _userCourseQualifications -> qualis) ->
let blocks = qualificationUserBlockedDue . entityVal . snd <$> qualis
--blocks = qaulis <$> view (_2 . _entityVal . _qualificationUserBlockedDue)
in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell blocks $ qualificationBlockedCell
colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c)
colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $
let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidIconCell cutoff qb qu <> spacerCell <> dayCell (qu ^. _qualificationUserValidUntil)
in \(view _userCourseQualifications -> qualis) ->
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell
colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c)
colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgTableQualificationBlockedDue) $
let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell isAdmin cutoff qb qu
in \(view _userCourseQualifications -> qualis) ->
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell
data UserTableCsv = UserTableCsv
{ csvUserSurname :: UserSurname
@ -417,13 +419,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, submission
)
)
qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser) -> do
E.on $ qualification E.^. QualificationId E.==. qualificationUser E.^. QualificationUserQualification
qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do
E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId
E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user)
E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
E.&&. qualificationBlock `isLatestBlockBefore` E.now_
E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here
return (qualification, qualificationUser)
return (qualification, qualificationUser, qualificationBlock)
let
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
@ -624,6 +627,8 @@ courseUserDeregisterForm _cid = wFormToAForm . pure . pure $ CourseUserDeregiste
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR
postCUsersR tid ssh csh = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
showSex <- getShowSex
(course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
@ -656,7 +661,7 @@ postCUsersR tid ssh csh = do
, guardOn showSex . cap' $ colUserSex'
, pure . cap' $ colUserEmail
, pure . cap' $ colUserMatriclenr
, pure . cap' $ colUserQualifications
, pure . cap' $ colUserQualifications nowaday
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
, guardOn hasExams . cap' $ colUserExams tid ssh csh
@ -734,8 +739,7 @@ postCUsersR tid ssh csh = do
redirect $ CourseR tid ssh csh CUsersR
(CourseUserRegisterExamData{..}, selectedUsers) -> do
Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
now <- liftIO getCurrentTime
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
let (exam, mOccurrence) = registerExam
mExamReg <- lift $ insertUnique ExamRegistration
{ examRegistrationExam = exam
@ -759,8 +763,7 @@ postCUsersR tid ssh csh = do
Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
redirect $ CourseR tid ssh csh CUsersR
(CourseUserReRegisterData, selectedUsers) -> do
now <- liftIO getCurrentTime
(CourseUserReRegisterData, selectedUsers) -> do
Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
didUpdate <- lift $ updateWhereCount
[ CourseParticipantUser ==. uid

23
src/Handler/LMS.hs
View File

@ -19,6 +19,7 @@ module Handler.LMS
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
, getLmsFakeR , postLmsFakeR
, getLmsUserR
, getLmsUserAllR
)
where
@ -582,8 +583,7 @@ postLmsR sid qsh = do
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
<* aformMessage msgRestartWarning
]
-- lmsStatusLink = toMaybe isAdmin LmsUserR
]
colChoices cmpMap = mconcat
[ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdr MsgLmsUser AdminUserR
@ -603,7 +603,7 @@ postLmsR sid qsh = do
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock)
qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
@ -721,8 +721,14 @@ getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html
getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)])
-- intended to be viewed primarily in a modal, wie lmsStatusCell
getLmsUserR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do
getLmsUserAllR :: CryptoUUIDUser -> Handler Html
getLmsUserAllR = viewLmsUserR Nothing Nothing
getLmsUserR :: SchoolId -> QualificationShorthand -> CryptoUUIDUser -> Handler Html
getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh)
viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
viewLmsUserR msid mqsh uuid = do
uid <- decrypt uuid
now <- liftIO getCurrentTime
(user@User{userDisplayName}, quals, qblocks) <- runDB $ do
@ -738,8 +744,11 @@ getLmsUserR uuid = do
`Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid
E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
)
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
Ex.where_ $ E.and $
(E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
[ (qual E.^. QualificationSchool E.==.) . E.val <$> msid
, (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh
]
Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr)
bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName))]

5
src/Handler/Qualification.hs
View File

@ -527,6 +527,7 @@ postQualificationR sid qsh = do
, qualificationValidDuration=validMonths
}} <- getBy404 $ SchoolQualificationShort sid qsh
-- Block copied to Handler/Qualifications TODO: refactor
let getBlockReasons unblk = Ex.select $ do
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
`Ex.innerJoin` Ex.table @QualificationUserBlock
@ -565,7 +566,7 @@ postQualificationR sid qsh = do
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
<* aformMessage msgGrantWarning
] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR
linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
linkUserName = bool ForProfileR ForProfileDataR isAdmin
colChoices cmpMap = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
@ -585,7 +586,7 @@ postQualificationR sid qsh = do
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock)
qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))

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

@ -60,21 +60,23 @@ data TutorialUserActionData
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do
postTUsersR tid ssh csh tutn = do
isAdmin <- hasReadAccessTo AdminR
(Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
qualifications <- getCourseQualifications cid
now <- liftIO getCurrentTime
let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays
dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
let nowaday = utctDay now
minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays
dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
colChoices = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
, pure colUserEmail
, pure colUserMatriclenr
, pure colUserQualifications
, pure colUserQualificationBlocked
, pure $ colUserQualifications nowaday
, pure $ colUserQualificationBlocked isAdmin nowaday
]
psValidator = def
& defaultSortingByName

20
src/Handler/Utils/Table/Cells.hs
View File

@ -326,19 +326,21 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific
Nothing -> mempty
(Just descr) -> spacerCell <> markupCellLargeModal descr
qualificationValidUntilCell :: (IsDBTable m c, HasQualification a, HasQualificationUser a) => a -> DBCell m c
qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd
where
qsh = q ^. hasQualification . _qualificationShorthand . _CI
vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
-- DEPRECATED
-- qualificationValidUntilCell :: (IsDBTable m c, HasQualification a, HasQualificationUser a) => a -> DBCell m c
-- qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd
-- where
-- qsh = q ^. hasQualification . _qualificationShorthand . _CI
-- vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c
qualificationValidIconCell d qu qb = blockIcon $ isValidQualification d qu qb
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
qualificationValidIconCell d qb qu = do
blockIcon $ isValidQualification d qu qb
where
blockIcon = cell . toWidget . iconQualificationBlock
qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> a -> Maybe b -> DBCell m c
qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb
qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> Maybe b -> a -> DBCell m c
qualificationValidReasonCell showReason d qb qu = ic <> foldMap blc qb
where
ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})