summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFélix Sipma <felix.sipma@no-log.org>2018-02-27 19:55:33 +0100
committerFélix Sipma <felix.sipma@no-log.org>2018-02-27 19:55:33 +0100
commit1dade9829ff89d8b7613951847d6dbdf2bdab330 (patch)
tree1bbf8e287f0ef3902c19624fae64e8811e0b95cb
parentbd186d69fabf1fd7ece99a85d3ab3379c1f2ea97 (diff)
add html to emails
-rw-r--r--fournilsipma-server.cabal3
-rw-r--r--package.yaml1
-rw-r--r--src/Shop/Handler.hs99
3 files changed, 85 insertions, 18 deletions
diff --git a/fournilsipma-server.cabal b/fournilsipma-server.cabal
index b68c388..1c448a5 100644
--- a/fournilsipma-server.cabal
+++ b/fournilsipma-server.cabal
@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: a4e725fcc04710e03fdfcee0388b60aa60b9f9b660db8d6b38354018ac7b081a
+-- hash: 887fb6444d7b21115e3338b2e175b7ddca7fb44258f2a5f9f82aa3036b50d19a
name: fournilsipma-server
version: 0.1.0
@@ -39,6 +39,7 @@ library
, boxes
, bytestring
, formatting
+ , lucid
, mime-mail
, monad-control
, monad-logger
diff --git a/package.yaml b/package.yaml
index 2a9bde1..b42dcac 100644
--- a/package.yaml
+++ b/package.yaml
@@ -28,6 +28,7 @@ library:
- formatting
- HaskellNet
- HaskellNet-SSL
+ - lucid
- mime-mail
- monad-control
- monad-logger
diff --git a/src/Shop/Handler.hs b/src/Shop/Handler.hs
index b3ef23e..56b4701 100644
--- a/src/Shop/Handler.hs
+++ b/src/Shop/Handler.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -7,20 +8,21 @@
module Shop.Handler where
import Control.Monad.Logger (LoggingT, runStdoutLoggingT,
- logInfo, logWarn, logError)
+ logInfo, logWarn, logError, logDebug)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Formatting (format, (%), fixed)
import Shop.Config
import Shop.Types
-import Network.HaskellNet.SMTP (AuthType(..), sendMail)
+import Lucid
+import Network.HaskellNet.SMTP (AuthType(..), sendMail, closeSMTP)
import Network.HaskellNet.SMTP.SSL (Settings(..), authenticate,
defaultSettingsSMTPSTARTTLS,
- doSMTPSTARTTLSWithSettings)
+ doSMTPSTARTTLSWithSettings, connectSMTPSTARTTLSWithSettings)
import Network.Mail.Mime (Address(..), Mail(..),
renderAddress, renderMail')
-import Network.Mail.SMTP (simpleMail, plainTextPart)
+import Network.Mail.SMTP (simpleMail, plainTextPart, htmlPart)
import Network.Socket (HostName, PortNumber)
import Protolude hiding (product, (%))
import Servant (throwError)
@@ -99,8 +101,40 @@ chargeMail from to chargeform stotal cid = simpleMail
, "Détails :"
]
<> details (articles chargeform)
+ , htmlPart $ renderText $ htmlContent "Fournil Sipma: Nouvelle commande" $ do
+ table_ $
+ tbody_ $ do
+ tr_ $ do
+ td_ "Nom"
+ td_ (toHtml $ name chargeform)
+ tr_ $ do
+ td_ "Email"
+ td_ (toHtml $ email chargeform)
+ tr_ $ do
+ td_ "Téléphone"
+ td_ (toHtml $ phone chargeform)
+ tr_ $ do
+ td_ "Date"
+ td_ (toHtml $ date chargeform)
+ tr_ $ do
+ td_ "Nom"
+ td_ (toHtml stotal)
+ tr_ $ do
+ td_ "Référence de la commande"
+ td_ (toHtml $ UUID.toText cid)
+ div_ "Détails"
+ table_ $ do
+ thead_ $ do
+ th_ "Désignation"
+ th_ "Quantité"
+ tbody_ $ mapM_ rowarticlehtml (articles chargeform)
]
where
+ rowarticlehtml :: Monad m => Article -> HtmlT m ()
+ rowarticlehtml a = tr_ $ do
+ td_ (toHtml $ nom $ product a)
+ td_ (toHtml $ if quantity a == 0 then "" else show $ quantity a)
+
details articles = toS $ render $ hsep 2 left (map (vcat left . map (text . toS)) (transpose rows))
rows = [ "Désignation", "Quantité" ] : map rowarticle (articles chargeform)
rowarticle a = [ nom $ product a, if quantity a == 0 then "" else show $ quantity a ]
@@ -114,6 +148,7 @@ confirmationMail from to chargeform stotal cid = simpleMail
("[fournilsipma] Commande validée: " <> date chargeform <> " (" <> stotal <> ")")
[ plainTextPart $ toS $ T.unlines
[ "Votre commande, d'un montant de " <> stotal <> ", a bien été validée."
+ , ""
, "Pensez à venir la récupérer le " <> date chargeform <> "."
, ""
, "À bientôt!"
@@ -121,14 +156,38 @@ confirmationMail from to chargeform stotal cid = simpleMail
, "Référence de la commande : " <> UUID.toText cid
, ""
, "Détails de la commande :"
+ , ""
]
<> details (articles chargeform)
+ , htmlPart $ renderText $ htmlContent "Fournil Sipma: Commande validée" $ do
+ p_ $ "Votre commande, d'un montant de " <> toHtml stotal <> ", a bien été validée."
+ p_ $ "Pensez à venir la récupérer le " <> toHtml (date chargeform) <> "."
+ p_ "À bientôt!"
+ p_ $ "Référence de la commande : " <> toHtml (UUID.toText cid)
+ p_ "Détails de la commande :"
+ table_ $ do
+ thead_ $ do
+ th_ "Désignation"
+ th_ "Quantité"
+ th_ "Poids"
+ th_ "Prix unitaire"
+ th_ "Total"
+ tbody_ $ mapM_ rowarticlehtml filteredarticles
]
where
+ rowarticlehtml :: Monad m => Article -> HtmlT m ()
+ rowarticlehtml a = tr_ $ do
+ td_ $ toHtml $ nom $ product a
+ td_ $ toHtml (show $ quantity a :: Text)
+ td_ $ toHtml $ show (poids (product a)) <> "g"
+ td_ $ toHtml $ showPrice $ prix $ product a
+ td_ $ toHtml $ showPrice $ prix (product a) * quantity a
+
+ filteredarticles = filter (\a -> quantity a > 0) $ articles chargeform
details articles = toS $ render $ hsep 2 left (map (vcat left . map (text . toS)) (transpose rows))
rows =
[ "Désignation", "Quantité", "Poids", "Prix unitaire", "Total" ]
- : map rowarticle (filter (\a -> quantity a > 0) $ articles chargeform)
+ : map rowarticle filteredarticles
rowarticle a =
[ nom $ product a
, show $ quantity a
@@ -137,18 +196,24 @@ confirmationMail from to chargeform stotal cid = simpleMail
, showPrice $ prix (product a) * quantity a
]
+htmlContent :: Monad m => Text -> HtmlT m a -> HtmlT m a
+htmlContent title content = do
+ doctype_
+ html_ $ do
+ head_ $ do
+ meta_ [ httpEquiv_ "Content-Type", content_ "text/html; charset=UTF-8" ]
+ title_ $ toHtml title
+ body_ content
+
sendCustomMail :: HostName -> PortNumber -> Text -> Text -> Mail -> App ()
sendCustomMail server port username password msg = do
+ $(logDebug) $ "Connecting to SMTP server " <> toS server <> ":" <> show port
rendered <- liftIO $ renderMail' msg
- sendres <- liftIO $ doSMTPSTARTTLSWithSettings server (defaultSettingsSMTPSTARTTLS { sslPort = port }) $ \connection -> do
- authSucceed <- authenticate LOGIN (toS username) (toS password) connection
- if authSucceed
- then do
- sendMail (toS $ renderAddress (mailFrom msg)) (map (toS . renderAddress) (mailTo msg)) (toS rendered) connection
- return SendSuccess
- else return SendAuthenticationError
- case sendres of
- SendSuccess -> $(logInfo) $ "Email successfully sent on " <> toS server
- SendAuthenticationError -> $(logError) $ "SMTP authentication error on " <> toS server
-
-data SendResult = SendSuccess | SendAuthenticationError
+ connection <- liftIO $ connectSMTPSTARTTLSWithSettings server (defaultSettingsSMTPSTARTTLS { sslPort = port })
+ authSucceed <- liftIO $ authenticate LOGIN (toS username) (toS password) connection
+ if authSucceed
+ then do
+ liftIO $ sendMail (toS $ addressEmail (mailFrom msg)) (map (toS . addressEmail) (mailTo msg)) (toS rendered) connection
+ $(logInfo) $ "Email successfully sent on " <> toS server
+ else $(logError) $ "SMTP authentication error on " <> toS server
+ liftIO $ closeSMTP connection