chore(problem): admin problem filtering works on full text now

2024-08-26 15:17:01 +02:00 · 2024-08-26 15:17:01 +02:00 · e8f9c21b7c
commit e8f9c21b7c
parent 109e845db6
6 changed files with 38 additions and 21 deletions
--- 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
--- 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
--- 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

--- 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)
      ]
--- 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 $
--- 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 $