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

chore(firm): add rerouting counts

Browse Source
This commit is contained in:
Steffen Jost 2023-10-20 16:44:55 +00:00
parent 601ce7abdf
commit 6d221fa3c2
8 changed files with 94 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -82,6 +82,8 @@ TableCompanyNos: Firmennummern
TableCompanyNrUsers: Firmenangehörige TableCompanyNrUsers: Firmenangehörige
TableCompanyNrSupers: Ansprechpartner TableCompanyNrSupers: Ansprechpartner
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
TableCompanyNrRerouteDefault: Standard Umleitungen
TableCompanyNrRerouteActive: Aktive Umleitungen
TableSupervisor: Ansprechpartner TableSupervisor: Ansprechpartner
TableCreationTime: Erstellungszeit TableCreationTime: Erstellungszeit
TableJob !ident-ok: Job TableJob !ident-ok: Job

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

@ -82,6 +82,8 @@ TableCompanyNos: Company numbers
TableCompanyNrUsers: Associates TableCompanyNrUsers: Associates
TableCompanyNrSupers: Supervisors TableCompanyNrSupers: Supervisors
TableCompanyNrForeignSupers: External Supervisors TableCompanyNrForeignSupers: External Supervisors
TableCompanyNrRerouteDefault: Default reroutes
TableCompanyNrRerouteActive: Active reroutes
TableSupervisor: Supervisor TableSupervisor: Supervisor
TableCreationTime: Creation TableCreationTime: Creation
TableJob !ident-ok: Job TableJob !ident-ok: Job

6
routes
View File

@ -113,8 +113,10 @@
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
/firm FirmAllR GET /firm FirmAllR GET
/firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand FirmR GET POST
/firm/#CompanyShorthand/users FirmUsersR GET POST
/firm/#CompanyShorthand/supers FirmSupersR GET POST
/exam-office ExamOfficeR !exam-office: /exam-office ExamOfficeR !exam-office:
/ EOExamsR GET POST !system-exam-office / EOExamsR GET POST !system-exam-office

2
src/Database/Esqueleto/Utils.hs
View File

@ -628,7 +628,7 @@ unKey :: ( Coercible (Key entity) a
=> E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a)
unKey = E.veryUnsafeCoerceSqlExprValue unKey = E.veryUnsafeCoerceSqlExprValue
-- | distinct version of `Database.Esqueleto.subSelectCount`
subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a) subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)

24
src/Foundation/Navigation.hs
View File

@ -125,6 +125,8 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR
breadcrumb FirmSupersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
@ -757,6 +759,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
, navForceActive = False , navForceActive = False
} }
} }
, return NavHeader
{ navHeaderRole = NavHeaderPrimary
, navIcon = IconCompany
, navLink = NavLink
{ navLabel = MsgMenuFirms
, navRoute = FirmAllR
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
}
, return NavHeader , return NavHeader
{ navHeaderRole = NavHeaderPrimary { navHeaderRole = NavHeaderPrimary
, navIcon = IconPrintCenter , navIcon = IconPrintCenter
@ -2401,6 +2415,16 @@ pageActions ApiDocsR = return
, navChildren = [] , navChildren = []
} }
] ]
pageActions (FirmR fsh) = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
, navChildren = []
}
, NavPageActionPrimary
{ navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh
, navChildren = []
}
]
pageActions PrintCenterR = do pageActions PrintCenterR = do
openDays <- useRunDB $ Ex.select $ do openDays <- useRunDB $ Ex.select $ do
pj <- Ex.from $ Ex.table @PrintJob pj <- Ex.from $ Ex.table @PrintJob

64
src/Handler/Firm.hs
View File

@ -106,18 +106,27 @@ postFirmAllR = do
|] |]
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64) type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)
resultAllCompany :: Lens' AllCompanyTableData Company resultAllCompany :: Lens' AllCompanyTableData Company
resultAllCompany = _dbrOutput . _1 . _entityVal resultAllCompany = _dbrOutput . _1 . _entityVal
resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
resultAllCompanyUsers = _dbrOutput . _2 . _unValue resultAllCompanyUsers = _dbrOutput . _2 . _unValue
resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64
resultAllCompanySupervisors = _dbrOutput . _3 . _unValue resultAllCompanySupervisors = _dbrOutput . _3 . _unValue
resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64
resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue
resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64
resultAllCompanyDefaultReroutes = _dbrOutput . _5 . _unValue
resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64
resultAllCompanyActiveReroutes = _dbrOutput . _6 . _unValue
resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64
resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
fromUserCompany mbFltr cmpy = do fromUserCompany mbFltr cmpy = do
@ -137,6 +146,9 @@ firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompa
-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) -- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
-- return $ usrCmpy E.^. UserCompanyUser -- return $ usrCmpy E.^. UserCompanyUser
firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))
-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountForeignSupervisors cmpy = E.coalesceDefault -- firmCountForeignSupervisors cmpy = E.coalesceDefault
-- [E.subSelect $ do -- [E.subSelect $ do
@ -154,6 +166,19 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
pure $ usrSuper E.^. UserSupervisorSupervisor pure $ usrSuper E.^. UserSupervisorSupervisor
firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do
usrSuper <- E.from $ E.table @UserSupervisor
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
pure $ usrSuper E.^. UserSupervisorSupervisor
firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountActiveReroutes' cmpy = E.subSelectCount $ do
usrSuper <- E.from $ E.table @UserSupervisor
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget)
mkFirmAllTable isAdmin uid = do mkFirmAllTable isAdmin uid = do
@ -166,7 +191,14 @@ mkFirmAllTable isAdmin uid = do
usrCmpy <- E.from $ E.table @UserCompany usrCmpy <- E.from $ E.table @UserCompany
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid
return (cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy, firmCountForeignSupervisors cmpy) return ( cmpy
, cmpy & firmCountUsers
, cmpy & firmCountSupervisors
, cmpy & firmCountForeignSupervisors
, cmpy & firmCountDefaultReroutes
, cmpy & firmCountActiveReroutes
, cmpy & firmCountActiveReroutes'
)
dbtRowKey = (E.^. CompanyId) dbtRowKey = (E.^. CompanyId)
dbtProj = dbtProjId dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
@ -178,9 +210,12 @@ mkFirmAllTable isAdmin uid = do
in anchorCell (FirmR fsh) $ toWgt fsh in anchorCell (FirmR fsh) $ toWgt fsh
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr
, sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr
, sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
] ]
dbtSorting = mconcat dbtSorting = mconcat
[ singletonMap "name" $ SortColumn (E.^. CompanyName) [ singletonMap "name" $ SortColumn (E.^. CompanyName)
@ -188,7 +223,10 @@ mkFirmAllTable isAdmin uid = do
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
, singletonMap "users" $ SortColumn firmCountUsers , singletonMap "users" $ SortColumn firmCountUsers
, singletonMap "supervisors" $ SortColumn firmCountSupervisors , singletonMap "supervisors" $ SortColumn firmCountSupervisors
, singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes
, singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors
, singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes
, singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ [

2
src/Utils/Icon.hs
View File

@ -114,6 +114,7 @@ data Icon
| IconLocked | IconLocked
| IconUnlocked | IconUnlocked
| IconResetTries -- also see IconReset | IconResetTries -- also see IconReset
| IconCompany
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData) deriving anyclass (Universe, Finite, NFData)
@ -205,6 +206,7 @@ iconText = \case
IconLocked -> "lock" IconLocked -> "lock"
IconUnlocked -> "lock-open-alt" IconUnlocked -> "lock-open-alt"
IconResetTries -> "trash-undo" IconResetTries -> "trash-undo"
IconCompany -> "building"
nullaryPathPiece ''Icon $ camelToPathPiece' 1 nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon deriveLift ''Icon

11
test/Database/Fill.hs
View File

@ -636,9 +636,10 @@ fillDb = do
void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann bpol False False
void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann ffacil True True
void . insert' $ UserCompany fhamann nice False False void . insert' $ UserCompany fhamann nice False False
-- need more tests
insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers] insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers]
insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userDisplayName = dn} <- matUsers, dn == "Walker" || dn == "John"] insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers]
-- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost gkleen True
-- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost svaupel False
@ -651,13 +652,17 @@ fillDb = do
, UserSupervisor jost svaupel False , UserSupervisor jost svaupel False
, UserSupervisor jost sbarth False , UserSupervisor jost sbarth False
, UserSupervisor jost tinaTester True , UserSupervisor jost tinaTester True
, UserSupervisor jost jost True
, UserSupervisor svaupel gkleen False , UserSupervisor svaupel gkleen False
, UserSupervisor svaupel fhamann True , UserSupervisor svaupel fhamann True
, UserSupervisor sbarth tinaTester True , UserSupervisor sbarth tinaTester True
, UserSupervisor gkleen fhamann False , UserSupervisor gkleen fhamann False
, UserSupervisor gkleen gkleen True
, UserSupervisor tinaTester tinaTester False
] ]
++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ] ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers ]
++ take 111 [ UserSupervisor gkleen uid False | Entity uid _ <- drop 300 matUsers ] ++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ]
++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ]
upsertManyWhere supvs [] [] [] upsertManyWhere supvs [] [] []
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error! -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!