chore(firm): add supervisor table stub

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

@@ -10,6 +10,9 @@ FirmAllActNotify: Mitteilung versenden
 FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
 FirmUserActNotify: Mitteilung versenden
 FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
+FirmSuperActNotify: Mitteilung versenden
+FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen
+FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen
 FilterSupervisor: Hat aktiven Ansprechpartner
 FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört
 FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört

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

@@ -10,6 +10,9 @@ FirmAllActNotify: Send message
 FirmAllActResetSupervision: Reset supervisors for all company associates
 FirmUserActNotify: Send message
 FirmUserActMkSuper: Mark as company supervisor
+FirmSuperActNotify: Send message
+FirmSuperActRMSuperDef: Remove as default supervisor
+FirmSuperActRMSuperAll: Remove all active supervisions for this company
 FilterSupervisor: Has active supervisor
 FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
 FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}

src/Handler/Firm.hs

@@ -578,10 +578,160 @@ postFirmUsersR fsh = do
 -----------------------------
 -- Firm Supervisors Table
 
+data FirmSuperAction = FirmSuperActNotify 
+                     | FirmSuperActRMSuperDef
+                     | FirmSuperActRMSuperAll
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''FirmSuperAction id
+
+data FirmSuperActionData = FirmSuperActNotifyData
+                         | FirmSuperActRMSuperDefData
+                         | FirmSuperActRMSuperAllData
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+type SuperCompanyTableExpr = E.SqlExpr (Entity User)
+
+querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
+querySuperUser = id
+
+type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64)
+
+resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
+resultSuperUser = _dbrOutput . _1 
+
+resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64
+resultSuperCompanySupervised = _dbrOutput . _2 . _unValue
+
+resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64
+resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue
+
+instance HasEntity SuperCompanyTableData User where 
+  hasEntity = resultSuperUser
+
+instance HasUser SuperCompanyTableData where 
+  hasUser = resultSuperUser . _entityVal
+
+
+mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
+mkFirmSuperTable isAdmin cid = do
+  let
+    -- fsh = unCompanyKey cid
+    resultDBTable = DBTable{..}
+      where
+        dbtSQLQuery = \usr -> do
+          -- refactor this
+          let subs = do 
+                      (usrSpr :& usrCmp) <- E.from $  E.table @UserSupervisor 
+                                        `E.innerJoin` E.table @UserCompany 
+                                        `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
+                      E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+                          E.&&.  usrCmp E.^. UserCompanyCompany       E.==. E.val cid
+              subs' = do 
+                      (usrSpr :& usrCmp) <- E.from $  E.table @UserSupervisor 
+                                        `E.innerJoin` E.table @UserCompany 
+                                        `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
+                      E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+                          E.&&.  usrCmp E.^. UserCompanyCompany       E.==. E.val cid
+                          E.&&.  usrSpr E.^. UserSupervisorRerouteNotifications
+          E.where_ $ E.exists subs
+          return (usr, E.subSelectCount subs, E.subSelectCount subs')
+        dbtRowKey = querySuperUser >>> (E.^. UserId)
+        dbtProj = dbtProjId
+        dbtColonnade = formColonnade $ mconcat
+          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
+          , colUserNameModalHdr MsgTableSupervisor ForProfileDataR
+          , sortable (Just "matriculation")   (i18nCell MsgTableMatrikelNr)              $ \(view   resultSuperUser                         -> entUsr) -> cellHasMatrikelnummerLinked entUsr
+          , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber)        $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
+          , sortable (Just "postal-pref")     (i18nCell MsgPrefersPostal)                $ \(view $ resultSuperUser . _userPrefersPostal         -> b) -> iconFixedCell $ iconLetterOrEmail b
+          , colUserEmail
+          , sortable Nothing (i18nCell MsgTableCompanyNrEmpSupervised)  $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
+          , sortable Nothing (i18nCell MsgTableCompanyNrEmpRerouted  )  $ \(view resultSuperCompanyReroutes   -> nr) -> wgtCell $ word2widget nr
+          ]
+        dbtSorting = mconcat
+          [ single $ sortUserNameLink querySuperUser
+          , single $ sortUserEmail    querySuperUser          
+          , singletonMap "matriculation"    $ SortColumn $ querySuperUser        >>> (E.^. UserMatrikelnummer)
+          , singletonMap "personal-number"  $ SortColumn $ querySuperUser        >>> (E.^. UserCompanyPersonalNumber)
+          , singletonMap "postal-pref"      $ SortColumn $ querySuperUser        >>> (E.^. UserPrefersPostal)
+          ]
+        dbtFilter = mconcat
+          [ single $ fltrUserNameEmail querySuperUser
+          ]
+        dbtFilterUI mPrev = mconcat
+          [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
+          ]
+        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+        acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
+        acts = mconcat
+          [ singletonMap FirmSuperActNotify     $ pure FirmSuperActNotifyData
+          , singletonMap FirmSuperActRMSuperDef $ pure FirmSuperActRMSuperDefData
+          , singletonMap FirmSuperActRMSuperAll $ pure FirmSuperActRMSuperAllData
+          ]
+        dbtParams = DBParamsForm
+          { dbParamsFormMethod = POST
+          , dbParamsFormAction = Nothing
+          , dbParamsFormAttrs  = []
+          , dbParamsFormSubmit = FormSubmit
+          , dbParamsFormAdditional
+              = renderAForm FormStandard $ (, mempty) . First . Just
+                  <$> multiActionA acts (fslI MsgTableAction) Nothing
+          , dbParamsFormEvaluate = liftHandler . runFormPost
+          , dbParamsFormResult   = id
+          , dbParamsFormIdent    = def
+          }
+        dbtIdent :: Text
+        dbtIdent = "firm-supervisors"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+        dbtExtraReps = []
+
+    postprocess :: FormResult (First FirmSuperActionData, DBFormResult UserId Bool SuperCompanyTableData)
+                -> FormResult (      FirmSuperActionData, Set UserId)
+    postprocess inp = do
+        (First (Just act), m) <- inp
+        let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
+        return (act, s)
+    
+    resultDBTableValidator = def
+      & defaultSorting  [SortAscBy "user-name"]
+  over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
+
+
 getFirmSupersR, postFirmSupersR :: CompanyShorthand ->  Handler Html
 getFirmSupersR = postFirmSupersR
 postFirmSupersR fsh = do
-  let _fshId = CompanyKey fsh
+  isAdmin <- hasReadAccessTo AdminR
+  let fshId = CompanyKey fsh
+  (Company{..},(fsprRes,fsprTable)) <- runDB $ (,)
+    <$> get404 fshId
+    <*> mkFirmSuperTable isAdmin fshId
+
+  formResult fsprRes $ \case
+    (FirmSuperActNotifyData    , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " supervisors. TODO"
+    (FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove "  <> tshow (length fids) <> " default supervisors. TODO"
+    (FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make "  <> tshow (length fids) <> " default and active supervisors. TODO"
+
   siteLayout (citext2widget fsh) $ do
     setTitle $ citext2Html fsh
-    [whamlet|!!!STUB!!!TO DO!!!|]
+    -- TODO: factor out company info section hamlet here and from user table
+    [whamlet|
+      <section>
+        <h2>!!!STUB!!!TO DO!!!
+      <section .profile>     
+        <dl .deflist.profile-dl>
+          $maybe fem <- companyEmail
+            <dt .deflist__dt>
+              _{MsgFirmEmail} #{iconLetterOrEmail False} 
+            <dd .deflist__dd .email>
+              #{mailtoHtml fem}
+          $maybe addr <- companyPostAddress
+            <dt .deflist__dt>
+              _{MsgFirmAddress} #{iconLetterOrEmail True} 
+            <dd .deflist__dd>
+              #{addr}
+      <section>
+        ^{fsprTable}
+    |]

templates/firm-users.hamlet

@@ -32,12 +32,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           <td .table__td>_{MsgFirmDefaultPreferenceInfo}          
         <tr .table__row .table__row--head>          
           <th .table__th>_{MsgTableCompanyNrUsers}
-          <th .table__th>_{MsgTableCompanyNrForeignSupers}
+          <th .table__th colspan=3>_{MsgTableCompanyNrForeignSupers}
         <tr .table__row>          
           <td .table__td>#{nrCompanyUsers}
           <td .table__td>#{nrCompanyForeignSupers}          
-          <td .table__td>
+          <td .table__td colspan=2>
-              Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel.    
+              Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel.
 
         <tr .table__row .table__row--head>          
           <th .table__th>_{MsgTableCompanyNrEmpSupervised}
@@ -51,12 +51,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           <td .table__td>#{nrCompanyActiveReroutes}
         <tr .table__row>
           <td .table__td>
-            Anzahl Firmenangehörige, für die derzeit mindestens ein Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören!
+            Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören!
           <td .table__td>
-            Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören!
+            Mindestens ein Ansprechpartner mit Umleitung.
           <td .table__td>
-            Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist, welcher den Versand per Briefpost bevorzugt. #
+            Email oder Brief ist individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner.
-            Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner.
           <td .table__td>
             Gesamtzahl aller aktiven Benachrichtigungsumleitungen. #
             <em>