From 207a3041928acfd3b3ca65467bd31231ace0dea8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Mar 2025 17:54:05 +0100 Subject: [PATCH] chore(mail): towards #2979 by allowing to filter by content in mail center --- src/Database/Esqueleto/Utils.hs | 41 +++++++++++++++++++++++++++++---- src/Handler/Admin/Test.hs | 7 ++++-- src/Handler/MailCenter.hs | 6 +++++ 3 files changed, 48 insertions(+), 6 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index c510bbb6c..c4763c5ba 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- 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") [] \ No newline at end of file + in E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") [] diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index d5a29b055..da19b7ec9 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2925 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- 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" diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 219445226..4c5666cde 100644 --- a/src/Handler/MailCenter.hs +++ b/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