chore(firm): add columns and filters and refactor some
This commit is contained in:
parent
612d975384
commit
715b751363
@ -28,4 +28,6 @@ FilterFirmExtern: Externe Firma
|
||||
FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
|
||||
FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
|
||||
FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
|
||||
NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus.
|
||||
NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus.
|
||||
TableIsDefaultSupervisor: Standardansprechpartner
|
||||
TableIsDefaultReroute: Standardumleitung
|
||||
@ -28,4 +28,6 @@ FilterFirmExtern: External company
|
||||
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
|
||||
FirmSupervisorIndependent: Independent supervisors
|
||||
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
|
||||
NoCompanySelected: Select at least one company, please.
|
||||
NoCompanySelected: Select at least one company, please.
|
||||
TableIsDefaultSupervisor: Default supervisor
|
||||
TableIsDefaultReroute: Default reroute
|
||||
@ -41,6 +41,11 @@ import Database.Esqueleto.Utils.TH
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
|
||||
decryptUser = decrypt
|
||||
|
||||
encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
|
||||
encryptUser = encrypt
|
||||
|
||||
---------------------------
|
||||
-- Firm specific utilities
|
||||
@ -90,6 +95,120 @@ addDefaultSupervisorsAll mutualSupervision cids = do
|
||||
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
|
||||
|
||||
|
||||
------------------------------
|
||||
-- repeatedly useful queries
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
|
||||
------------------
|
||||
-- Debug Handler
|
||||
@ -190,95 +309,6 @@ 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
|
||||
@ -438,17 +468,18 @@ postFirmAllR = do
|
||||
formResult firmRes $ \case
|
||||
(_, fids) | null fids -> addMessageI Error MsgNoCompanySelected
|
||||
|
||||
(FirmAllActResetSupervisionData{..}, fids) -> runDB $ do
|
||||
delSupers <- if firmAllActResetKeepOldSupers == Just False
|
||||
then E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ E.exists $ do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
else return 0
|
||||
newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids
|
||||
addMessageI Info $ MsgFirmResetSupervision newSupers delSupers
|
||||
(FirmAllActResetSupervisionData{..}, fids) -> do
|
||||
runDB $ do
|
||||
delSupers <- if firmAllActResetKeepOldSupers == Just False
|
||||
then E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ E.exists $ do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
else return 0
|
||||
newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids
|
||||
addMessageI Info $ MsgFirmResetSupervision newSupers delSupers
|
||||
reloadKeepGetParams FirmAllR -- reload to reflect changes
|
||||
|
||||
(FirmAllActNotifyData , Set.toList -> fids) -> do
|
||||
@ -508,20 +539,23 @@ 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
|
||||
mkSprOption (E.Value uid, E.Value udn) = do
|
||||
uuid <- toPathPiece <$> encryptUser uid
|
||||
return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }
|
||||
procOptions = fmap mkOptionList . traverse mkSprOption
|
||||
|
||||
rawSupers <- E.select $ do
|
||||
usr <- E.from $ E.table @User
|
||||
E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
|
||||
return (usr E.^. UserId, usr E.^. UserDisplayName)
|
||||
let
|
||||
-- supervisorField :: Field Handler UserId
|
||||
supervisorField = selectField $ procOptions rawSupers
|
||||
supervisorsField = multiSelectField $ procOptions rawSupers
|
||||
|
||||
fsh = unCompanyKey cid
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
@ -586,11 +620,30 @@ mkFirmUserTable isAdmin cid = do
|
||||
Nothing -> E.true
|
||||
Just True -> E.exists checkSuper
|
||||
Just False -> E.notExists checkSuper
|
||||
, singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) ->
|
||||
case criterion of
|
||||
Just uid -> do
|
||||
-- uid <- decryptUser uuid
|
||||
E.exists $ do
|
||||
usrSpr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
||||
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
_otherwise -> E.true
|
||||
, singletonMap "supervisors-are" $ FilterColumn $ \row criteria ->
|
||||
case criteria of
|
||||
_ | Set.null criteria -> E.true
|
||||
| otherwise -> do
|
||||
-- uids <- traverse decryptUser criteria
|
||||
E.exists $ do
|
||||
usrSpr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
||||
E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
|
||||
]
|
||||
-- superField = selectField $ ????
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
||||
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
|
||||
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
||||
-- , prismAForm (multiFilter "supervisors-are" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
|
||||
, 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)
|
||||
@ -694,12 +747,18 @@ data FirmSuperActionData = FirmSuperActNotifyData
|
||||
| FirmSuperActRMSuperAllData
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
type SuperCompanyTableExpr = E.SqlExpr (Entity User)
|
||||
type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany))
|
||||
|
||||
querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
|
||||
querySuperUser = id
|
||||
querySuperUser = $(sqlLOJproj 2 1)
|
||||
|
||||
type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)])
|
||||
querySuperUserCompany :: SuperCompanyTableExpr -> E.SqlExpr (Maybe (Entity UserCompany))
|
||||
querySuperUserCompany = $(sqlLOJproj 2 2)
|
||||
|
||||
type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
|
||||
, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
|
||||
, E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany)
|
||||
)
|
||||
|
||||
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
|
||||
resultSuperUser = _dbrOutput . _1
|
||||
@ -713,6 +772,11 @@ resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue
|
||||
resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
|
||||
resultSuperCompanies = _dbrOutput . _4
|
||||
|
||||
resultSuperCompanyDefaultSuper :: Lens' SuperCompanyTableData (Maybe Bool)
|
||||
resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue
|
||||
|
||||
resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
|
||||
resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
|
||||
|
||||
instance HasEntity SuperCompanyTableData User where
|
||||
hasEntity = resultSuperUser
|
||||
@ -720,17 +784,6 @@ instance HasEntity SuperCompanyTableData User where
|
||||
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
|
||||
@ -738,20 +791,23 @@ mkFirmSuperTable isAdmin cid = do
|
||||
-- fsh = unCompanyKey cid
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = \usr -> do
|
||||
dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
|
||||
EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
|
||||
E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
|
||||
return ( usr
|
||||
, usr & firmCountForSupervisor cid Nothing
|
||||
, usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
||||
, usrCmp E.?. UserCompanySupervisor
|
||||
, usrCmp E.?. UserCompanySupervisorReroute
|
||||
)
|
||||
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do
|
||||
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> 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)
|
||||
return (usr, supervised, rerouted, cmps, supervisor, reroute)
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
|
||||
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
|
||||
@ -761,8 +817,10 @@ mkFirmSuperTable isAdmin cid = do
|
||||
, 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
|
||||
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
|
||||
, sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink querySuperUser
|
||||
@ -778,6 +836,8 @@ mkFirmSuperTable isAdmin cid = do
|
||||
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
||||
return (cmp E.^. CompanyName)
|
||||
)
|
||||
, singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor)
|
||||
, singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail querySuperUser
|
||||
|
||||
@ -37,7 +37,7 @@ module Handler.Utils.Table.Pagination
|
||||
, dbtProjFilteredPostId, dbtProjFilteredPostSimple
|
||||
, noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
|
||||
, withCsvExtraRep
|
||||
, singletonFilter
|
||||
, singletonFilter, multiFilter
|
||||
, DBParams(..)
|
||||
, cellAttrs, cellContents
|
||||
, addCellClass
|
||||
@ -647,6 +647,13 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
|
||||
fromInner = maybe Map.empty $ Map.singleton key . pure
|
||||
fromOuter = Map.lookup key >=> listToMaybe
|
||||
|
||||
multiFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe [v])
|
||||
-- ^ for use with @prismAForm@
|
||||
multiFilter key = prism' fromInner fromOuter
|
||||
where
|
||||
-- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v])
|
||||
fromInner = maybe Map.empty (Map.singleton key)
|
||||
fromOuter = Just . Map.lookup key
|
||||
|
||||
data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
|
||||
( ToNamedRecord csv, CsvColumnsExplained csv
|
||||
|
||||
@ -109,12 +109,14 @@ data Icon
|
||||
| IconLetter
|
||||
| IconAt
|
||||
| IconSupervisor
|
||||
| IconSupervisorForeign
|
||||
-- | IconWaitingForUser
|
||||
| IconExpired
|
||||
| IconLocked
|
||||
| IconUnlocked
|
||||
| IconResetTries -- also see IconReset
|
||||
| IconCompany
|
||||
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||
deriving anyclass (Universe, Finite, NFData)
|
||||
|
||||
@ -201,12 +203,13 @@ iconText = \case
|
||||
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
|
||||
IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter
|
||||
IconSupervisor -> "head-side" -- must be notably different to user
|
||||
IconSupervisorForeign -> "alien"
|
||||
-- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
|
||||
IconExpired -> "hourglass-end"
|
||||
IconLocked -> "lock"
|
||||
IconUnlocked -> "lock-open-alt"
|
||||
IconResetTries -> "trash-undo"
|
||||
IconCompany -> "building"
|
||||
IconCompany -> "building"
|
||||
|
||||
nullaryPathPiece ''Icon $ camelToPathPiece' 1
|
||||
deriveLift ''Icon
|
||||
|
||||
Loading…
Reference in New Issue
Block a user