diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index b25230af4..850cbb651 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -82,6 +82,8 @@ TableCompanyNos: Firmennummern TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner +TableCompanyNrRerouteDefault: Standard Umleitungen +TableCompanyNrRerouteActive: Aktive Umleitungen TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e3d095d4f..5642ba22f 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -82,6 +82,8 @@ TableCompanyNos: Company numbers TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors TableCompanyNrForeignSupers: External Supervisors +TableCompanyNrRerouteDefault: Default reroutes +TableCompanyNrRerouteActive: Active reroutes TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job diff --git a/routes b/routes index b4485c890..e6e4618b7 100644 --- a/routes +++ b/routes @@ -113,8 +113,10 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET -/firm/#CompanyShorthand FirmR GET POST +/firm FirmAllR GET +/firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/users FirmUsersR GET POST +/firm/#CompanyShorthand/supers FirmSupersR GET POST /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index af0fd0e76..f9a1dde82 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -628,7 +628,7 @@ unKey :: ( Coercible (Key entity) a => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a) 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 query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index a38b62b93..4c405b25f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -125,6 +125,8 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmSupersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -757,6 +759,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , 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 { navHeaderRole = NavHeaderPrimary , navIcon = IconPrintCenter @@ -2401,6 +2415,16 @@ pageActions ApiDocsR = return , navChildren = [] } ] +pageActions (FirmR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh + , navChildren = [] + } + ] pageActions PrintCenterR = do openDays <- useRunDB $ Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d711045a7..0af9b186c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -106,18 +106,27 @@ postFirmAllR = do |] -type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64) -resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = _dbrOutput . _1 . _entityVal +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 = _dbrOutput . _1 . _entityVal -resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 -resultAllCompanyUsers = _dbrOutput . _2 . _unValue +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _2 . _unValue -resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 -resultAllCompanySupervisors = _dbrOutput . _3 . _unValue +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue -resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 -resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue +resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 +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 mbFltr cmpy = do @@ -137,6 +146,9 @@ firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompa -- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) -- 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 cmpy = E.coalesceDefault -- [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) 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 isAdmin uid = do @@ -166,7 +191,14 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId 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) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat @@ -178,9 +210,12 @@ mkFirmAllTable isAdmin uid = do in anchorCell (FirmR fsh) $ toWgt fsh , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm - , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> 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 "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> 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 [ singletonMap "name" $ SortColumn (E.^. CompanyName) @@ -188,7 +223,10 @@ mkFirmAllTable isAdmin uid = do , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "users" $ SortColumn firmCountUsers , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors + , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes + , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat [ diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 2c8d9de6a..a3602faec 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -114,6 +114,7 @@ data Icon | IconLocked | IconUnlocked | IconResetTries -- also see IconReset + | IconCompany deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -205,6 +206,7 @@ iconText = \case IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" + IconCompany -> "building" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8bda1668b..7161397c7 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -636,9 +636,10 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True 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 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] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False @@ -651,13 +652,17 @@ fillDb = do , UserSupervisor jost svaupel False , UserSupervisor jost sbarth False , UserSupervisor jost tinaTester True + , UserSupervisor jost jost True , UserSupervisor svaupel gkleen False , UserSupervisor svaupel fhamann True , UserSupervisor sbarth tinaTester True , UserSupervisor gkleen fhamann False + , UserSupervisor gkleen gkleen True + , UserSupervisor tinaTester tinaTester False ] - ++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ] - ++ take 111 [ UserSupervisor gkleen uid False | Entity uid _ <- drop 300 matUsers ] + ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- 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 [] [] [] -- NOTE: multiple calls like this are ok -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!