From d026cf065609ab26f1a8209dd8e924265728c95d Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 6 Mar 2018 02:26:27 +0000 Subject: [PATCH] Treat email address as `EmailAddress` instead of `Text` including in the mailer --- config/models | 2 +- src/Text/Email/Local.hs | 30 ++++++++++++++++++++++++++++++ src/Vervis/Foundation.hs | 6 +++--- src/Vervis/Handler/Person.hs | 2 ++ src/Vervis/Model.hs | 3 +++ src/Yesod/Mail/Send.hs | 30 +++++++++++++++++++++++++----- stack.yaml | 3 ++- templates/person.hamlet | 2 +- vervis.cabal | 3 +++ 9 files changed, 70 insertions(+), 11 deletions(-) create mode 100644 src/Text/Email/Local.hs diff --git a/config/models b/config/models index 54bb79e..a87fdfd 100644 --- a/config/models +++ b/config/models @@ -27,7 +27,7 @@ Person ident SharerId login Text passphraseHash ByteString - email Text + email EmailAddress verified Bool verifiedKey Text resetPassphraseKey Text diff --git a/src/Text/Email/Local.hs b/src/Text/Email/Local.hs new file mode 100644 index 0000000..f56113b --- /dev/null +++ b/src/Text/Email/Local.hs @@ -0,0 +1,30 @@ +{- 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 + - . + -} + +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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 2cffa63..d529299 100644 --- a/src/Vervis/Foundation.hs +++ b/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 ] diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index b44366e..e5d3ca0 100644 --- a/src/Vervis/Handler/Person.hs +++ b/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) diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 1a7ab85..467cb16 100644 --- a/src/Vervis/Model.hs +++ b/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 diff --git a/src/Yesod/Mail/Send.hs b/src/Yesod/Mail/Send.hs index 4231b1e..8ddd65b 100644 --- a/src/Yesod/Mail/Send.hs +++ b/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.SMTP hiding (sendMail) +import Network.Mail.Mime (Mail, simpleMail') +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) = diff --git a/stack.yaml b/stack.yaml index 78e4167..c2b5b7a 100644 --- a/stack.yaml +++ b/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., diff --git a/templates/person.hamlet b/templates/person.hamlet index 9f37bf3..cccf595 100644 --- a/templates/person.hamlet +++ b/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 $# . -^{avatarW secure $ personEmail person} +^{avatarW secure $ emailText $ personEmail person}
  • diff --git a/vervis.cabal b/vervis.cabal index e611f9d..2f88316 100644 --- a/vervis.cabal +++ b/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