fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(log): add more filter options to admin problem log

Browse Source
This commit is contained in:
Steffen Jost 2024-07-03 17:56:13 +02:00
parent 073432c75b
commit feb8d92bc1
5 changed files with 36 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -126,6 +126,7 @@ AdminProblemSolved: Erledigt
AdminProblemSolver: Bearbeitet von AdminProblemSolver: Bearbeitet von
AdminProblemCreated: Erkannt AdminProblemCreated: Erkannt
AdminProblemInfo: Problembeschreibung 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 AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen

1
messages/uniworx/categories/admin/en-eu.msg
View File

@ -126,6 +126,7 @@ AdminProblemSolved: Done
AdminProblemSolver: Solved by AdminProblemSolver: Solved by
AdminProblemCreated: Recognized AdminProblemCreated: Recognized
AdminProblemInfo: Problem 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 AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
AdminProblemNewCompany: New company from AVS; verify and add default supervisors AdminProblemNewCompany: New company from AVS; verify and add default supervisors

1
src/Audit/Types.hs
View File

@ -261,6 +261,7 @@ derivePersistFieldJSON ''Transaction
-- Datatype for raising admin awareness to certain problems -- Datatype for raising admin awareness to certain problems
-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries -- 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 that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead
-- Note: Adjust MsgAdminProblemInfoTooltip as well
data AdminProblem data AdminProblem
= AdminProblemNewCompany -- new company was noticed, presumably without supervisors = AdminProblemNewCompany -- new company was noticed, presumably without supervisors
{ adminProblemCompany :: CompanyId { adminProblemCompany :: CompanyId

12
src/Handler/Admin.hs
View File

@ -339,10 +339,18 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
, single ("solver", sortUserNameBareM querySolver) , single ("solver", sortUserNameBareM querySolver)
] ]
dbtFilter = mconcat 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 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 :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
acts = mconcat acts = mconcat

42
src/Handler/Utils/Table/Columns.hs
View File

@ -417,12 +417,16 @@ fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F
fltrUserNameUI = fltrUserNameLinkUI fltrUserNameUI = fltrUserNameLinkUI
fltrUserNameLinkUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) 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 :: (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) 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 :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers
@ -686,7 +690,7 @@ fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . F
fltrRelevantStudyFeaturesTermsUI :: DBFilterUI fltrRelevantStudyFeaturesTermsUI :: DBFilterUI
fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI
fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias -> fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias ->
E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do 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 :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrRelevantStudyFeaturesDegreeUI mPrev = fltrRelevantStudyFeaturesDegreeUI mPrev =
prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgTableDegreeName) 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 :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias -> fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias ->
E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do 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 :: (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 let uid = heu ^. hasEntity . _entityKey
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) 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' (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor icnSuper = text2markup " " <> icon IconSupervisor
cell $ toWgt $ mconcat companies 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? -- 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 :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c)
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu ->
let uid = heu ^. hasEntity . _entityKey in let uid = heu ^. hasEntity . _entityKey in
sqlCell $ do sqlCell $ do
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) 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' (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies pure $ toWgt $ mconcat companies
@ -803,12 +807,12 @@ fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFol
let numCrits = setMapMaybe readMay criterias let numCrits = setMapMaybe readMay criterias
fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias
fltrCShort = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) 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 in if null numCrits
then fltrCName E.||. fltrCShort 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 :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text
setFoldMap = foldMap 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) => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs)
fltrAVSCardNos queryUser = Map.singleton "avs-card" fch fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
where where
fch = FilterColumnHandler $ \case fch = FilterColumnHandler $ \case
[] -> return (const E.true) [] -> return (const E.true)
cs -> do cs -> do
let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case
Nothing -> addMessageI Error MsgAvsCommunicationTimeout Nothing -> addMessageI Error MsgAvsCommunicationTimeout
>> return (const E.false) >> return (const E.false)
(Just (Left err)) -> addMessage Error (someExc2Html err) (Just (Left err)) -> addMessage Error (someExc2Html err)
>> return (const E.false) >> return (const E.false)
(Just (Right (null -> True))) -> return (const E.false) (Just (Right (null -> True))) -> return (const E.false)
(Just (Right apids)) -> return $ (Just (Right apids)) -> return $
\(queryUser -> user) -> \(queryUser -> user) ->
E.exists $ E.from $ \usrAvs -> E.exists $ E.from $ \usrAvs ->
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId 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 someExc2Html (SomeException e) = text2Html $ tshow e
fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrAVSCardNosUI mPrev = fltrAVSCardNosUI mPrev =
prismAForm (singletonFilter "avs-card" ) mPrev $ prismAForm (singletonFilter "avs-card" ) mPrev $
aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded])) aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))