From e8f9c21b7c8e7829d9493413ff199c8b7768df21 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 26 Aug 2024 15:17:01 +0200 Subject: [PATCH] chore(problem): admin problem filtering works on full text now --- .../uniworx/categories/admin/de-de-formal.msg | 1 - messages/uniworx/categories/admin/en-eu.msg | 1 - src/Database/Esqueleto/Utils.hs | 1 + src/Handler/Admin.hs | 14 +++++-- src/Handler/Utils.hs | 37 ++++++++++++------- src/Utils/Pandoc.hs | 5 ++- 6 files changed, 38 insertions(+), 21 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index bdb52de55..922d58f4c 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -127,7 +127,6 @@ 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 cccdf50a3..96972ad87 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -127,7 +127,6 @@ 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/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index dc927ec1d..4f8494fdf 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -688,6 +688,7 @@ infixl 8 ->. infixl 8 ->>. +-- Unsafe variant, see Database.Esqueleto.PostgreSQL.JSON for a safe version! (->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index cc03072b7..64c4acadd 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -317,7 +317,13 @@ resultUser :: Traversal' ProblemLogTableData (Entity User) resultUser = _dbrOutput . _3 . _Just mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget) -mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} +mkProblemLogTable = do + -- problem_types <- E.select $ do + -- ap <- E.from $ E.table @ProblemLog + -- let res = ap E.^. ProblemLogInfo E.->>. "problem" + -- E.groupBy res + -- return res + over _1 postprocess <$> dbTable validator DBTable{..} where -- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch dbtIdent = "problem-log" :: Text @@ -350,10 +356,10 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} dbtFilter = mconcat [ 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))) -- not stored in plaintext! , single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) , single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) - , single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> + -- , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext! + , single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen ifNothingM criterion True $ \(crit::Text) -> do let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem protxt <- adminProblem2Text problem @@ -363,7 +369,7 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} dbtFilterUI mPrev = mconcat [ 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 "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo) , 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) ] diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 1b2735680..b7a112d86 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -166,6 +166,7 @@ redirectKeepGetParams route = liftHandler $ do adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns +-- WARNING: this function should correspond with adminProblem2Text adminProblemCell AdminProblemNewCompany{} = i18nCell MsgAdminProblemNewCompany adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} @@ -181,29 +182,37 @@ adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} adminProblemCell AdminProblemUnknown{adminProblemText} = textCell $ "Problem: " <> adminProblemText +company2msg :: CompanyId -> SomeMessage UniWorX +company2msg = text2message . ciOriginal . unCompanyKey + +-- used to enable filtering, must correspond to function adminProblemCell shown above adminProblem2Text :: AdminProblem -> DB Text adminProblem2Text adprob = do - mr <- getMessageRender + MsgRenderer mr <- getMsgRenderer case adprob of AdminProblemNewCompany{} -> return $ mr MsgAdminProblemNewCompany - AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute} -- , adminProblemCompanyNew} -- TODO - -> return $ mr (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) -- TODO <> companyIdCell adminProblemCompanyNew + AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew} + -> return $ mr $ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew] AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} -> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) - AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing} - -> return $ mr MsgAdminProblemCompanySuperiorChange - -- TODO AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid} - -- = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid) - AdminProblemNewlyUnsupervised{} -- TODO adminProblemCompanyNew} - -> mr MsgAdminProblemNewlyUnsupervised -- TODO <> companyIdCell adminProblemCompanyNew + AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid} + -> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do + uid <- MaybeT $ pure mbuid + User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid + pure $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing} + -- -> return $ mr MsgAdminProblemCompanySuperiorChange + -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid} + -- -> get uid >>= \case + -- Nothing -> + -- return $ mr MsgAdminProblemCompanySuperiorChange + -- Just User{userDisplayName = udn, userSurname = usn} -> + -- return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + AdminProblemNewlyUnsupervised{adminProblemCompanyNew} + -> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew] AdminProblemUnknown{adminProblemText} -> return $ "Problem: " <> adminProblemText - _ -> return "TODO -- CONTINUE HERE" - - -company2msg :: CompanyId -> SomeMessage UniWorX -company2msg = text2message . ciOriginal . unCompanyKey msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ diff --git a/src/Utils/Pandoc.hs b/src/Utils/Pandoc.hs index d2030d2a3..fbe00080d 100644 --- a/src/Utils/Pandoc.hs +++ b/src/Utils/Pandoc.hs @@ -17,7 +17,10 @@ import qualified Text.Pandoc as P markdownToHtml :: Html -> Either P.PandocError Html -markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html) +markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html) + +htmlToPlainText :: Html -> Either P.PandocError Text +htmlToPlainText html = P.runPure $ P.writePlain htmlWriterOptions =<< P.readHtml markdownReaderOptions (toStrict $ renderHtml html) plainTextToHtml :: Text -> Html plainTextToHtml text = fromRight (toMarkup text) $ P.runPure $