chore(mail): towards #2979 by allowing to filter by content in mail center
This commit is contained in:
parent
1b8c6c33a7
commit
207a304192
@ -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") []
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user