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

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

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

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
 

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

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
+    AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew}
-      -> return $ mr (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) -- TODO <> companyIdCell adminProblemCompanyNew
+      -> return $ mr $ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew]
     AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
       -> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
-    AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
+    AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid}
-      -> return $ mr MsgAdminProblemCompanySuperiorChange
+      -> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do
-    -- TODO AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
+          uid <- MaybeT $ pure mbuid
-    --   = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
+          User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
-    AdminProblemNewlyUnsupervised{} -- TODO adminProblemCompanyNew}
+          pure $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
-      -> mr MsgAdminProblemNewlyUnsupervised -- TODO <> companyIdCell adminProblemCompanyNew
+    -- 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 $

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 $