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

chore(users): show companies in users list

Browse Source
This commit is contained in:
Steffen Jost 2022-12-09 18:02:26 +01:00
parent 1686a96cc5
commit 6606ccc82c
10 changed files with 86 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/admin/de-de-formal.msg
View File

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

2
messages/uniworx/categories/admin/en-eu.msg
View File

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

1
messages/uniworx/utils/table_column/de-de-formal.msg
View File

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

1
messages/uniworx/utils/table_column/en-eu.msg
View File

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

4
models/lms.model
View File

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

8
src/Foundation/Navigation.hs
View File

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

39
src/Handler/Admin.hs
View File

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

8
src/Handler/Profile.hs
View File

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

10
src/Handler/Users.hs
View File

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

36
src/Handler/Utils/Table/Columns.hs
View File

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