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
$forall usr <- unreachables
-
- ^{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 --
----------------------------