Switch to yesod-auth-account and make the mail code independent of Vervis
This commit is contained in:
fr33domlover
parent
fb47407f2b
commit
3398b56931
18 changed files with 398 additions and 190 deletions
|
|
@ -24,10 +24,13 @@ Sharer
|
|||
UniqueSharer ident
|
||||
|
||||
Person
|
||||
ident SharerId
|
||||
login Text
|
||||
hash Text Maybe
|
||||
email Text Maybe
|
||||
ident SharerId
|
||||
login Text
|
||||
passphraseHash ByteString
|
||||
email Text
|
||||
verified Bool
|
||||
verifiedKey Text
|
||||
resetPassphraseKey Text
|
||||
|
||||
UniquePersonIdent ident
|
||||
UniquePersonLogin login
|
||||
|
|
|
|||
|
|
@ -82,9 +82,14 @@ max-accounts: 3
|
|||
# will be sent. The login field is optional, provide if you need SMTP
|
||||
# authentication.
|
||||
|
||||
# smtp:
|
||||
# login:
|
||||
# user: "_env:SMTPUSER:vervis_dev"
|
||||
# password: "_env:SMTPPASS:vervis_dev_password"
|
||||
# host: "_env:SMTPHOST:localhost"
|
||||
# port: "_env:SMTPPORT:587"
|
||||
# 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(appConnPool foundation)
|
||||
mail
|
||||
-- (appConnPool foundation)
|
||||
(loggingFunction foundation)
|
||||
(readChan queue)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ((==.))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
userPasswordHash = personHash
|
||||
setPasswordHash hash person = person { personHash = Just hash }
|
||||
instance PersistUserCredentials Person where
|
||||
userUsernameF = PersonLogin
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
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")
|
||||
import Yesod.Mail.Send (MailSettings)
|
||||
|
||||
-- | 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
|
||||
-- will be sent.
|
||||
, appSmtp :: Maybe SmtpSettings
|
||||
-- | SMTP server details for sending email, and other email related
|
||||
-- details. If set to 'Nothing', no email will be sent.
|
||||
, 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 {..}
|
||||
|
||||
|
|
|
|||
214
src/Yesod/Mail/Send.hs
Normal file
214
src/Yesod/Mail/Send.hs
Normal 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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
^{avatar}
|
||||
^{avatarW $ personEmail person}
|
||||
|
||||
<ul>
|
||||
<li>
|
||||
|
|
|
|||
4
templates/person/email/reset-passphrase.md
Normal file
4
templates/person/email/reset-passphrase.md
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
Visit the following link to reset your passphrase on the Vervis instance at
|
||||
<@{HomeR}>:
|
||||
|
||||
<#{url}>
|
||||
4
templates/person/email/verify-account.md
Normal file
4
templates/person/email/verify-account.md
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
Visit the following link to verify your account on the Vervis instance at
|
||||
<@{HomeR}>:
|
||||
|
||||
<#{url}>
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue