Merged PR 18025: Mail search function implemented
- searching emails - show course qualification in separate columns Related work items: #2978, #2979
This commit is contained in:
commit
479e807d6d
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -5,6 +5,7 @@
|
||||
QualificationShort: Shorthand
|
||||
QualificationName: Qualification
|
||||
QualificationDescription: Description
|
||||
QualificationValidReason qsh: #{qsh} Validity
|
||||
QualificationValidIndicator: Validity
|
||||
QualificationValidDuration: Validity period
|
||||
QualificationAuditDuration: Audit log retention period
|
||||
|
||||
@ -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}
|
||||
TableUserParkingToken day@Text: Parkmarke #{day}
|
||||
TableFilterSentBefore: Gesendet bis
|
||||
TableFilterSentAfter: Gesendet ab
|
||||
@ -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}
|
||||
TableUserParkingToken day: Parking token #{day}
|
||||
TableFilterSentBefore: Sent before
|
||||
TableFilterSentAfter: Sent after
|
||||
@ -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"
|
||||
|
||||
@ -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)
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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,10 +49,29 @@ 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
|
||||
(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 = []
|
||||
mailCc = []
|
||||
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{..}
|
||||
|
||||
|
||||
type MCTableExpr =
|
||||
( E.SqlExpr (Entity SentMail)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
@ -100,16 +119,24 @@ 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)))
|
||||
, ("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 "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 )
|
||||
, prismAForm (singletonFilter "content" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommContent) -- & setTooltip MsgCommContentSearch)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
dbtIdent :: Text
|
||||
@ -121,17 +148,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
|
||||
@ -150,8 +176,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
|
||||
|
||||
@ -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
|
||||
|
||||
22
src/Mail.hs
22
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,24 @@ 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
|
||||
, 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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user