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

chore(daily): add more columns #90

Browse Source
This commit is contained in:
Steffen Jost 2024-09-13 18:03:41 +02:00 committed by Sarah Vaupel
parent 4dbe005709
commit ce62b99d2b
5 changed files with 74 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Handler/LMS.hs
View File

@ -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

7
src/Handler/Qualification.hs
View File

@ -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 ::

74
src/Handler/School/DayTasks.hs
View File

@ -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)}

17
src/Handler/Utils/Company.hs
View File

@ -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)

4
test/Database/Fill.hs
View File

@ -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"