From 207a3041928acfd3b3ca65467bd31231ace0dea8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Mar 2025 17:54:05 +0100 Subject: [PATCH 1/5] 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 From 7e61e56ae1f69645c85b144692fc01f9d095e9a0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Mar 2025 18:00:55 +0100 Subject: [PATCH 2/5] chore(mail): towards #2979 by providing simple mail resent function --- src/Handler/MailCenter.hs | 20 +++++++++++++++++++- src/Mail.hs | 21 +++++++++++++++++++++ 2 files changed, 40 insertions(+), 1 deletion(-) diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 4c5666cde..70792a07d 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -19,7 +19,7 @@ import qualified Data.Map as Map -- import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) --- import Database.Esqueleto.Experimental ((:&)(..)) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E @@ -53,6 +53,24 @@ data MCTableActionData = MCActDummyData deriving (Eq, Ord, Read, Show, Generic) +resendMailTo :: (MonoFoldable mono, Element mono ~ SentMailId) => UserEmail -> mono -> Handler () +resendMailTo recv smids = do + mails <- runDBRead $ E.select $ do + (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId) + E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids + return (sm, smc) + -- recvName <- fmap userDisplayName $ getByFilter $ [UserEmail ==. recv] ||. [UserDisplayEmail ==. rev] + forM_ mails $ \(Entity {entityVal=SentMail{..}}, Entity{entityVal=SentMailContent{sentMailContentContent=content}}) -> do + let mailParts = getMailContent content + mailTo = [Address{addressName = Nothing, addressEmail = ciOriginal recv}] + mailCc = [] + mailBcc = [] + mailFrom = error "not used" -- :: Address + -- continue here: delete some weird outdated headers + mailHeaders = toHeaders sentMailHeaders -- :: Headers + sendSimpleMail Mail{..} + + type MCTableExpr = ( E.SqlExpr (Entity SentMail) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) diff --git a/src/Mail.hs b/src/Mail.hs index cb44ce38e..61eeab90c 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -40,6 +40,7 @@ module Mail , _addressName, _addressEmail , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent + , sendSimpleMail ) where import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON) @@ -136,6 +137,9 @@ import Data.Text.Lazy.Encoding (decodeUtf8') import System.FilePath (takeFileName) import Network.HTTP.Types.Header (hETag) import Web.HttpApiData (ToHttpApiData(toHeader)) +import Data.Containers.ListUtils + +{-# ANN module ("HLint: ignore Parenthesize unary negation" :: String) #-} newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address } @@ -371,6 +375,23 @@ defMailT ls (MailT mailC) = do mail3 conn +sendSimpleMail :: ( MonadHandler m + , YesodMail (HandlerSite m) + , MonadUnliftIO m + , MonadThrow m + ) => Mail -> m () +sendSimpleMail eml = do + fromAddress <- defaultFromAddress + returnPath <- unpack <$> envelopeFromAddress + let recipients = nubOrd $ map (unpack . addressEmail) $ mailTo eml ++ mailCc eml ++ mailBcc eml + content <- liftIO $ LBS.toStrict <$> renderMail' eml{mailFrom = fromAddress} + mailSmtp $ \conn -> do + liftIO $ SMTP.sendMail + returnPath + recipients + content + conn + data PrioritisedAlternatives m = PrioritisedAlternatives { preferredAlternative :: Last (m Part) From 9ba7a82449c72009124625b513574be53322b513 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 10 Mar 2025 11:41:48 +0100 Subject: [PATCH 3/5] fix(mail): fix #2979 by completing simple mail resent function --- .../uniworx/categories/print/de-de-formal.msg | 5 +- messages/uniworx/categories/print/en-eu.msg | 5 +- src/Handler/MailCenter.hs | 51 ++++++++++--------- src/Mail.hs | 1 + 4 files changed, 35 insertions(+), 27 deletions(-) diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 0a6f96a23..df4a729fb 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -28,5 +28,8 @@ PrintLmsUser: E‑Learning Id PrintJobs: Druckaufräge PrintLetterType: Brieftypkürzel -MCActDummy: Platzhalter +MCActResendEmail: E‑Mail Kopie versenden +MCActResendEmailTooltip: Eine unveränderte Kopie der E‑Mail erneut versenden. Nur die vorherigen Empfänger werden offiziell aufgeführt, sie erhalten jedoch keine neue Kopie. +MCActResendEmailInfo n@Int recv@Text: #{pluralDEnN n "E‑Mail Kopie"} wurden an #{recv} versandt. + CCActDummy: Platzhalter \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index b722f9d32..11b58c159 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -28,5 +28,8 @@ PrintLmsUser: E‑learning id PrintJobs: Print jobs PrintLetterType: Letter type shorthand -MCActDummy: Placeholder +MCActResendEmail: Resend email copy +MCActResendEmailTooltip: Resend an unchanged copy of the email. Only previous recipients will officially be listed, but they will not receive another copy. +MCActResendEmailInfo n recv: #{n} #{noneOneMoreEN n "email copy" "email copy" "email copies"} were sent to #{recv} only. + CCActDummy: Placeholder \ No newline at end of file diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 70792a07d..d7d489c20 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -41,7 +41,7 @@ import qualified Data.ByteString.Lazy as LB import Handler.Utils -data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing +data MCTableAction = MCActResendEmail deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe MCTableAction @@ -49,25 +49,26 @@ instance Finite MCTableAction nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''MCTableAction id -data MCTableActionData = MCActDummyData +newtype MCTableActionData = MCActResendEmailData UserEmail deriving (Eq, Ord, Read, Show, Generic) resendMailTo :: (MonoFoldable mono, Element mono ~ SentMailId) => UserEmail -> mono -> Handler () resendMailTo recv smids = do - mails <- runDBRead $ E.select $ do - (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId) - E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids - return (sm, smc) - -- recvName <- fmap userDisplayName $ getByFilter $ [UserEmail ==. recv] ||. [UserDisplayEmail ==. rev] + (recvName, mails) <- runDBRead $ (,) + <$> (userDisplayName . entityVal <<$>> getByFilter ([UserEmail ==. recv] ||. [UserDisplayEmail ==. recv])) + <*> E.select (do + (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId) + E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids + return (sm, smc) + ) forM_ mails $ \(Entity {entityVal=SentMail{..}}, Entity{entityVal=SentMailContent{sentMailContentContent=content}}) -> do let mailParts = getMailContent content - mailTo = [Address{addressName = Nothing, addressEmail = ciOriginal recv}] + mailTo = [] mailCc = [] - mailBcc = [] - mailFrom = error "not used" -- :: Address - -- continue here: delete some weird outdated headers - mailHeaders = toHeaders sentMailHeaders -- :: Headers + mailBcc = [Address{addressName = recvName, addressEmail = ciOriginal recv}] + mailFrom = error "Handler.MailCenter.resenMailTo: mailFrom not replaced by sendSimpleMail" -- :: Address -- will be filled in later by sendSimpleMail + mailHeaders = toHeaders sentMailHeaders -- :: Headers -- keep as it was? Includes To/Cc/Bcc sendSimpleMail Mail{..} @@ -145,17 +146,16 @@ mkMCTable = do { dbParamsFormMethod = POST , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormNoSubmit - , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) - -- , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional - -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) - -- acts = mconcat - -- [ singletonMap MCActDummy $ pure MCActDummyData - -- ] - -- in renderAForm FormStandard - -- $ (, mempty) . First . Just - -- <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = let acts :: Map MCTableAction (AForm Handler MCTableActionData) + acts = mconcat + [ singletonMap MCActResendEmail $ MCActResendEmailData + <$> areq (emailField & cfStrip & cfCI) (fslI MsgMCActResendEmail & setTooltip MsgMCActResendEmailTooltip) Nothing + ] + in renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -174,8 +174,9 @@ getMailCenterR = postMailCenterR postMailCenterR = do (mcRes, mcTable) <- runDB mkMCTable formResult mcRes $ \case - (MCActDummyData, Set.toList -> _smIds) -> do - addMessageI Success MsgBoolIrrelevant + (MCActResendEmailData recv, smIds) -> do + resendMailTo recv smIds + addMessageI (bool Success Error $ null smIds) $ MsgMCActResendEmailInfo (Set.size smIds) (ciOriginal recv) reloadKeepGetParams MailCenterR siteLayoutMsg MsgMenuMailCenter $ do setTitleI MsgMenuMailCenter diff --git a/src/Mail.hs b/src/Mail.hs index 61eeab90c..90b2591a7 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -375,6 +375,7 @@ defMailT ls (MailT mailC) = do mail3 conn +-- | sends an email as it is, no changes except mailFrom sendSimpleMail :: ( MonadHandler m , YesodMail (HandlerSite m) , MonadUnliftIO m From 24196cc2cd2747938aabbd6c9b4dd31421cad320 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 10 Mar 2025 12:01:43 +0100 Subject: [PATCH 4/5] fix(mail): day filtering working in comms center --- messages/uniworx/utils/table_column/de-de-formal.msg | 4 +++- messages/uniworx/utils/table_column/en-eu.msg | 4 +++- src/Handler/CommCenter.hs | 7 +++++-- src/Handler/MailCenter.hs | 6 ++++-- 4 files changed, 15 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index e4c0fd753..abc8d219a 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -121,4 +121,6 @@ TableFilterCommaName: Mehrere Namen mit Komma trennen. TableFilterCommaNameNr: Mehrere Namen oder exakte Nummern mit Komma trennen. TableUserEdit: Benutzer bearbeiten TableRows: Zeilen -TableUserParkingToken day@Text: Parkmarke #{day} \ No newline at end of file +TableUserParkingToken day@Text: Parkmarke #{day} +TableFilterSentBefore: Gesendet bis +TableFilterSentAfter: Gesendet ab \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 4aa554108..2feb3f9dd 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -121,4 +121,6 @@ TableFilterCommaName: Separate names by comma. TableFilterCommaNameNr: Separate names and exact numbers by comma. TableUserEdit: Edit user TableRows: Rows -TableUserParkingToken day: Parking token #{day} \ No newline at end of file +TableUserParkingToken day: Parking token #{day} +TableFilterSentBefore: Sent before +TableFilterSentAfter: Sent after \ No newline at end of file diff --git a/src/Handler/CommCenter.hs b/src/Handler/CommCenter.hs index 3d9e560e8..8a3fed551 100644 --- a/src/Handler/CommCenter.hs +++ b/src/Handler/CommCenter.hs @@ -115,7 +115,9 @@ mkCCTable = do ] ] dbtFilter = Map.fromList - [ ("sent" , FilterColumn . E.mkDayFilterTo + [ ("sentTo" , FilterColumn . E.mkDayFilterTo + $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used + , ("sentFrom" , FilterColumn . E.mkDayFilterFrom $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]) @@ -124,7 +126,8 @@ mkCCTable = do ,E.str2text' $ queryMail row E.?. SentMailHeaders ]) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "date" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + [ prismAForm (singletonFilter "sentTo" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentBefore) + , prismAForm (singletonFilter "sentFrom" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentAfter) , 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) ] diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index d7d489c20..c6871eeb7 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -119,7 +119,8 @@ mkMCTable = do , ("recipient" , sortUserNameBareM queryRecipient) ] dbtFilter = Map.fromList - [ ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) + [ ("sentTo" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) + , ("sentFrom" , FilterColumn . E.mkDayFilterFrom $ views (to queryMail) (E.^. SentMailSentAt)) , ("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))) @@ -130,7 +131,8 @@ mkMCTable = do ) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + [ prismAForm (singletonFilter "sentTo" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentBefore) + , prismAForm (singletonFilter "sentFrom" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentAfter) , 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 ) From 9d1a97172e3faa899b4515952b1cf05bec1b92b8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 10 Mar 2025 15:57:06 +0100 Subject: [PATCH 5/5] fix(tutorial): fix #2978 by having one column per course qualification --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + src/Handler/Course/Users.hs | 25 +++++++++++++------ src/Handler/Tutorial/Users.hs | 18 ++++++------- 4 files changed, 28 insertions(+), 17 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bcf9d71e1..e5e196fb5 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -5,6 +5,7 @@ QualificationShort: Kürzel QualificationName: Qualifikation QualificationDescription: Beschreibung +QualificationValidReason qsh@Text: #{qsh} Gültigkeit QualificationValidIndicator: Gültigkeit QualificationValidDuration: Gültigkeitsdauer QualificationAuditDuration: Aufbewahrungszeitraum E‑Learning Log diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 96686cb37..077dd530c 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -5,6 +5,7 @@ QualificationShort: Shorthand QualificationName: Qualification QualificationDescription: Description +QualificationValidReason qsh: #{qsh} Validity QualificationValidIndicator: Validity QualificationValidDuration: Validity period QualificationAuditDuration: Audit log retention period diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index a4ca26ea4..8cf378447 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -240,15 +240,24 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c) colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ - let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidUntilCell cutoff qb qu - in \(view _userCourseQualifications -> qualis) -> - (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell + let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidUntilCell cutoff qb qu + in \(view _userCourseQualifications -> qualis) -> + (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell qualis qualNamedValidCell + +-- colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c) +-- colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ +-- let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell isAdmin cutoff qb qu +-- in \(view _userCourseQualifications -> qualis) -> +-- (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell + +colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Entity Qualification -> Colonnade Sortable UserTableData (DBCell m c) +colUserQualificationBlocked isAdmin cutoff Entity{entityKey=qid, entityVal=Qualification{qualificationShorthand=qsh}} + = sortable (Just "user-qualification") (i18nCell (MsgQualificationValidReason $ ciOriginal qsh) & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ + let qualNamedReasonCell (_q,qu,qb) = qualificationValidReasonCell isAdmin cutoff qb qu + -- in \(view _userCourseQualifications . to (filter ((== qid) . entityKey . fst3)) -> qualis) -> + in \(view _userCourseQualifications -> qualis) -> + (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell (filter ((== qid) . entityKey . fst3) qualis) qualNamedReasonCell -colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c) -colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ - let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell' Nothing isAdmin cutoff qb qu - in \(view _userCourseQualifications -> qualis) -> - (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell data UserTableCsv = UserTableCsv { csvUserSurname :: UserSurname diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 8fab438e9..e1489e808 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -126,15 +126,15 @@ postTUsersR tid ssh csh tutn = do let nowaday = utctDay now minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays dayExpiry = flip computeNewValidDate nowaday <$> minDur - colChoices = mconcat $ catMaybes - [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) - , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR - , pure colUserEmail - , pure $ colUserMatriclenr isAdmin - , pure $ colUserQualifications nowaday - , pure $ colUserQualificationBlocked isAdmin nowaday - , pure $ colUserExamOccurrencesCheck tid ssh csh - , pure $ colUserExams tid ssh csh + colChoices = mconcat $ + [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) + , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR + , colUserEmail + , colUserMatriclenr isAdmin + ] <> + [ colUserQualificationBlocked isAdmin nowaday q | q <- qualifications] <> + [ colUserExamOccurrencesCheck tid ssh csh + , colUserExams tid ssh csh ] psValidator = def & defaultSortingByName