From b7771137a598eb21a068c21fa0caf1cd36062ede Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Oct 2018 17:27:31 +0200 Subject: [PATCH] Monadic construction of mime emails --- config/settings.yml | 4 + package.yaml | 1 + src/Foundation.hs | 6 + src/Import/NoFoundation.hs | 2 + src/Jobs.hs | 36 ++++-- src/Mail.hs | 244 +++++++++++++++++++++++++++++++++++++ src/Model/Types.hs | 10 ++ src/Settings.hs | 13 ++ src/index.md | 10 ++ 9 files changed, 313 insertions(+), 13 deletions(-) create mode 100644 src/Mail.hs diff --git a/config/settings.yml b/config/settings.yml index 46676454e..8c34e8265 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/package.yaml b/package.yaml index 9311ef57d..d620d3fc7 100644 --- a/package.yaml +++ b/package.yaml @@ -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. diff --git a/src/Foundation.hs b/src/Foundation.hs index 6326a8d90..b8b3d2e7e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index bef1d3ac9..e1d2dfe37 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -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 diff --git a/src/Jobs.hs b/src/Jobs.hs index 423411dc3..f9681be10 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Mail.hs b/src/Mail.hs new file mode 100644 index 000000000..1d803d5f6 --- /dev/null +++ b/src/Mail.hs @@ -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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index cc4861626..cd76390cb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index c9fbcd7e3..33de49dcc 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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" diff --git a/src/index.md b/src/index.md index a1c616b17..1a81b627c 100644 --- a/src/index.md +++ b/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