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

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)
 

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

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 {..}