chore(mail): towards #2979 by allowing to filter by content in mail center

src/Database/Esqueleto/Utils.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -12,7 +12,9 @@ module Database.Esqueleto.Utils
   , isNumerical, hasLetter
   , isInfixOf, hasInfix
   , isPrefixOf_, hasPrefix_
-  , strConcat, substring
+  , strConcat
+  , substring, substringRegex
+  , decodeBase64, encodeEscape, mailContentContains
   , (=?.), (?=.)
   , (=~.), (~=.)
   , (>~.), (<~.)
@@ -98,7 +100,7 @@ import Data.Monoid (Last(..))
 
 import Utils (commaSeparatedText)
 -- import Utils.Set (concatMapSet)
-
+import Model.Types.Mail (MailContent)
 
 {-# ANN any ("HLint: ignore Use any" :: String) #-}
 {-# ANN all ("HLint: ignore Use all" :: String) #-}
@@ -259,6 +261,37 @@ substring (E.ERaw _m1 f1) (E.ERaw _m2 f2) (E.ERaw _m3 f3)
           , strVals <> fromiVals <> foriVals
           )
 
+substringRegex :: ( E.SqlString str, E.SqlString from)
+          => E.SqlExpr (E.Value str)
+          -> E.SqlExpr (E.Value from)
+          -> E.SqlExpr (E.Value str)
+substringRegex (E.ERaw _m1 f1) (E.ERaw _m2 f2)
+  = E.ERaw E.noMeta $ \_nParens info ->
+      let (strTLB, strVals) = f1 E.Parens info
+          (fromiTLB, fromiVals) = f2 E.Parens info
+       in ( "SUBSTRING" <> E.parens (E.parens strTLB <> " FROM " <> E.parens fromiTLB)
+          , strVals <> fromiVals
+          )
+
+-- useful for searching within MailContent in db
+decodeBase64 :: E.SqlString str => E.SqlExpr (E.Value str) -> E.SqlExpr (E.Value str)
+decodeBase64 = E.unsafeSqlFunction "decode" . (, E.val "base64" :: E.SqlExpr (E.Value Text))
+
+encodeEscape :: E.SqlString str => E.SqlExpr (E.Value str) -> E.SqlExpr (E.Value str)
+encodeEscape = E.unsafeSqlFunction "encode" . (, E.val "escape" :: E.SqlExpr (E.Value Text))
+
+mailContentContains :: E.SqlString str => E.SqlExpr (E.Value MailContent) -> E.SqlExpr (E.Value str) -> E.SqlExpr (E.Value Bool)
+mailContentContains hay needle = hasNeedle plainText E.||. hasNeedle encodedBase64
+  where
+    hayText :: E.SqlExpr (E.Value Text) = E.unsafeSqlCastAs "text" hay
+    hasNeedle = isInfixOf needle
+    encodedBase64 = encodeEscape $ decodeBase64 $
+                    substringRegex hayText $ E.val reB64
+    plainText     = substringRegex hayText $ E.val rePlain
+    reB64   :: Text = ".*\\{\"type\": \"text/plain; charset=utf-8\", \"content\": \\{\"content\": \"(.*?)\", \"encoding\": \"base64\"\\}.*"
+    rePlain :: Text = ".*\\{\"type\": \"text/plain; charset=utf-8\", \"content\": \"(.*?)\", \"headers\": \\[\\], \"encoding\": \"quoted-printable-text\".*"
+
+
 explicitUnsafeCoerceSqlExprValue :: forall b a.
                                     Text
                                  -> E.SqlExpr (E.Value a)
@@ -863,4 +896,4 @@ truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity
                   => proxy record -> ReaderT backend m ()
 truncateTable tbl =
   let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
-  in  E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []
+  in  E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []

src/Handler/Admin/Test.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2925 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -93,6 +93,7 @@ makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
 getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
 getAdminTestR = postAdminTestR
 postAdminTestR = do
+  uid <- requireAuthId -- this is an admin-only route anyway
   ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
   let btnForm = wrapForm btnWdgt def
         { formAction = Just $ SomeRoute AdminTestR
@@ -101,7 +102,9 @@ postAdminTestR = do
         }
   case btnResult of
     (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
-    (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
+    (FormSuccess CreateMath) -> do
+      void $ queueJob $ JobUserNotification { jRecipient = uid, jNotification = NotificationUserAuthModeUpdate uid }
+      addMessage Warning "Knopf Mathematik erkannt"
     (FormSuccess CrashApp)   -> addMessage Error "Crash Button Ratio 0 betätigt" >> error ("Crash Button" <> show (1 % 0))
     FormMissing -> return ()
     _other -> addMessage Warning "KEIN Knopf erkannt"

src/Handler/MailCenter.hs

@@ -104,12 +104,18 @@ mkMCTable = do
       , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
       , ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus id     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
       -- , ("regex"     , FilterColumn . E.mkRegExFilterWith id                 $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      , ("content"   , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
+          body <- E.from $ E.table @SentMailContent
+          E.where_ $ body E.^. SentMailContentId E.==. queryMail row E.^. SentMailContentRef
+                E.&&. E.mailContentContains (body E.^. SentMailContentContent) (E.val criterion)
+        )
       ]
     dbtFilterUI mPrev = mconcat
       [ prismAForm (singletonFilter "sent"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
       , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
       , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
       -- , prismAForm (singletonFilter "regex"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    )
+      , prismAForm (singletonFilter "content"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommContent) --    & setTooltip MsgCommContentSearch)
       ]
     dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
     dbtIdent :: Text