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

chore(company): show company column for lms and quals, show lms blocked reason for admins in quals

Browse Source
This commit is contained in:
Steffen Jost 2023-03-16 11:47:21 +00:00
parent 09c4eb3a7b
commit 921e5df9d9
6 changed files with 52 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -583,7 +583,7 @@ mkLicenceTable dbtIdent aLic apids = do
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
validator = def -- & defaultSorting [SortDescBy "column-label"] validator = def & defaultSorting [SortAscBy "user-name"]
postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool)) postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
-> FormResult ( LicenceTableActionData, Set AvsPersonId) -> FormResult ( LicenceTableActionData, Set AvsPersonId)
postprocess inp = do postprocess inp = do

24
src/Handler/LMS.hs
View File

@ -395,7 +395,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived))
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
@ -514,6 +519,16 @@ postLmsR sid qsh = do
[ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
, colUserNameModalHdr MsgLmsUser AdminUserR , colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail , colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( 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
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, 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
@ -608,8 +623,10 @@ postLmsR sid qsh = do
-- intended to be viewed primarily in a modal, vie lmsStatusPlusCell' -- intended to be viewed primarily in a modal, vie lmsStatusPlusCell'
getLmsUserR :: CryptoUUIDUser -> Handler Html getLmsUserR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do getLmsUserR uuid = do
uid <- decrypt uuid uid <- decrypt uuid
now <- liftIO getCurrentTime
let nowaday = utctDay now
(user@User{userDisplayName}, quals) <- runDB $ do (user@User{userDisplayName}, quals) <- runDB $ do
usr <- get404 uid usr <- get404 uid
qs <- Ex.select $ do qs <- Ex.select $ do
@ -625,7 +642,8 @@ getLmsUserR uuid = do
) )
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
E.||. E.isJust ( lmsUsr E.?. LmsUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
pure (qual, qualUsr, lmsUsr) Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr)
return (usr,qs) return (usr,qs)
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]

2
src/Handler/PrintCenter.hs
View File

@ -279,7 +279,7 @@ mkPJTable = do
(First (Just act), jobMap) <- inp (First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet) return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "created"] psValidator = def & defaultSorting [SortDescBy "created"]
-- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter -- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
over _1 postprocess <$> dbTable psValidator DBTable{..} over _1 postprocess <$> dbTable psValidator DBTable{..}

27
src/Handler/Qualification.hs
View File

@ -317,6 +317,13 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
-- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted]) , queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
@ -340,7 +347,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | otherwise -> E.true
) )
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
@ -426,15 +433,27 @@ postQualificationR sid qsh = do
, singletonMap QualificationActBlock $ QualificationActBlockData , singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing <$> apreq textField (fslI MsgQualificationBlockReason) Nothing
] isAdmin ] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
colChoices = mconcat colChoices = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdr MsgLmsUser ForProfileR , colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail , colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( 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
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, 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-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCellNoReason b ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b
, 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-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) -- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)

7
templates/lms-user.hamlet
View File

@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$if null quals $if null quals
_{MsgQualificationUserNone} _{MsgQualificationUserNone}
$else $else
$forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals $forall (Entity _ quali, mbQualUsr, mbLmsUsr, validity) <- quals
<section> <section>
<div .container> <div .container>
<h2> <h2>
#{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali} #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) &nbsp; #{boolSymbol (E.unValue validity)}
<div .container> <div .container>
<dl .deflist> <dl .deflist>
$maybe (Entity _ qualUsr) <- mbQualUsr $maybe (Entity _ qualUsr) <- mbQualUsr
@ -41,7 +41,8 @@ $else
<dd .deflist__dd > <dd .deflist__dd >
<span .email> <span .email>
#{lmsUserPin lmsUsr} #{lmsUserPin lmsUsr}
\ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)} <br>
^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
$if lmsUserResetPin lmsUsr $if lmsUserResetPin lmsUsr
\ #{icon IconReset} \ #{icon IconReset}
$maybe ts <- lmsUserReceived lmsUsr $maybe ts <- lmsUserReceived lmsUsr

4
test/Database/Fill.hs
View File

@ -172,7 +172,7 @@ fillDb = do
, userTitle = Just "Dr." , userTitle = Just "Dr."
, userMaxFavourites = 14 , userMaxFavourites = 14
, userMaxFavouriteTerms = 4 , userMaxFavouriteTerms = 4
, userTheme = userDefaultTheme , userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat , userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
@ -574,7 +574,7 @@ fillDb = do
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False
void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True
void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True
void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False
void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False
void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True
void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False