From c2d1bb444bbfa7545e12cf7f29f810b54592fb24 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 25 Feb 2018 09:28:55 +0000 Subject: [PATCH] Add email sending capability to Vervis --- src/Vervis/Application.hs | 26 +++++++++- src/Vervis/Foundation.hs | 4 +- src/Vervis/Mail.hs | 99 +++++++++++++++++++++++++++++++++++++++ src/Vervis/Mail/Types.hs | 23 +++++++++ src/Vervis/Settings.hs | 31 +++++++++++- stack.yaml | 8 ++-- vervis.cabal | 5 ++ 7 files changed, 188 insertions(+), 8 deletions(-) create mode 100644 src/Vervis/Mail.hs create mode 100644 src/Vervis/Mail/Types.hs diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index f538c80..0f98e6b 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -65,6 +65,7 @@ import Vervis.Handler.Ticket import Vervis.Handler.Wiki import Vervis.Handler.Workflow +import Vervis.Mail (runMailer) import Vervis.Migration (migrateDB) import Vervis.Ssh (runSsh) @@ -90,6 +91,11 @@ makeFoundation appSettings = do (if appMutableStatic appSettings then staticDevel else static) (appStaticDir appSettings) + appMailQueue <- + case appSmtp appSettings of + Nothing -> return Nothing + Just _ -> Just <$> newChan + -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a @@ -174,6 +180,19 @@ sshServer foundation = (appConnPool foundation) (loggingFunction foundation) +mailer :: App -> IO () +mailer foundation = + case (appSmtp $ appSettings foundation, appMailQueue foundation) of + (Nothing , Nothing) -> return () + (Nothing , Just _) -> error "Mail queue unnecessarily created" + (Just _ , Nothing) -> error "Mail queue wasn't created" + (Just smtp, Just queue) -> + runMailer + smtp + (appConnPool foundation) + (loggingFunction foundation) + (readChan queue) + -- | The @main@ function for an executable running this site. appMain :: IO () appMain = do @@ -192,9 +211,12 @@ appMain = do -- Generate a WAI Application from the foundation app <- makeApplication foundation - -- [experimental] Run SSH server and pray + -- Run SSH server forkIO $ sshServer foundation + -- Run mailer if SMTP is enabled + forkIO $ mailer foundation + -- Run the application with Warp runSettings (warpSettings foundation) app diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index eb4f57a..e7826bd 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -33,6 +33,7 @@ import Data.Text as T (pack, intercalate) import Text.Jasmine.Local (discardm) import Vervis.Import.NoFoundation hiding (last) +import Vervis.Mail.Types import Vervis.Model.Group import Vervis.Model.Ident import Vervis.Model.Role @@ -49,6 +50,7 @@ data App = App , appConnPool :: ConnectionPool -- ^ Database connection pool. , appHttpManager :: Manager , appLogger :: Logger + , appMailQueue :: Maybe (Chan MailMessage) } -- This is where we define all of the routes in our application. For a full diff --git a/src/Vervis/Mail.hs b/src/Vervis/Mail.hs new file mode 100644 index 0000000..d7703df --- /dev/null +++ b/src/Vervis/Mail.hs @@ -0,0 +1,99 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | This modules provides email support for Vervis. It allows handler code to +-- send email messages, synchronously (i.e. instantly in the same thread) and +-- asynchronously (i.e. pass the work to a separate thread, so that the user +-- can have their HTTP response without waiting for the mail to be sent). +module Vervis.Mail + ( sendMail + , submitMail + , runMailer + ) +where + +import Prelude + +import Control.Concurrent.Chan (writeChan) +import Control.Monad (forever) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask) +import Data.Text (Text) +import Database.Persist +import Database.Persist.Sql +import Network.Mail.Mime (Mail, emptyMail) +import Network.Mail.SMTP hiding (sendMail) +import Yesod.Core.Handler (getsYesod) + +import Vervis.Foundation +import Vervis.Mail.Types +import Vervis.Settings + +type Mailer = LoggingT (ReaderT ConnectionPool IO) +type MailerDB = SqlPersistT Mailer + +src :: Text +src = "Mail" + +runMailerDB :: MailerDB a -> Mailer a +runMailerDB action = do + pool <- lift ask + runSqlPool action pool + +formatMessage :: MailMessage -> Mail +formatMessage MailMessage = emptyMail $ Address Nothing "vervis" + +smtp :: SmtpSettings -> Mail -> IO () +smtp (SmtpSettings mlogin host port) = + case mlogin of + Nothing -> sendMail' host port + Just (SmtpLogin user pass) -> sendMailWithLogin' host port user pass + +send :: SmtpSettings -> MailMessage -> IO () +send settings = smtp settings . formatMessage + +-- | Send an email message through an SMTP server and return once it's sent. +-- Returns 'True' if sent, 'False' if email is disabled in settings. +sendMail :: MailMessage -> Handler Bool +sendMail msg = do + msettings <- getsYesod $ appSmtp . appSettings + case msettings of + Nothing -> return False + Just settings -> liftIO $ send settings msg >> return True + +-- | Submit an email message into the queue for delivery through an SMTP +-- server, and return without waiting for it to be sent. Returns 'True' if +-- submitted, 'False' if email is disabled in settings. +submitMail :: MailMessage -> Handler Bool +submitMail msg = do + mchan <- getsYesod appMailQueue + case mchan of + Nothing -> return False + Just chan -> liftIO $ writeChan chan msg >> return True + +-- | Run mailer loop which reads messages from a queue and sends them to SMTP +-- server. +runMailer + :: SmtpSettings -- ^ Details of SMTP server + -> ConnectionPool -- ^ DB connection pool for DB access + -> LogFunc -- ^ What to do with log messages + -> IO MailMessage -- ^ IO action that reads a message for sending + -> IO () +runMailer settings pool logFunc readMail = + flip runReaderT pool $ flip runLoggingT logFunc $ do + $logInfoS src "Mailer component starting" + forever $ liftIO $ readMail >>= send settings diff --git a/src/Vervis/Mail/Types.hs b/src/Vervis/Mail/Types.hs new file mode 100644 index 0000000..95fdd98 --- /dev/null +++ b/src/Vervis/Mail/Types.hs @@ -0,0 +1,23 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | These types were moved here from Vervis.Mail to avoid Vervis.Mail and +-- Vervis.Foundation importing each other. +module Vervis.Mail.Types + ( MailMessage (..) + ) +where + +data MailMessage = MailMessage diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index c92000b..a4649b3 100644 --- a/src/Vervis/Settings.hs +++ b/src/Vervis/Settings.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -34,11 +34,36 @@ import Data.FileEmbed (embedFile) import Data.Yaml (decodeEither') import Database.Persist.Postgresql (PostgresConf) import Language.Haskell.TH.Syntax (Exp, Name, Q) +import Network.Socket (HostName, PortNumber) import Network.Wai.Handler.Warp (HostPreference) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, widgetFileReload) +data SmtpLogin = SmtpLogin + { smtpUser :: String + , smtpPassword :: String + } + +instance FromJSON SmtpLogin where + parseJSON = withObject "SmtpLogin" $ \ o -> + SmtpLogin + <$> o .: "user" + <*> o .: "password" + +data SmtpSettings = SmtpSettings + { smtpLogin :: Maybe SmtpLogin + , smtpHost :: HostName + , smtpPort :: PortNumber + } + +instance FromJSON SmtpSettings where + parseJSON = withObject "SmtpSettings" $ \ o -> + SmtpSettings + <$> o .:? "login" + <*> o .: "host" + <*> (fromInteger <$> o .: "port") + -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, -- theoretically even a database. @@ -79,6 +104,9 @@ data AppSettings = AppSettings , appRegister :: Bool -- | The maximal number of user accounts that can be registered. , appAccounts :: Maybe Int + -- | SMTP server details for sending email. If set to 'Nothing', no email + -- will be sent. + , appSmtp :: Maybe SmtpSettings } instance FromJSON AppSettings where @@ -107,6 +135,7 @@ instance FromJSON AppSettings where appSshKeyFile <- o .: "ssh-key-file" appRegister <- o .: "registration" appAccounts <- o .: "max-accounts" + appSmtp <- o .:? "smtp" return AppSettings {..} diff --git a/stack.yaml b/stack.yaml index 6e70fc8..154094d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,7 +8,7 @@ resolver: lts-6.5 # Local packages, usually specified by relative directory name packages: - '.' - - '../../../other-work/ssh' + - '../ssh' - '../hit-graph' - '../hit-harder' - '../hit-network' @@ -18,9 +18,6 @@ packages: extra-deps: - diagrams-svg-1.4.0.2 - highlighter2-0.2.5 - - hit-graph-0.1 - - hit-harder-0.1 - - hit-network-0.1 - libravatar-0.4 - monad-hash-0.1 # for 'tuple' package, remove once I use lenses instead @@ -28,6 +25,9 @@ extra-deps: - SimpleAES-0.4.2 # for text drawing with 'diagrams' - SVGFonts-1.5.0.1 + - tagged-0.8.5 + - transformers-0.4.3.0 + - transformers-compat-0.5.1.4 # remove once I use lenses instead - tuple-0.3.0.2 # - ssh-0.3.2 diff --git a/vervis.cabal b/vervis.cabal index 78c26ad..c8eff6a 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -145,6 +145,8 @@ library Vervis.Handler.Workflow Vervis.Import Vervis.Import.NoFoundation + Vervis.Mail + Vervis.Mail.Types Vervis.MediaType Vervis.Migration Vervis.Model @@ -262,10 +264,12 @@ library , libravatar -- for converting Darcs patch hash Digest to ByteString , memory + , mime-mail , monad-control , monad-logger -- for Database.Persist.Local , mtl + , network , pandoc , pandoc-types -- for PathPiece instance for CI, Web.PathPieces.Local @@ -278,6 +282,7 @@ library , resourcet , safe , shakespeare + , smtp-mail , ssh -- for rendering diagrams , svg-builder