diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg
index c08c769cd..579e8ddf0 100644
--- a/messages/uniworx/utils/table_column/de-de-formal.msg
+++ b/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
diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg
index dd7742a45..b441ea783 100644
--- a/messages/uniworx/utils/table_column/en-eu.msg
+++ b/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
diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs
index 1062ac2a5..46b08a864 100644
--- a/src/Handler/Firm.hs
+++ b/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
$forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper
- #{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)
-queryCompany = id
+queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
+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 $
- mconcat
- [ if not isAdmin then mempty else -- guardOnM idAdmin $
- dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
+ dbtColonnade = formColonnade $ mconcat
+ [ guardMonoid isAdmin $ 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|
-
- #{companyPostAddress}
-
- Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
- $if companyPrefersPostal
- #{icon IconLetter} Briefversand
- $else
- #{icon IconAt} Email
-
- AVS Nummer #{companyAvsId}
-
-
- !!!STUB!!!TO DO!!!
-
- Table showing all company associated users
+
+
+ #{companyPostAddress}
+
+ Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
+ $if companyPrefersPostal
+ #{icon IconLetter} Briefversand
+ $else
+ #{icon IconAt} Email
+
+
+ Company associated users, excluding foreign supervisors
+
+ ^{fusrTable}
|]
diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs
index c0e32c3f4..682e0c7f4 100644
--- a/src/Handler/LMS.hs
+++ b/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) ->