Merged PR 18025: Mail search function implemented

- searching emails
- show course qualification in separate columns

Related work items: #2978, #2979

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

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

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

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

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -122,3 +122,5 @@ TableFilterCommaNameNr: Mehrere Namen oder exakte Nummern mit Komma trennen.
 TableUserEdit: Benutzer bearbeiten
 TableRows: Zeilen
 TableUserParkingToken day@Text: Parkmarke #{day}
+TableFilterSentBefore: Gesendet bis
+TableFilterSentAfter: Gesendet ab

messages/uniworx/utils/table_column/en-eu.msg

@@ -122,3 +122,5 @@ TableFilterCommaNameNr: Separate names and exact numbers by comma.
 TableUserEdit: Edit user
 TableRows: Rows
 TableUserParkingToken day: Parking token #{day}
+TableFilterSentBefore: Sent before
+TableFilterSentAfter: Sent after

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)

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/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)
       ]

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
+    let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidUntilCell cutoff qb qu
-  in  \(view _userCourseQualifications -> qualis) ->
+    in  \(view _userCourseQualifications -> qualis) ->
-        (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell
+          (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

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
@@ -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
+      , dbParamsFormSubmit = FormSubmit
-      , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
+      , dbParamsFormAdditional
-      -- , dbParamsFormSubmit = FormSubmit
+          = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
-      -- , dbParamsFormAdditional
+                acts = mconcat
-      --     = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
+                  [ singletonMap MCActResendEmail $ MCActResendEmailData
-      --           acts = mconcat
+                      <$> areq (emailField & cfStrip & cfCI) (fslI MsgMCActResendEmail & setTooltip MsgMCActResendEmailTooltip) Nothing
-      --             [ singletonMap MCActDummy $ pure MCActDummyData
+                  ]
-      --             ]
+             in renderAForm FormStandard
-      --        in renderAForm FormStandard
+               $  (, mempty) . First . Just
-      --          $  (, mempty) . First . Just
+              <$> multiActionA acts (fslI MsgTableAction) Nothing
-      --         <$> 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
+    (MCActResendEmailData recv, smIds) -> do
-      addMessageI Success MsgBoolIrrelevant
+      resendMailTo recv smIds
+      addMessageI (bool Success Error $ null smIds) $ MsgMCActResendEmailInfo (Set.size smIds) (ciOriginal recv)
       reloadKeepGetParams MailCenterR
   siteLayoutMsg MsgMenuMailCenter $ do
     setTitleI MsgMenuMailCenter

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
+        colChoices  = mconcat $
-          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
+          , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
-          , pure   colUserEmail
+          , colUserEmail
-          , pure $ colUserMatriclenr isAdmin
+          , colUserMatriclenr isAdmin
-          , pure $ colUserQualifications nowaday
+          ] <>
-          , pure $ colUserQualificationBlocked isAdmin nowaday
+          [ colUserQualificationBlocked isAdmin nowaday q | q <- qualifications] <>
-          , pure $ colUserExamOccurrencesCheck tid ssh csh
+          [ colUserExamOccurrencesCheck tid ssh csh
-          , pure $ colUserExams tid ssh csh
+          , colUserExams tid ssh csh
           ]
         psValidator = def
           & defaultSortingByName

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)