chore(firm): implement firm-users dbTable
This commit is contained in:
parent
ff176faa12
commit
90703f4921
@ -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
|
||||
|
||||
@ -80,6 +80,7 @@ TableCompanyShort: Company shorthand
|
||||
TableCompanies: Companies
|
||||
TableCompanyNo: Company number
|
||||
TableCompanyNos: Company numbers
|
||||
TableCompanyUser: Associate
|
||||
TableCompanyNrUsers: Associates
|
||||
TableCompanyNrSupers: Supervisors
|
||||
TableCompanyNrEmpSupervised: Supervsied employees
|
||||
|
||||
@ -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)
|
||||
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|
|
||||
<p>
|
||||
#{companyPostAddress}
|
||||
<p>
|
||||
Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
|
||||
$if companyPrefersPostal
|
||||
#{icon IconLetter} Briefversand
|
||||
$else
|
||||
#{icon IconAt} Email
|
||||
<p>
|
||||
AVS Nummer #{companyAvsId}
|
||||
|
||||
<h1>
|
||||
!!!STUB!!!TO DO!!!
|
||||
<p>
|
||||
Table showing all company associated users
|
||||
<section>
|
||||
<p>
|
||||
#{companyPostAddress}
|
||||
<p>
|
||||
Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
|
||||
$if companyPrefersPostal
|
||||
#{icon IconLetter} Briefversand
|
||||
$else
|
||||
#{icon IconAt} Email
|
||||
<section>
|
||||
<h4>
|
||||
Company associated users, excluding foreign supervisors
|
||||
<p>
|
||||
^{fusrTable}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
@ -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) ->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user