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

This commit is contained in:
fr33domlover 2018-03-03 21:33:59 +00:00
parent fb47407f2b
commit 3398b56931
18 changed files with 398 additions and 190 deletions

View file

@ -24,10 +24,13 @@ Sharer
UniqueSharer ident UniqueSharer ident
Person Person
ident SharerId ident SharerId
login Text login Text
hash Text Maybe passphraseHash ByteString
email Text Maybe email Text
verified Bool
verifiedKey Text
resetPassphraseKey Text
UniquePersonIdent ident UniquePersonIdent ident
UniquePersonLogin login UniquePersonLogin login

View file

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

View file

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

View file

@ -17,23 +17,27 @@ module Vervis.Foundation where
import Prelude (init, last) import Prelude (init, last)
import Control.Monad.Logger (logWarn)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Database.Persist.Sql (ConnectionPool, runSqlPool) import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Network.Mail.Mime (Address (..))
import Text.Shakespeare.Text (textFile)
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
--import Text.Jasmine (minifym) --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.Auth.Message (AuthMessage (IdentifierNotFound))
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import Yesod.Mail.Send
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
--import qualified Data.CaseInsensitive as CI --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 qualified Data.Text.Encoding as TE
import Text.Jasmine.Local (discardm) import Text.Jasmine.Local (discardm)
import Vervis.Import.NoFoundation hiding (last) import Vervis.Import.NoFoundation hiding (last)
import Vervis.Mail.Types
import Vervis.Model.Group import Vervis.Model.Group
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Role import Vervis.Model.Role
@ -50,7 +54,7 @@ data App = App
, appConnPool :: ConnectionPool -- ^ Database connection pool. , appConnPool :: ConnectionPool -- ^ Database connection pool.
, appHttpManager :: Manager , appHttpManager :: Manager
, appLogger :: Logger , 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 -- 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 instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner appConnPool 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 instance YesodAuth App where
type AuthId App = PersonId type AuthId App = PersonId
@ -349,12 +374,70 @@ instance YesodAuth App where
Just (Entity pid _) -> Authenticated pid Just (Entity pid _) -> Authenticated pid
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authHashDB $ Just . UniquePersonLogin] authPlugins _ = [accountPlugin]
authHttpManager = getHttpManager authHttpManager = getHttpManager
instance YesodAuthPersist App 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 -- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages. -- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where instance RenderMessage App FormMessage where

View file

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

View file

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

View file

@ -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

View file

@ -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

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- 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. - 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.IO.Class (MonadIO)
import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Proxy import Data.Proxy
import Data.Text (Text) import Data.Text (Text)
@ -43,7 +44,25 @@ changes =
(FTPrim $ backendDataType (Proxy :: Proxy Text)) (FTPrim $ backendDataType (Proxy :: Proxy Text))
FieldRequired 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 () migrateDB :: MonadIO m => ReaderT SqlBackend m ()

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- 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. - 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.Quasi
import Database.Persist.Sql (fromSqlKey) import Database.Persist.Sql (fromSqlKey)
import Yesod.Auth.HashDB (HashDBUser (..)) import Yesod.Auth.Account (PersistUserCredentials (..))
import Database.Persist.Local.Class.PersistEntityGraph import Database.Persist.Local.Class.PersistEntityGraph
import Vervis.Model.Group import Vervis.Model.Group
@ -38,9 +38,23 @@ import Vervis.Model.Workflow
share [mkPersist sqlSettings{-, mkMigrate "migrateAll"-}] share [mkPersist sqlSettings{-, mkMigrate "migrateAll"-}]
$(persistFileWith lowerCaseSettings "config/models") $(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' -- "Vervis.Discussion" uses a 'HashMap' where the key type is 'MessageId'
instance Hashable MessageId where instance Hashable MessageId where

View file

@ -34,35 +34,11 @@ import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither') import Data.Yaml (decodeEither')
import Database.Persist.Postgresql (PostgresConf) import Database.Persist.Postgresql (PostgresConf)
import Language.Haskell.TH.Syntax (Exp, Name, Q) import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Socket (HostName, PortNumber)
import Network.Wai.Handler.Warp (HostPreference) import Network.Wai.Handler.Warp (HostPreference)
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
widgetFileReload) 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 -- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files, -- loaded from various sources: defaults, environment variables, config files,
@ -104,9 +80,9 @@ data AppSettings = AppSettings
, appRegister :: Bool , appRegister :: Bool
-- | The maximal number of user accounts that can be registered. -- | The maximal number of user accounts that can be registered.
, appAccounts :: Maybe Int , 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 instance FromJSON AppSettings where
@ -135,7 +111,7 @@ instance FromJSON AppSettings where
appSshKeyFile <- o .: "ssh-key-file" appSshKeyFile <- o .: "ssh-key-file"
appRegister <- o .: "registration" appRegister <- o .: "registration"
appAccounts <- o .: "max-accounts" appAccounts <- o .: "max-accounts"
appSmtp <- o .:? "smtp" appMail <- o .:? "mail"
return AppSettings {..} return AppSettings {..}

214
src/Yesod/Mail/Send.hs Normal file
View file

@ -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

View file

@ -13,6 +13,11 @@ packages:
- '../hit-harder' - '../hit-harder'
- '../hit-network' - '../hit-network'
- '../persistent-migration' - '../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., # Packages to be pulled from upstream that are not in the resolver (e.g.,
# acme-missiles-0.3) # acme-missiles-0.3)

View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# 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. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -18,7 +18,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
fast. fast.
<p> <p>
<a href=@{PersonNewR}>Sign up <a href=@{AuthR newAccountR}>Sign up
<h2>Repos <h2>Repos

View file

@ -12,8 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
$maybe avatar <- avatarW <$> personEmail person ^{avatarW $ personEmail person}
^{avatar}
<ul> <ul>
<li> <li>

View file

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

View file

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

View file

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