fraport/fradrive-old
Archived
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? QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte?
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationGrantReason: Erteilungsbegründung
QualificationBlockReason: Entzugsbegründung QualificationBlockReason: Entzugsbegründung
QualificationBlockNotify: Benachrichtigung verschicken QualificationBlockNotify: Benachrichtigung verschicken
QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen 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? QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?
QualificationUserNoRenewal: Expires without further notification QualificationUserNoRenewal: Expires without further notification
QualificationUserNone: No registered qualifications for this person. QualificationUserNone: No registered qualifications for this person.
QualificationGrantReason: Reason for granting
QualificationBlockReason: Reason for revoking QualificationBlockReason: Reason for revoking
QualificationBlockNotify: Send notification QualificationBlockNotify: Send notification
QualificationBlockRemoveSupervisor: Remove all supervisors 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 MenuLms !ident-ok: E‑Learning
MenuLmsEdit: Bearbeiten E‑Learning MenuLmsEdit: Bearbeiten E‑Learning
MenuLmsUser: Benutzer Qualifikationen MenuLmsUser: Benutzer Qualifikationen
MenuLmsUserAll: Alle Benutzer Qualifikationen
MenuLmsUsers: Export E‑Learning Benutzer MenuLmsUsers: Export E‑Learning Benutzer
MenuLmsUserlist: Melden E‑Learning Benutzer MenuLmsUserlist: Melden E‑Learning Benutzer
MenuLmsResult: Melden Ergebnisse E‑Learning 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 MenuLms: E‑Learning
MenuLmsEdit: Edit E‑Learning MenuLmsEdit: Edit E‑Learning
MenuLmsUser: User Qualifications MenuLmsUser: User Qualifications
MenuLmsUserAll: All User Qualifications
MenuLmsUsers: Download E‑Learning Users MenuLmsUsers: Download E‑Learning Users
MenuLmsUserlist: Upload E‑Learning Users MenuLmsUserlist: Upload E‑Learning Users
MenuLmsResult: Upload E‑Learning Results MenuLmsResult: Upload E‑Learning Results

42
routes
View File

@ -260,29 +260,29 @@
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect !/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
/qualification QualificationAllR GET !free /qualification QualificationAllR GET !free
/qualification/#SchoolId QualificationSchoolR GET !free /qualification/#SchoolId QualificationSchoolR GET !free
/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free /qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free
/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement -- /qualification/#SchoolId/#QualificationShorthand/#CryptoUUIDUser QualificationUserR GET -- see LmsUserR
-- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL /qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement
-- LMS -- LMS
/lms LmsAllR GET POST /lms LmsAllR GET POST
/lms/#SchoolId LmsSchoolR GET /lms/#SchoolId LmsSchoolR GET
/lms/#SchoolId/#QualificationShorthand LmsR GET POST /lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS /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/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter
/lmsuser/#CryptoUUIDUser LmsUserR GET /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET
/lmsuser/#CryptoUUIDUser LmsUserAllR GET
/api ApiDocsR GET !free /api ApiDocsR GET !free
/swagger SwaggerR 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 (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect 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 (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing

29
src/Handler/Admin.hs
View File

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

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

@ -356,6 +356,7 @@ data LicenceTableActionData = LicenceTableChangeAvsData
} }
| LicenceTableGrantFDriveData | LicenceTableGrantFDriveData
{ licenceTableChangeFDriveQId :: QualificationId { licenceTableChangeFDriveQId :: QualificationId
, licenceTableChangeFDriveReason :: Text
, licenceTableChangeFDriveEnd :: Day , licenceTableChangeFDriveEnd :: Day
, licenceTableChangeFDriveRenew :: Maybe Bool , licenceTableChangeFDriveRenew :: Maybe Bool
} }
@ -445,11 +446,7 @@ getProblemAvsSynchR = do
then return (-1) then return (-1)
else do else do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
qualificationUserBlocking licenceTableChangeFDriveQId uids licenceTableChangeFDriveNotify $ qualificationUserBlocking licenceTableChangeFDriveQId uids False (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify
Just $ QualificationBlocked
{ qualificationBlockedDay = nowaday
, qualificationBlockedReason = licenceTableChangeFDriveReason
}
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
| oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks | otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
@ -459,6 +456,7 @@ getProblemAvsSynchR = do
(n, Qualification{qualificationShorthand}) <- runDB $ do (n, Qualification{qualificationShorthand}) <- runDB $ do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True (Left licenceTableChangeFDriveReason) False
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
(length uids,) <$> get404 licenceTableChangeFDriveQId (length uids,) <$> get404 licenceTableChangeFDriveQId
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n 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.InnerJoin` E.SqlExpr (Entity User)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
) )
queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs) 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 :: 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 :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser))
queryQualUser = $(E.sqlLOJproj 3 2) queryQualUser = $(E.sqlLOJproj 4 2)
queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) 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 :: Lens' LicenceTableData (Entity UserAvs)
resultUserAvs = _dbrOutput . _1 resultUserAvs = _dbrOutput . _1
@ -505,30 +507,40 @@ resultQualUser = _dbrOutput . _3 . _Just
resultQualification :: Traversal' LicenceTableData (Entity Qualification) resultQualification :: Traversal' LicenceTableData (Entity Qualification)
resultQualification = _dbrOutput . _4 . _Just resultQualification = _dbrOutput . _4 . _Just
resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _5 . _Just
instance HasEntity LicenceTableData User where instance HasEntity LicenceTableData User where
hasEntity = resultUser hasEntity = resultUser
instance HasUser LicenceTableData where 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 :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus dbtIdent aLic apids = do mkLicenceTable apidStatus dbtIdent aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now let nowaday = utctDay now
avsQids = entityKey <$> avsQualifications
-- fltrLic qual = if -- 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 -- | 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 -- | 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) 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: -- 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 $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification
E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser
E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) E.where_ $ fltrLic qual
return (usrAvs, user, qualUser, 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? dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here: -- Not sure what changes here:
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) 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) [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal -- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
, colUserNameLink AdminUserR , colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
-- , colUserCompany -- , 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" , 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 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 icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies pure $ toWgt $ mconcat companies
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q , 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 "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 "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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip , sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b cellMaybe (qualificationValidReasonCell True nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b ) $ \(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 , 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 ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue)) , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
, single ("validity" , SortColumn $ queryQualUser >>> validQualification' nowaday) , single ("validity" , SortColumn $ queryQualUser >>> validQualification' now)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ 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 -> , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` 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 , optionExternalValue = tshow cQualId
} }
aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications 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 :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
acts = mconcat acts = mconcat
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData [ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
, if aLic == AvsNoLicence , if aLic == AvsNoLicence
then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq textField (fslI MsgQualificationBlockReason) Nothing <*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
<*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing <*> 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}|] in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) 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) makeCourseTable :: (ToSortable h, Functor h)

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

@ -18,7 +18,8 @@ import Import
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Course 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 Database.Esqueleto.Utils.TH
import Handler.Course.Register (deregisterParticipant) 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 E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
return (user, participant, note E.?. CourseUserNoteId, subGroup) 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 type UserTableData = DBRow ( Entity User
, Entity CourseParticipant , Entity CourseParticipant
@ -131,7 +132,9 @@ _userSheets = _dbrOutput . _7
-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications -- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications
_userQualifications :: Getter UserTableData [Entity Qualification] _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 :: Lens' UserTableData UserTableQualifications
_userCourseQualifications = _dbrOutput . _8 _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 Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points
_other -> mempty _other -> mempty
colUserQualifications :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c)
colUserQualifications = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $
\(view _userCourseQualifications -> qualis) -> let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidIconCell cutoff qb qu <> spacerCell <> dayCell (qu ^. _qualificationUserValidUntil)
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationValidUntilCell in \(view _userCourseQualifications -> qualis) ->
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell
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
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 data UserTableCsv = UserTableCsv
{ csvUserSurname :: UserSurname { csvUserSurname :: UserSurname
@ -417,13 +419,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, submission , submission
) )
) )
qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser) -> do qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do
E.on $ qualification E.^. QualificationId E.==. qualificationUser E.^. QualificationUserQualification 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.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user)
E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids 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 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 let
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') 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 :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR getCUsersR = postCUsersR
postCUsersR tid ssh csh = do postCUsersR tid ssh csh = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
showSex <- getShowSex showSex <- getShowSex
(course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do (course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
@ -656,7 +661,7 @@ postCUsersR tid ssh csh = do
, guardOn showSex . cap' $ colUserSex' , guardOn showSex . cap' $ colUserSex'
, pure . cap' $ colUserEmail , pure . cap' $ colUserEmail
, pure . cap' $ colUserMatriclenr , pure . cap' $ colUserMatriclenr
, pure . cap' $ colUserQualifications , pure . cap' $ colUserQualifications nowaday
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
, guardOn hasExams . cap' $ colUserExams tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh
@ -735,7 +740,6 @@ postCUsersR tid ssh csh = do
(CourseUserRegisterExamData{..}, selectedUsers) -> do (CourseUserRegisterExamData{..}, selectedUsers) -> do
Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
now <- liftIO getCurrentTime
let (exam, mOccurrence) = registerExam let (exam, mOccurrence) = registerExam
mExamReg <- lift $ insertUnique ExamRegistration mExamReg <- lift $ insertUnique ExamRegistration
{ examRegistrationExam = exam { examRegistrationExam = exam
@ -760,7 +764,6 @@ postCUsersR tid ssh csh = do
redirect $ CourseR tid ssh csh CUsersR redirect $ CourseR tid ssh csh CUsersR
(CourseUserReRegisterData, selectedUsers) -> do (CourseUserReRegisterData, selectedUsers) -> do
now <- liftIO getCurrentTime
Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
didUpdate <- lift $ updateWhereCount didUpdate <- lift $ updateWhereCount
[ CourseParticipantUser ==. uid [ CourseParticipantUser ==. uid

21
src/Handler/LMS.hs
View File

@ -19,6 +19,7 @@ module Handler.LMS
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
, getLmsFakeR , postLmsFakeR , getLmsFakeR , postLmsFakeR
, getLmsUserR , getLmsUserR
, getLmsUserAllR
) )
where where
@ -583,7 +584,6 @@ postLmsR sid qsh = do
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
<* aformMessage msgRestartWarning <* aformMessage msgRestartWarning
] ]
-- lmsStatusLink = toMaybe isAdmin LmsUserR
colChoices cmpMap = mconcat colChoices cmpMap = mconcat
[ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdr MsgLmsUser AdminUserR , 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 "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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> , 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 , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid , 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)]) getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)])
-- intended to be viewed primarily in a modal, wie lmsStatusCell -- intended to be viewed primarily in a modal, wie lmsStatusCell
getLmsUserR :: CryptoUUIDUser -> Handler Html getLmsUserAllR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do 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 uid <- decrypt uuid
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
(user@User{userDisplayName}, quals, qblocks) <- runDB $ do (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 `Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid
E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
) )
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) Ex.where_ $ E.and $
E.||. E.isJust ( lmsUsr E.?. LmsUserUser) (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] Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr) pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr)
bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName))] 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 , qualificationValidDuration=validMonths
}} <- getBy404 $ SchoolQualificationShort sid qsh }} <- getBy404 $ SchoolQualificationShort sid qsh
-- Block copied to Handler/Qualifications TODO: refactor
let getBlockReasons unblk = Ex.select $ do let getBlockReasons unblk = Ex.select $ do
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
`Ex.innerJoin` Ex.table @QualificationUserBlock `Ex.innerJoin` Ex.table @QualificationUserBlock
@ -565,7 +566,7 @@ postQualificationR sid qsh = do
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
<* aformMessage msgGrantWarning <* aformMessage msgGrantWarning
] isAdmin ] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
linkUserName = bool ForProfileR ForProfileDataR isAdmin linkUserName = bool ForProfileR ForProfileDataR isAdmin
colChoices cmpMap = mconcat colChoices cmpMap = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) [ 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 "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> , 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 , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))

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

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

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

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