555 lines
28 KiB
Haskell
555 lines
28 KiB
Haskell
-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.Firm
|
|
( getFirmAllR , postFirmAllR
|
|
, getFirmR , postFirmR
|
|
, getFirmUsersR , postFirmUsersR
|
|
, getFirmSupersR, postFirmSupersR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
-- import Jobs
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
-- import qualified Data.Csv as Csv
|
|
-- import qualified Data.Text as T
|
|
import qualified Data.CaseInsensitive as CI
|
|
-- import qualified Data.Conduit.List as C
|
|
-- 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 (from, on)
|
|
-- import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
getFirmR, postFirmR :: CompanyShorthand -> Handler Html
|
|
getFirmR = postFirmR
|
|
postFirmR fsh = do
|
|
let fshId = CompanyKey fsh
|
|
cusers <- runDB $ do
|
|
cusers <- selectList [UserCompanyCompany ==. fshId] []
|
|
selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
|
|
csuper <- runDB $ do
|
|
csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] []
|
|
selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
|
|
cactSuper <- runDB $ E.select $ do
|
|
(usr :& spr :& scmpy) <- E.from $
|
|
E.table @User
|
|
`E.innerJoin` E.table @UserSupervisor
|
|
`E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
|
|
`E.leftJoin` E.table @UserCompany
|
|
`E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser)
|
|
E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers)
|
|
E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany)
|
|
E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany]
|
|
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
|
return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows', usr E.^. UserPrefersPostal)
|
|
|
|
siteLayoutMsg (SomeMessage fsh) $ do
|
|
setTitle $ citext2Html fsh
|
|
[whamlet|
|
|
<h2>PROVISORISCHE DEBUG SEITE
|
|
<p>Diese Seite wird in der finalen Version nicht mehr enthalten sein.
|
|
|
|
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
|
|
<ul>
|
|
$forall u <- csuper
|
|
<li>^{linkUserWidget ForProfileDataR u}
|
|
|
|
<h3>#{length cactSuper} Active Supervisors for Employees
|
|
<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} #
|
|
#{iconLetterOrEmail prefPost} #
|
|
$maybe csh <- mbCsh
|
|
$if csh /= fshId
|
|
from foreign company #{unCompanyKey csh}
|
|
$else
|
|
from this company
|
|
$nothing
|
|
having no associated company
|
|
|
|
<h3>#{length cusers} Employees
|
|
<ul>
|
|
$forall u <- cusers
|
|
<li>^{linkUserWidget ForProfileDataR u}
|
|
|
|
In the end, this needs to be a dbTable, of course!
|
|
|]
|
|
|
|
|
|
-----------------------
|
|
-- 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)
|
|
|
|
-- just in case for future extensions
|
|
type AllCompanyTableExpr = E.SqlExpr (Entity Company)
|
|
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)
|
|
resultAllCompanyEntity = _dbrOutput . _1
|
|
|
|
resultAllCompany :: Lens' AllCompanyTableData Company
|
|
resultAllCompany = resultAllCompanyEntity . _entityVal
|
|
|
|
resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyUsers = _dbrOutput . _2 . _unValue
|
|
|
|
resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanySupervisors = _dbrOutput . _3 . _unValue
|
|
|
|
resultAllCompanyEmployeeSupervised :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyEmployeeSupervised = _dbrOutput . _4 . _unValue
|
|
|
|
resultAllCompanyEmployeeRerouted :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyEmployeeRerouted = _dbrOutput . _5 . _unValue
|
|
|
|
resultAllCompanyEmpRerPost :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyEmpRerPost = _dbrOutput . _6 . _unValue
|
|
|
|
resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyForeignSupers = _dbrOutput . _7 . _unValue
|
|
|
|
resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyDefaultReroutes = _dbrOutput . _8 . _unValue
|
|
|
|
resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyActiveReroutes = _dbrOutput . _9 . _unValue
|
|
|
|
resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyActiveReroutes' = _dbrOutput . _10 . _unValue
|
|
|
|
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
|
|
fromUserCompany mbFltr cmpy = do
|
|
usrCmpy <- E.from $ E.table @UserCompany
|
|
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
|
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
|
|
|
|
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
|
|
|
|
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
|
|
-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
|
|
-- usrCmpy <- E.from $ E.table @UserCompany
|
|
-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId)
|
|
-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
|
|
-- return $ usrCmpy E.^. UserCompanyUser
|
|
|
|
firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))
|
|
|
|
firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr)
|
|
where
|
|
fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)
|
|
fltr usrc = E.exists $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
|
|
firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr)
|
|
where
|
|
fltr usrc = E.exists $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
|
|
firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr)
|
|
where
|
|
fltr usrc = E.exists $ do
|
|
(usrSuper :& usr) <-
|
|
E.from $ E.table @UserSupervisor
|
|
`E.innerJoin` E.table @User
|
|
`E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
E.&&. usr E.^. UserPrefersPostal
|
|
E.&&. E.isJust (usr E.^. UserPostAddress)
|
|
|
|
|
|
-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
-- firmCountForeignSupervisors cmpy = E.coalesceDefault
|
|
-- [E.subSelect $ do
|
|
-- usrSuper <- E.from $ E.table @UserSupervisor
|
|
-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor)
|
|
-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
|
|
-- return E.countRows
|
|
-- ] (E.val 0)
|
|
|
|
firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
|
|
pure $ usrSuper E.^. UserSupervisorSupervisor
|
|
|
|
firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
pure $ usrSuper E.^. UserSupervisorSupervisor
|
|
|
|
firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountActiveReroutes' cmpy = E.subSelectCount $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
|
|
|
|
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget)
|
|
mkFirmAllTable isAdmin uid = do
|
|
-- now <- liftIO getCurrentTime
|
|
let
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery cmpy = 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
|
|
return ( cmpy -- 1
|
|
, cmpy & firmCountUsers -- 2
|
|
, cmpy & firmCountSupervisors -- 3
|
|
, cmpy & firmCountEmployeeSupervised -- 4
|
|
, cmpy & firmCountEmployeeRerouted -- 5
|
|
, cmpy & firmCountEmployeeRerPost -- 6
|
|
, cmpy & firmCountForeignSupervisors -- 7
|
|
, cmpy & firmCountDefaultReroutes -- 8
|
|
, cmpy & firmCountActiveReroutes -- 9
|
|
, cmpy & firmCountActiveReroutes' -- 10
|
|
)
|
|
dbtRowKey = (E.^. CompanyId)
|
|
dbtProj = dbtProjId
|
|
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) ->
|
|
let fsh = companyShorthand firm
|
|
in anchorCell (FirmUsersR fsh) $ toWgt fsh
|
|
, 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 MsgTableCompanyNrSupersDefault) $ \row ->
|
|
anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ word2widget $ row ^. resultAllCompanySupervisors
|
|
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> 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
|
|
, sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "name" $ SortColumn (E.^. CompanyName)
|
|
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
|
|
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
|
|
, singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal)
|
|
, singletonMap "users" $ SortColumn firmCountUsers
|
|
, singletonMap "supervisors" $ SortColumn firmCountSupervisors
|
|
, singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
|
|
, singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted
|
|
, singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost
|
|
, singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes
|
|
, singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors
|
|
, singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes
|
|
, singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
|
|
]
|
|
dbtFilter = mconcat
|
|
[ 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.==. 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)
|
|
)
|
|
)
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrCompanyNameNrUI mPrev
|
|
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
acts :: Map FirmAllAction (AForm Handler FirmAllActionData)
|
|
acts = mconcat
|
|
[ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData
|
|
, singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData
|
|
]
|
|
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"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData)
|
|
-> FormResult ( FirmAllActionData, 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 :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy "short"]
|
|
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) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " companies. TODO"
|
|
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO"
|
|
siteLayoutMsg MsgMenuFirms $ do
|
|
setTitleI MsgMenuFirms
|
|
$(i18nWidgetFile "firm-all")
|
|
|
|
|
|
-----------------------
|
|
-- Firm Users Table
|
|
|
|
data FirmUserAction = FirmUserActNotify
|
|
| FirmUserActMkSuper
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3
|
|
embedRenderMessage ''UniWorX ''FirmUserAction id
|
|
|
|
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
|
|
fsh = unCompanyKey cid
|
|
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
|
|
, singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
let checkSuper = do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
in case criterion of
|
|
Nothing -> E.true
|
|
Just True -> E.exists checkSuper
|
|
Just False -> E.notExists checkSuper
|
|
, singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
let checkSuper = do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
E.&&. E.exists (do
|
|
spr <- E.from $ E.table @UserCompany
|
|
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
|
E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
)
|
|
in case criterion of
|
|
Nothing -> E.true
|
|
Just True -> E.exists checkSuper
|
|
Just False -> E.notExists checkSuper
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
|
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
|
, prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
|
|
]
|
|
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{..}, (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 $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")"
|
|
[whamlet|
|
|
<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}
|
|
|]
|
|
|
|
|
|
-----------------------------
|
|
-- Firm Supervisors Table
|
|
|
|
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
|
|
getFirmSupersR = postFirmSupersR
|
|
postFirmSupersR fsh = do
|
|
let _fshId = CompanyKey fsh
|
|
siteLayout (citext2widget fsh) $ do
|
|
setTitle $ citext2Html fsh
|
|
[whamlet|!!!STUB!!!TO DO!!!|]
|