Monadic construction of mime emails
This commit is contained in:
Gregor Kleen
parent
0df588c267
commit
b7771137a5
@ -8,6 +8,10 @@ host: "_env:HOST:*4" # any IPv4 host
|
||||
port: "_env:PORT:3000"
|
||||
ip-from-header: "_env:IP_FROM_HEADER:false"
|
||||
approot: "_env:APPROOT:http://localhost:3000"
|
||||
mail-from:
|
||||
name: "_env:MAILFROM_NAME:Uni2Work"
|
||||
email: "_env:MAILFROM_EMAIL:uniworx@localhost"
|
||||
mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
|
||||
|
||||
detailed-logging: "_env:DETAILED_LOGGING:false"
|
||||
should-log-all: "_env:LOG_ALL:false"
|
||||
|
||||
@ -99,6 +99,7 @@ dependencies:
|
||||
- HaskellNet-SSL
|
||||
- network
|
||||
- resource-pool
|
||||
- mime-mail
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
|
||||
@ -140,6 +140,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
type DB a = YesodDB UniWorX a
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
type MailM a = MailT (HandlerT UniWorX IO) a
|
||||
|
||||
-- Pattern Synonyms for convenience
|
||||
pattern CSheetR tid ssh csh shn ptn
|
||||
@ -1288,6 +1289,11 @@ unsafeHandler :: UniWorX -> Handler a -> IO a
|
||||
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
||||
|
||||
|
||||
instance YesodMail UniWorX where
|
||||
defaultFromAddress = getsYesod $ appMailFrom . appSettings
|
||||
mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
|
||||
|
||||
|
||||
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
|
||||
type MonadCryptoKey m = CryptoIDKey
|
||||
cryptoIDKey f = getsYesod appCryptoIDKey >>= f
|
||||
|
||||
@ -27,3 +27,5 @@ import Text.Shakespeare.Text as Import hiding (text, stext)
|
||||
import Data.Universe as Import
|
||||
import Data.Pool as Import (Pool)
|
||||
import Network.HaskellNet.SMTP as Import (SMTPConnection)
|
||||
|
||||
import Mail as Import
|
||||
|
||||
36
src/Jobs.hs
36
src/Jobs.hs
@ -24,10 +24,15 @@ import Jobs.Types
|
||||
import Data.Conduit.TMChan
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Data.Text.Lazy as LT
|
||||
|
||||
import Data.Aeson (fromJSON, toJSON)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Database.Persist.Sql (executeQQ, fromSqlKey)
|
||||
|
||||
import Data.Monoid (Last(..))
|
||||
import Control.Monad.Trans.Writer (WriterT(..), execWriterT)
|
||||
|
||||
|
||||
data JobQueueException = JInvalid QueuedJobId QueuedJob
|
||||
| JLocked QueuedJobId InstanceId UTCTime
|
||||
@ -44,26 +49,29 @@ handleJobs :: UniWorX -> IO ()
|
||||
-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
|
||||
handleJobs foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appJobCtl .| handleJobs'
|
||||
where
|
||||
logStart = $(logDebugS) "Jobs" "Started"
|
||||
logStop = $(logDebugS) "Jobs" "Shutting down"
|
||||
logStart = $logDebugS "Jobs" "Started"
|
||||
logStop = $logDebugS "Jobs" "Shutting down"
|
||||
|
||||
handleJobs' :: Sink JobCtl Handler ()
|
||||
handleJobs' = C.mapM_ $ void . handleAny ($(logErrorS) "Jobs" . tshow) . handleCmd
|
||||
handleJobs' = C.mapM_ $ void . handleAny ($logErrorS "Jobs" . tshow) . handleCmd
|
||||
where
|
||||
handleQueueException :: MonadLogger m => JobQueueException -> m ()
|
||||
handleQueueException (JInvalid jId j) = $(logWarnS) "Jobs" $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
|
||||
handleQueueException (JNonexistant jId) = $(logInfoS) "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
|
||||
handleQueueException (JLocked jId lInstance lTime) = $(logDebugS) "Jobs" $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
|
||||
handleQueueException (JInvalid jId j) = $logWarnS "Jobs" $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
|
||||
handleQueueException (JNonexistant jId) = $logInfoS "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
|
||||
handleQueueException (JLocked jId lInstance lTime) = $logDebugS "Jobs" $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
|
||||
|
||||
handleCmd JobCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
|
||||
handleCmd JobCtlFlush = void . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
|
||||
handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \QueuedJob{..} -> do
|
||||
let
|
||||
content :: Job
|
||||
Aeson.Success content = fromJSON queuedJobContent
|
||||
Aeson.Success content = fromJSON queuedJobContent -- `jLocked` ensures that `queuedJobContent` parses
|
||||
|
||||
$(logDebugS) "Jobs" $ "Would do: " <> tshow content -- FIXME
|
||||
$logDebugS "Jobs" . LT.toStrict . decodeUtf8 $ Aeson.encode content
|
||||
|
||||
runDB $ delete jId
|
||||
Last jobDone <- execWriterT $ performJob content
|
||||
|
||||
when (fromMaybe False jobDone) $
|
||||
runDB $ delete jId
|
||||
|
||||
jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
|
||||
jLocked jId act = do
|
||||
@ -93,9 +101,7 @@ jLocked jId act = do
|
||||
, QueuedJobLockTime =. Nothing
|
||||
]
|
||||
|
||||
setSerializable = [executeQQ|
|
||||
SET TRANSACTION ISOLATION LEVEL SERIALIZABLE
|
||||
|]
|
||||
setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|]
|
||||
|
||||
|
||||
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
|
||||
@ -117,3 +123,7 @@ queueJob job = do
|
||||
writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
|
||||
return jId
|
||||
|
||||
|
||||
performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) ()
|
||||
performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do
|
||||
$logDebugS "Jobs" "NotificationSubmissionRated" -- FIXME
|
||||
|
||||
244
src/Mail.hs
Normal file
244
src/Mail.hs
Normal file
@ -0,0 +1,244 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, GeneralizedNewtypeDeriving
|
||||
, DerivingStrategies
|
||||
, FlexibleInstances
|
||||
, MultiParamTypeClasses
|
||||
, UndecidableInstances
|
||||
, DeriveGeneric
|
||||
, TemplateHaskell
|
||||
, OverloadedStrings
|
||||
, RecordWildCards
|
||||
, FlexibleContexts
|
||||
, TypeFamilies
|
||||
#-}
|
||||
|
||||
module Mail
|
||||
( -- * Structured MIME emails
|
||||
module Network.Mail.Mime
|
||||
-- * MailT
|
||||
, MailT, mailT
|
||||
, MonadMail(..)
|
||||
-- * YesodMail
|
||||
, YesodMail(..)
|
||||
-- * Monadically constructing Mail
|
||||
, MonadState(..)
|
||||
, PrioritisedAlternatives
|
||||
, ToMailPart(..)
|
||||
, addAlternatives, provideAlternative, providePreferredAlternative
|
||||
, addPart
|
||||
, MonadHeader(..)
|
||||
, MailHeader
|
||||
, MailObjectId
|
||||
, replaceMailHeader, addMailHeader, removeMailHeader
|
||||
, replaceMailHeaderI, addMailHeaderI
|
||||
, setSubjectI, setMailObjectId, setMailObjectId'
|
||||
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
|
||||
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
|
||||
|
||||
import Network.Mail.Mime hiding (addPart, addAttachment)
|
||||
import qualified Network.Mail.Mime as Mime (addPart)
|
||||
|
||||
import Data.Monoid (Last(..))
|
||||
import Control.Monad.Trans.RWS (RWST(..), execRWST)
|
||||
import Control.Monad.Trans.State (StateT(..), execStateT, State)
|
||||
import Control.Monad.Trans.Writer (execWriter, Writer)
|
||||
import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
|
||||
import Control.Monad.Fail
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
import Data.Sequence (Seq)
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import qualified Data.Foldable as Foldable
|
||||
|
||||
import qualified Data.Text.Lazy as LT
|
||||
|
||||
import Utils.Lens.TH
|
||||
import Control.Lens
|
||||
|
||||
import Text.Blaze.Renderer.Utf8
|
||||
|
||||
import Data.UUID (UUID)
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as UUID
|
||||
import Data.UUID.Cryptographic.ImplicitNamespace
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import GHC.TypeLits (KnownSymbol)
|
||||
|
||||
import Network.BSD (getHostName)
|
||||
|
||||
|
||||
makeLenses_ ''Mail
|
||||
makeLenses_ ''Part
|
||||
|
||||
|
||||
newtype MailT m a = MailT { unMailT :: RWST [Text] () Mail m a }
|
||||
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
|
||||
, MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
|
||||
, MonadState Mail
|
||||
)
|
||||
|
||||
instance (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
|
||||
type MonadCryptoKey (MailT m) = CryptoIDKey
|
||||
cryptoIDKey f = lift (cryptoIDKey return) >>= f
|
||||
|
||||
class MonadHandler m => MonadMail m where
|
||||
mailLanguages :: m [Text]
|
||||
|
||||
instance MonadHandler m => MonadMail (MailT m) where
|
||||
mailLanguages = MailT ask
|
||||
|
||||
getMessageRender :: ( MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
, RenderMessage site msg
|
||||
) => m (msg -> Text)
|
||||
getMessageRender = renderMessage <$> getYesod <*> mailLanguages
|
||||
|
||||
|
||||
class YesodMail site where
|
||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||
defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
|
||||
|
||||
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||
mailObjectIdDomain = pack <$> liftIO getHostName
|
||||
|
||||
mailT :: ( MonadHandler m
|
||||
, YesodMail (HandlerSite m)
|
||||
) => [Text] -- ^ Languages in priority order
|
||||
-> MailT m a
|
||||
-> m Mail
|
||||
mailT ls (MailT mail) = do
|
||||
fromAddress <- defaultFromAddress
|
||||
fst <$> execRWST mail ls (emptyMail fromAddress)
|
||||
|
||||
|
||||
data PrioritisedAlternatives m = PrioritisedAlternatives
|
||||
{ preferredAlternative :: Last (m Part)
|
||||
, otherAlternatives :: Seq (m Part)
|
||||
} deriving (Generic)
|
||||
|
||||
instance Monoid (PrioritisedAlternatives m) where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
class ToMailPart a where
|
||||
toMailPart :: a -> State Part ()
|
||||
|
||||
instance ToMailPart LT.Text where
|
||||
toMailPart text = do
|
||||
_partType .= "text/plain"
|
||||
_partEncoding .= QuotedPrintableText
|
||||
_partContent .= encodeUtf8 text
|
||||
|
||||
instance ToMailPart Text where
|
||||
toMailPart = toMailPart . LT.fromStrict
|
||||
|
||||
instance ToMailPart Html where
|
||||
toMailPart html = do
|
||||
_partType .= "text/html"
|
||||
_partEncoding .= QuotedPrintableText
|
||||
_partContent .= renderMarkup html
|
||||
|
||||
|
||||
addAlternatives :: Monad m
|
||||
=> Writer (PrioritisedAlternatives m) ()
|
||||
-> MailT m ()
|
||||
addAlternatives provided = MailT $ do
|
||||
let PrioritisedAlternatives{..} = execWriter provided
|
||||
alternatives <- lift . sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
|
||||
modify $ Mime.addPart alternatives
|
||||
|
||||
provideAlternative, providePreferredAlternative
|
||||
:: Monad m
|
||||
=> StateT Part m ()
|
||||
-> Writer (PrioritisedAlternatives m) ()
|
||||
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT part initialPart }
|
||||
providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT part initialPart }
|
||||
|
||||
addPart :: Monad m => StateT Part m () -> MailT m ()
|
||||
addPart part = MailT $ do
|
||||
part' <- lift $ execStateT part initialPart
|
||||
modify . Mime.addPart $ pure part'
|
||||
|
||||
initialPart :: Part
|
||||
initialPart = Part
|
||||
{ partType = "text/plain"
|
||||
, partEncoding = None
|
||||
, partFilename = Nothing
|
||||
, partHeaders = []
|
||||
, partContent = mempty
|
||||
}
|
||||
|
||||
|
||||
class MonadHandler m => MonadHeader m where
|
||||
modifyHeaders :: (Headers -> Headers) -> m ()
|
||||
objectIdHeader :: m MailHeader
|
||||
|
||||
instance MonadHandler m => MonadHeader (MailT m) where
|
||||
modifyHeaders f = MailT . modify $ over _mailHeaders f
|
||||
objectIdHeader = return "Message-ID"
|
||||
|
||||
instance MonadHandler m => MonadHeader (StateT Part m) where
|
||||
modifyHeaders f = _partHeaders %= f
|
||||
objectIdHeader = return "Content-ID"
|
||||
|
||||
|
||||
type MailHeader = ByteString
|
||||
type MailObjectId = Text
|
||||
|
||||
|
||||
replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m ()
|
||||
replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC
|
||||
|
||||
addMailHeader :: MonadHeader m => MailHeader -> Text -> m ()
|
||||
addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c)
|
||||
|
||||
removeMailHeader :: MonadHeader m => MailHeader -> m ()
|
||||
removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
|
||||
|
||||
|
||||
replaceMailHeaderI :: ( RenderMessage site msg
|
||||
, MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
, MonadHeader m
|
||||
) => MailHeader -> msg -> m ()
|
||||
replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg
|
||||
|
||||
addMailHeaderI :: ( RenderMessage site msg
|
||||
, MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
, MonadHeader m
|
||||
) => MailHeader -> msg -> m ()
|
||||
addMailHeaderI header msg = addMailHeader header =<< (getMessageRender <*> pure msg)
|
||||
|
||||
|
||||
setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
|
||||
setSubjectI = replaceMailHeaderI "Subject"
|
||||
|
||||
setMailObjectUUID :: (MonadHandler m, YesodMail (HandlerSite m)) => UUID -> MailT m MailObjectId
|
||||
setMailObjectUUID uuid = do
|
||||
domain <- mailObjectIdDomain
|
||||
oidHeader <- objectIdHeader
|
||||
let objectId = UUID.toText uuid <> "@" <> domain
|
||||
replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
|
||||
return objectId
|
||||
|
||||
setMailObjectId :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m MailObjectId
|
||||
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
|
||||
|
||||
setMailObjectId' :: ( MonadHandler m
|
||||
, YesodMail (HandlerSite m)
|
||||
, MonadCrypto m
|
||||
, HasCryptoUUID plain m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, KnownSymbol (CryptoIDNamespace UUID plain)
|
||||
, Binary plain
|
||||
) => plain -> MailT m MailObjectId
|
||||
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
|
||||
@ -442,6 +442,16 @@ derivePersistFieldJSON ''AuthenticationMode
|
||||
|
||||
derivePersistFieldJSON ''Value
|
||||
|
||||
|
||||
data NotificationSettings = NotificationSettings
|
||||
{
|
||||
} deriving (Eq, Ord, Read, Show)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
} ''NotificationSettings
|
||||
derivePersistFieldJSON ''NotificationSettings
|
||||
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
|
||||
@ -51,6 +51,8 @@ import qualified Data.Char as Char
|
||||
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
|
||||
import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
|
||||
|
||||
import Network.Mail.Mime (Address)
|
||||
|
||||
import Model
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
@ -75,6 +77,8 @@ data AppSettings = AppSettings
|
||||
, appIpFromHeader :: Bool
|
||||
-- ^ Get the IP address from the header when logging. Useful when sitting
|
||||
-- behind a reverse proxy.
|
||||
, appMailFrom :: Address
|
||||
, appMailObjectDomain :: Text
|
||||
|
||||
, appDetailedRequestLogging :: Bool
|
||||
-- ^ Use detailed request logging system
|
||||
@ -225,6 +229,12 @@ deriveFromJSON
|
||||
}
|
||||
''SmtpAuthConf
|
||||
|
||||
deriveFromJSON
|
||||
defaultOptions
|
||||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
}
|
||||
''Address
|
||||
|
||||
|
||||
|
||||
instance FromJSON AppSettings where
|
||||
@ -247,6 +257,9 @@ instance FromJSON AppSettings where
|
||||
appPort <- o .: "port"
|
||||
appIpFromHeader <- o .: "ip-from-header"
|
||||
|
||||
appMailFrom <- o .: "mail-from"
|
||||
appMailObjectDomain <- o .: "mail-object-domain"
|
||||
|
||||
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
|
||||
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
|
||||
appMinimumLogLevel <- o .: "minimum-log-level"
|
||||
|
||||
10
src/index.md
10
src/index.md
@ -96,3 +96,13 @@ CryptoID
|
||||
|
||||
Model.Migration
|
||||
: Manuelle Datenbank-Migration
|
||||
|
||||
Jobs
|
||||
: `handleJobs` worker thread handling background jobs
|
||||
`JobQueueException`
|
||||
|
||||
Jobs.Types
|
||||
: `Job`, `Notification`, `JobCtl` Types of Jobs
|
||||
|
||||
Mail
|
||||
: Monadically constructing MIME emails
|
||||
|
||||
Loading…
Reference in New Issue
Block a user