feat(mail): archive all sent mail & better verp
This commit is contained in:
Gregor Kleen
parent
4451ceedf7
commit
1666081fea
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
13
models/mail.model
Normal file
13
models/mail.model
Normal file
@ -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
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ]
|
||||
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
21
src/Jobs/Handler/PruneOldSentMails.hs
Normal file
21
src/Jobs/Handler/PruneOldSentMails.hs
Normal file
@ -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|]
|
||||
@ -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'
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -96,6 +96,7 @@ data Job
|
||||
| JobPruneFallbackPersonalisedSheetFilesKeys
|
||||
| JobRechunkFiles
|
||||
| JobDetectMissingFiles
|
||||
| JobPruneOldSentMails
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification
|
||||
= NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
|
||||
81
src/Mail.hs
81
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
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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{..}
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -233,6 +233,8 @@ makeLenses_ ''Rating'
|
||||
|
||||
makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
|
||||
makeLenses_ ''SentMail
|
||||
|
||||
makePrisms ''AllocationPriority
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
Loading…
Reference in New Issue
Block a user