From 6606ccc82c758fa01fb46394424f62aa3f922404 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Fri, 9 Dec 2022 18:02:26 +0100
Subject: [PATCH] chore(users): show companies in users list

---
 .../uniworx/categories/admin/de-de-formal.msg |  2 +-
 messages/uniworx/categories/admin/en-eu.msg   |  2 +-
 .../utils/table_column/de-de-formal.msg       |  1 +
 messages/uniworx/utils/table_column/en-eu.msg |  1 +
 models/lms.model                              |  4 +-
 src/Foundation/Navigation.hs                  |  8 ++++
 src/Handler/Admin.hs                          | 39 ++++++++++---------
 src/Handler/Profile.hs                        |  8 ++--
 src/Handler/Users.hs                          | 10 +++++
 src/Handler/Utils/Table/Columns.hs            | 36 +++++++++++++++++
 10 files changed, 86 insertions(+), 25 deletions(-)

diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg
index 1a6353160..0a02c699e 100644
--- a/messages/uniworx/categories/admin/de-de-formal.msg
+++ b/messages/uniworx/categories/admin/de-de-formal.msg
@@ -95,7 +95,7 @@ TestDownloadDirect: Direkte Generierung
 TestDownloadInTransaction: Generierung während Datenbank-Transaktion
 TestDownloadFromDatabase: Generierung während Download aus Datenbank
 
-ProblemsHeading: Overview Problems
+ProblemsHeading: Problemübersicht
 ProblemsHeadingDrivers: Fahrberechtigungen
 ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen
 ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive
diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg
index 9a4e5ab52..1f346e598 100644
--- a/messages/uniworx/categories/admin/en-eu.msg
+++ b/messages/uniworx/categories/admin/en-eu.msg
@@ -95,7 +95,7 @@ TestDownloadDirect: Direct generation
 TestDownloadInTransaction: Generate during database transaction
 TestDownloadFromDatabase: Generate while streaming from database
 
-ProblemsHeading: Problemübersicht
+ProblemsHeading: Overview Problems
 ProblemsHeadingDrivers: Driving Licences
 ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely
 ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive
diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg
index 81e97e872..7bf2ecfad 100644
--- a/messages/uniworx/utils/table_column/de-de-formal.msg
+++ b/messages/uniworx/utils/table_column/de-de-formal.msg
@@ -71,3 +71,4 @@ TableDiffDaysTooltip: Zeitspanne nach ISO 8601. Beispiel: "P2Y3M4D" ist eine Zei
 TableExamOfficeLabel: Label-Name
 TableExamOfficeLabelStatus: Label-Farbe
 TableExamOfficeLabelPriority: Label-Priorität
+TableCompany: Firma
diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg
index 450a5c9a1..0cba1d67c 100644
--- a/messages/uniworx/utils/table_column/en-eu.msg
+++ b/messages/uniworx/utils/table_column/en-eu.msg
@@ -71,3 +71,4 @@ TableDiffDaysTooltip: Duration given according to ISO 8601. Example: "P2Y3M4D" i
 TableExamOfficeLabel: Label name
 TableExamOfficeLabelStatus: Label colour
 TableExamOfficeLabelPriority: Label priority
+TableCompany: Company
\ No newline at end of file
diff --git a/models/lms.model b/models/lms.model
index 4c8ae02ee..139cc6c3f 100644
--- a/models/lms.model
+++ b/models/lms.model
@@ -15,8 +15,8 @@ Qualification
   -- elearningOnly       Bool                   -- successful E-learing automatically increases validity. NO!
   -- refreshInvitation   StoredMarkup           -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
   -- expiryNotification  StoredMarkup Maybe     -- configurable user-profile-notifcations are used instead NO!
-  avsLicence          AvsLicence Maybe          -- if set, is synchronized to Avs as a driving licence
-  sapId               Text Maybe                -- if set, all QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
+  avsLicence          AvsLicence Maybe          -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
+  sapId               Text Maybe                -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
   SchoolQualificationShort school shorthand            -- must be unique per school and shorthand
   SchoolQualificationName  school name                 -- must be unique per school and name
   -- across all schools, only one qualification may be a driving licence:
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index c376aa598..583273cd2 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -779,6 +779,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       , navIcon       = IconMenuAdmin
       , navChildren   =
           [ NavLink
+              { navLabel       = MsgProblemsHeading
+              , navRoute       = AdminR
+              , navAccess'     = NavAccessTrue
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
               { navLabel       = MsgMenuUsers
               , navRoute       = UsersR
               , navAccess'     = NavAccessTrue
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index eb5efbf9f..5215d16b5 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -73,7 +73,7 @@ getAdminR = do
 
 getProblemUnreachableR :: Handler Html
 getProblemUnreachableR = do
-  unreachables <- runDB $ E.select getUnreachableUsers
+  unreachables <- runDB $ E.select retrieveUnreachableUsers
   siteLayoutMsg MsgProblemsUnreachableHeading $ do
     setTitleI   MsgProblemsUnreachableHeading
     [whamlet|
@@ -82,14 +82,14 @@ getProblemUnreachableR = do
         <ul>
           $forall usr <- unreachables
             <li>
-              ^{linkUserWidget AdminUserR usr}
+              ^{linkUserWidget ForProfileR usr}
     |]
 
 getProblemFbutNoR :: Handler Html
 getProblemFbutNoR = do 
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
-  rnofs <- runDB $ E.select $ getDriversRWithoutF nowaday
+  rnofs <- runDB $ E.select $ retrieveDriversRWithoutF nowaday
   siteLayoutMsg MsgProblemsRWithoutFHeading $ do
     setTitleI   MsgProblemsRWithoutFHeading
     [whamlet|
@@ -105,7 +105,7 @@ getProblemWithoutAvsId :: Handler Html
 getProblemWithoutAvsId = do 
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
-  rnofs <- runDB $ E.select $ getDriversWithoutAvsId nowaday
+  rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId nowaday
   siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
     setTitleI   MsgProblemsNoAvsIdHeading
     [whamlet|
@@ -129,19 +129,19 @@ mkUnreachableUsersTable = do
 -}
 
 areAllUsersReachable :: DB Bool
--- areAllUsersReachable = isNothing <$> E.selectOne getUnreachableUsers
-areAllUsersReachable = E.selectNotExists getUnreachableUsers
+-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers
+areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers
 
-getUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User))
-getUnreachableUsers = do     
+retrieveUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User))
+retrieveUnreachableUsers = do     
     user <- E.from $ E.table @User
     E.where_ $  E.isNothing (user E.^. UserPostAddress)
           E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") 
     return user 
 
 allDriversHaveAvsId :: Day -> DB Bool
--- allDriversHaveAvsId = fmap isNothing . E.selectOne . getDriversWithoutAvsId
-allDriversHaveAvsId = E.selectNotExists . getDriversWithoutAvsId
+-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
+allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
 
 qIsValid :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool)
 qIsValid qualUsr nowaday = 
@@ -153,8 +153,8 @@ qIsValid qualUsr nowaday =
 
 {-
 -- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
-getDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
-getDriversWithoutAvsId' nowaday = do     
+retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
+retrieveDriversWithoutAvsId' nowaday = do     
   (usr :& qualUsr :& qual) <- E.from $ E.table @User
     `E.innerJoin`  E.table @QualificationUser
     `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
@@ -172,8 +172,8 @@ getDriversWithoutAvsId' nowaday = do
 -}
 
 -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
-getDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
-getDriversWithoutAvsId nowaday = do     
+retrieveDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
+retrieveDriversWithoutAvsId nowaday = do     
   usr <- E.from $ E.table @User
   E.where_ $ 
       E.exists (do -- a valid avs licence 
@@ -195,12 +195,12 @@ getDriversWithoutAvsId nowaday = do
 
 
 allRDriversHaveFs :: Day -> DB Bool
--- allRDriversHaveFs = fmap isNothing . E.selectOne . getDriversRWithoutF
-allRDriversHaveFs = E.selectNotExists . getDriversRWithoutF
+-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF 
+allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF 
 
 -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
-getDriversRWithoutF :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
-getDriversRWithoutF nowaday = do     
+retrieveDriversRWithoutF :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
+retrieveDriversRWithoutF nowaday = do     
   usr <- E.from $ E.table @User
   let hasValidQual lic = do
         (qual :& qualUsr) <- E.from (E.table @Qualification 
@@ -213,3 +213,6 @@ getDriversRWithoutF nowaday = do
     E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
   return usr
   
+{-
+getAdjustLicences :: SchoolId -> QualificationShortand -> Handler Html
+-}
\ No newline at end of file
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 62ab6df58..81707ea77 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -661,14 +661,15 @@ makeProfileData (Entity uid User{..}) = do
       E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
       E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
       return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
-  studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
-      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+  studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do      
       E.on $ studyfeat E.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
       E.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
+      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
       return  (studyfeat, studydegree, studyterms)
   companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
-      E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
       E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+      E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid            
+      E.orderBy [E.asc (comp E.^. CompanyName)] -- E.desc (usrComp E.^. UserCompanySupervisor), 
       return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
   let companies = intersperse (text2markup ", ") $ 
         (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
@@ -676,6 +677,7 @@ makeProfileData (Entity uid User{..}) = do
   supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
       E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
       E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
+      E.orderBy [E.asc (usrSpvr E.^. UserDisplayName) ]
       return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
   let supervisors = intersperse (text2widget ", ") $ 
         (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index deadc20dc..6ba4ec536 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -85,6 +85,16 @@ postUsersR = do
 --      , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
 --          (AdminUserR <$> encrypt uid)
 --          (toWgt userMatrikelnummer)
+      , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
+            companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+              E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId 
+              E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid              
+              E.orderBy [E.asc (comp E.^. CompanyName)]
+              return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
+            let companies = intersperse (text2markup ", ") $ 
+                  (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
+                icnSuper = text2markup " " <> icon IconSupervisor
+            pure $ toWgt $ mconcat companies
       , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
           (AdminUserR <$> encrypt uid)
           (toWgt userCompanyPersonalNumber)
diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs
index 0e53f1bd0..28b37aa23 100644
--- a/src/Handler/Utils/Table/Columns.hs
+++ b/src/Handler/Utils/Table/Columns.hs
@@ -22,6 +22,9 @@ import qualified Database.Esqueleto.Utils as E hiding ((->.))
 import qualified Database.Esqueleto.PostgreSQL.JSON as E (JSONBExpr, (->.))
 import qualified Database.Esqueleto.Internal.Internal as IE
 import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
+--import           Database.Esqueleto.Experimental ((:&)(..))
+--import qualified Database.Esqueleto.Experimental as Ex
+
 
 import Handler.Utils.Table.Cells
 import Handler.Utils.Table.Pagination
@@ -918,6 +921,39 @@ sortAllocationPriority queryPriority = singletonMap "priority" . SortColumns . v
   , SomeExprValue (prio E.->. "ordinal" :: E.JSONBExpr Void)
   ]
 
+
+---------------
+-- Companies --
+---------------
+
+{-
+-- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
+colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> do   
+      let uid = heu ^. hasEntity . _entityKey
+      companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+        E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
+        E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+        return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
+      let companies = intersperse (text2markup ", ") $ 
+            (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
+          icnSuper = text2markup " " <> icon IconSupervisor
+      cell $ toWgt $ mconcat companies
+-}
+
+colUserCompany' :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c)
+colUserCompany' = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu ->
+      let uid = heu ^. hasEntity . _entityKey in 
+      sqlCell $ do 
+        companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+          E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
+          E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+          return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
+        let companies = intersperse (text2markup ", ") $ 
+              (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
+            icnSuper = text2markup " " <> icon IconSupervisor
+        pure $ toWgt $ mconcat companies
+
+
 ----------------------------
 -- Colonnade manipulation --
 ----------------------------