Add email sending capability to Vervis

src/Vervis/Application.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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
 

src/Vervis/Foundation.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

src/Vervis/Mail.hs

@@ -0,0 +1,99 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | 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

src/Vervis/Mail/Types.hs

@@ -0,0 +1,23 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | 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

src/Vervis/Settings.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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 {..}
 

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

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