From a9d56c51dcc727f8637b09a0e849372e75032f5e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 23 Oct 2023 09:57:57 +0000 Subject: [PATCH 1/8] fix(users): allow prefer postal setting for users with fraport department --- src/Handler/Profile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 5c2acdd0a..39730ffd5 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -370,7 +370,7 @@ validateSettings User{..} = do userPrefersPostal' <- use _stgPrefersPostal guardValidation MsgUserPrefersPostalInvalid $ - not $ userPrefersPostal' && postalNotSet + not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment) userPinPassword' <- use _stgPinPassword let pinBad = validCmdArgument =<< userPinPassword' From 29bffb6a475f463b9621cc75ab894c0fbcee8121 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 23 Oct 2023 12:23:07 +0000 Subject: [PATCH 2/8] chore(users): filter supervisors --- messages/uniworx/categories/user/de-de-formal.msg | 1 + messages/uniworx/categories/user/en-eu.msg | 1 + src/Handler/Users.hs | 8 +++++++- 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index b11ff586a..a3c630c46 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -94,6 +94,7 @@ UserHijack: Sitzung übernehmen UserAddSupervisor: Ansprechpartner hinzufügen UserSetSupervisor: Ansprechpartner ersetzen UserRemoveSupervisor: Alle Ansprechpartner entfernen +UserIsSupervisor: Ist Ansprechpartner AuthKindLDAP: Fraport AG Kennung AuthKindPWHash: FRADrive Kennung AuthKindNoLogin: Kein Login möglich diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 9b33bfdc7..10c42830d 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -94,6 +94,7 @@ UserHijack: Hijack session UserAddSupervisor: Add supervisor UserSetSupervisor: Replace supervisors UserRemoveSupervisor: Set to unsupervised +UserIsSupervisor: Is supervisor AuthKindLDAP: Fraport AG account AuthKindPWHash: FRADrive account AuthKindNoLogin: No login diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 23ca1e78d..d72bdc9ac 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -314,10 +314,15 @@ postUsersR = do ) , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion -> E.from $ \usrAvs -> -- do - E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^.UserId + E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) ) + , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of + Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor + Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor + _ -> E.val True :: E.SqlExpr (E.Value Bool) + ) ] , dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) @@ -329,6 +334,7 @@ postUsersR = do , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor) , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) From ebecbf5c7f021a61af01eddb98d4ed6ac9d52e1f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 23 Oct 2023 13:58:01 +0000 Subject: [PATCH 3/8] chore(firm): add table actions (WIP) --- .../uniworx/categories/firm/de-de-formal.msg | 7 ++ messages/uniworx/categories/firm/en-eu.msg | 6 ++ .../utils/table_column/de-de-formal.msg | 2 + messages/uniworx/utils/table_column/en-eu.msg | 2 + src/Foundation/I18n.hs | 9 ++- src/Handler/Firm.hs | 74 +++++++++++++------ src/Handler/LMS.hs | 5 +- 7 files changed, 78 insertions(+), 27 deletions(-) create mode 100644 messages/uniworx/categories/firm/de-de-formal.msg create mode 100644 messages/uniworx/categories/firm/en-eu.msg diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg new file mode 100644 index 000000000..07bc13737 --- /dev/null +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -0,0 +1,7 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAllActNotify: Mitteilung versenden +FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen + diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg new file mode 100644 index 000000000..dcfeea99c --- /dev/null +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -0,0 +1,6 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAllActNotify: Send message +FirmAllActResetSupervision: Reset supervisors for all company associates diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 850cbb651..aee81f2bb 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -81,6 +81,8 @@ TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner +TableCompanyNrSupersActive: Mitarbeiter mit Ansprechpartner +TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5642ba22f..70583dfc7 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -81,6 +81,8 @@ TableCompanyNo: Company number TableCompanyNos: Company numbers TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors +TableCompanyNrSupersActive: Associates having supervisors +TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 1271b4da4..a7fd0ac1d 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -1,7 +1,12 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- To add new language files: +-- 1. include new statement, e.g. mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" +-- 2. create appropriate translation files in the specified folder +-- 3. add constructor to list of module exports + {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,6 +25,7 @@ module Foundation.I18n , UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..) , UniWorXQualificationMessage(..) , UniWorXPrintMessage(..) + , UniWorXFirmMessage(..) , UniWorXAvsMessage(..) , UniWorXAuthorshipStatementMessage(..) , ShortTermIdentifier(..) @@ -233,6 +239,7 @@ mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-for mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal" mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal" mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" +mkMessageAddition ''UniWorX "Firm" "messages/uniworx/categories/firm" "de-de-formal" mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal" mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal" mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal" diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 0af9b186c..653561d27 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -20,7 +20,7 @@ import Import import Handler.Utils -- import qualified Data.Set as Set --- import qualified Data.Map as Map +import qualified Data.Map as Map -- import qualified Data.Csv as Csv -- import qualified Data.Text as T -- import qualified Data.CaseInsensitive as CI @@ -91,19 +91,20 @@ postFirmR fsh = do |] -getFirmAllR, postFirmAllR :: Handler Html -getFirmAllR = postFirmAllR -postFirmAllR = do - uid <- requireAuthId - isAdmin <- hasReadAccessTo AdminR - firmTable <- runDB $ do - view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! - ^{firmTable} - |] +----------------------- +-- 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) type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) @@ -180,7 +181,7 @@ firmCountActiveReroutes' cmpy = E.subSelectCount $ do E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -190,7 +191,7 @@ mkFirmAllTable isAdmin uid = 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 + E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return ( cmpy , cmpy & firmCountUsers , cmpy & firmCountSupervisors @@ -202,8 +203,9 @@ mkFirmAllTable isAdmin uid = do dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ + dbSelect (applying _2) id (return . view (_dbrOutput . _1 . _entityKey)) + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm @@ -211,7 +213,7 @@ mkFirmAllTable isAdmin uid = do , 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 MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> 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 @@ -242,15 +244,37 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] + postprocess :: FormResult (First act', DBFormResult CompanyId Bool FirmAllActionData) + -> FormResult ( act', 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 = def -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] - dbTable resultDBTableValidator resultDBTable + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable +getFirmAllR, postFirmAllR :: Handler Html +getFirmAllR = postFirmAllR +postFirmAllR = do + uid <- requireAuthId + isAdmin <- hasReadAccessTo AdminR + (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + formResult firmRes $ \case + (FirmAllActNotifyData, fids) -> addMessageI Info $ SomeMessage $ "Notify " <> length fids <> " companies. TODO" + (FirmAllActResetSupervisionData, fids) -> addMessageI Info $ SomeMessage $ "Reset " <> length fids <> " companies. TODO" + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + -- $(widgetFile "firm-all") + [whamlet|!!!STUB!!!TO DO!!! + ^{firmTable} + |] --- -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html --- -- getQualificationEditR = postQualificationEditR --- -- postQualificationEditR = error "TODO" + +----------------------- +-- Firm Users Table getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR @@ -260,6 +284,10 @@ postFirmUsersR fsh = do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] + +----------------------------- +-- Firm Supervisors Table + getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 94d2df971..c0e32c3f4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -359,9 +359,8 @@ data LmsTableAction = LmsActNotify | LmsActReset | LmsActRestart deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - -instance Universe LmsTableAction -instance Finite LmsTableAction + deriving anyclass (Universe, Finite) + nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id From 19eea7abe8ddd317c8dc14cb1264bd07402414e2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 09:08:04 +0000 Subject: [PATCH 4/8] chore(firm): change dbTable to form with selection box (WIP) --- src/Handler/Firm.hs | 58 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 44 insertions(+), 14 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 653561d27..45b47f9da 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -102,14 +102,17 @@ data FirmAllAction = FirmAllActNotify nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmAllAction id -data FirmAllActionData = FirmAllActNotifyData { } +data FirmAllActionData = FirmAllActNotifyData | FirmAllActResetSupervisionData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) +resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) +resultAllCompanyEntity = _dbrOutput . _1 + resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = _dbrOutput . _1 . _entityVal +resultAllCompany = resultAllCompanyEntity . _entityVal resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 resultAllCompanyUsers = _dbrOutput . _2 . _unValue @@ -181,12 +184,19 @@ firmCountActiveReroutes' cmpy = E.subSelectCount $ do E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: + -- ( Functor h, ToSortable h + -- , AsCornice h p FirmAllActionData + -- (DBCell (MForm Handler) + -- (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- ) cols + -- ) => + Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} - where + where dbtSQLQuery cmpy = do unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany @@ -202,9 +212,11 @@ mkFirmAllTable isAdmin uid = do ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat + dbtColonnade = -- formColonnade $ + mconcat [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ - dbSelect (applying _2) id (return . view (_dbrOutput . _1 . _entityKey)) + -- hole :: (x -> f x) -> r -> f r + dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> @@ -237,22 +249,40 @@ mkFirmAllTable isAdmin uid = do [ ] dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def + 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 act', DBFormResult CompanyId Bool FirmAllActionData) - -> FormResult ( act', Set CompanyId) + postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData) + -> 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)) -- This type signature is not optional! resultDBTableValidator = def - -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -263,8 +293,8 @@ postFirmAllR = do isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins formResult firmRes $ \case - (FirmAllActNotifyData, fids) -> addMessageI Info $ SomeMessage $ "Notify " <> length fids <> " companies. TODO" - (FirmAllActResetSupervisionData, fids) -> addMessageI Info $ SomeMessage $ "Reset " <> length fids <> " companies. TODO" + (FirmAllActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " companies. TODO" + (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") From dfa03f8ba80009f01bb80cbc0b57d61e5b212df3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 10:07:12 +0000 Subject: [PATCH 5/8] refactor(firm): dbTable form for firm all with selection box working now --- src/Handler/Firm.hs | 253 +++++++++++++++----------- src/Handler/Utils/Table/Pagination.hs | 14 +- 2 files changed, 156 insertions(+), 111 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 45b47f9da..5aafa0ed9 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR , postFirmAllR + ( getFirmAllR , postFirmAllR , getFirmR , postFirmR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR @@ -43,14 +43,14 @@ getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do let fshId = CompanyKey fsh - cusers <- runDB $ do + cusers <- runDB $ do cusers <- selectList [UserCompanyCompany ==. fshId] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] - csuper <- runDB $ do + 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 $ + 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) @@ -61,28 +61,28 @@ postFirmR fsh = do 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') - - siteLayoutMsg (SomeMessage fsh) $ do + + siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh - [whamlet| + [whamlet|

#{length csuper} Company Default Supervisors (non-foreign only) -
    +
      $forall u <- csuper
    • ^{linkUserWidget ForProfileDataR u}

      #{length cactSuper} Active Supervisors for Employees -
        +
          $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper -
        • #{nr} Employees supervised by ^{nameWidget dn sn} +
        • #{nr} Employees supervised by ^{nameWidget dn sn} $maybe csh <- mbCsh $if csh /= fshId from foreign company #{unCompanyKey csh} - $else - from this company + $else + from this company $nothing having no associated company -

          #{length cusers} Employees +

          #{length cusers} Employees
            $forall u <- cusers
          • ^{linkUserWidget ForProfileDataR u} @@ -102,17 +102,17 @@ data FirmAllAction = FirmAllActNotify nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmAllAction id -data FirmAllActionData = FirmAllActNotifyData +data FirmAllActionData = FirmAllActNotifyData | FirmAllActResetSupervisionData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) -resultAllCompanyEntity = _dbrOutput . _1 +resultAllCompanyEntity = _dbrOutput . _1 resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = resultAllCompanyEntity . _entityVal +resultAllCompany = resultAllCompanyEntity . _entityVal resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 resultAllCompanyUsers = _dbrOutput . _2 . _unValue @@ -133,7 +133,7 @@ resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () -fromUserCompany mbFltr cmpy = do +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 @@ -142,9 +142,9 @@ 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.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) -- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do +-- 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) @@ -156,48 +156,48 @@ firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E -- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountForeignSupervisors cmpy = E.coalesceDefault -- [E.subSelect $ do --- usrSuper <- E.from $ E.table @UserSupervisor +-- 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) +-- 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 +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 + 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 + 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 :: +mkFirmAllTable :: -- ( Functor h, ToSortable h - -- , AsCornice h p FirmAllActionData - -- (DBCell (MForm Handler) + -- , AsCornice h p FirmAllActionData + -- (DBCell (MForm Handler) -- (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) -- ) cols - -- ) => + -- ) => Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) -mkFirmAllTable isAdmin uid = do +mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} - where - dbtSQLQuery cmpy = do + 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 @@ -212,17 +212,50 @@ mkFirmAllTable isAdmin uid = do ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId - dbtColonnade = -- formColonnade $ + dbtColonnade = formColonnade $ mconcat [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ - -- hole :: (x -> f x) -> r -> f r + {- hole :: (x -> f x) -> r -> f r + (FormResult + (DBFormResult (Key Company) Bool (DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)) + ) + -> f (FormResult + (DBFormResult + (Key Company) + Bool + (DBRow + (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, + E.Value Word64, E.Value Word64, E.Value Word64))))) + -> FormResult + (First FirmAllActionData, + DBFormResult CompanyId Bool FirmAllActionData) + -> f (FormResult + (First FirmAllActionData, + DBFormResult CompanyId Bool FirmAllActionData)) + + ------- + + ( (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) + -> f (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) + ) + -> (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -> f (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + + ------ + Lens' (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) + (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + ------ + Lens' (FormResult (Map (Key Company) (AllCompanyTableData,Bool -> Bool))) + (FormResult (First FirmAllActionData, (Map (CompanyId) (FirmAllActionData ,Bool -> Bool)))) + -- applying bringt uns unter das FormResult + -} dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) - , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm - , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm in anchorCell (FirmR fsh) $ toWgt fsh - , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + , 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) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr @@ -230,7 +263,7 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr - ] + ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) @@ -243,14 +276,14 @@ mkFirmAllTable isAdmin uid = do , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat - [ + [ ] dbtFilterUI = mconcat - [ + [ ] dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) - acts = mconcat + acts = mconcat [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData , singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData ] @@ -268,18 +301,18 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormIdent = def } dbtIdent :: Text - dbtIdent = "firm" + dbtIdent = "firm" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData) + 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)) -- This type signature is not optional! resultDBTableValidator = def & defaultSorting [SortAscBy "short"] @@ -295,10 +328,10 @@ postFirmAllR = do formResult firmRes $ \case (FirmAllActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " companies. TODO" (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" - siteLayoutMsg MsgMenuFirms $ do + siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! + [whamlet|!!!STUB!!!TO DO!!! ^{firmTable} |] @@ -308,9 +341,9 @@ postFirmAllR = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR -postFirmUsersR fsh = do +postFirmUsersR fsh = do let _fshId = CompanyKey fsh - siteLayout (citext2widget fsh) $ do + siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] @@ -320,9 +353,9 @@ postFirmUsersR fsh = do getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR -postFirmSupersR fsh = do +postFirmSupersR fsh = do let _fshId = CompanyKey fsh - siteLayout (citext2widget fsh) $ do + siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] @@ -335,7 +368,7 @@ postFirmSupersR fsh = do -- , qtcValidUntil :: Day -- , qtcLastRefresh :: Day -- , qtcBlockStatus :: Maybe Bool --- , qtcBlockFrom :: Maybe UTCTime +-- , qtcBlockFrom :: Maybe UTCTime -- , qtcScheduleRenewal:: Bool -- , qtcLmsStatusTxt :: Maybe Text -- , qtcLmsStatusDay :: Maybe UTCTime @@ -352,7 +385,7 @@ postFirmSupersR fsh = do -- , qtcValidUntil = compDay -- , qtcLastRefresh = compDay -- , qtcBlockStatus = Nothing --- , qtcBlockFrom = Nothing +-- , qtcBlockFrom = Nothing -- , qtcScheduleRenewal= True -- , qtcLmsStatusTxt = Just "Success" -- , qtcLmsStatusDay = Just compTime @@ -390,7 +423,7 @@ postFirmSupersR fsh = do -- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) -- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) -- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) --- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) +-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) -- ] @@ -445,15 +478,15 @@ postFirmSupersR fsh = do -- -- hasQualificationUserBlock = resultQualBlock --- data QualificationTableAction --- = QualificationActExpire +-- data QualificationTableAction +-- = QualificationActExpire -- | QualificationActUnexpire -- | QualificationActBlockSupervisor -- | QualificationActBlock -- | QualificationActUnblock -- | QualificationActRenew -- | QualificationActGrant --- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -- instance Universe QualificationTableAction -- instance Finite QualificationTableAction @@ -468,15 +501,15 @@ postFirmSupersR fsh = do -- isAdminAct _ = True -- -} --- data QualificationTableActionData --- = QualificationActExpireData --- | QualificationActUnexpireData +-- data QualificationTableActionData +-- = QualificationActExpireData +-- | QualificationActUnexpireData -- | QualificationActBlockSupervisorData -- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } -- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} -- | QualificationActRenewData --- | QualificationActGrantData { qualTableActGrantUntil :: Day } --- deriving (Eq, Ord, Show, Generic) +-- | QualificationActGrantData { qualTableActGrantUntil :: Day } +-- deriving (Eq, Ord, Show, Generic) -- isExpiryAct :: QualificationTableActionData -> Bool -- isExpiryAct QualificationActExpireData = True @@ -514,14 +547,14 @@ postFirmSupersR fsh = do -- ) -- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps --- -- +-- -- -- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId -- E.&&. qualBlock `isLatestBlockBefore` E.val now -- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser -- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work -- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser --- E.where_ $ fltr qualUser --- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- E.where_ $ fltr qualUser +-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) -- return (qualUser, user, lmsUser, qualBlock) @@ -531,15 +564,15 @@ postFirmSupersR fsh = do -- ) -- => Bool -- -> Entity Qualification --- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) +-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) -- -> (Map CompanyId Company -> cols) -- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) -- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- svs <- getSupervisees --- now <- liftIO getCurrentTime --- -- lookup all companies --- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do +-- now <- liftIO getCurrentTime +-- -- lookup all companies +-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do -- cmps <- selectList [] [] -- [Asc CompanyShorthand] -- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps -- let @@ -584,14 +617,14 @@ postFirmSupersR fsh = do -- dbtFilter = mconcat -- [ single $ fltrUserNameEmail queryUser -- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> --- E.from $ \usrAvs -> -- do +-- E.from $ \usrAvs -> -- do -- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId -- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. -- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) -- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of -- Nothing -> E.false -- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do --- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId +-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId -- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId -- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) -- ) @@ -600,14 +633,14 @@ postFirmSupersR fsh = do -- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria -- ) -- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> --- E.from $ \(usrComp `E.InnerJoin` comp) -> do +-- E.from $ \(usrComp `E.InnerJoin` comp) -> do -- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` -- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) -- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId -- testcrit = maybe testname testnumber $ readMay $ CI.original criterion -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId -- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit --- ) +-- ) -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- if | Just renewal <- mbRenewal @@ -626,7 +659,7 @@ postFirmSupersR fsh = do -- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) -- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) -- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) --- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) +-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) -- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) -- , if isNothing mbRenewal then mempty -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) @@ -651,31 +684,31 @@ postFirmSupersR fsh = do -- <*> (view resultCompanyUser >>= getCompanies) -- <*> (view resultCompanyUser >>= getCompanyNos) -- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) --- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) +-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) -- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) --- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) +-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) -- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) -- <*> getStatusPlusTxt -- <*> getStatusPlusDay --- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of +-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of -- [] -> pure Nothing -- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps -- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) --- getStatusPlusTxt = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case +-- getStatusPlusTxt = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case -- Just LmsBlocked{} -> return $ Just "Failed" -- Just LmsExpired{} -> return $ Just "Expired" -- Just LmsSuccess{} -> return $ Just "Success" -- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ -- preview (resultLmsUser . _entityVal . _lmsUserStarted) --- getStatusPlusDay = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case +-- getStatusPlusDay = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case -- lsd@(Just _) -> return lsd -- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) - + -- dbtCsvDecode = Nothing --- dbtExtraReps = [] +-- dbtExtraReps = [] -- dbtParams = DBParamsForm -- { dbParamsFormMethod = POST -- , dbParamsFormAction = Nothing @@ -704,7 +737,7 @@ postFirmSupersR fsh = do -- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html -- getQualificationR = postQualificationR --- postQualificationR sid qsh = do +-- postQualificationR sid qsh = do -- isAdmin <- hasReadAccessTo AdminR -- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning -- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning @@ -719,13 +752,13 @@ postFirmSupersR fsh = do -- }} <- getBy404 $ SchoolQualificationShort sid qsh -- -- Block copied to Handler/Qualifications TODO: refactor --- let getBlockReasons unblk = E.select $ do --- (quser :& qblock) <- E.from $ E.table @QualificationUser +-- let getBlockReasons unblk = E.select $ do +-- (quser :& qblock) <- E.from $ E.table @QualificationUser -- `E.innerJoin` E.table @QualificationUserBlock -- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) -- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid -- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) --- E.groupBy (qblock E.^. QualificationUserBlockReason) +-- E.groupBy (qblock E.^. QualificationUserBlockReason) -- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows -- E.orderBy [E.desc countRows'] -- E.limit 7 @@ -739,34 +772,34 @@ postFirmSupersR fsh = do -- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) -- acts = mconcat $ -- [ singletonMap QualificationActExpire $ pure QualificationActExpireData --- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData --- <$ aformMessage msgUnexpire --- ] ++ bool +-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData +-- <$ aformMessage msgUnexpire +-- ] ++ bool -- -- nonAdmin actions, ie. Supervisor --- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] +-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- -- Admin-only actions -- [ singletonMap QualificationActUnblock $ QualificationActUnblockData -- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing -- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) --- , singletonMap QualificationActBlock $ QualificationActBlockData +-- , singletonMap QualificationActBlock $ QualificationActBlockData -- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing -- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) -- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) -- , singletonMap QualificationActRenew $ pure QualificationActRenewData --- , singletonMap QualificationActGrant $ QualificationActGrantData +-- , singletonMap QualificationActGrant $ QualificationActGrantData -- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry -- <* aformMessage msgGrantWarning -- ] isAdmin -- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) --- linkUserName = bool ForProfileR ForProfileDataR isAdmin +-- linkUserName = bool ForProfileR ForProfileDataR isAdmin -- colChoices cmpMap = mconcat -- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) -- , colUserNameModalHdr MsgLmsUser linkUserName --- , colUserEmail +-- , colUserEmail -- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> -- let icnSuper = text2markup " " <> icon IconSupervisor --- cs = [ (cmpName, cmpSpr) --- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps +-- cs = [ (cmpName, cmpSpr) +-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps -- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap -- ] -- companies = intercalate (text2markup ", ") $ @@ -775,9 +808,9 @@ postFirmSupersR fsh = do -- , guardMonoid isAdmin colUserMatriclenr -- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) -- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d --- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d +-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d -- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) --- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> +-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> -- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row -- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip -- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification @@ -788,13 +821,13 @@ postFirmSupersR fsh = do -- psValidator = def & defaultSorting [SortDescBy "last-refresh"] -- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator -- return (tbl, qent) - + -- formResult lmsRes $ \case -- (QualificationActRenewData, selectedUsers) | isAdmin -> do --- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers +-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers -- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks -- reloadKeepGetParams $ QualificationR sid qsh --- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do +-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do -- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing -- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers -- reloadKeepGetParams $ QualificationR sid qsh @@ -807,18 +840,18 @@ postFirmSupersR fsh = do -- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire -- addMessageI msgKind msgVal -- reloadKeepGetParams $ QualificationR sid qsh --- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do +-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do -- let selUserIds = Set.toList selectedUsers --- (unblock, reason) = case action of --- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) +-- (unblock, reason) = case action of +-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) -- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) -- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) -- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks --- notify = case action of +-- notify = case action of -- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify -- _ -> False - --- oks <- runDB $ do + +-- oks <- runDB $ do -- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] -- qualificationUserBlocking qid selUserIds unblock Nothing reason notify -- let nrq = length selectedUsers diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a2a5fc381..2e44c6323 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,10 +1,20 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +{- FOP - Frequently occurring problems using dbTable: + + - When changing a dbTable to a form, eg. using `dbSelect` then change the colonnade defnition from `dbColonnade` to `formColonnade`! + Both functions are equal to id, but the types are quite different. + + - Don't mix up the row type alias traditionally ending with ...Data and the Action-Result-Type also ending with ...Data + +-} + module Handler.Utils.Table.Pagination ( module Handler.Utils.Table.Pagination.Types , dbFilterKey @@ -1654,10 +1664,12 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x) -> Colonnade h r (DBCell (HandlerFor UniWorX) x) widgetColonnade = id +-- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) formColonnade = id +-- | force the column list type for simple tables that do not contain forms, and especially no dbSelect, avoids explicit type signatures dbColonnade :: Colonnade h r (DBCell DB x) -> Colonnade h r (DBCell DB x) dbColonnade = id From 315eedd1bc74be2f97ce80ea3160b31e13da2ed6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 12:47:35 +0000 Subject: [PATCH 6/8] chore(users): allow admins to change foreign emails without confirmation --- src/Handler/Profile.hs | 12 +++++++----- src/Handler/Utils.hs | 4 ++++ 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 39730ffd5..3dde9b54d 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -102,7 +102,6 @@ instance RenderMessage UniWorX NotificationTriggerKind where where mr = renderMessage f ls - makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template html = do MsgRenderer mr <- getMsgRenderer @@ -169,7 +168,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do mbUid <- liftHandler maybeAuthId - isAdmin <- lift . lift $ hasReadAccessTo AdminR + isAdmin <- checkAdmin let sectionIsHidden :: NotificationTriggerKind -> DB Bool @@ -376,7 +375,7 @@ validateSettings User{..} = do let pinBad = validCmdArgument =<< userPinPassword' pinMinChar = 5 pinLength = maybe 0 length userPinPassword' - pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else liftHandler $ hasReadAccessTo AdminR -- admins are allowed to ignore pin requirements + pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else checkAdmin -- admins are allowed to ignore pin requirements whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk @@ -450,9 +449,12 @@ serveProfileR (uid, user@User{..}) = do formResult res $ \SettingsForm{..} -> do now <- liftIO getCurrentTime + isAdmin <- checkAdmin + thisUser <- fromMaybe uid <$> maybeAuthId + let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid) runDBJobs $ do update uid $ - [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472 + [ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below [ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++ [ UserDisplayName =. stgDisplayName , UserMaxFavourites =. stgMaxFavourites @@ -472,7 +474,7 @@ serveProfileR (uid, user@User{..}) = do , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] updateFavourites Nothing - when (stgDisplayEmail /= userDisplayEmail) $ do + when changeEmailByUser $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail let diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index d13be8cee..2460eb65d 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -38,6 +38,10 @@ import Handler.Utils.Term as Handler.Utils import Control.Monad.Logger +-- | default check if the user an active admin +checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool +checkAdmin = liftHandler $ hasReadAccessTo AdminR + -- | Prefix a message with a short course id, -- eg. for window title bars, etc. From 9ca9c38830060dc73722a2da796280bbfa34115f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 14:55:55 +0000 Subject: [PATCH 7/8] chore(users): allow multiple filter criteria for avs no and personal no --- .../utils/table_column/de-de-formal.msg | 2 +- messages/uniworx/utils/table_column/en-eu.msg | 2 +- src/Database/Esqueleto/Utils.hs | 13 ++++- src/Handler/PrintCenter.hs | 6 +-- src/Handler/Users.hs | 50 ++++++++----------- 5 files changed, 39 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index fdf42b885..86b07953e 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -16,7 +16,7 @@ TableTerm !ident-ok: Jahr TableCourseSchool: Bereich TableSubmissionGroup: Feste Abgabegruppe TableNoSubmissionGroup: Keine feste Abgabegruppe -TableMatrikelNr: AVS Nr +TableMatrikelNr: AVS Personennummer TableSex: Geschlecht TableBirthday: Geburtsdatum TableSchool: Bereich diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index b4fe83d34..8a9c79bf8 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -16,7 +16,7 @@ TableTerm: Year TableCourseSchool: Department TableSubmissionGroup: Registered submission group TableNoSubmissionGroup: No registered submission group -TableMatrikelNr: AVS No +TableMatrikelNr: AVS person no TableSex: Sex TableBirthday: Birthday TableSchool: Department diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 70cdaaecc..139e955e1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -24,7 +24,7 @@ module Database.Esqueleto.Utils , mkContainsFilter, mkContainsFilterWith , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkDayFilter, mkDayFilterFrom, mkDayFilterTo - , mkExistsFilter + , mkExistsFilter, mkExistsFilterWithComma , anyFilter, allFilter , ascNullsFirst, descNullsLast , orderByList @@ -421,6 +421,17 @@ mkExistsFilter query row criterias | Set.null criterias = true | otherwise = any (E.exists . query row) $ Set.toList criterias +mkExistsFilterWithComma :: PathPiece a + => (Text -> a) + -> (t -> a -> E.SqlQuery ()) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) +mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias) + + -- | Combine several filters, using logical or anyFilter :: Foldable f => f (t -> cs -> E.SqlExpr (E.Value Bool)) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 083d8572d..6be31bf20 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -225,9 +225,9 @@ mkPJTable = do dbtFilter = mconcat [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) - , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index d72bdc9ac..d856a29c4 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -101,7 +101,7 @@ postUsersR = do (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr - , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -265,15 +265,9 @@ postUsersR = do Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) - , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if - | Set.null criteria -> E.true - | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria - ) - , ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if - | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? - | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria - ) - , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if + , ( "personal-number" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber)) + , ( "matriculation" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches + , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- exact filter on table UserAvs | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | otherwise -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria ) @@ -312,12 +306,12 @@ postUsersR = do E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId) E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) ) - , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion -> - E.from $ \usrAvs -> -- do - E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser - E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. - (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) - ) + -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter + -- E.from $ \usrAvs -> -- do + -- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser + -- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. + -- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) + -- ) , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor @@ -325,19 +319,19 @@ postUsersR = do ) ] , dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) - , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) - , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) - -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) - , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) - , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) + , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) + , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus) -- contains filter on UserMatrikelnummer + -- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs + , prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor) - , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) - , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) - , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) + , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) + , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm From a28786412e8f7b8b2b9e83cc7e528898bfd85f38 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 16:13:31 +0000 Subject: [PATCH 8/8] chore(firm): add firm-all filters and code cleaning --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + routes | 2 +- src/Database/Esqueleto/Utils.hs | 5 ++ src/Handler/Firm.hs | 85 +++++++------------ src/Handler/Qualification.hs | 3 +- src/Handler/Utils/Table/Columns.hs | 19 +++++ 7 files changed, 57 insertions(+), 59 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index aee81f2bb..b96544ca9 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -75,6 +75,7 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanyFilter: Firma oder Nummer TableCompanyShort: Firmenkürzel TableCompanies: Firmen TableCompanyNo: Firmennummer diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 70583dfc7..a4e62b00b 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -75,6 +75,7 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanyFilter: Company/Nr TableCompanyShort: Company shorthand TableCompanies: Companies TableCompanyNo: Company number diff --git a/routes b/routes index e6e4618b7..b77b24c70 100644 --- a/routes +++ b/routes @@ -113,7 +113,7 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET +/firm FirmAllR GET POST /firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST /firm/#CompanyShorthand/supers FirmSupersR GET POST diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f9a1dde82..1b4326ed5 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -46,6 +46,7 @@ module Database.Esqueleto.Utils , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe + , num2text , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue @@ -656,10 +657,14 @@ selectCountDistinct q = do selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) +-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers +num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) +num2text = E.unsafeSqlCastAs "text" day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" +-- | cast text to day, truly unsafe day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day) day' = E.unsafeSqlCastAs "date" diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5aafa0ed9..7ce1cc857 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -19,11 +19,11 @@ import Import -- import Jobs import Handler.Utils --- import qualified Data.Set as Set +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.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) @@ -35,8 +35,8 @@ import Database.Esqueleto.Utils.TH -- avoids repetition of local definitions --- single :: (k,a) -> Map k a --- single = uncurry Map.singleton +single :: (k,a) -> Map k a +single = uncurry Map.singleton getFirmR, postFirmR :: CompanyShorthand -> Handler Html @@ -106,6 +106,10 @@ data FirmAllActionData = FirmAllActNotifyData | FirmAllActResetSupervisionData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +-- just in case for future extensions +type AllCompanyTableExpr = E.SqlExpr (Entity Company) +queryCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) +queryCompany = id type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) @@ -184,14 +188,7 @@ firmCountActiveReroutes' cmpy = E.subSelectCount $ do E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -mkFirmAllTable :: - -- ( Functor h, ToSortable h - -- , AsCornice h p FirmAllActionData - -- (DBCell (MForm Handler) - -- (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - -- ) cols - -- ) => - Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -214,48 +211,14 @@ mkFirmAllTable isAdmin uid = do dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ - {- hole :: (x -> f x) -> r -> f r - (FormResult - (DBFormResult (Key Company) Bool (DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)) - ) - -> f (FormResult - (DBFormResult - (Key Company) - Bool - (DBRow - (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, - E.Value Word64, E.Value Word64, E.Value Word64))))) - -> FormResult - (First FirmAllActionData, - DBFormResult CompanyId Bool FirmAllActionData) - -> f (FormResult - (First FirmAllActionData, - DBFormResult CompanyId Bool FirmAllActionData)) - - ------- - - ( (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) - -> f (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) - ) - -> (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - -> f (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - - ------ - Lens' (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) - (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - ------ - Lens' (FormResult (Map (Key Company) (AllCompanyTableData,Bool -> Bool))) - (FormResult (First FirmAllActionData, (Map (CompanyId) (FirmAllActionData ,Bool -> Bool)))) - -- applying bringt uns unter das FormResult - -} + [ if not isAdmin then mempty else -- guardOnM idAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) - , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm - , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm in anchorCell (FirmR fsh) $ toWgt fsh - , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + , 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) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr @@ -276,10 +239,21 @@ mkFirmAllTable isAdmin uid = do , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat - [ + [ single $ fltrCompanyNameNr queryCompany + , single ("is-supervisor", FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.innerJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryCompany row E.^. CompanyId + E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) + ) ] - dbtFilterUI = mconcat - [ + dbtFilterUI mPrev = mconcat + [ fltrCompanyNameNrUI mPrev + , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) ] dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) @@ -293,8 +267,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional - = renderAForm FormStandard - $ (, mempty) . First . Just + = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id @@ -313,7 +286,7 @@ mkFirmAllTable isAdmin uid = do 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)) -- This type signature is not optional! + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 3068d6132..d29a0815d 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -504,8 +504,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional - = renderAForm FormStandard - $ (, mempty) . First . Just + = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 280becf18..e42451442 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -753,6 +753,25 @@ sortUserCompany queryUser = ( "user-company" return (comp E.^. CompanyName) )) +-- | Search companies by name, shorthand oder AVS nr +fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) + => (a -> E.SqlExpr (Entity Company)) + -> (d, FilterColumn t fs) +fltrCompanyNameNr query = ( "company-name-number", FilterColumn $ anyFilter + [ mkContainsFilterWithCommaPlus CI.mk $ query >>> (E.^. CompanyName) + , mkContainsFilterWithCommaPlus CI.mk $ query >>> (E.^. CompanyShorthand) + , mkContainsFilterWithCommaPlus id $ query >>> (E.num2text . (E.^. CompanyAvsId)) + ] + ) + + +fltrCompanyNameNrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameNrUI = fltrCompanyNameNrHdrUI MsgTableCompanyFilter + +fltrCompanyNameNrHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameNrHdrUI msg mPrev = + prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaPlus) + ---------------------------- -- Colonnade manipulation --