chore(firm): implement firm-users dbTable

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -80,6 +80,7 @@ TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
 TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
+TableCompanyUser: Firmenangehöriger
 TableCompanyNrUsers: Firmenangehörige
 TableCompanyNrSupers: Ansprechpartner
 TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner

messages/uniworx/utils/table_column/en-eu.msg

@@ -80,6 +80,7 @@ TableCompanyShort: Company shorthand
 TableCompanies: Companies
 TableCompanyNo: Company number
 TableCompanyNos: Company numbers
+TableCompanyUser: Associate
 TableCompanyNrUsers: Associates
 TableCompanyNrSupers: Supervisors
 TableCompanyNrEmpSupervised: Supervsied employees 

src/Handler/Firm.hs

@@ -28,7 +28,7 @@ import qualified Data.CaseInsensitive as CI
 -- import Database.Persist.Sql (updateWhereCount)
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
--- import qualified Database.Esqueleto.Legacy as EL
+import qualified Database.Esqueleto.Legacy as EL (from, on)
 -- import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
@@ -77,7 +77,7 @@ postFirmR fsh = do
       <ul>
         $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper
           <li>#{nr} Employees supervised by ^{nameWidget dn sn} #
-            #{icon (bool IconAt IconLetter prefPost)} #
+            #{iconLetterOrEmail prefPost} #
             $maybe csh <- mbCsh
               $if csh /= fshId
                 from foreign company #{unCompanyKey csh}
@@ -112,8 +112,8 @@ data FirmAllActionData = FirmAllActNotifyData
 
 -- just in case for future extensions
 type AllCompanyTableExpr = E.SqlExpr (Entity Company)
-queryCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
+queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
-queryCompany = id
+queryAllCompany = id
 
 type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)
 resultAllCompanyEntity          :: Lens' AllCompanyTableData (Entity Company)
@@ -255,10 +255,8 @@ mkFirmAllTable isAdmin uid = do
                   )
         dbtRowKey = (E.^. CompanyId)
         dbtProj = dbtProjId
-        dbtColonnade = formColonnade $
+        dbtColonnade = formColonnade $ mconcat
-          mconcat
+          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
-          [ if not isAdmin then mempty else -- guardOnM idAdmin $
-            dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
           , sortable (Just "name")          (i18nCell MsgTableCompany)                 $ \(view resultAllCompany -> firm) ->
               anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm
           , sortable (Just "short")         (i18nCell MsgTableCompanyShort)            $ \(view resultAllCompany -> firm) ->
@@ -276,7 +274,7 @@ mkFirmAllTable isAdmin uid = do
           , 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
-          , sortable (Just "postal-pref")   (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconCell $ bool IconAt IconLetter b
+          , sortable (Just "postal-pref")   (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
           ]
         dbtSorting = mconcat
           [ singletonMap "name"           $ SortColumn (E.^. CompanyName)
@@ -294,12 +292,12 @@ mkFirmAllTable isAdmin uid = do
           , singletonMap "reroute-all"    $ SortColumn firmCountActiveReroutes'
           ]
         dbtFilter = mconcat
-          [ single $ fltrCompanyNameNr queryCompany
+          [ single $ fltrCompanyNameNr queryAllCompany
           , single ("is-supervisor", FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do              
               (usr :& usrCmp) <- E.from $ E.table @User
                 `E.innerJoin` E.table @UserCompany
                 `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)              
-              E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryCompany row E.^. CompanyId
+              E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
                 E.&&. (  (usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
                   E.||.  (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
                   E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
@@ -376,31 +374,149 @@ data FirmUserActionData = FirmUserActNotifyData
                         | FirmUserActMkSuperData
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
+type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany)
+
+queryUserUser :: UserCompanyTableExpr -> E.SqlExpr (Entity User)
+queryUserUser = $(sqlIJproj 2 1)
+
+queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
+queryUserUserCompany = $(sqlIJproj 2 2)
+
+type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64)
+
+resultUserUser :: Lens' UserCompanyTableData (Entity User)
+resultUserUser = _dbrOutput . _1 
+
+resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany)
+resultUserUserCompany = _dbrOutput . _2
+
+resultUserCompanySupervisors :: Lens' UserCompanyTableData Word64
+resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
+
+resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
+resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
+
+instance HasEntity UserCompanyTableData User where 
+  hasEntity = resultUserUser
+
+instance HasUser UserCompanyTableData where 
+  hasUser = resultUserUser . _entityVal
+
+
+firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
+firmCountUserSupervisors usrCmp = E.subSelectCount $ do
+  usrSpr <- E.from $ E.table @UserSupervisor
+  E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
+  
+firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
+firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
+  usrSpr <- E.from $ E.table @UserSupervisor
+  E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
+      E.&&.  usrSpr E.^. UserSupervisorRerouteNotifications
+
+mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget)
+mkFirmUserTable isAdmin cid = do
+  let
+    resultDBTable = DBTable{..}
+      where
+        dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
+          EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
+          E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
+          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
+        dbtRowKey = queryUserUser >>> (E.^. UserId)
+        dbtProj = dbtProjId
+        dbtColonnade = formColonnade $ mconcat
+          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
+          , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
+          , sortable (Just "matriculation")   (i18nCell MsgTableMatrikelNr)              $ \(view resultUserUser           -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
+          , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber)        $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
+          , sortable (Just "supervisors")     (i18nCell MsgTableCompanyNrSupers       )  $ \(view resultUserCompanySupervisors  -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "reroutes")        (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultUserCompanyReroutes     -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "postal-pref")     (i18nCell MsgPrefersPostal)                $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+          , colUserEmail
+          ]
+        dbtSorting = mconcat
+          [ single $ sortUserNameLink queryUserUser
+          , single $ sortUserEmail    queryUserUser
+          , singletonMap "postal-pref"      $ SortColumn $ queryUserUser        >>> (E.^. UserPrefersPostal)
+          , singletonMap "matriculation"    $ SortColumn $ queryUserUser        >>> (E.^. UserMatrikelnummer)
+          , singletonMap "personal-number"  $ SortColumn $ queryUserUser        >>> (E.^. UserCompanyPersonalNumber)
+          , singletonMap "supervisors"      $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
+          , singletonMap "reroutes"         $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
+          ]
+        dbtFilter = mconcat
+          [ single $ fltrUserNameEmail queryUserUser          
+          ]
+        dbtFilterUI mPrev = mconcat
+          [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
+          ]
+        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+        acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
+        acts = mconcat
+          [ singletonMap FirmUserActNotify  $ pure FirmUserActNotifyData
+          , singletonMap FirmUserActMkSuper $ pure FirmUserActMkSuperData
+          ]
+        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-users"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+        dbtExtraReps = []
+
+    postprocess :: FormResult (First FirmUserActionData, DBFormResult UserId Bool UserCompanyTableData)
+                -> FormResult (      FirmUserActionData, 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 :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
+    resultDBTableValidator = def
+      & defaultSorting  [SortAscBy "user-name"]
+  over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
+
+
 
 
 getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
 getFirmUsersR  = postFirmUsersR
 postFirmUsersR fsh = do
+  isAdmin <- hasReadAccessTo AdminR
   let fshId = CompanyKey fsh
-  Company{..} <- runDB $ get404 fshId
+  (Company{..}, (fusrRes, fusrTable)) <- runDB $ (,) 
+    <$> get404 fshId
+    <*> mkFirmUserTable isAdmin fshId
+  formResult fusrRes $ \case
+    (FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO"
+    (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make "  <> tshow (length fids) <> " employees to supervisors. TODO"
   siteLayout (citext2widget companyName) $ do
-    setTitle $ citext2Html companyShorthand
+    setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")"
     [whamlet|
-      <p>
+      <section> 
-        #{companyPostAddress}
+        <p>
-      <p>
+          #{companyPostAddress}
-        Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
+        <p>
-          $if companyPrefersPostal
+          Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
-            #{icon IconLetter} Briefversand
+            $if companyPrefersPostal
-          $else 
+              #{icon IconLetter} Briefversand
-            #{icon IconAt} Email
+            $else 
-      <p>
+              #{icon IconAt} Email
-        AVS Nummer #{companyAvsId}
+      <section>
-
+        <h4>
-      <h1>
+          Company associated users, excluding foreign supervisors
-        !!!STUB!!!TO DO!!!
+        <p>
-      <p>
+          ^{fusrTable}
-        Table showing all company associated users
     |]
 
 

src/Handler/LMS.hs

@@ -631,7 +631,7 @@ postLmsR sid qsh = do
               <*  aformMessage msgRestartWarning              
           ]        
         colChoices cmpMap = mconcat
-          [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey))
+          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
           , colUserNameModalHdr MsgLmsUser AdminUserR
           , colUserEmail
           , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->