chore(company): show company column for lms and quals, show lms blocked reason for admins in quals
This commit is contained in:
parent
09c4eb3a7b
commit
921e5df9d9
@ -583,7 +583,7 @@ mkLicenceTable dbtIdent aLic apids = do
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
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))
|
||||
-> FormResult ( LicenceTableActionData, Set AvsPersonId)
|
||||
postprocess inp = do
|
||||
|
||||
@ -395,7 +395,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived))
|
||||
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
|
||||
, 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
|
||||
[ 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"
|
||||
, colUserNameModalHdr MsgLmsUser AdminUserR
|
||||
, 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 "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> 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'
|
||||
getLmsUserR :: CryptoUUIDUser -> Handler Html
|
||||
getLmsUserR uuid = do
|
||||
getLmsUserR uuid = do
|
||||
uid <- decrypt uuid
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
(user@User{userDisplayName}, quals) <- runDB $ do
|
||||
usr <- get404 uid
|
||||
qs <- Ex.select $ do
|
||||
@ -625,7 +642,8 @@ getLmsUserR uuid = do
|
||||
)
|
||||
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
|
||||
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)
|
||||
|
||||
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
|
||||
|
||||
@ -279,7 +279,7 @@ mkPJTable = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
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
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
|
||||
|
||||
@ -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-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
|
||||
, 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
|
||||
[ 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
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||
| otherwise -> E.true
|
||||
)
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||
@ -426,15 +433,27 @@ postQualificationR sid qsh = do
|
||||
, singletonMap QualificationActBlock $ QualificationActBlockData
|
||||
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing
|
||||
] isAdmin
|
||||
linkLmsUser = toMaybe isAdmin LmsUserR
|
||||
linkLmsUser = toMaybe isAdmin LmsUserR
|
||||
linkUserName = bool ForProfileR ForProfileDataR isAdmin
|
||||
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
|
||||
colChoices = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
||||
, colUserNameModalHdr MsgLmsUser ForProfileR
|
||||
, colUserNameModalHdr MsgLmsUser linkUserName
|
||||
, 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 "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||
, 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
|
||||
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
||||
-- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)
|
||||
|
||||
@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$if null quals
|
||||
_{MsgQualificationUserNone}
|
||||
$else
|
||||
$forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals
|
||||
$forall (Entity _ quali, mbQualUsr, mbLmsUsr, validity) <- quals
|
||||
<section>
|
||||
<div .container>
|
||||
<h2>
|
||||
#{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali}
|
||||
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) #{boolSymbol (E.unValue validity)}
|
||||
<div .container>
|
||||
<dl .deflist>
|
||||
$maybe (Entity _ qualUsr) <- mbQualUsr
|
||||
@ -41,7 +41,8 @@ $else
|
||||
<dd .deflist__dd >
|
||||
<span .email>
|
||||
#{lmsUserPin lmsUsr}
|
||||
\ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
|
||||
<br>
|
||||
^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
|
||||
$if lmsUserResetPin lmsUsr
|
||||
\ #{icon IconReset}
|
||||
$maybe ts <- lmsUserReceived lmsUsr
|
||||
|
||||
@ -172,7 +172,7 @@ fillDb = do
|
||||
, userTitle = Just "Dr."
|
||||
, userMaxFavourites = 14
|
||||
, userMaxFavouriteTerms = 4
|
||||
, userTheme = userDefaultTheme
|
||||
, userTheme = ThemeMossGreen
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, 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 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 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 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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user