Treat email address as EmailAddress instead of Text including in the mailer

config/models

@@ -27,7 +27,7 @@ Person
     ident              SharerId
     login              Text
     passphraseHash     ByteString
-    email              Text
+    email              EmailAddress
     verified           Bool
     verifiedKey        Text
     resetPassphraseKey Text

src/Text/Email/Local.hs

@@ -0,0 +1,30 @@
+{- 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/>.
+ -}
+
+module Text.Email.Local
+    ( emailText
+    )
+where
+
+import Prelude
+
+import Text.Email.Validate
+
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Encoding.Error as TE
+
+emailText :: EmailAddress -> T.Text
+emailText = TE.decodeUtf8With TE.lenientDecode . toByteString

src/Vervis/Foundation.hs

@@ -20,7 +20,6 @@ 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)
@@ -30,6 +29,7 @@ import Yesod.Auth.Message   (AuthMessage (IdentifierNotFound))
 import Yesod.Core.Types     (Logger)
 import Yesod.Default.Util   (addStaticContentExternal)
 
+import Text.Email.Local
 import Yesod.Mail.Send
 
 import qualified Yesod.Core.Unsafe as Unsafe
@@ -423,7 +423,7 @@ instance AccountSendEmail App where
             setMessage $ "Mail sending disabed, please contact admin"
             $logWarn $ T.concat
                 [ "Verification email NOT SENT for user "
-                , uname, " <", email, ">: "
+                , uname, " <", emailText email, ">: "
                 , url
                 ]
     sendNewPasswordEmail uname email url = do
@@ -432,7 +432,7 @@ instance AccountSendEmail App where
             setMessage $ "Mail sending disabed, please contact admin"
             $logWarn $ T.concat
                 ["Password reset email NOT SENT for user "
-                , uname, " <", email, ">: "
+                , uname, " <", emailText email, ">: "
                 , url
                 ]
 

src/Vervis/Handler/Person.hs

@@ -30,6 +30,8 @@ import Vervis.Form.Person
 import Text.Blaze.Html (toHtml)
 import Yesod.Auth.Account (newAccountR)
 
+import Text.Email.Local
+
 import Vervis.Model.Ident
 import Vervis.Secure
 import Vervis.Widget (avatarW)

src/Vervis/Model.hs

@@ -22,9 +22,12 @@ import Yesod hiding (Header, parseTime)
 
 import Database.Persist.Quasi
 import Database.Persist.Sql (fromSqlKey)
+import Text.Email.Validate (EmailAddress)
 import Yesod.Auth.Account (PersistUserCredentials (..))
 
+import Database.Persist.EmailAddress
 import Database.Persist.Local.Class.PersistEntityGraph
+
 import Vervis.Model.Group
 import Vervis.Model.Ident
 import Vervis.Model.Repo

src/Yesod/Mail/Send.hs

@@ -34,6 +34,7 @@ module Yesod.Mail.Send
     ( YesodMailSend (..)
     , MailSettings ()
     , MailRecipe ()
+    , Address (..)
     , sendMail
     , submitMail
     , runMailer
@@ -50,15 +51,20 @@ 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 Data.Text.Encoding (encodeUtf8)
 import Database.Persist.Sql (LogFunc)
-import Network.Mail.Mime (Address (..), Mail, simpleMail')
+import Network.Mail.Mime (Mail, simpleMail')
-import Network.Mail.SMTP hiding (sendMail)
+import Network.Mail.SMTP hiding (Address (..), sendMail)
 import Network.Socket (HostName, PortNumber)
+import Text.Email.Validate (EmailAddress, validate)
 import Text.Shakespeare.Text (TextUrl, renderTextUrl)
 import Yesod.Core (Route, Yesod)
 import Yesod.Core.Handler (HandlerT {-HandlerFor-}, getsYesod, getUrlRenderParams)
 
+import qualified Network.Mail.Mime as M (Address (..))
+
+import Text.Email.Local
+
 type HandlerFor site = HandlerT site IO
 
 class Yesod site => YesodMailSend site where
@@ -105,13 +111,26 @@ instance FromJSON SmtpSettings where
         <*> o .: "host"
         <*> (fromInteger <$> o .: "port")
 
+data EmailAddress' = EmailAddress' { toEmailAddress :: EmailAddress }
+
+instance FromJSON EmailAddress' where
+    parseJSON = withText "EmailAddress" $ \ t ->
+        case validate $ encodeUtf8 t of
+            Left err    -> fail $ "Parsing email address failed: " ++ err
+            Right email -> return $ EmailAddress' email
+
+data Address = Address
+    { addressName  :: Maybe Text
+    , addressEmail :: EmailAddress
+    }
+
 data Address' = Address' { toAddress :: Address }
 
 instance FromJSON Address' where
     parseJSON = withObject "Address" $ \ o -> fmap Address' $
         Address
         <$> o .:? "name"
-        <*> o .: "email"
+        <*> (toEmailAddress <$> o .: "email")
 
 data MailSettings = MailSettings
     { mailSmtp       :: SmtpSettings
@@ -155,7 +174,8 @@ 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
+        conv (Address n e) = M.Address n $ emailText e
+    in  simpleMail' (conv to) (conv from) subject $ renderTextUrl render mkbody
 
 smtp :: SmtpSettings -> Mail -> IO ()
 smtp (SmtpSettings mlogin host port) =

stack.yaml

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

templates/person.hamlet

@@ -12,7 +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/>.
 
-^{avatarW secure $ personEmail person}
+^{avatarW secure $ emailText $ personEmail person}
 
 <ul>
   <li>

vervis.cabal

@@ -89,6 +89,7 @@ library
                        Network.SSH.Local
                        Text.Blaze.Local
                        Text.Display
+                       Text.Email.Local
                        Text.FilePath.Local
                        Text.Jasmine.Local
                        Web.PathPieces.Local
@@ -234,6 +235,7 @@ library
                        -- for Data.Git.Local
                      , directory-tree
                      , dlist
+                     , email-validate
                      , esqueleto
                      , fast-logger
                        -- for building a message tree using DFS in
@@ -272,6 +274,7 @@ library
                        -- for PathPiece instance for CI, Web.PathPieces.Local
                      , path-pieces
                      , persistent
+                     , persistent-email-address
                      , persistent-migration
                      , persistent-postgresql
                      , persistent-template