From feb8d92bc1a038b1e282ddbc6e8a95325331b8e2 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 3 Jul 2024 17:56:13 +0200 Subject: [PATCH] chore(log): add more filter options to admin problem log --- .../uniworx/categories/admin/de-de-formal.msg | 1 + messages/uniworx/categories/admin/en-eu.msg | 1 + src/Audit/Types.hs | 1 + src/Handler/Admin.hs | 12 +++++- src/Handler/Utils/Table/Columns.hs | 42 ++++++++++--------- 5 files changed, 36 insertions(+), 21 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 45403eebe..48a4d8c15 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -126,6 +126,7 @@ AdminProblemSolved: Erledigt AdminProblemSolver: Bearbeitet von AdminProblemCreated: Erkannt AdminProblemInfo: Problembeschreibung +AdminProblemInfoTooltip: Nur Teile der folgenden englische Begriffe sind derzeit möglich: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 58058188c..6a969d8c0 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -126,6 +126,7 @@ AdminProblemSolved: Done AdminProblemSolver: Solved by AdminProblemCreated: Recognized AdminProblemInfo: Problem +AdminProblemInfoTooltip: Only parts of the following keys currently work here: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemNewCompany: New company from AVS; verify and add default supervisors diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 57473bfbb..26213d616 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -261,6 +261,7 @@ derivePersistFieldJSON ''Transaction -- Datatype for raising admin awareness to certain problems -- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries -- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead +-- Note: Adjust MsgAdminProblemInfoTooltip as well data AdminProblem = AdminProblemNewCompany -- new company was noticed, presumably without supervisors { adminProblemCompany :: CompanyId diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a94af84d3..e4ddc8cf1 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -339,10 +339,18 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} , single ("solver", sortUserNameBareM querySolver) ] dbtFilter = mconcat - [ single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) + [ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) + , single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) + , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) + , single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) + , single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved) + [ prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemUser & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "solver" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort) + , prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo & setTooltip MsgAdminProblemInfoTooltip) + , prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableCompanyShort) + , prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved) ] acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData) acts = mconcat diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index e04364f1e..a2feb123e 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -417,12 +417,16 @@ fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F fltrUserNameUI = fltrUserNameLinkUI fltrUserNameLinkUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) -fltrUserNameLinkUI = fltrUserNameLinkHdrUI MsgTableCourseMembers +fltrUserNameLinkUI = fltrUserNameLinkHdrUI MsgTableCourseMembers fltrUserNameLinkHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) -fltrUserNameLinkHdrUI msg mPrev = +fltrUserNameLinkHdrUI msg mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI msg) +fltrUserDisplayNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrUserDisplayNameHdrUI msg mPrev = + prismAForm (singletonFilter "user-display-name") mPrev $ aopt textField (fslI msg) + fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers @@ -686,7 +690,7 @@ fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . F fltrRelevantStudyFeaturesTermsUI :: DBFilterUI fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI - + fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do @@ -705,7 +709,7 @@ fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrRelevantStudyFeaturesDegreeUI mPrev = prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgTableDegreeName) - + fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do @@ -741,13 +745,13 @@ fltrQualificationHdrUI msg mPrev = prismAForm (singletonFilter "qualification" . {- -- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do let uid = heu ^. hasEntity . _entityKey companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ + let companies = intersperse (text2markup ", ") $ (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor cell $ toWgt $ mconcat companies @@ -756,13 +760,13 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \ -- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB? colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> - let uid = heu ^. hasEntity . _entityKey in - sqlCell $ do + let uid = heu ^. hasEntity . _entityKey in + sqlCell $ do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ + let companies = intersperse (text2markup ", ") $ (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies @@ -803,12 +807,12 @@ fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFol let numCrits = setMapMaybe readMay criterias fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias fltrCShort = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) needle criterias - fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits + fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits in if null numCrits then fltrCName E.||. fltrCShort - else fltrCName E.||. fltrCShort E.||. fltrCno + else fltrCName E.||. fltrCShort E.||. fltrCno ) - where + where setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text setFoldMap = foldMap @@ -825,22 +829,22 @@ fltrCompanyNameNrHdrUI msg mPrev = --------- -fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) +fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs) fltrAVSCardNos queryUser = Map.singleton "avs-card" fch - where + where fch = FilterColumnHandler $ \case [] -> return (const E.true) cs -> do let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout - maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case - Nothing -> addMessageI Error MsgAvsCommunicationTimeout + maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case + Nothing -> addMessageI Error MsgAvsCommunicationTimeout >> return (const E.false) (Just (Left err)) -> addMessage Error (someExc2Html err) >> return (const E.false) (Just (Right (null -> True))) -> return (const E.false) - (Just (Right apids)) -> return $ + (Just (Right apids)) -> return $ \(queryUser -> user) -> E.exists $ E.from $ \usrAvs -> E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId @@ -849,8 +853,8 @@ fltrAVSCardNos queryUser = Map.singleton "avs-card" fch someExc2Html (SomeException e) = text2Html $ tshow e fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) -fltrAVSCardNosUI mPrev = - prismAForm (singletonFilter "avs-card" ) mPrev $ +fltrAVSCardNosUI mPrev = + prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))