From ebecbf5c7f021a61af01eddb98d4ed6ac9d52e1f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 23 Oct 2023 13:58:01 +0000 Subject: [PATCH] chore(firm): add table actions (WIP) --- .../uniworx/categories/firm/de-de-formal.msg | 7 ++ messages/uniworx/categories/firm/en-eu.msg | 6 ++ .../utils/table_column/de-de-formal.msg | 2 + messages/uniworx/utils/table_column/en-eu.msg | 2 + src/Foundation/I18n.hs | 9 ++- src/Handler/Firm.hs | 74 +++++++++++++------ src/Handler/LMS.hs | 5 +- 7 files changed, 78 insertions(+), 27 deletions(-) create mode 100644 messages/uniworx/categories/firm/de-de-formal.msg create mode 100644 messages/uniworx/categories/firm/en-eu.msg diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg new file mode 100644 index 000000000..07bc13737 --- /dev/null +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -0,0 +1,7 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAllActNotify: Mitteilung versenden +FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen + diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg new file mode 100644 index 000000000..dcfeea99c --- /dev/null +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -0,0 +1,6 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAllActNotify: Send message +FirmAllActResetSupervision: Reset supervisors for all company associates diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 850cbb651..aee81f2bb 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -81,6 +81,8 @@ TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner +TableCompanyNrSupersActive: Mitarbeiter mit Ansprechpartner +TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5642ba22f..70583dfc7 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -81,6 +81,8 @@ TableCompanyNo: Company number TableCompanyNos: Company numbers TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors +TableCompanyNrSupersActive: Associates having supervisors +TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 1271b4da4..a7fd0ac1d 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -1,7 +1,12 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- To add new language files: +-- 1. include new statement, e.g. mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" +-- 2. create appropriate translation files in the specified folder +-- 3. add constructor to list of module exports + {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,6 +25,7 @@ module Foundation.I18n , UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..) , UniWorXQualificationMessage(..) , UniWorXPrintMessage(..) + , UniWorXFirmMessage(..) , UniWorXAvsMessage(..) , UniWorXAuthorshipStatementMessage(..) , ShortTermIdentifier(..) @@ -233,6 +239,7 @@ mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-for mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal" mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal" mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" +mkMessageAddition ''UniWorX "Firm" "messages/uniworx/categories/firm" "de-de-formal" mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal" mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal" mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal" diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 0af9b186c..653561d27 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -20,7 +20,7 @@ import Import import Handler.Utils -- import qualified Data.Set as Set --- import qualified Data.Map as Map +import qualified Data.Map as Map -- import qualified Data.Csv as Csv -- import qualified Data.Text as T -- import qualified Data.CaseInsensitive as CI @@ -91,19 +91,20 @@ postFirmR fsh = do |] -getFirmAllR, postFirmAllR :: Handler Html -getFirmAllR = postFirmAllR -postFirmAllR = do - uid <- requireAuthId - isAdmin <- hasReadAccessTo AdminR - firmTable <- runDB $ do - view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! - ^{firmTable} - |] +----------------------- +-- All Firms Table + +data FirmAllAction = FirmAllActNotify + | FirmAllActResetSupervision + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmAllAction id + +data FirmAllActionData = FirmAllActNotifyData { } + | FirmAllActResetSupervisionData + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) @@ -180,7 +181,7 @@ firmCountActiveReroutes' cmpy = E.subSelectCount $ do E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -190,7 +191,7 @@ mkFirmAllTable isAdmin uid = do unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany 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 , cmpy & firmCountUsers , cmpy & firmCountSupervisors @@ -202,8 +203,9 @@ mkFirmAllTable isAdmin uid = do dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ + dbSelect (applying _2) id (return . view (_dbrOutput . _1 . _entityKey)) + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm @@ -211,7 +213,7 @@ mkFirmAllTable isAdmin uid = do , 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 "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \(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 @@ -242,15 +244,37 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] + postprocess :: FormResult (First act', DBFormResult CompanyId Bool FirmAllActionData) + -> FormResult ( act', Set CompanyId) + postprocess inp = do + (First (Just act), cmpMap) <- inp + let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap + return (act, cmpSet) + resultDBTableValidator = def -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] - dbTable resultDBTableValidator resultDBTable + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable +getFirmAllR, postFirmAllR :: Handler Html +getFirmAllR = postFirmAllR +postFirmAllR = do + uid <- requireAuthId + isAdmin <- hasReadAccessTo AdminR + (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + formResult firmRes $ \case + (FirmAllActNotifyData, fids) -> addMessageI Info $ SomeMessage $ "Notify " <> length fids <> " companies. TODO" + (FirmAllActResetSupervisionData, fids) -> addMessageI Info $ SomeMessage $ "Reset " <> length fids <> " companies. TODO" + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + -- $(widgetFile "firm-all") + [whamlet|!!!STUB!!!TO DO!!! + ^{firmTable} + |] --- -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html --- -- getQualificationEditR = postQualificationEditR --- -- postQualificationEditR = error "TODO" + +----------------------- +-- Firm Users Table getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR @@ -260,6 +284,10 @@ postFirmUsersR fsh = do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] + +----------------------------- +-- Firm Supervisors Table + getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 94d2df971..c0e32c3f4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -359,9 +359,8 @@ data LmsTableAction = LmsActNotify | LmsActReset | LmsActRestart deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - -instance Universe LmsTableAction -instance Finite LmsTableAction + deriving anyclass (Universe, Finite) + nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id