diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 459750323..71c910999 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -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. \ No newline at end of file +NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. +TableIsDefaultSupervisor: Standardansprechpartner +TableIsDefaultReroute: Standardumleitung \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 6d497c91e..7491437fe 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -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. \ No newline at end of file +NoCompanySelected: Select at least one company, please. +TableIsDefaultSupervisor: Default supervisor +TableIsDefaultReroute: Default reroute \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e7020fab4..17990295c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 2e44c6323..415fb255b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 982d19b5f..0018e74e0 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -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