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

refactor(qualification): refactor profile block displays

Browse Source
This commit is contained in:
Steffen Jost 2023-06-30 07:40:13 +00:00
parent 23bc9033e7
commit 46f3a3324c
2 changed files with 23 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
src/Handler/Profile.hs
View File

@ -567,6 +567,7 @@ getForProfileDataR cID = do
makeProfileData :: Entity User -> DB Widget makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do makeProfileData (Entity uid User{..}) = do
now <- liftIO getCurrentTime
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
-- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
@ -611,7 +612,7 @@ makeProfileData (Entity uid User{..}) = do
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
qualificationsTable <- mkQualificationsTable uid -- Tabelle mit allen Qualifikationen qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
let examTable, ownTutorialTable, tutorialTable :: Widget let examTable, ownTutorialTable, tutorialTable :: Widget
examTable = i18n MsgPersonalInfoExamAchievementsWip examTable = i18n MsgPersonalInfoExamAchievementsWip
ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
@ -946,39 +947,39 @@ mkCorrectionsTable =
-- | Table listing all qualifications that the given user is enrolled in -- | Table listing all qualifications that the given user is enrolled in
mkQualificationsTable :: UserId -> DB Widget mkQualificationsTable :: UTCTime -> UserId -> DB Widget
mkQualificationsTable = mkQualificationsTable =
let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a) let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))) -> a)
-> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a) -> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))) -> a)
withType = id withType = id
validator = def & defaultSorting [SortAscBy "valid-until", SortAscBy "quali"]
validator = def -- TODO & defaultSorting [SortDescBy "valid-until"] in \now uid -> dbTableWidget' validator
in \uid -> dbTableWidget' validator
DBTable DBTable
{ dbtIdent = "userQualifications" :: Text { dbtIdent = "userQualifications" :: Text
, dbtSQLQuery = \(quali `E.InnerJoin` quser) -> do , dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
E.on $ quali E.^. QualificationId E.==. quser E.^. QualificationUserQualification E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
return (quali, quser) E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
, dbtRowKey = \(_quali `E.InnerJoin` quser) -> quser E.^. QualificationUserId E.&&. qblock `isLatestBlockBefore` E.val now
return (quali, quser, qblock)
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
, dbtProj = dbtProjId , dbtProj = dbtProjId
, dbtColonnade = mconcat , dbtColonnade = mconcat
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool) [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal) , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip , sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
) $ qualificationBlockedCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue ) 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 "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh) , 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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
] ]
, dbtSorting = mconcat , dbtSorting = mconcat
[ sortSchool $ to (\(quali `E.InnerJoin` _) -> quali E.^. QualificationSchool) [ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)
, singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _) -> quali E.^. QualificationName , singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
, singletonMap "blocked-due" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserBlockedDue , singletonMap "blocked" $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom
, singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserValidUntil , singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserValidUntil
, singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserLastRefresh , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserLastRefresh
, singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserFirstHeld , singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
] ]
, dbtFilter = mempty , dbtFilter = mempty
, dbtFilterUI = mempty , dbtFilterUI = mempty

2
src/Handler/Qualification.hs
View File

@ -585,7 +585,7 @@ postQualificationR sid qsh = do
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, 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 ^? resultQualBlock) row 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