Switch to yesod-auth-account and make the mail code independent of Vervis

config/models

@@ -26,8 +26,11 @@ Sharer
 Person
     ident              SharerId
     login              Text
-    hash  Text     Maybe
+    passphraseHash     ByteString
-    email Text     Maybe
+    email              Text
+    verified           Bool
+    verifiedKey        Text
+    resetPassphraseKey Text
 
     UniquePersonIdent ident
     UniquePersonLogin login

config/settings.yml

@@ -82,9 +82,14 @@ max-accounts: 3
 # will be sent. The login field is optional, provide if you need SMTP
 # authentication.
 
+# mail:
 #   smtp:
 #     login:
 #       user:     "_env:SMTPUSER:vervis_dev"
 #       password: "_env:SMTPPASS:vervis_dev_password"
 #     host:       "_env:SMTPHOST:localhost"
 #     port:       "_env:SMTPPORT:587"
+#   sender:
+#     name:       "_env:SENDERNAME:vervis"
+#     email:      "_env:SENDEREMAIL:vervis@vervis.vervis"
+#   allow-reply:  false

src/Vervis/Application.hs

@@ -48,6 +48,7 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
 import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
 import Yesod.Default.Main                   (LogFunc)
+import Yesod.Mail.Send (runMailer)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -65,7 +66,6 @@ import Vervis.Handler.Ticket
 import Vervis.Handler.Wiki
 import Vervis.Handler.Workflow
 
-import Vervis.Mail (runMailer)
 import Vervis.Migration (migrateDB)
 import Vervis.Ssh (runSsh)
 
@@ -92,7 +92,7 @@ makeFoundation appSettings = do
         (appStaticDir appSettings)
 
     appMailQueue <-
-        case appSmtp appSettings of
+        case appMail appSettings of
             Nothing -> return Nothing
             Just _  -> Just <$> newChan
 
@@ -182,14 +182,14 @@ sshServer foundation =
 
 mailer :: App -> IO ()
 mailer foundation =
-    case (appSmtp $ appSettings foundation, appMailQueue foundation) of
+    case (appMail $ 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) ->
+        (Just mail, Just queue) ->
             runMailer
-                smtp
+                mail
-                (appConnPool foundation)
+            --  (appConnPool foundation)
                 (loggingFunction foundation)
                 (readChan queue)
 

src/Vervis/Foundation.hs

@@ -17,23 +17,27 @@ module Vervis.Foundation where
 
 import Prelude (init, last)
 
+import Control.Monad.Logger (logWarn)
 import Control.Monad.Trans.Maybe
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
+import Network.Mail.Mime (Address (..))
+import Text.Shakespeare.Text (textFile)
 import Text.Hamlet          (hamletFile)
 --import Text.Jasmine         (minifym)
-import Yesod.Auth.HashDB    (authHashDB)
+import Yesod.Auth.Account
+import Yesod.Auth.Account.Message (AccountMsg (MsgUsernameExists))
 import Yesod.Auth.Message   (AuthMessage (IdentifierNotFound))
 import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
+import Yesod.Mail.Send
 
 import qualified Yesod.Core.Unsafe as Unsafe
 --import qualified Data.CaseInsensitive as CI
-import Data.Text as T (pack, intercalate)
+import Data.Text as T (pack, intercalate, concat)
 --import qualified Data.Text.Encoding as TE
 
 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
@@ -50,7 +54,7 @@ data App = App
     , appConnPool    :: ConnectionPool -- ^ Database connection pool.
     , appHttpManager :: Manager
     , appLogger      :: Logger
-    , appMailQueue   :: Maybe (Chan MailMessage)
+    , appMailQueue   :: Maybe (Chan (MailRecipe App))
     }
 
 -- This is where we define all of the routes in our application. For a full
@@ -331,6 +335,27 @@ instance YesodPersist App where
 instance YesodPersistRunner App where
     getDBRunner = defaultGetDBRunner appConnPool
 
+instance YesodMailSend App where
+    data MailMessage App
+        = MailVerifyAccount Text
+        | MailResetPassphrase Text
+    formatMailMessage _reply _mname msg =
+        case msg of
+            MailVerifyAccount url ->
+                ( "Verify your Vervis account"
+                , $(textFile "templates/person/email/verify-account.md")
+                )
+            MailResetPassphrase url ->
+                ( "Reset your Vervis passphrase"
+                , $(textFile "templates/person/email/reset-passphrase.md")
+                )
+    getMailSettings = getsYesod $ appMail . appSettings
+    getSubmitMail = do
+        mchan <- getsYesod appMailQueue
+        case mchan of
+            Nothing   -> return Nothing
+            Just chan -> return $ Just $ liftIO . writeChan chan
+
 instance YesodAuth App where
     type AuthId App = PersonId
 
@@ -349,12 +374,70 @@ instance YesodAuth App where
             Just (Entity pid _) -> Authenticated pid
 
     -- You can add other plugins like BrowserID, email or OAuth here
-    authPlugins _ = [authHashDB $ Just . UniquePersonLogin]
+    authPlugins _ = [accountPlugin]
 
     authHttpManager = getHttpManager
 
 instance YesodAuthPersist App
 
+newtype AccountPersistDB' a = AccountPersistDB'
+    { unAccountPersistDB' :: Handler a
+    }
+    deriving (Functor, Applicative, Monad, MonadIO)
+
+morphAPDB :: AccountPersistDB App Person a -> AccountPersistDB' a
+morphAPDB = AccountPersistDB' . runAccountPersistDB
+
+instance AccountDB AccountPersistDB' where
+    type UserAccount AccountPersistDB' = Entity Person
+
+    loadUser          = morphAPDB . loadUser
+
+    addNewUser name email key pwd = AccountPersistDB' $ runDB $ do
+        now <- liftIO getCurrentTime
+        let sharer = Sharer
+                { sharerIdent   = text2shr name
+                , sharerName    = Nothing
+                , sharerCreated = now
+                }
+        msid <- insertBy sharer
+        case msid of
+            Left _ -> do
+                mr <- getMessageRender
+                return $ Left $ mr $ MsgUsernameExists name
+            Right sid -> do
+                let person = Person sid name pwd email False key ""
+                pid <- insert person
+                return $ Right $ Entity pid person
+
+    verifyAccount     = morphAPDB . verifyAccount
+    setVerifyKey      = (morphAPDB .) . setVerifyKey
+    setNewPasswordKey = (morphAPDB .) . setNewPasswordKey
+    setNewPassword    = (morphAPDB .) . setNewPassword
+
+instance AccountSendEmail App where
+    sendVerifyEmail uname email url = do
+        sent <- sendMail (Address (Just uname) email) (MailVerifyAccount url)
+        unless sent $ do
+            setMessage $ "Mail sending disabed, please contact admin"
+            $logWarn $ T.concat
+                [ "Verification email NOT SENT for user "
+                , uname, " <", email, ">: "
+                , url
+                ]
+    sendNewPasswordEmail uname email url = do
+        sent <- sendMail (Address (Just uname) email) (MailResetPassphrase url)
+        unless sent $ do
+            setMessage $ "Mail sending disabed, please contact admin"
+            $logWarn $ T.concat
+                ["Password reset email NOT SENT for user "
+                , uname, " <", email, ">: "
+                , url
+                ]
+
+instance YesodAuthAccount AccountPersistDB' App where
+    runAccountDB = unAccountPersistDB'
+
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
 instance RenderMessage App FormMessage where

src/Vervis/Handler/Home.hs

@@ -22,6 +22,7 @@ import Vervis.Import hiding (on)
 
 import Database.Esqueleto hiding ((==.))
 import Vervis.GitOld
+import Yesod.Auth.Account (newAccountR)
 
 import qualified Database.Esqueleto as E ((==.))
 

src/Vervis/Handler/Person.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.
  -
@@ -28,7 +28,7 @@ import Database.Esqueleto hiding (isNothing, count)
 import Vervis.Form.Person
 --import Model
 import Text.Blaze.Html (toHtml)
-import Yesod.Auth.HashDB (setPassword)
+import Yesod.Auth.Account (newAccountR)
 
 import Vervis.Model.Ident
 import Vervis.Widget (avatarW)
@@ -44,7 +44,8 @@ getPeopleR = do
 
 -- | Create new user
 postPeopleR :: Handler Html
-postPeopleR = do
+postPeopleR = redirect $ AuthR newAccountR
+{-
     settings <- getsYesod appSettings
     if appRegister settings
         then do
@@ -88,15 +89,18 @@ postPeopleR = do
         else do
             setMessage "User registration disabled"
             redirect PeopleR
+-}
 
 getPersonNewR :: Handler Html
-getPersonNewR = do
+getPersonNewR = redirect $ AuthR newAccountR
+{-
     regEnabled <- getsYesod $ appRegister . appSettings
     if regEnabled
         then do
             ((_result, widget), enctype) <- runFormPost newPersonForm
             defaultLayout $(widgetFile "person-new")
         else notFound
+-}
 
 getPersonR :: ShrIdent -> Handler Html
 getPersonR ident = do

src/Vervis/Mail.hs

@@ -1,99 +0,0 @@
-{- 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

@@ -1,23 +0,0 @@
-{- 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/Migration.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.
  -
@@ -22,6 +22,7 @@ import Prelude
 
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
+import Data.ByteString (ByteString)
 import Data.Maybe (fromMaybe)
 import Data.Proxy
 import Data.Text (Text)
@@ -43,7 +44,25 @@ changes =
             (FTPrim $ backendDataType (Proxy :: Proxy Text))
             FieldRequired
         )
-    --, lift $ do
+    , changeFieldType "Person" "hash" $
+        backendDataType (Proxy :: Proxy ByteString)
+    , unsetFieldMaybe "Person" "email" "'no@email'"
+    , addField "Person" (Just "TRUE") Field
+        { fieldName  = "verified"
+        , fieldType  = FTPrim $ backendDataType (Proxy :: Proxy Bool)
+        , fieldMaybe = FieldRequired
+        }
+    , addField "Person" (Just "''") Field
+        { fieldName  = "verifiedKey"
+        , fieldType  = FTPrim $ backendDataType (Proxy :: Proxy Text)
+        , fieldMaybe = FieldRequired
+        }
+    , addField "Person" (Just "''") Field
+        { fieldName  = "resetPassphraseKey"
+        , fieldType  = FTPrim $ backendDataType (Proxy :: Proxy Text)
+        , fieldMaybe = FieldRequired
+        }
+    , renameField "Person" "hash" "passphraseHash"
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m ()

src/Vervis/Model.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.
  -
@@ -22,7 +22,7 @@ import Yesod hiding (Header, parseTime)
 
 import Database.Persist.Quasi
 import Database.Persist.Sql (fromSqlKey)
-import Yesod.Auth.HashDB (HashDBUser (..))
+import Yesod.Auth.Account (PersistUserCredentials (..))
 
 import Database.Persist.Local.Class.PersistEntityGraph
 import Vervis.Model.Group
@@ -38,9 +38,23 @@ import Vervis.Model.Workflow
 share [mkPersist sqlSettings{-, mkMigrate "migrateAll"-}]
     $(persistFileWith lowerCaseSettings "config/models")
 
-instance HashDBUser Person where
+instance PersistUserCredentials Person where
-    userPasswordHash = personHash
+    userUsernameF       = PersonLogin
-    setPasswordHash hash person = person { personHash = Just hash }
+    userPasswordHashF   = PersonPassphraseHash
+    userEmailF          = PersonEmail
+    userEmailVerifiedF  = PersonVerified
+    userEmailVerifyKeyF = PersonVerifiedKey
+    userResetPwdKeyF    = PersonResetPassphraseKey
+    uniqueUsername      = UniquePersonLogin
+    -- 'Person' contains a sharer ID, so we can't let yesod-auth-account use
+    -- 'userCreate' to create a new user. Instead, override the default
+    -- implementation, where we can make sure to create a 'Sharer' and then a
+    -- 'Person' that refers to its 'SharerId'.
+    -- userCreate name email key pwd = Person {-?-} name pwd email False key ""
+    userCreate =
+        error
+            "userCreate: addNewUser is supposed to be overridden so that this \
+            \function is never used!"
 
 -- "Vervis.Discussion" uses a 'HashMap' where the key type is 'MessageId'
 instance Hashable MessageId where

src/Vervis/Settings.hs

@@ -34,35 +34,11 @@ 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)
-
+import Yesod.Mail.Send (MailSettings)
-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,
@@ -104,9 +80,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
+      -- | SMTP server details for sending email, and other email related
-      -- will be sent.
+      -- details. If set to 'Nothing', no email will be sent.
-    , appSmtp                   :: Maybe SmtpSettings
+    , appMail                   :: Maybe MailSettings
     }
 
 instance FromJSON AppSettings where
@@ -135,7 +111,7 @@ instance FromJSON AppSettings where
         appSshKeyFile             <- o .: "ssh-key-file"
         appRegister               <- o .: "registration"
         appAccounts               <- o .: "max-accounts"
-        appSmtp                   <- o .:? "smtp"
+        appMail                   <- o .:? "mail"
 
         return AppSettings {..}
 

src/Yesod/Mail/Send.hs

@@ -0,0 +1,214 @@
+{- 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 Yesod apps. 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).
+--
+-- Since the module is based on my own usage, some simple things aren't
+-- provided, but can be trivially provided if someone needs them (or when I get
+-- to the task of adding them regardless, whichever happens first):
+--
+-- * Only plain text email is supported, but HTML email support is trivial to
+--   add if someone needs it
+-- * Only a single recipient is taken per message, but it's trivial to support
+--   taking a list of recipients
+-- * The mail is sent via an SMTP server using the @smtp-mail@ package. However
+--   it's easy to add flexibility to choose some other method. For example
+--   sending via the sendmail executable (package @mime-mail@), or sending via
+--   the Amazon SES server (package @mime-mail-ses@).
+module Yesod.Mail.Send
+    ( YesodMailSend (..)
+    , MailSettings ()
+    , MailRecipe ()
+    , 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.Aeson
+import Data.Text (Text)
+--import Database.Persist
+import Database.Persist.Sql (LogFunc)
+import Network.Mail.Mime (Address (..), Mail, simpleMail')
+import Network.Mail.SMTP hiding (sendMail)
+import Network.Socket (HostName, PortNumber)
+import Text.Shakespeare.Text (TextUrl, renderTextUrl)
+import Yesod.Core (Route, Yesod)
+import Yesod.Core.Handler (HandlerT {-HandlerFor-}, getsYesod, getUrlRenderParams)
+
+type HandlerFor site = HandlerT site IO
+
+class Yesod site => YesodMailSend site where
+
+    -- |
+    data MailMessage site
+
+    -- |
+    formatMailMessage
+        :: Bool
+        -> Maybe Text
+        -> MailMessage site
+        -> (Text, TextUrl (Route site))
+
+    -- |
+    getMailSettings
+        :: HandlerFor site (Maybe MailSettings)
+
+    -- |
+    getSubmitMail
+        :: HandlerFor site (Maybe (MailRecipe site -> HandlerFor site ()))
+
+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")
+
+data Address' = Address' { toAddress :: Address }
+
+instance FromJSON Address' where
+    parseJSON = withObject "Address" $ \ o -> fmap Address' $
+        Address
+        <$> o .:? "name"
+        <*> o .: "email"
+
+data MailSettings = MailSettings
+    { mailSmtp       :: SmtpSettings
+    , mailSender     :: Address
+    , mailAllowReply :: Bool
+    }
+
+instance FromJSON MailSettings where
+    parseJSON = withObject "MailSettings" $ \ o ->
+        MailSettings
+        <$> o .: "smtp"
+        <*> (toAddress <$> o .: "sender")
+        <*> o .: "allow-reply"
+
+-- | This is exported from 'Text.Shakespeare' but the docs there say it's an
+-- internal module that will be hidden on the next release. So I prefer not to
+-- rely on it and define this type here.
+type RenderUrl url = url -> [(Text, Text)] -> Text
+
+data MailRecipe site = MailRecipe
+    { mailUrlRender :: RenderUrl (Route site)
+    , mailRecipient :: Address
+    , mailMessage   :: MailMessage site
+    }
+
+type Mailer = LoggingT IO
+--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
+-}
+
+renderMessage
+    :: YesodMailSend site => Address -> Bool -> MailRecipe site -> Mail
+renderMessage from reply (MailRecipe render to msg) =
+    let (subject, mkbody) = formatMailMessage reply (addressName to) msg
+    in  simpleMail' to from subject $ renderTextUrl render mkbody
+
+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 :: YesodMailSend site => MailSettings -> MailRecipe site -> IO ()
+send (MailSettings s a r) = smtp s . renderMessage a r
+
+-- | 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
+    :: YesodMailSend site
+    => Address
+    -> MailMessage site
+    -> HandlerFor site Bool
+sendMail recip msg = do
+    msettings <- getMailSettings
+    case msettings of
+        Nothing       -> return False
+        Just settings -> do
+            urp <- getUrlRenderParams
+            let recipe = MailRecipe urp recip msg
+            liftIO $ send settings recipe >> 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
+    :: YesodMailSend site
+    => Address
+    -> MailMessage site
+    -> HandlerFor site Bool
+submitMail recip msg = do
+    msubmit <- getSubmitMail
+    case msubmit of
+        Nothing     -> return False
+        Just submit -> do
+            urp <- getUrlRenderParams
+            let recipe = MailRecipe urp recip msg
+            submit recipe >> return True
+
+-- | Run mailer loop which reads messages from a queue and sends them to SMTP
+-- server.
+runMailer
+    :: YesodMailSend site
+    => MailSettings         -- ^ Details of SMTP server and email formatting
+--  -> ConnectionPool       -- ^ DB connection pool for DB access
+    -> LogFunc              -- ^ What to do with log messages
+    -> IO (MailRecipe site) -- ^ 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

stack.yaml

@@ -13,6 +13,11 @@ packages:
   - '../hit-harder'
   - '../hit-network'
   - '../persistent-migration'
+# - '../yesod-auth-account'
+  - location:
+     git: https://dev.seek-together.space/s/fr33domlover/r/yesod-auth-account
+     commit: 75cc90c910d6c897b623392608f6a4ad3f0b8f09
+    extra-dep: true
 
 # Packages to be pulled from upstream that are not in the resolver (e.g.,
 # acme-missiles-0.3)

templates/homepage.hamlet

@@ -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.
 $#
@@ -18,7 +18,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   fast.
 
 <p>
-  <a href=@{PersonNewR}>Sign up
+  <a href=@{AuthR newAccountR}>Sign up
 
 <h2>Repos
 

templates/person.hamlet

@@ -12,8 +12,7 @@ $# 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/>.
 
-$maybe avatar <- avatarW <$> personEmail person
+^{avatarW $ personEmail person}
-  ^{avatar}
 
 <ul>
   <li>

templates/person/email/reset-passphrase.md

@@ -0,0 +1,4 @@
+Visit the following link to reset your passphrase on the Vervis instance at
+<@{HomeR}>:
+
+<#{url}>

templates/person/email/verify-account.md

@@ -0,0 +1,4 @@
+Visit the following link to verify your account on the Vervis instance at
+<@{HomeR}>:
+
+<#{url}>

vervis.cabal

@@ -93,6 +93,7 @@ library
                        Text.Jasmine.Local
                        Web.PathPieces.Local
                        Yesod.Paginate.Local
+                       Yesod.Mail.Send
 
                        Vervis.Application
                        Vervis.Avatar
@@ -142,8 +143,6 @@ library
                        Vervis.Handler.Workflow
                        Vervis.Import
                        Vervis.Import.NoFoundation
-                       Vervis.Mail
-                       Vervis.Mail.Types
                        Vervis.MediaType
                        Vervis.Migration
                        Vervis.Model
@@ -301,7 +300,7 @@ library
                      , yaml
                      , yesod
                      , yesod-auth
-                     , yesod-auth-hashdb
+                     , yesod-auth-account
                      , yesod-core
                      , yesod-form
                      , yesod-static