870 lines
46 KiB
Haskell
870 lines
46 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 -Wno-unused-binds #-} -- 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
|
|
, getFirmCommR , postFirmCommR
|
|
, getFirmsCommR, postFirmsCommR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
-- import Jobs
|
|
import Handler.Utils
|
|
import Handler.Utils.Communication
|
|
|
|
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 Bool, E.Value Bool)
|
|
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 Bool
|
|
resultAllCompanySupervisors = _dbrOutput . _3 . _unValue
|
|
|
|
resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool
|
|
resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _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
|
|
|
|
firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool)
|
|
firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor))
|
|
|
|
|
|
firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))
|
|
|
|
firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool)
|
|
firmHasDefaultReroutes = E.exists . 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 & firmHasSupervisors -- 3
|
|
, cmpy & firmHasDefaultReroutes -- 4
|
|
-- , cmpy & firmCountEmployeeSupervised -- 4
|
|
-- , cmpy & firmCountEmployeeRerouted -- 5
|
|
-- , cmpy & firmCountEmployeeRerPost -- 6
|
|
-- , cmpy & firmCountForeignSupervisors -- 7
|
|
-- , 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) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
|
|
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok
|
|
-- , 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 firmHasSupervisors
|
|
-- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
|
|
-- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted
|
|
-- , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost
|
|
, singletonMap "reroute-def" $ SortColumn firmHasDefaultReroutes
|
|
-- , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors
|
|
-- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes
|
|
-- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single $ fltrCompanyNameNr queryAllCompany
|
|
, single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId)))
|
|
, 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)
|
|
)
|
|
)
|
|
, single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
|
|
-- let checkSuper = do -- expensive
|
|
-- usrSpr <- E.from $ E.table @UserSupervisor
|
|
-- E.where_ $ E.notExists (do
|
|
-- spr <- E.from $ E.table @UserCompany
|
|
-- E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
-- E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
-- ) E.&&. E.exists (do
|
|
-- usr <- E.from $ E.table @UserCompany
|
|
-- E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
-- E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
|
|
-- )
|
|
let checkSuper = do
|
|
usr <- E.from $ E.table @UserCompany
|
|
E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
E.&&. E.exists (do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
|
E.&&. E.notExists (do
|
|
sprCmp <- E.from $ E.table @UserCompany
|
|
E.where_ $ sprCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
E.&&. sprCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
)
|
|
)
|
|
in case criterion of
|
|
Nothing -> E.true
|
|
Just True -> E.exists checkSuper
|
|
Just False -> E.notExists checkSuper
|
|
)
|
|
, single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrCompanyNameUI mPrev
|
|
, prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo)
|
|
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
|
, prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
|
|
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPostalAddress)
|
|
]
|
|
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
|
|
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO"
|
|
(FirmAllActNotifyData , fids) -> do
|
|
usrs <- runDB $ E.select $ E.distinct $ do
|
|
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
|
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList (Set.toList fids)
|
|
return $ usr E.^. UserId
|
|
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
|
|
redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
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
|
|
, singletonMap "has-foreign-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.notExists (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
|
|
]
|
|
-- superField = selectField $ ????
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
|
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
|
|
, 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)
|
|
, prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign 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 cid = CompanyKey fsh
|
|
(( Entity{entityVal=Company{..}}
|
|
, E.Value nrCompanyUsers
|
|
, E.Value nrCompanySupervisors
|
|
, E.Value nrCompanyForeignSupers
|
|
, E.Value nrCompanyEmployeeSupervised
|
|
, E.Value nrCompanyEmployeeRerouted
|
|
, E.Value nrCompanyEmployeeRerPost
|
|
, E.Value nrCompanyDefaultReroutes
|
|
, E.Value nrCompanyActiveReroutes
|
|
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
|
<$> fromMaybeM notFound (E.selectOne $ do
|
|
cmpy <- E.from $ E.table @Company
|
|
E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
|
|
return ( cmpy
|
|
, cmpy & firmCountUsers
|
|
, cmpy & firmCountSupervisors
|
|
, cmpy & firmCountForeignSupervisors
|
|
, cmpy & firmCountEmployeeSupervised
|
|
, cmpy & firmCountEmployeeRerouted
|
|
, cmpy & firmCountEmployeeRerPost
|
|
, cmpy & firmCountDefaultReroutes
|
|
, cmpy & firmCountActiveReroutes
|
|
))
|
|
-- superVs <- E.select $ do
|
|
-- usr <- E.from $ E.table @User
|
|
-- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
|
|
-- return usr
|
|
<*> mkFirmUserTable isAdmin cid
|
|
|
|
formResult fusrRes $ \case
|
|
(FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO"
|
|
(FirmUserActNotifyData , fids) -> do
|
|
cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser]
|
|
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
|
|
siteLayout (citext2widget companyName) $ do
|
|
setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")"
|
|
$(widgetFile "firm-users")
|
|
|
|
|
|
-----------------------------
|
|
-- 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, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)])
|
|
|
|
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
|
|
resultSuperUser = _dbrOutput . _1
|
|
|
|
resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64
|
|
resultSuperCompanySupervised = _dbrOutput . _2 . _unValue
|
|
|
|
resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64
|
|
resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue
|
|
|
|
resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
|
|
resultSuperCompanies = _dbrOutput . _4
|
|
|
|
|
|
instance HasEntity SuperCompanyTableData User where
|
|
hasEntity = resultSuperUser
|
|
|
|
instance HasUser SuperCompanyTableData where
|
|
hasUser = resultSuperUser . _entityVal
|
|
|
|
firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery ()
|
|
firmQuerySupervisedBy cid mbFltr usr = do
|
|
(usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor
|
|
`E.innerJoin` E.table @UserCompany
|
|
`E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
|
|
let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
|
E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
|
E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr
|
|
|
|
firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64)
|
|
firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy
|
|
|
|
mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
|
|
mkFirmSuperTable isAdmin cid = do
|
|
let
|
|
-- fsh = unCompanyKey cid
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery = \usr -> do
|
|
E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
|
|
return ( usr
|
|
, usr & firmCountForSupervisor cid Nothing
|
|
, usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
|
)
|
|
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
|
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do
|
|
cmps <- E.select $ do
|
|
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
|
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
|
return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
|
|
return (usr, supervised, rerouted, cmps)
|
|
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 "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) ->
|
|
intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps]
|
|
, 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 (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "rerouted") (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)
|
|
, singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing
|
|
, singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
|
, singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do
|
|
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId
|
|
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
|
return (cmp E.^. CompanyName)
|
|
)
|
|
]
|
|
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
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
let fshId = CompanyKey fsh
|
|
(Company{..},(fsprRes,fsprTable)) <- runDB $ (,)
|
|
<$> get404 fshId
|
|
<*> mkFirmSuperTable isAdmin fshId
|
|
|
|
formResult fsprRes $ \case
|
|
(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"
|
|
(FirmSuperActNotifyData , fids) -> do
|
|
cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser]
|
|
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
|
|
|
|
siteLayout (citext2widget fsh) $ do
|
|
setTitle $ citext2Html fsh
|
|
-- 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}
|
|
|]
|
|
|
|
|
|
getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html
|
|
getFirmCommR = postFirmCommR
|
|
postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh)
|
|
|
|
|
|
getFirmsCommR, postFirmsCommR :: Handler Html
|
|
getFirmsCommR = postFirmsCommR
|
|
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing
|
|
|
|
|
|
handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html
|
|
handleFirmCommR ultDest mbFsh = do
|
|
let decryptUserId :: CryptoUUIDUser -> Handler UserId
|
|
decryptUserId = decrypt
|
|
|
|
mbCid = CompanyKey <$> mbFsh
|
|
|
|
{-
|
|
queryEmpys :: CompanyId -> Handler [UserId]
|
|
queryEmpys cid = E.unValue <<$>> runDB (E.select $ do
|
|
(emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
|
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid
|
|
return $ emp E.^. UserId
|
|
)
|
|
-}
|
|
|
|
selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users
|
|
|
|
empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices)
|
|
E.unValue <<$>> runDB (E.select $ do
|
|
(emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
|
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid
|
|
return $ emp E.^. UserId
|
|
))
|
|
|
|
cmpys <- E.unValue <<$>> runDB (E.select $ do
|
|
cmpy <- E.from $ E.table @Company
|
|
E.where_ $ E.exists $ do
|
|
usrCmpy <- E.from $ E.table @UserCompany
|
|
E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected
|
|
E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
|
return $ cmpy E.^.CompanyId
|
|
)
|
|
let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
queryCmpy sORe acid = do
|
|
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
|
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid
|
|
E.&&. (if sORe
|
|
then -- supervisors only
|
|
E.exists $ do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
|
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys
|
|
else -- selected employees for this company only
|
|
usr E.^. UserId `E.in_` E.valList empys
|
|
)
|
|
return usr
|
|
|
|
commR CommunicationRoute
|
|
{ crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh
|
|
, crUltDest = ultDest
|
|
, crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
, crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
, crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
|
|
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
|
|
[(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <>
|
|
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid]
|
|
}
|
|
|
|
{- Auswahlbox für Mitteilung:
|
|
Wenn Firma gewählt, dann zeige:
|
|
Alle Supervisor von Leuten in X, gruppiert nach deren Firma
|
|
Alle Teilnehmer von X
|
|
Wenn keine Firma gewählt, dann zeige:
|
|
Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma
|
|
Alle gewählten Personen, gruppiert nach deren Firma
|
|
-}
|