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

fix(build): major qualfication block quirks fixed

Browse Source
This commit is contained in:
Steffen Jost 2023-06-30 13:15:39 +00:00
parent ee5439cd0b
commit ab48e40ac7
14 changed files with 129 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,7 +22,7 @@ LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationLastNotified: Letzte Benachrichtigung
TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Entzogen
TableQualificationBlockedDue: Entzug
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?
TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt
InfoQualificationBlockStatus: Besteht aktuell ein Entzug? Falsch bedeutet, dass ein Entzug zuletzt aufgehoben wurde

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

@ -22,7 +22,7 @@ LmsQualificationValidUntil: Valid until
TableQualificationLastRefresh: Last renewed
TableQualificationLastNotified: Last notified
TableQualificationFirstHeld: First held
TableQualificationBlockedDue: Revoked
TableQualificationBlockedDue: Revocations
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons
TableQualificationNoRenewal: Discontinued

12
src/Database/Esqueleto/Utils.hs
View File

@ -13,6 +13,7 @@ module Database.Esqueleto.Utils
, strConcat, substring
, (=?.), (?=.)
, (=~.), (~=.)
, (>~.), (<~.)
, or, and
, any, all
, subSelectAnd, subSelectOr
@ -133,6 +134,17 @@ infixl 4 ~=.
(~=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool)
(~=.) a b = E.isNothing a E.||. (a E.==. E.just b)
-- | like (>.), but also succeeds if the right-hand side is NULL
infixl 4 >~.
(>~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
(>~.) a b = E.isNothing b E.||. (E.just a E.>. b)
-- | like (<.), but also succeeds if the right-hand side is NULL
infixl 4 <~.
(<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
(<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
-- | Negation of `isNothing` which is missing
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
isJust = E.not_ . E.isNothing

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

@ -533,13 +533,13 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
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 `E.LeftOuterJoin` qblock) -> do
E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId
E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId
E.&&. qblock `isLatestBlockBefore` E.val now
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)
E.&&. qblock `isLatestBlockBefore` E.val now
E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
return (usrAvs, user, qualUser, qual, qblock)
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here:
@ -561,12 +561,12 @@ 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) $ \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 "validity") (i18nCell MsgQualificationValidIndicator) $ \row ->
-- cellMaybe (qualificationValidIconCell nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & 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

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

@ -192,7 +192,7 @@ colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTab
(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) $
colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $
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
@ -420,11 +420,11 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
)
)
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.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
E.&&. qualificationBlock `isLatestBlockBefore` E.now_
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.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
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, qualificationBlock)
let

12
src/Handler/LMS.hs
View File

@ -378,11 +378,11 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOute
-- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all;
-- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest
E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. qualBlock `isLatestBlockBefore` E.now_
E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser
E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
E.&&. qualBlock `isLatestBlockBefore` E.now_
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
@ -598,10 +598,10 @@ postLmsR sid qsh = do
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
in wgtCell companies
, colUserMatriclenr
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, 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 "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
@ -764,7 +764,7 @@ viewLmsUserR msid mqsh uuid = do
pure (qBlock, qbUsr Ex.?. UserDisplayName)
return $ Map.singleton quid blocks
) qs
return (usr,qs,bs)
return (usr, qs, Map.filter notNull bs)
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
siteLayout heading $ do
setTitle $ toHtml userDisplayName

12
src/Handler/Profile.hs
View File

@ -958,20 +958,20 @@ mkQualificationsTable =
{ dbtIdent = "userQualifications" :: Text
, dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
E.&&. qblock `isLatestBlockBefore` E.val now
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
E.&&. qblock `isLatestBlockBefore` E.val now
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
return (quali, quser, qblock)
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
, dbtProj = dbtProjId
, dbtColonnade = mconcat
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
]
, dbtSorting = mconcat
[ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)

12
src/Handler/Qualification.hs
View File

@ -333,13 +333,13 @@ qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) ->
qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
--
E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
E.&&. qualBlock `isLatestBlockBefore` E.now_
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ fltr qualUser
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
E.&&. qualBlock `isLatestBlockBefore` E.now_
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
return (qualUser, user, lmsUser, qualBlock)
@ -382,9 +382,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted])
@ -555,7 +556,7 @@ postQualificationR sid qsh = do
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
-- Admin-only actions
[ singletonMap QualificationActUnblock $ QualificationActUnblockData
<$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationBlockReason) Nothing
<$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
, singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
@ -585,6 +586,7 @@ postQualificationR sid qsh = do
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, 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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip

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

@ -16,6 +16,11 @@ import qualified Database.Esqueleto.Experimental as E -- might need TypeApplic
import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime (toMidnight)
import Handler.Utils.Widgets (statusHtml)
statusQualificationBlock :: Bool -> Html
statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s
-- needs refactoring, probbably no longer helpful
mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
@ -65,14 +70,14 @@ quserToNotify quser cutoff =
)
)
-- condition to ensure that the lastes QualificationUserBlock was picked
-- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
isLatestBlockBefore qualBlock cutoff = E.notExists $ do
newerBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom
E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
newerBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom
E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
)
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do

35
src/Handler/Utils/Widgets.hs
View File

@ -122,6 +122,12 @@ editedByW fmt tm usr = do
ft <- handlerToWidget $ formatTime fmt tm
[whamlet|_{MsgUtilEditedBy usr ft}|]
----------
-- HEAT --
----------
boolHeat :: Bool -- ^ @isHot@
-> Milli
boolHeat = bool 0 1
@ -148,7 +154,6 @@ invCoHeat :: ( Real a, Real b)
invCoHeat (realToFrac -> full) (realToFrac -> achieved)
= fromRational $ cutOffPercent 0.3 (full^2) (achieved^2)
dualHeat :: ( Real a, Real b, Real c )
=> a -> b -> c -> Milli
-- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
@ -180,6 +185,34 @@ invDualCoHeat :: ( Real a, Real b, Real c )
invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
-----------
-- COLOR --
-----------
-- TODO: someone with frontend capabilities should get rid of class tooltip__handle and check theme consistent colors
statusHtml :: MessageStatus -> Html -> Html
statusHtml sts wgt =
[shamlet|
<span .tooltip__handle .#{statusToUrgencyClass sts}>
^{wgt}
|]
statusWidget :: MessageStatus -> Widget -> Widget
statusWidget sts wgt =
[whamlet|
<span .tooltip__handle .#{statusToUrgencyClass sts}>
^{wgt}
|]
heatedWidget :: Milli -> Widget -> Widget
heatedWidget ht wgt =
[whamlet|
<span .heated style="--hotness: #{ht}">
^{wgt}
|]
examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
where

2
src/Model/Migration.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

47
src/Model/Migration/Definitions.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -855,29 +855,32 @@ customMigrations = mapF $ \case
ALTER TABLE "term" DROP COLUMN "active";
|]
Migration20230524QualificationUserBlock ->
unlessM (tableExists "qualification_user_block") $ do
[executeQQ|
CREATE TABLE "qualification_user_block"
( "id" SERIAL8 PRIMARY KEY UNIQUE
, "qualification_user" bigint NOT NULL
, "from" timestamp with time zone NOT NULL
, "reason" character varying NOT NULL
, "blocker" bigint
, CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY (qualification_user) REFERENCES qualification_user(id) ON DELETE CASCADE
, CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY (blocker) REFERENCES user(id)
)
|]
Migration20230524QualificationUserBlock ->
whenM (andM [ not <$> tableExists "qualification_user_block"
, tableExists "qualification_user"
, columnExists "qualification_user" "blocked_due"
] ) $ do
[executeQQ|
CREATE TABLE "qualification_user_block"
( "id" SERIAL8 PRIMARY KEY UNIQUE
, "qualification_user" bigint NOT NULL
, "from" timestamp with time zone NOT NULL
, "reason" character varying NOT NULL
, "blocker" bigint
, CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE
, CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id)
)
|]
let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|]
migrateBlocks [ fromPersistValue -> Right (quid :: QualificationUserId), fromPersistValue -> Right (Just (Legacy.QualificationBlocked{..} :: Legacy.QualificationBlocked)) ] =
[executeQQ|INSERT INTO "qualification_user_block" ("qualification_user", "from", "reason") VALUES (#{quid}, #{qualificationBlockedDay}, #{qualificationBlockedReason})|]
migrateBlocks _ = return ()
in runConduit $ getBlocks .| C.mapM_ migrateBlocks
let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|]
migrateBlocks [ fromPersistValue -> Right (quid :: QualificationUserId), fromPersistValue -> Right (Just (Legacy.QualificationBlocked{..} :: Legacy.QualificationBlocked)) ] =
[executeQQ|INSERT INTO "qualification_user_block" ("qualification_user", "from", "reason") VALUES (#{quid}, #{qualificationBlockedDay}, #{qualificationBlockedReason})|]
migrateBlocks _ = return ()
in runConduit $ getBlocks .| C.mapM_ migrateBlocks
[executeQQ|
ALTER TABLE "qualification_user" DROP COLUMN "blocked_due";
|]
[executeQQ|
ALTER TABLE "qualification_user" DROP COLUMN "blocked_due";
|]
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool

17
templates/lms-user.hamlet
View File

@ -11,9 +11,9 @@ $else
<section>
<div .container>
<h2>
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) &nbsp;
<span .#{statusToUrgencyClass (bool Error Success (E.unValue validity))}>
#{iconQualificationBlock (E.unValue validity)}
#{qualificationShorthand quali} #
#{statusQualificationBlock (E.unValue validity)} #
#{qualificationName quali} (#{qualificationSchool quali})
<div .container>
<dl .deflist>
$maybe (Entity quid qualUsr) <- mbQualUsr
@ -28,12 +28,11 @@ $else
$forall (Entity _ block, blockerDN) <- qblock
<li>
#{iconQualificationBlock (view _qualificationUserBlockUnblock block)}
\ #{view _qualificationUserBlockReason block}
<p>
$maybe bdn <- E.unValue blockerDN
^{editedByW SelFormatDateTime (view _qualificationUserBlockFrom block) bdn}
$nothing
^{formatTimeW SelFormatDateTime (view _qualificationUserBlockFrom block)}
\ #{view _qualificationUserBlockReason block} #
$maybe bdn <- E.unValue blockerDN
^{editedByW SelFormatDateTime (view _qualificationUserBlockFrom block) bdn}
$nothing
^{formatTimeW SelFormatDateTime (view _qualificationUserBlockFrom block)}
<dt .deflist__dt>_{MsgTableQualificationLastRefresh}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)}
<dt .deflist__dt>_{MsgTableQualificationFirstHeld}

8
test/Database/Fill.hs
View File

@ -691,7 +691,7 @@ fillDb = do
qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466"
qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801"
qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing
qfjost <- insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) True (n_day' $ -9) -- TODO: better dates!
qfjost <- insert' $ QualificationUser jost qid_f (n_day 11) (n_day $ -1) (n_day $ -22) True (n_day' $ -9) -- TODO: better dates!
void . insert $ QualificationUserBlock qfjost False (n_day' $ -6) "First block" (Just svaupel)
void . insert $ QualificationUserBlock qfjost True (n_day' $ -5) "Second unblock" (Just gkleen)
void . insert $ QualificationUserBlock qfjost False (n_day' $ -4) "Third block" Nothing
@ -699,7 +699,7 @@ fillDb = do
void . insert $ QualificationUserBlock qfjost False (n_day' $ -1) "Fifth block" (Just svaupel)
void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) True (n_day' $ -9) -- TODO: better dates!
void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) True (n_day' $ -9)
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True (n_day' $ -9)
void . insert $ QualificationUserBlock qfkleen False (n_day' 1) "Future block" (Just svaupel)
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) False (n_day' $ -1)
void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) True (n_day' $ -9)
@ -707,8 +707,8 @@ fillDb = do
qftest <- insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) False (n_day' $ -9)
void . insert $ QualificationUserBlock qftest False (n_day' $ -7) "Some longer explanation for the block, which explains what has happened here, but is probably to long to be shown inline!" (Just jost)
void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) False (n_day' $ -3)
qrkleen <- insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) True (n_day' $ -4)
void . insert $ QualificationUserBlock qrkleen True (n_day' $ -7) "Not a block, just a reason for granting" (Just jost)
qrkleen <- insert' $ QualificationUser gkleen qid_r (n_day 44) (n_day $ -2) (n_day $ -9) True (n_day' $ -4)
void . insert $ QualificationUserBlock qrkleen True (n_day' $ -7) "Granted by lottery win" (Just jost)
void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) False (n_day' $ -6)
-- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) True (n_day' $ -9)
void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) True (n_day' $ -7)