summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFélix Sipma <felix.sipma@no-log.org>2018-02-20 13:20:34 +0100
committerFélix Sipma <felix.sipma@no-log.org>2018-02-20 13:20:34 +0100
commitd5d6f465d38a4275ff03e28593cfb3a2322608fe (patch)
tree4b162ca35cfeb8d4b86de9236f9617818138f49f
parenteecc33687d6fda8caa2a3fa2868a54b1d4e4bd44 (diff)
send emails
-rw-r--r--fournilsipma-server.cabal9
-rw-r--r--package.yaml5
-rw-r--r--src/Shop/Config.hs91
-rw-r--r--src/Shop/Handler.hs97
4 files changed, 174 insertions, 28 deletions
diff --git a/fournilsipma-server.cabal b/fournilsipma-server.cabal
index 7840289..b68c388 100644
--- a/fournilsipma-server.cabal
+++ b/fournilsipma-server.cabal
@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 2f8de900b496f844b545353970a7e39ec571c26efb1443d49690bc42b5ae1199
+-- hash: a4e725fcc04710e03fdfcee0388b60aa60b9f9b660db8d6b38354018ac7b081a
name: fournilsipma-server
version: 0.1.0
@@ -32,10 +32,14 @@ library
src
default-extensions: NoImplicitPrelude
build-depends:
- aeson
+ HaskellNet
+ , HaskellNet-SSL
+ , aeson
, base >=4.7 && <5
+ , boxes
, bytestring
, formatting
+ , mime-mail
, monad-control
, monad-logger
, network
@@ -43,6 +47,7 @@ library
, protolude
, servant
, servant-server
+ , smtp-mail
, text
, uuid
, wai
diff --git a/package.yaml b/package.yaml
index ba98640..2a9bde1 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,8 +23,12 @@ library:
dependencies:
- aeson
- base >=4.7 && <5
+ - boxes
- bytestring
- formatting
+ - HaskellNet
+ - HaskellNet-SSL
+ - mime-mail
- monad-control
- monad-logger
- network
@@ -32,6 +36,7 @@ library:
- protolude
- servant-server
- servant
+ - smtp-mail
- text
- uuid
- wai
diff --git a/src/Shop/Config.hs b/src/Shop/Config.hs
index 7c79e28..1986744 100644
--- a/src/Shop/Config.hs
+++ b/src/Shop/Config.hs
@@ -15,6 +15,7 @@ import System.Environment (lookupEnv, setEnv)
import Path
import Data.ByteString.Char8 (pack)
import GHC.Show (Show(..))
+import Network.Socket (HostName, PortNumber)
data Environment =
@@ -29,44 +30,74 @@ setLogger Development = logStdoutDev
setLogger Production = logStdout
data Config = Config
- { getConfigEnv :: !Environment
- , getConfigHost :: !HostPreference
- , getConfigPort :: !Int
- , getConfigSocket :: !(Maybe FilePath)
- , getConfigUrlPath :: !Text
+ { getConfigEnv :: !Environment
+ , getConfigHost :: !HostPreference
+ , getConfigPort :: !Int
+ , getConfigSocket :: !(Maybe FilePath)
+ , getConfigUrlPath :: !Text
+ , getConfigSMTPServer :: !HostName
+ , getConfigSMTPPort :: !PortNumber
+ , getConfigSMTPUser :: !Text
+ , getConfigSMTPPassword :: !Text
+ , getConfigSMTPFromName :: !(Maybe Text)
+ , getConfigSMTPFromEmail :: !Text
}
data ConfigMonoid = ConfigMonoid
- { configMonoidEnv :: !(Maybe Environment)
- , configMonoidHost :: !(Maybe HostPreference)
- , configMonoidPort :: !(Maybe Int)
- , configMonoidSocket :: !(Maybe FilePath)
- , configMonoidUrlPath :: !(Maybe Text)
+ { configMonoidEnv :: !(Maybe Environment)
+ , configMonoidHost :: !(Maybe HostPreference)
+ , configMonoidPort :: !(Maybe Int)
+ , configMonoidSocket :: !(Maybe FilePath)
+ , configMonoidUrlPath :: !(Maybe Text)
+ , configMonoidSMTPServer :: !(Maybe HostName)
+ , configMonoidSMTPPort :: !(Maybe PortNumber)
+ , configMonoidSMTPUser :: !(Maybe Text)
+ , configMonoidSMTPPassword :: !(Maybe Text)
+ , configMonoidSMTPFromName :: !(Maybe Text)
+ , configMonoidSMTPFromEmail :: !(Maybe Text)
} deriving Show
instance Monoid ConfigMonoid where
mempty = ConfigMonoid
- { configMonoidEnv = Nothing
- , configMonoidHost = Nothing
- , configMonoidPort = Nothing
- , configMonoidSocket = Nothing
- , configMonoidUrlPath = Nothing
+ { configMonoidEnv = Nothing
+ , configMonoidHost = Nothing
+ , configMonoidPort = Nothing
+ , configMonoidSocket = Nothing
+ , configMonoidUrlPath = Nothing
+ , configMonoidSMTPServer = Nothing
+ , configMonoidSMTPPort = Nothing
+ , configMonoidSMTPUser = Nothing
+ , configMonoidSMTPPassword = Nothing
+ , configMonoidSMTPFromName = Nothing
+ , configMonoidSMTPFromEmail = Nothing
}
mappend l r = ConfigMonoid
- { configMonoidEnv = configMonoidEnv l <|> configMonoidEnv r
- , configMonoidHost = configMonoidHost l <|> configMonoidHost r
- , configMonoidPort = configMonoidPort l <|> configMonoidPort r
- , configMonoidSocket = configMonoidSocket l <|> configMonoidSocket r
- , configMonoidUrlPath = configMonoidUrlPath l <|> configMonoidUrlPath r
+ { configMonoidEnv = configMonoidEnv l <|> configMonoidEnv r
+ , configMonoidHost = configMonoidHost l <|> configMonoidHost r
+ , configMonoidPort = configMonoidPort l <|> configMonoidPort r
+ , configMonoidSocket = configMonoidSocket l <|> configMonoidSocket r
+ , configMonoidUrlPath = configMonoidUrlPath l <|> configMonoidUrlPath r
+ , configMonoidSMTPServer = configMonoidSMTPServer l <|> configMonoidSMTPServer r
+ , configMonoidSMTPPort = configMonoidSMTPPort l <|> configMonoidSMTPPort r
+ , configMonoidSMTPUser = configMonoidSMTPUser l <|> configMonoidSMTPUser r
+ , configMonoidSMTPPassword = configMonoidSMTPPassword l <|> configMonoidSMTPPassword r
+ , configMonoidSMTPFromName = configMonoidSMTPFromName l <|> configMonoidSMTPFromName r
+ , configMonoidSMTPFromEmail = configMonoidSMTPFromEmail l <|> configMonoidSMTPFromEmail r
}
configMonoidToConfig :: ConfigMonoid -> Config
configMonoidToConfig c = Config
- { getConfigEnv = fromMaybe Production (configMonoidEnv c)
- , getConfigHost = fromMaybe "127.0.0.1" (configMonoidHost c)
- , getConfigPort = fromMaybe 8080 (configMonoidPort c)
- , getConfigSocket = configMonoidSocket c
+ { getConfigEnv = fromMaybe Production (configMonoidEnv c)
+ , getConfigHost = fromMaybe "127.0.0.1" (configMonoidHost c)
+ , getConfigPort = fromMaybe 8080 (configMonoidPort c)
+ , getConfigSocket = configMonoidSocket c
, getConfigUrlPath = fromMaybe "" (configMonoidUrlPath c)
+ , getConfigSMTPServer = fromMaybe "127.0.0.1" (configMonoidSMTPServer c)
+ , getConfigSMTPPort = fromMaybe 25 (configMonoidSMTPPort c)
+ , getConfigSMTPUser = fromMaybe "" (configMonoidSMTPUser c)
+ , getConfigSMTPPassword = fromMaybe "" (configMonoidSMTPPassword c)
+ , getConfigSMTPFromName = configMonoidSMTPFromName c
+ , getConfigSMTPFromEmail = fromMaybe "" (configMonoidSMTPFromEmail c)
}
getEnvConfig :: IO ConfigMonoid
@@ -76,12 +107,24 @@ getEnvConfig = do
port <- lookupEnv "SHOP_PORT"
socket <- lookupEnv "SHOP_SOCKET"
urlpath <- lookupEnv "SHOP_URLPATH"
+ smtpserver <- lookupEnv "SHOP_SMTP_SERVER"
+ smtpport <- lookupEnv "SHOP_SMTP_PORT"
+ smtpuser <- lookupEnv "SHOP_SMTP_USER"
+ smtppassword <- lookupEnv "SHOP_SMTP_PASSWORD"
+ smtpfromname <- lookupEnv "SHOP_SMTP_FROM_NAME"
+ smtpfromemail <- lookupEnv "SHOP_SMTP_FROM_EMAIL"
return $ mempty
{ configMonoidEnv = readMaybe =<< env
, configMonoidHost = readMaybe =<< host
, configMonoidPort = readMaybe =<< port
, configMonoidSocket = socket
, configMonoidUrlPath = readMaybe =<< urlpath
+ , configMonoidSMTPServer = readMaybe =<< smtpserver
+ , configMonoidSMTPPort = readMaybe =<< smtpport
+ , configMonoidSMTPUser = readMaybe =<< smtpuser
+ , configMonoidSMTPPassword = readMaybe =<< smtppassword
+ , configMonoidSMTPFromName = toS <$> smtpfromname
+ , configMonoidSMTPFromEmail = readMaybe =<< smtpfromemail
}
getConfig :: IO Config
diff --git a/src/Shop/Handler.hs b/src/Shop/Handler.hs
index 0d2f7d5..ab235de 100644
--- a/src/Shop/Handler.hs
+++ b/src/Shop/Handler.hs
@@ -7,16 +7,26 @@
module Shop.Handler where
import Control.Monad.Logger (LoggingT, runStdoutLoggingT,
- logInfo, logWarn)
+ logInfo, logWarn, logError)
+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 Network.HaskellNet.SMTP.SSL (Settings(..), authenticate,
+ defaultSettingsSMTPSTARTTLS,
+ doSMTPSTARTTLSWithSettings)
+import Network.Mail.Mime (Address(..), Mail(..),
+ renderAddress, renderMail')
+import Network.Mail.SMTP (simpleMail, plainTextPart)
+import Network.Socket (HostName, PortNumber)
import Protolude hiding (product, (%))
import Servant (throwError)
import Servant.Server (ServantErr(..), err500, (:~>)(..))
import qualified Servant.Server.Internal.Handler as SH
+import Text.PrettyPrint.Boxes hiding ((<>))
type Handler = LoggingT SH.Handler
@@ -45,8 +55,9 @@ handlerToApp = lift
charge :: ChargeForm -> App ChargeResponse
charge chargeform = do
cfg <- ask
- -- TODO: send email
cid <- liftIO $ UUID.toText <$> UUID.nextRandom
+ sendCustomMail' cfg (chmail cfg cid)
+ sendCustomMail' cfg (comail cfg cid)
$(logInfo) $ "Charge successfully created: \"" <> email chargeform <> "\" (" <> showPrice total <> ")"
return ChargeResponse
{ chargeid = cid
@@ -56,6 +67,88 @@ charge chargeform = do
}
where
total = foldl (\n a -> n + quantity a * prix (product a)) 0 (articles chargeform)
+ comail cfg = confirmationMail
+ (Address (getConfigSMTPFromName cfg) (getConfigSMTPFromEmail cfg))
+ (Address (Just $ name chargeform) (email chargeform))
+ chargeform
+ (showPrice total)
+ chmail cfg = chargeMail
+ (Address (getConfigSMTPFromName cfg) (getConfigSMTPFromEmail cfg))
+ (Address (getConfigSMTPFromName cfg) (getConfigSMTPFromEmail cfg))
+ chargeform
+ (showPrice total)
+ sendCustomMail' cfg = sendCustomMail (getConfigSMTPServer cfg) (getConfigSMTPPort cfg) (getConfigSMTPUser cfg) (getConfigSMTPPassword cfg)
showPrice :: Int -> Text
showPrice p = toS $ format (fixed 2) (fromIntegral p / 100) <> "€"
+
+chargeMail :: Address -> Address -> ChargeForm -> Text -> Text -> Mail
+chargeMail from to chargeform stotal cid = simpleMail
+ from
+ [to]
+ []
+ []
+ ("[fournilsipma] Nouvelle commande de " <> name chargeform <> ": " <> date chargeform <> " (" <> stotal <> ")")
+ [ plainTextPart $ toS $ T.unlines
+ [ "Nom : " <> name chargeform
+ , "Email : " <> email chargeform
+ , "Téléphone : " <> phone chargeform
+ , "Date : " <> date chargeform
+ , "Total : " <> stotal
+ , "Référence de la commande : " <> cid
+ , "Détails :"
+ ]
+ <> details (articles chargeform)
+ ]
+ where
+ 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 ]
+
+confirmationMail :: Address -> Address -> ChargeForm -> Text -> Text -> Mail
+confirmationMail from to chargeform stotal cid = simpleMail
+ from
+ [ to ]
+ []
+ []
+ ("[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!"
+ , ""
+ , "Référence de la commande : " <> cid
+ , ""
+ , "Détails de la commande :"
+ ]
+ <> details (articles chargeform)
+ ]
+ where
+ 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)
+ rowarticle a =
+ [ nom $ product a
+ , show $ quantity a
+ , show (poids $ product a) <> "g"
+ , showPrice $ prix $ product a
+ , showPrice $ prix (product a) * quantity a
+ ]
+
+sendCustomMail :: HostName -> PortNumber -> Text -> Text -> Mail -> App ()
+sendCustomMail server port username password msg = do
+ 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