chore(firm): add table actions (WIP)

messages/uniworx/categories/firm/de-de-formal.msg

@@ -0,0 +1,7 @@
+# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+FirmAllActNotify: Mitteilung versenden
+FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
+

messages/uniworx/categories/firm/en-eu.msg

@@ -0,0 +1,6 @@
+# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+FirmAllActNotify: Send message
+FirmAllActResetSupervision: Reset supervisors for all company associates

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

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

src/Foundation/I18n.hs

@@ -1,7 +1,12 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- 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"

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 

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