From ce62b99d2bdeef1fcd9a78a53a617cf9375c203b Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 13 Sep 2024 18:03:41 +0200 Subject: [PATCH] chore(daily): add more columns #90 --- src/Handler/LMS.hs | 7 +--- src/Handler/Qualification.hs | 7 +--- src/Handler/School/DayTasks.hs | 74 ++++++++++++++++++++++++---------- src/Handler/Utils/Company.hs | 17 +++++++- test/Database/Fill.hs | 4 +- 5 files changed, 74 insertions(+), 35 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 13f782661..9821c2309 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -29,6 +29,7 @@ import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS +import Handler.Utils.Company import qualified Data.Set as Set @@ -420,11 +421,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder - primeComp = E.subSelect . E.from $ \uc -> do - E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser - E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] - return (uc E.^. UserCompanyCompany) - return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser) + return (qualUser, user, lmsUser, qualBlock, printAcknowledged, selectCompanyUserPrime user, validQualification now qualUser) mkLmsTable :: ( Functor h, ToSortable h diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6eee590d3..8ca169696 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -18,6 +18,7 @@ import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS +import Handler.Utils.Company import qualified Data.Set as Set import qualified Data.Map as Map @@ -345,11 +346,7 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - let primeComp = E.subSelect . E.from $ \uc -> do - E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser - E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] - return (uc E.^. UserCompanyCompany) - return (qualUser, user, lmsUser, qualBlock, primeComp) + return (qualUser, user, lmsUser, qualBlock, selectCompanyUserPrime user) mkQualificationTable :: diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 29219e84a..29b27e86b 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -14,6 +14,7 @@ module Handler.School.DayTasks import Import import Handler.Utils +import Handler.Utils.Company -- import qualified Data.Set as Set import qualified Data.Map as Map @@ -55,17 +56,21 @@ occurrenceDayValue d = Aeson.object type DailyTableExpr = ( E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Tutorial) + `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) + `E.InnerJoin` E.SqlExpr (Entity User) ) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) -queryCourse = $(sqlIJproj 2 1) - +queryCourse = $(sqlIJproj 4 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) -queryTutorial = $(sqlIJproj 2 2) +queryTutorial = $(sqlIJproj 4 2) + +queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) +queryUser = $(sqlIJproj 4 4) -type DailyTableData = DBRow (Entity Course, Entity Tutorial) +type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity User, E.Value (Maybe CompanyId)) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 @@ -73,23 +78,36 @@ resultCourse = _dbrOutput . _1 resultTutorial :: Lens' DailyTableData (Entity Tutorial) resultTutorial = _dbrOutput . _2 +resultUser :: Lens' DailyTableData (Entity User) +resultUser = _dbrOutput . _3 -mkDailyTable :: SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) -mkDailyTable ssh nd = do +resultCompanyId :: Traversal' DailyTableData CompanyId +resultCompanyId = _dbrOutput . _4 . _unValue . _Just + +instance HasEntity DailyTableData User where + hasEntity = resultUser + +instance HasUser DailyTableData where + hasUser = resultUser . _entityVal + +mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) +mkDailyTable isAdmin ssh nd = do let - dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial)) - dbtSQLQuery (course `E.InnerJoin` tut) = do - EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse - E.where_ $ course E.^. CourseSchool E.==. E.val ssh + dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) + dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do + EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId + EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial + EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser + E.where_ $ crs E.^. CourseSchool E.==. E.val ssh E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue nd)) E.&&. E.exists (do trm <- E.from $ E.table @Term - E.where_ $ E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) - E.&&. trm E.^. TermId E.==. course E.^. CourseTerm + E.where_ $ trm E.^. TermId E.==. crs E.^. CourseTerm + E.&&. E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) ) - return (course, tut) + return (crs, tut, usr, selectCompanyUserPrime usr) dbtRowKey = queryTutorial >>> (E.^. TutorialId) - dbtProj = dbtProjId + dbtProj = dbtProjId dbtColonnade = mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c @@ -98,19 +116,30 @@ mkDailyTable ssh nd = do = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName + , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid + , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR + , colUserMatriclenr isAdmin ] dbtSorting = Map.fromList - [ ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + [ sortUserNameLink queryUser + , sortUserMatriclenr queryUser + , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company", SortColumn $ queryUser >>> selectCompanyUserPrime) ] dbtFilter = Map.fromList - [ ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) - , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) - , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) - + [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) + , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) + , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany) + , fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtIdent :: Text @@ -143,15 +172,16 @@ mkDailyTable ssh nd = do (First (Just act), jobMap) <- inp let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap return (act, jobSet) - psValidator = def & defaultSorting [SortAscBy "course", SortAscBy "tutorial"] + psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] over _1 postprocess <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do + isAdmin <- hasReadAccessTo AdminR dday <- formatTime SelFormatDate nd - (_,tableDaily) <- runDB $ mkDailyTable ssh nd + (_,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 86f88ef03..c8dad2968 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Handler.Utils.Company where @@ -21,6 +23,9 @@ import qualified Database.Esqueleto.PostgreSQL as E import Handler.Utils.Users import Handler.Utils.Widgets +-- KeyCompany is CompanyShorthand, i.e. CI Text +instance E.SqlString (Key Company) + -- Snippet to restrict to primary company only -- E.&&. E.notExists (do -- othr <- E.from $ E.table @UserCompany @@ -233,7 +238,8 @@ deleteDefaultSupervisorsForUsers cids sprs usrs = $ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs) $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter --- | retrieve maximum company user priority fo a user +-- | retrieve maximum company user priority for a user + getCompanyUserMaxPrio :: UserId -> DB Int getCompanyUserMaxPrio uid = do mbMaxPrio <- E.selectOne $ do @@ -241,3 +247,12 @@ getCompanyUserMaxPrio uid = do E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid return . E.max_ $ usrCmp E.^. UserCompanyPriority return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio + +-- | retrieve maximum company user priority for a user within SQL query +-- Note: if there a multiple top-companies, only one is returned +selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId)) +selectCompanyUserPrime usr = E.subSelect $ do + uc <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserId E.==. uc E.^. UserCompanyUser + E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] + return (uc E.^. UserCompanyCompany) \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index f1047d2ef..4e05a2d04 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -86,7 +86,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Just now , userTokensIssuedAfter = Just now - , userMatrikelnummer = Nothing + , userMatrikelnummer = Just 999 , userEmail = "G.Kleen@campus.lmu.de" , userDisplayEmail = "gregor.kleen@ifi.lmu.de" , userDisplayName = "Gregor Kleen" @@ -292,7 +292,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Nothing + , userMatrikelnummer = Just 365 , userEmail = "vaupel.sarah@campus.lmu.de" , userDisplayEmail = "vaupel.sarah@campus.lmu.de" , userDisplayName = "Sarah Vaupel"