From 3398b56931cd0ce484e9b23e163650b78e4533cc Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 3 Mar 2018 21:33:59 +0000 Subject: [PATCH] Switch to yesod-auth-account and make the mail code independent of Vervis --- config/models | 11 +- config/settings.yml | 17 +- src/Vervis/Application.hs | 12 +- src/Vervis/Foundation.hs | 93 ++++++++- src/Vervis/Handler/Home.hs | 1 + src/Vervis/Handler/Person.hs | 12 +- src/Vervis/Mail.hs | 99 ---------- src/Vervis/Mail/Types.hs | 23 --- src/Vervis/Migration.hs | 23 ++- src/Vervis/Model.hs | 24 ++- src/Vervis/Settings.hs | 34 +--- src/Yesod/Mail/Send.hs | 214 +++++++++++++++++++++ stack.yaml | 5 + templates/homepage.hamlet | 4 +- templates/person.hamlet | 3 +- templates/person/email/reset-passphrase.md | 4 + templates/person/email/verify-account.md | 4 + vervis.cabal | 5 +- 18 files changed, 398 insertions(+), 190 deletions(-) delete mode 100644 src/Vervis/Mail.hs delete mode 100644 src/Vervis/Mail/Types.hs create mode 100644 src/Yesod/Mail/Send.hs create mode 100644 templates/person/email/reset-passphrase.md create mode 100644 templates/person/email/verify-account.md diff --git a/config/models b/config/models index 6fe05d0..54bb79e 100644 --- a/config/models +++ b/config/models @@ -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 diff --git a/config/settings.yml b/config/settings.yml index d8c4710..24fda87 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 0f98e6b..694cb27 100644 --- a/src/Vervis/Application.hs +++ b/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 - (appConnPool foundation) + mail + -- (appConnPool foundation) (loggingFunction foundation) (readChan queue) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index c448fa1..6255606 100644 --- a/src/Vervis/Foundation.hs +++ b/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 diff --git a/src/Vervis/Handler/Home.hs b/src/Vervis/Handler/Home.hs index 751ba57..7d4e6e2 100644 --- a/src/Vervis/Handler/Home.hs +++ b/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 ((==.)) diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index a5252a3..6401f92 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -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 diff --git a/src/Vervis/Mail.hs b/src/Vervis/Mail.hs deleted file mode 100644 index d7703df..0000000 --- a/src/Vervis/Mail.hs +++ /dev/null @@ -1,99 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2018 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - --- | This modules provides email support for Vervis. It allows handler code to --- send email messages, synchronously (i.e. instantly in the same thread) and --- asynchronously (i.e. pass the work to a separate thread, so that the user --- can have their HTTP response without waiting for the mail to be sent). -module Vervis.Mail - ( sendMail - , submitMail - , runMailer - ) -where - -import Prelude - -import Control.Concurrent.Chan (writeChan) -import Control.Monad (forever) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask) -import Data.Text (Text) -import Database.Persist -import Database.Persist.Sql -import Network.Mail.Mime (Mail, emptyMail) -import Network.Mail.SMTP hiding (sendMail) -import Yesod.Core.Handler (getsYesod) - -import Vervis.Foundation -import Vervis.Mail.Types -import Vervis.Settings - -type Mailer = LoggingT (ReaderT ConnectionPool IO) -type MailerDB = SqlPersistT Mailer - -src :: Text -src = "Mail" - -runMailerDB :: MailerDB a -> Mailer a -runMailerDB action = do - pool <- lift ask - runSqlPool action pool - -formatMessage :: MailMessage -> Mail -formatMessage MailMessage = emptyMail $ Address Nothing "vervis" - -smtp :: SmtpSettings -> Mail -> IO () -smtp (SmtpSettings mlogin host port) = - case mlogin of - Nothing -> sendMail' host port - Just (SmtpLogin user pass) -> sendMailWithLogin' host port user pass - -send :: SmtpSettings -> MailMessage -> IO () -send settings = smtp settings . formatMessage - --- | Send an email message through an SMTP server and return once it's sent. --- Returns 'True' if sent, 'False' if email is disabled in settings. -sendMail :: MailMessage -> Handler Bool -sendMail msg = do - msettings <- getsYesod $ appSmtp . appSettings - case msettings of - Nothing -> return False - Just settings -> liftIO $ send settings msg >> return True - --- | Submit an email message into the queue for delivery through an SMTP --- server, and return without waiting for it to be sent. Returns 'True' if --- submitted, 'False' if email is disabled in settings. -submitMail :: MailMessage -> Handler Bool -submitMail msg = do - mchan <- getsYesod appMailQueue - case mchan of - Nothing -> return False - Just chan -> liftIO $ writeChan chan msg >> return True - --- | Run mailer loop which reads messages from a queue and sends them to SMTP --- server. -runMailer - :: SmtpSettings -- ^ Details of SMTP server - -> ConnectionPool -- ^ DB connection pool for DB access - -> LogFunc -- ^ What to do with log messages - -> IO MailMessage -- ^ IO action that reads a message for sending - -> IO () -runMailer settings pool logFunc readMail = - flip runReaderT pool $ flip runLoggingT logFunc $ do - $logInfoS src "Mailer component starting" - forever $ liftIO $ readMail >>= send settings diff --git a/src/Vervis/Mail/Types.hs b/src/Vervis/Mail/Types.hs deleted file mode 100644 index 95fdd98..0000000 --- a/src/Vervis/Mail/Types.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2018 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - --- | These types were moved here from Vervis.Mail to avoid Vervis.Mail and --- Vervis.Foundation importing each other. -module Vervis.Mail.Types - ( MailMessage (..) - ) -where - -data MailMessage = MailMessage diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 1eb6d60..3b8e07a 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -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 () diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 8f22ac9..1a7ab85 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -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 diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index a4649b3..5d06a4d 100644 --- a/src/Vervis/Settings.hs +++ b/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) - -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 {..} diff --git a/src/Yesod/Mail/Send.hs b/src/Yesod/Mail/Send.hs new file mode 100644 index 0000000..4231b1e --- /dev/null +++ b/src/Yesod/Mail/Send.hs @@ -0,0 +1,214 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | This modules provides email support for 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 diff --git a/stack.yaml b/stack.yaml index 7180303..78e4167 100644 --- a/stack.yaml +++ b/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) diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet index bed5cd5..7feaf81 100644 --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2018 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -18,7 +18,7 @@ $# . fast.

- Sign up + Sign up

Repos diff --git a/templates/person.hamlet b/templates/person.hamlet index b8b708e..160da52 100644 --- a/templates/person.hamlet +++ b/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 $# . -$maybe avatar <- avatarW <$> personEmail person - ^{avatar} +^{avatarW $ personEmail person}
  • diff --git a/templates/person/email/reset-passphrase.md b/templates/person/email/reset-passphrase.md new file mode 100644 index 0000000..fb1ccd4 --- /dev/null +++ b/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}> diff --git a/templates/person/email/verify-account.md b/templates/person/email/verify-account.md new file mode 100644 index 0000000..1373654 --- /dev/null +++ b/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}> diff --git a/vervis.cabal b/vervis.cabal index 0f28b33..25300c4 100644 --- a/vervis.cabal +++ b/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