chore(daily): add more columns #90

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
+    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, selectCompanyUserPrime user, validQualification now qualUser)
-          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)
 
 
 mkLmsTable :: ( Functor h, ToSortable h

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
+    return (qualUser, user, lmsUser, qualBlock, selectCompanyUserPrime user)
-          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)
 
 
 mkQualificationTable ::

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)
+resultCompanyId :: Traversal' DailyTableData CompanyId
-mkDailyTable ssh nd = do
+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 :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)))
-    dbtSQLQuery  (course `E.InnerJoin` tut) = do
+    dbtSQLQuery  (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do
-      EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse
+      EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
-      E.where_ $ course E.^. CourseSchool E.==. E.val ssh
+      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.where_ $ trm E.^. TermId E.==. crs E.^. CourseTerm
-            E.&&. trm E.^. TermId E.==. course 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))
+      [ fltrUserNameEmail   queryUser
-      , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
+      , 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 "course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgFilterCourse)
-      , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCourseTutorial)
+      , 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)}

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)

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"