From a28786412e8f7b8b2b9e83cc7e528898bfd85f38 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 16:13:31 +0000 Subject: [PATCH] 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 --