send emails

1 files changed, 95 insertions, 2 deletions

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