feat(mail): archive all sent mail & better verp

config/settings.yml

@@ -18,10 +18,10 @@ mail-from:
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
 mail-verp:
   separator:    "_env:VERP_SEPARATOR:+"
-  at-replacement: "_env:VERP_AT_REPLACEMENT:="
 mail-support:
   name:         "_env:MAILSUPPORT_NAME:"
   email:        "_env:MAILSUPPORT:uni2work@ifi.lmu.de"
+mail-retain-sent: 31470547
 
 job-workers:        "_env:JOB_WORKERS:10"
 job-flush-interval: "_env:JOB_FLUSH:30"

models/jobs.model

@@ -17,14 +17,6 @@ CronLastExec
     instance            InstanceId -- Which uni2work-instance did the work
     UniqueCronLastExec job
 
-
-SentNotification
-    content             Value
-    user                UserId
-    time                UTCTime
-    instance            InstanceId
-
-
 TokenBucket
     ident               TokenBucketIdent
     lastValue           Int64

models/mail.model

@@ -0,0 +1,13 @@
+SentMail
+    sentAt       UTCTime
+    sentBy       InstanceId
+    objectId     MailObjectId Maybe
+    bounceSecret BounceSecret Maybe
+    recipient    UserId Maybe
+    headers      MailHeaders
+    contentRef   SentMailContentId
+
+SentMailContent
+    hash    MailContentReference
+    content MailContent
+    Primary hash

src/Application.hs

@@ -182,7 +182,7 @@ makeFoundation appSettings'@AppSettings{..} = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -198,6 +198,7 @@ makeFoundation appSettings'@AppSettings{..} = do
           (error "ClusterID forced in tempFoundation")
           (error "memcached forced in tempFoundation")
           (error "MinioConn forced in tempFoundation")
+          (error "VerpSecret forced in tempFoundation")
 
     runAppLoggingT tempFoundation $ do
       $logInfoS "InstanceID" $ UUID.toText appInstanceID
@@ -241,6 +242,7 @@ makeFoundation appSettings'@AppSettings{..} = do
       appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
       appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
       appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
+      appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool
 
       appMemcached <- for appMemcachedConf $ \memcachedConf -> do
         $logDebugS "setup" "Memcached"
@@ -258,7 +260,7 @@ makeFoundation appSettings'@AppSettings{..} = do
           handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing
         return conn
 
-      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache
+      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret
 
       -- Return the foundation
       $logDebugS "setup" "Done"

src/Foundation/Instances.hs

@@ -39,6 +39,16 @@ import Network.Wai.Parse (lbsBackEnd)
 
 import UnliftIO.Pool (withResource)
 
+import qualified Control.Monad.State.Class as State
+import qualified Crypto.Hash as Crypto
+import qualified Crypto.MAC.KMAC as Crypto
+
+import qualified Data.Binary as Binary
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Database.Esqueleto as E
+
 
 data instance ButtonClass UniWorX
   = BCIsButton
@@ -178,22 +188,97 @@ instance YesodAuthPersist UniWorX where
 instance YesodMail UniWorX where
   defaultFromAddress = getsYesod $ view _appMailFrom
   mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
-  mailVerp = getsYesod $ view _appMailVerp
   mailDateTZ = return appTZ
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
     withResource pool act
-  mailT ctx mail = defMailT ctx $ do
+  mailT ctx mail = do
-    void setMailObjectIdRandom
+    mailRecord <- newEmptyTMVarIO
-    setDateCurrent
+    mailProcess <- allocateLinkedAsync $ do
-    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
+      defMailT ctx $ do
+        void setMailObjectIdRandom
+        sentMailSentAt <- liftIO getCurrentTime
+        setDate sentMailSentAt
+        replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
 
-    (mRes, smtpData) <- listen mail
+        (mRes, smtpData) <- listen mail
-    unless (view _MailSmtpDataSet smtpData)
-      setMailSmtpData
 
-    return mRes
+        sentMailObjectId <- getMailObjectId
+  
+        mContent <- State.get
+  
+        smtpData' <- if | smtpData ^. _MailSmtpDataSet -> return smtpData
+                        | otherwise -> getMailSmtpData
+        verpMode <- getsYesod $ view _appMailVerp
+        (smtpData'', sentMailBounceSecret) <- if
+          | Verp{..} <- verpMode
+          , [_] <- smtpData' ^.. _smtpRecipients . folded
+          , Just [l, d] <- previews (_smtpEnvelopeFrom . _Wrapped . _Just) (Text.splitOn "@") smtpData'
+            -> do
+              verpSecret <- getsYesod appVerpSecret
+              let bounceSecret = BounceSecret . Crypto.kmacGetDigest $ kmaclazy ("bounce" :: ByteString) verpSecret $ Binary.encode mContent
+                  verpAddr = l <> Text.singleton verpSeparator <> toPathPiece bounceSecret <> "@" <> d
+              return ( smtpData' <> mempty { smtpEnvelopeFrom = Last $ Just verpAddr }
+                     , Just bounceSecret
+                     )
+          | otherwise -> return (smtpData', Nothing)
+        tell smtpData''
 
+        sentMailSentBy <- getsYesod appInstanceID
+        let sentMailRecipient = Nothing -- Fill in later
+            sentMailHeaders = MailHeaders $ mconcat
+              [ renderAddressHeader "From" [mailFrom mContent]
+              , fromMaybe [] $ do
+                  toAddrs <- assertM' (not . null) $ mailTo mContent
+                  return $ renderAddressHeader "To" toAddrs
+              , fromMaybe [] $ do
+                  ccAddrs <- assertM' (not . null) $ mailCc mContent
+                  return $ renderAddressHeader "Cc" ccAddrs
+              , fromMaybe [] $ do
+                  bccAddrs <- assertM' (not . null) $ mailBcc mContent
+                  return $ renderAddressHeader "Bcc" bccAddrs
+              , mailHeaders mContent
+              ]
+              where
+                renderAddressHeader :: ByteString -> [Address] -> [(ByteString, Text)]
+                renderAddressHeader lbl = pure . (lbl, ) . Text.intercalate ", " . map renderAddress
+            sentMailContent = MailContent $ mailParts mContent
+            sentMailContentRef = SentMailContentKey . MailContentReference . Crypto.hashlazy $ Binary.encode sentMailContent
+
+        atomically $ putTMVar mailRecord
+          ( smtpData'' ^.. _smtpRecipients . folded
+          , sentMailContent
+          , SentMail{..}
+          )
+        atomically . guardM $ isEmptyTMVar mailRecord
+        return mRes
+
+    (smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord
+    liftHandler . runDB . setSerializable $ do
+      sentMailRecipient <- if
+        | [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do
+            recipUsers <- E.select . E.from $ \user -> do
+              E.where_ $ user E.^. UserDisplayEmail E.==. E.val recipAddr
+                   E.||. user E.^. UserEmail        E.==. E.val recipAddr
+                   E.||. user E.^. UserIdent        E.==. E.val recipAddr
+              return user
+            let recipUserCompare = mconcat
+                  [ comparing $ Down . (== recipAddr) . userIdent . entityVal
+                  , comparing $ Down . (== recipAddr) . userEmail . entityVal
+                  , comparing $ Down . (== recipAddr) . userDisplayEmail . entityVal
+                  ]
+            return $ if
+              | ( bU : us ) <- sortBy recipUserCompare recipUsers
+              , maybe True (\u -> recipUserCompare bU u == LT) $ listToMaybe us
+                -> Just $ entityKey bU
+              | otherwise -> Nothing
+        | otherwise -> return Nothing
+
+      void $ insertUnique SentMailContent{ sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
+                                         , sentMailContentContent
+                                         }
+      insert_ sentMail{ sentMailRecipient }
+      wait mailProcess
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
   type MonadCryptoKey m = CryptoIDKey

src/Foundation/Type.hs

@@ -57,6 +57,7 @@ data UniWorX = UniWorX
     , appHealthReport     :: TVar (Set (UTCTime, HealthReport))
     , appMemcached        :: Maybe (AEAD.Key, Memcached.Connection)
     , appUploadCache      :: Maybe MinioConn
+    , appVerpSecret       :: VerpSecret
     }
 
 makeLenses_ ''UniWorX

src/Handler/Utils/Users.hs

@@ -651,7 +651,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         lift $ update jId [ QueuedJobContent =. toJSON uContent' ]
    in runConduit $ getQueuedJobs .| C.mapM_ updateQueuedJob
 
-  updateWhere [ SentNotificationUser ==. oldUserId ] [ SentNotificationUser =. newUserId ]
+  updateWhere [ SentMailRecipient ==. Just oldUserId ] [ SentMailRecipient =. Just newUserId ]
 
   updateWhere [ SheetEditUser ==. oldUserId] [ SheetEditUser =. newUserId ]
 

src/Import/NoModel.hs

@@ -146,7 +146,7 @@ import Data.Time.Clock.Instances as Import ()
 import Data.Time.LocalTime.Instances as Import ()
 import Data.Time.Calendar.Instances as Import ()
 import Data.Time.Format.Instances as Import ()
-import Network.Mail.Mime.Instances as Import ()
+import Network.Mail.Mime.Instances as Import
 import Yesod.Core.Instances as Import ()
 import Data.Aeson.Types.Instances as Import ()
 import Database.Esqueleto.Instances as Import ()

src/Jobs.hs

@@ -60,6 +60,7 @@ import Jobs.Handler.PruneInvitations
 import Jobs.Handler.ChangeUserDisplayEmail
 import Jobs.Handler.Files
 import Jobs.Handler.PersonalisedSheetFiles
+import Jobs.Handler.PruneOldSentMails
 
 import Jobs.HealthReport
 

src/Jobs/Crontab.hs

@@ -78,6 +78,16 @@ determineCrontab = execWriterT $ do
       , cronNotAfter  = Right CronNotScheduled
       }
 
+  oldestSentMail <- lift $ preview (_head . _entityVal . _sentMailSentAt) <$> selectList [] [Asc SentMailSentAt, LimitTo 1]
+  whenIsJust ((,) <$> appMailRetainSent <*> oldestSentMail) $ \(retain, oldest) -> tell $ HashMap.singleton
+    (JobCtlQueue JobPruneOldSentMails)
+    Cron
+      { cronInitial   = CronTimestamp . utcToLocalTime $ addUTCTime retain oldest
+      , cronRepeat    = CronRepeatOnChange
+      , cronRateLimit = retain / 2
+      , cronNotAfter  = Right CronNotScheduled
+      }
+
 
   whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval ->
     tell $ HashMap.singleton

src/Jobs/Handler/PruneOldSentMails.hs

@@ -0,0 +1,21 @@
+module Jobs.Handler.PruneOldSentMails
+  ( dispatchJobPruneOldSentMails
+  ) where
+
+import Import
+
+import qualified Database.Esqueleto as E
+import Database.Persist.Sql (deleteWhereCount)
+
+
+dispatchJobPruneOldSentMails :: JobHandler UniWorX
+dispatchJobPruneOldSentMails = JobHandlerAtomic $ do
+  retain' <- getsYesod $ view _appMailRetainSent
+  whenIsJust retain' $ \retain -> do
+    now <- liftIO getCurrentTime
+    del <- deleteWhereCount [SentMailSentAt <. addUTCTime (-retain) now]
+    $logInfoS "JobPruneOldSentMails" [st|Deleted #{del} old sent mails|]
+  del <- E.deleteCount . E.from $ \sentMailContent ->
+    E.where_ . E.not_ . E.exists . E.from $ \sentMail ->
+      E.where_ $ sentMail E.^. SentMailContentRef E.==. sentMailContent E.^. SentMailContentId
+  $logInfoS "JobPruneOldSentMails" [st|Deleted #{del} old sent mail bodies|]

src/Jobs/Handler/SendNotification.hs

@@ -23,10 +23,5 @@ import Jobs.Handler.SendNotification.SubmissionEdited
 
 
 dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
-dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do
+dispatchJobSendNotification jRecipient jNotification = JobHandlerException $
   $(dispatchTH ''Notification) jNotification jRecipient
-
-  instanceID' <- getsYesod $ view instanceID
-  now <- liftIO getCurrentTime
-
-  runDB . insert_ $ SentNotification (toJSON jNotification) jRecipient now instanceID'

src/Jobs/HealthReport.hs

@@ -63,6 +63,10 @@ dispatchHealthCheckMatchingClusterConfig
       ourSetting <- getsYesod $ fmap fst . appMemcached
       dbSetting <- clusterSetting @'ClusterMemcachedKey
       return $ maybe True ((== dbSetting) . Just) ourSetting
+    clusterSettingMatches ClusterVerpSecret = do
+      ourSetting <- getsYesod appVerpSecret
+      dbSetting <- clusterSetting @'ClusterVerpSecret
+      return $ Just ourSetting == dbSetting
 
 
     clusterSetting :: forall key.

src/Jobs/Types.hs

@@ -96,6 +96,7 @@ data Job
   | JobPruneFallbackPersonalisedSheetFilesKeys
   | JobRechunkFiles
   | JobDetectMissingFiles
+  | JobPruneOldSentMails
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification
   = NotificationSubmissionRated { nSubmission :: SubmissionId }

src/Mail.hs

@@ -8,13 +8,12 @@ module Mail
     module Network.Mail.Mime
     -- * MailT
   , MailT, defMailT
-  , MailSmtpData(..)
+  , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
   , _MailSmtpDataSet
   , MailContext(..)
   , MonadMail(..)
   , getMailMessageRender, getMailMsgRenderer
     -- * YesodMail
-  , VerpMode(..)
   , YesodMail(..)
   , MailException(..)
     -- * Monadically constructing Mail
@@ -25,12 +24,13 @@ module Mail
   , MonadHeader(..)
   , MailHeader
   , MailObjectId
-  , replaceMailHeader, addMailHeader, removeMailHeader
+  , replaceMailHeader, addMailHeader, removeMailHeader, getMailHeaders, lookupMailHeader
   , replaceMailHeaderI, addMailHeaderI
   , setSubjectI
   , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
+  , getMailObjectId
   , setDate, setDateCurrent
-  , setMailSmtpData
+  , getMailSmtpData
   , _addressName, _addressEmail
   , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
   , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
@@ -62,10 +62,9 @@ import qualified Data.Sequence as Seq
 
 import qualified Data.Set as Set
 
-import qualified Data.Text as Text
-
 import qualified Data.Foldable as Foldable
 
+import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
@@ -123,6 +122,10 @@ import Crypto.Hash.Algorithms (SHAKE128)
 
 import Language.Haskell.TH (nameBase)
 
+import Network.Mail.Mime.Instances()
+
+import Control.Monad.Trans.Writer (execWriterT)
+
 
 makeLenses_ ''Address
 makeLenses_ ''Mail
@@ -152,7 +155,7 @@ instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) =>
 
 data MailSmtpData = MailSmtpData
   { smtpEnvelopeFrom :: Last Text
-  , smtpRecipients :: Set Text
+  , smtpRecipients :: Set Address
   } deriving (Eq, Ord, Show, Read, Generic)
 
 instance Semigroup MailSmtpData where
@@ -188,6 +191,8 @@ instance Default MailContext where
 
 makeLenses_ ''MailContext
 
+makeLenses_ ''MailSmtpData
+
 class (MonadHandler m, MonadState Mail m) => MonadMail m where
   askMailLanguages :: m Languages
   askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
@@ -198,16 +203,6 @@ instance MonadHandler m => MonadMail (MailT m) where
   askMailDateTimeFormat = (view _mcDateTimeFormat ??)
   tellMailSmtpData = tell
 
-data VerpMode = VerpNone
-              | Verp { verpSeparator, verpAtReplacement :: Char }
-  deriving (Eq, Show, Read, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = UntaggedValue
-  } ''VerpMode
-
 getMailMessageRender :: ( MonadMail m
                         , HandlerSite m ~ site
                         , RenderMessage site msg
@@ -248,11 +243,6 @@ class Yesod site => YesodMail site where
               ) => (SMTPConnection -> m a) -> m a
   mailSmtp _ = throwM MailNotAvailable
 
-  mailVerp :: ( MonadHandler m
-              , HandlerSite m ~ site
-              ) => m VerpMode
-  mailVerp = return VerpNone
-
   mailT :: ( MonadHandler m
            , HandlerSite m ~ site
            , MonadUnliftIO m
@@ -304,7 +294,7 @@ defMailT ls (MailT mailC) = do
     MailSmtpData{ smtpRecipients }
       | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
     MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
-                , smtpRecipients = (map unpack . toList -> recipients)
+                , smtpRecipients = (map (unpack . addressEmail) . toList -> recipients)
                 } -> mailSmtp $ \conn -> do
       $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
       liftIO $ SMTP.sendMail
@@ -434,15 +424,17 @@ partIsAttachment (repack -> fName) = modifyPart $ _partDisposition .= Attachment
 
 
 class MonadHandler m => MonadHeader m where
+  stateHeaders :: forall a. (Headers -> (a, Headers)) -> m a
   modifyHeaders :: (Headers -> Headers) -> m ()
+  modifyHeaders f = stateHeaders $ ((), ) . f
   objectIdHeader :: m MailHeader
 
 instance MonadHandler m => MonadHeader (MailT m) where
-  modifyHeaders f = MailT . modify $ over _mailHeaders f
+  stateHeaders = MailT . zoom _mailHeaders . state
   objectIdHeader = return "Message-ID"
 
 instance MonadHandler m => MonadHeader (StateT Part m) where
-  modifyHeaders f = _partHeaders %= f
+  stateHeaders = zoom _partHeaders . state
   objectIdHeader = return "Content-ID"
 
 
@@ -459,6 +451,12 @@ addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (hea
 removeMailHeader :: MonadHeader m => MailHeader -> m ()
 removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
 
+getMailHeaders :: MonadHeader m => MailHeader -> m [Text]
+getMailHeaders header = stateHeaders $ \hdrs -> (, hdrs) . map (view _2) $ filter (views _1 (== header)) hdrs
+
+lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
+lookupMailHeader = fmap listToMaybe . getMailHeaders
+
 
 replaceMailHeaderI :: ( RenderMessage site msg
                       , MonadMail m
@@ -512,6 +510,11 @@ setMailObjectIdPseudorandom obj = do
     seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj
   setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString)
 
+getMailObjectId :: ( MonadHeader m, YesodMail (HandlerSite m) ) => m (Maybe MailObjectId)
+getMailObjectId = fmap (fmap stripBrackets) . lookupMailHeader =<< objectIdHeader
+  where stripBrackets val = fromMaybe val $
+          Text.stripSuffix ">" =<< Text.stripPrefix "<" val
+
 
 setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
 setDateCurrent = setDate =<< liftIO getCurrentTime
@@ -539,27 +542,15 @@ setDate time = do
       ]
 
 
-setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m ()
+getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData
-setMailSmtpData = do
+getMailSmtpData = execWriterT $ do
-  Address _ from <- maybeT (throwM MailNoSenderSpecified) $ asum
+  Address _ from <- lift . maybeT (throwM MailNoSenderSpecified) $ asum
     [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
     , use _mailFrom
     ]
-  recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
+  recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
 
-  tell $ mempty { smtpRecipients = recps }
+  tell $ mempty
-
+    { smtpRecipients = recps
-  verpMode <- mailVerp
+    , smtpEnvelopeFrom = Last $ Just from 
-  if
+    }
-    | Verp{..} <- verpMode
-    , [recp] <- Set.toList recps
-    -> let (user, domain) = Text.breakOn "@" from
-           verp = mconcat
-             [ user
-             , Text.singleton verpSeparator
-             , Text.replace "@" (Text.singleton verpAtReplacement) recp
-             , domain
-             ]
-        in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
-    | otherwise
-    -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }

src/Model/Migration.hs

@@ -176,6 +176,8 @@ migrateManual = do
     , ("submission_edit_submission",          "CREATE INDEX submission_edit_submission ON submission_edit (submission)"                  )
     , ("user_ldap_primary_key",               "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)"                        )
     , ("file_content_entry_chunk_hash",       "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)"        )
+    , ("sent_mail_bounce_secret",             "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL")
+    , ("sent_mail_recipient",                 "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL")
     ]
   where
     addIndex :: Text -> Sql -> Migration

src/Model/Types/Mail.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-|
 Module: Model.Types.Mail
@@ -17,6 +18,18 @@ import qualified Data.Aeson.Types as Aeson
 import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HashMap
 
+import Crypto.Hash (digestFromByteString, SHAKE256)
+import Database.Persist.Sql (PersistFieldSql)
+
+import Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray as BA
+
+import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
+
+import Data.ByteString.Base32
+
+import qualified Data.CaseInsensitive as CI
+
 
 -- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
 --
@@ -85,3 +98,32 @@ instance FromJSON NotificationSettings where
     return . NotificationSettings $ \n -> fromMaybe (notificationAllowed def n) $ HashMap.lookup n o'
 
 derivePersistFieldJSON ''NotificationSettings
+
+
+newtype BounceSecret = BounceSecret (Digest (SHAKE256 128))
+  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+  deriving newtype ( PersistField, PersistFieldSql
+                   , Hashable, NFData
+                   , ByteArrayAccess
+                   )
+
+instance PathPiece BounceSecret where
+  toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
+  fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
+
+newtype MailContent = MailContent [Alternatives]
+  deriving (Eq, Show, Generic, Typeable)
+  deriving newtype (ToJSON, FromJSON)
+  deriving anyclass (Binary)
+
+derivePersistFieldJSON ''MailContent
+
+newtype MailContentReference = MailContentReference (Digest SHA3_512)
+  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+  deriving newtype ( PersistField, PersistFieldSql
+                   , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+                   , Hashable, NFData
+                   , ByteArrayAccess
+                   )
+
+derivePersistFieldJSON ''MailHeaders

src/Network/Mail/Mime/Instances.hs

@@ -1,20 +1,31 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Network.Mail.Mime.Instances
-  (
+  ( MailHeaders(..)
   ) where
 
 import ClassyPrelude
 import Network.Mail.Mime
 
-import Data.Aeson
+import Data.Aeson (FromJSON(..), ToJSON(..))
+import qualified Data.Aeson as Aeson
 import Data.Aeson.TH
 
+import Control.Monad.Fail (MonadFail(..))
+
 import Utils.PathPiece
 
 import Utils (assertM)
 
 import qualified Data.Csv as Csv
+import Data.Binary (Binary)
+
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString as BS
+
+import Data.Text.Encoding (decodeUtf8')
+
+import Control.Lens
 
 
 deriving instance Read Address
@@ -29,9 +40,9 @@ deriveToJSON defaultOptions
   } ''Address
 
 instance FromJSON Address where
-  parseJSON = withObject "Address" $ \obj -> do
+  parseJSON = Aeson.withObject "Address" $ \obj -> do
-    addressName <- assertM (not . null) <$> (obj .:? "name")
+    addressName <- assertM (not . null) <$> (obj Aeson..:? "name")
-    addressEmail <- obj .: "email"
+    addressEmail <- obj Aeson..: "email"
     return Address{..}
 
 
@@ -43,3 +54,68 @@ instance Csv.ToNamedRecord Address where
 
 instance Csv.DefaultOrdered Address where
   headerOrder _ = Csv.header [ "name", "email" ]
+
+  
+newtype MailHeaders = MailHeaders Headers
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance ToJSON MailHeaders where
+  toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs
+instance FromJSON MailHeaders where
+  parseJSON = fmap (MailHeaders . over (traverse . _1) encodeUtf8) . parseJSON
+
+deriving instance Generic Encoding
+deriving instance Generic Disposition
+deriving instance Generic PartContent
+deriving instance Generic Part
+deriving instance Generic Mail
+  
+instance Binary Encoding
+instance Binary Disposition
+instance Binary PartContent
+instance Binary Part
+instance Binary Address
+instance Binary Mail
+  
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''Encoding
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece . dropSuffix "Disposition"
+  } ''Disposition
+
+instance ToJSON PartContent where
+  toJSON (PartContent (toStrict -> content))
+    | BS.all (< 0x80) content
+    , Right content' <- decodeUtf8' content = Aeson.String content'
+  toJSON (PartContent content) = Aeson.object
+    [ "encoding" Aeson..= ("base64" :: String)
+    , "content" Aeson..= decodeUtf8 (Base64.encode $ toStrict content)
+    ]
+  toJSON (NestedParts ps) = toJSON ps
+instance FromJSON PartContent where
+  parseJSON (Aeson.String t) = return . PartContent . fromStrict $ encodeUtf8 t
+  parseJSON (Aeson.Object o) = do
+    encoding <- o Aeson..: "encoding"
+    content <- o Aeson..: "content"
+    if | encoding == "base64" -> either fail (return . PartContent . fromStrict) . Base64.decode $ encodeUtf8 content
+       | otherwise -> fail $ "Unknown encoding: “" <> encoding <> "”"
+  parseJSON v = NestedParts <$> parseJSON v
+
+instance ToJSON Part where
+  toJSON Part{..} = Aeson.object
+    [ "type" Aeson..= partType
+    , "encoding" Aeson..= partEncoding
+    , "disposition" Aeson..= partDisposition
+    , "headers" Aeson..= MailHeaders partHeaders
+    , "content" Aeson..= partContent
+    ]
+instance FromJSON Part where
+  parseJSON = Aeson.withObject "Part" $ \o -> do
+    partType <- o Aeson..: "type"
+    partEncoding <- o Aeson..: "encoding"
+    partDisposition <- o Aeson..: "disposition"
+    MailHeaders partHeaders <- o Aeson..: "headers"
+    partContent <- o Aeson..: "content"
+    return Part{..}

src/Settings.hs

@@ -114,6 +114,7 @@ data AppSettings = AppSettings
     , appMailFrom               :: Address
     , appMailObjectDomain       :: Text
     , appMailVerp               :: VerpMode
+    , appMailRetainSent         :: Maybe NominalDiffTime
     , appMailSupport            :: Address
     , appJobWorkers             :: Natural
     , appJobFlushInterval       :: Maybe NominalDiffTime
@@ -301,6 +302,16 @@ data TokenBucketConf = TokenBucketConf
   , tokenBucketInitialValue :: Int64
   } deriving (Eq, Ord, Show, Generic, Typeable)
 
+data VerpMode = VerpNone
+              | Verp { verpSeparator :: Char }
+  deriving (Eq, Show, Read, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , sumEncoding = UntaggedValue
+  } ''VerpMode
+
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 2
   } ''TokenBucketConf
@@ -451,6 +462,7 @@ instance FromJSON AppSettings where
         appMailFrom               <- o .: "mail-from"
         appMailObjectDomain       <- o .: "mail-object-domain"
         appMailVerp               <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
+        appMailRetainSent         <- o .: "mail-retain-sent"
         appMailSupport            <- o .: "mail-support"
 
         appJobWorkers             <- o .:  "job-workers"

src/Settings/Cluster.hs

@@ -3,6 +3,7 @@
 module Settings.Cluster
   ( ClusterSettingsKey(..)
   , ClusterSetting(..)
+  , VerpSecret(..)
   ) where
 
 import ClassyPrelude.Yesod
@@ -36,6 +37,9 @@ import Control.Monad.Fail
 
 import Model.Types.TH.PathPiece
 
+import Data.ByteArray (ByteArray, ByteArrayAccess)
+import qualified Crypto.Random as Crypto
+
 
 data ClusterSettingsKey
   = ClusterCryptoIDKey
@@ -44,6 +48,7 @@ data ClusterSettingsKey
   | ClusterJSONWebKeySet
   | ClusterId
   | ClusterMemcachedKey
+  | ClusterVerpSecret
   deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
 instance Universe ClusterSettingsKey
@@ -131,3 +136,19 @@ instance ClusterSetting 'ClusterMemcachedKey where
   type ClusterSettingValue 'ClusterMemcachedKey = AEAD.Key
   initClusterSetting _ = liftIO AEAD.newKey
   knownClusterSetting _ = ClusterMemcachedKey
+
+
+newtype VerpSecret = VerpSecret ByteString
+  deriving newtype (Eq, Ord, Monoid, Semigroup, ByteArray, ByteArrayAccess)
+
+instance ToJSON VerpSecret where
+  toJSON (VerpSecret vSecret) = Aeson.String . decodeUtf8 $ Base64.encode vSecret
+instance FromJSON VerpSecret where
+  parseJSON = Aeson.withText "VerpSecret" $ \t -> do
+    bytes <- either fail return . Base64.decode $ encodeUtf8 t
+    return $ VerpSecret bytes
+
+instance ClusterSetting 'ClusterVerpSecret where
+  type ClusterSettingValue 'ClusterVerpSecret = VerpSecret
+  initClusterSetting _ = liftIO $ Crypto.getRandomBytes 32
+  knownClusterSetting _ = ClusterVerpSecret

src/Utils/Lens.hs

@@ -233,6 +233,8 @@ makeLenses_ ''Rating'
 
 makeLenses_ ''FallbackPersonalisedSheetFilesKey
 
+makeLenses_ ''SentMail
+
 makePrisms ''AllocationPriority
 
 -- makeClassy_ ''Load