diff --git a/config/settings.yml b/config/settings.yml index 3b64d7f84..dbe27a59e 100644 --- a/config/settings.yml +++ b/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" diff --git a/models/jobs.model b/models/jobs.model index 7caa80506..4b8cf82f2 100644 --- a/models/jobs.model +++ b/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 diff --git a/models/mail.model b/models/mail.model new file mode 100644 index 000000000..114c37ce9 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 9566dee7a..ad8efdf5d 100644 --- a/src/Application.hs +++ b/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" diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index d1c62eec5..4640f93e4 100644 --- a/src/Foundation/Instances.hs +++ b/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 - void setMailObjectIdRandom - setDateCurrent - replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) + mailT ctx mail = do + mailRecord <- newEmptyTMVarIO + mailProcess <- allocateLinkedAsync $ do + defMailT ctx $ do + void setMailObjectIdRandom + sentMailSentAt <- liftIO getCurrentTime + setDate sentMailSentAt + replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) - (mRes, smtpData) <- listen mail - unless (view _MailSmtpDataSet smtpData) - setMailSmtpData + (mRes, smtpData) <- listen mail - 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 diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 5257f1c35..9ca763f3f 100644 --- a/src/Foundation/Type.hs +++ b/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 diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 2dfe01189..65a7af6c0 100644 --- a/src/Handler/Utils/Users.hs +++ b/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 ] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index d7e28eaa4..c9ca60853 100644 --- a/src/Import/NoModel.hs +++ b/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 () diff --git a/src/Jobs.hs b/src/Jobs.hs index 0068d9184..7b779d0a2 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 59d911bf8..91949d85a 100644 --- a/src/Jobs/Crontab.hs +++ b/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 diff --git a/src/Jobs/Handler/PruneOldSentMails.hs b/src/Jobs/Handler/PruneOldSentMails.hs new file mode 100644 index 000000000..27004c5a6 --- /dev/null +++ b/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|] diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 32e7c71e5..15e6f23d5 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/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' diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index de297d339..b899f2377 100644 --- a/src/Jobs/HealthReport.hs +++ b/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. diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index d98143eb8..a4fce51d6 100644 --- a/src/Jobs/Types.hs +++ b/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 } diff --git a/src/Mail.hs b/src/Mail.hs index 49b743874..bdc19a0e5 100644 --- a/src/Mail.hs +++ b/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 () -setMailSmtpData = do - Address _ from <- maybeT (throwM MailNoSenderSpecified) $ asum +getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData +getMailSmtpData = execWriterT $ do + 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 } - - verpMode <- mailVerp - 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 } + tell $ mempty + { smtpRecipients = recps + , smtpEnvelopeFrom = Last $ Just from + } diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index f38c00af5..3d5a9a710 100644 --- a/src/Model/Migration.hs +++ b/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 diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index dca966dd4..48a2fa67f 100644 --- a/src/Model/Types/Mail.hs +++ b/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 diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index ca2e73f91..841ab9f24 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/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 - addressName <- assertM (not . null) <$> (obj .:? "name") - addressEmail <- obj .: "email" + parseJSON = Aeson.withObject "Address" $ \obj -> do + addressName <- assertM (not . null) <$> (obj Aeson..:? "name") + 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{..} diff --git a/src/Settings.hs b/src/Settings.hs index 4e40ba9a4..b294fd7c6 100644 --- a/src/Settings.hs +++ b/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" diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index d3d197c19..a17fe3598 100644 --- a/src/Settings/Cluster.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index e3d1970ee..3fe3ea604 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -233,6 +233,8 @@ makeLenses_ ''Rating' makeLenses_ ''FallbackPersonalisedSheetFilesKey +makeLenses_ ''SentMail + makePrisms ''AllocationPriority -- makeClassy_ ''Load