1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Shop.Handler where
import Control.Monad.Logger (LoggingT, runStdoutLoggingT,
logInfo, logWarn, logError, logDebug)
import Data.Aeson (Value, encode)
import Data.Default.Class (def)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import Data.UUID.V4 (nextRandom)
import qualified Data.Yaml as Yaml
import Formatting (format, (%), fixed)
import Shop.Config
import Shop.Types
import Lucid
import Network.HaskellNet.SMTP (AuthType(..), sendMail, closeSMTP)
import Network.HaskellNet.SMTP.SSL (Settings(..), authenticate,
defaultSettingsSMTPSTARTTLS,
connectSMTPSTARTTLSWithSettings)
import Network.HTTP.Req
import Network.Mail.Mime (Address(..), Mail(..),
addAttachmentBS, renderAddress,
renderMail')
import Network.Mail.SMTP (simpleMail, plainTextPart, htmlPart)
import Network.Socket (HostName, PortNumber)
import Protolude hiding ((%))
import Servant (throwError)
import Servant.Server (ServantErr(..), err400, err500)
import Servant.Server.Internal.Handler
import Text.PrettyPrint.Boxes hiding ((<>))
type App = ReaderT Config (LoggingT Handler)
appToHandler :: Config -> App a -> Handler a
appToHandler cfg h = runStdoutLoggingT $ runReaderT h cfg
charge :: ChargeForm -> App Text
charge chargeform = do
cfg <- ask
-- TODO: add other validation steps
when (firstname chargeform == "") nameempty
when (lastname chargeform == "") nameempty
when (birthdate chargeform == "") dateempty
when (email chargeform == "") emailempty
when (amount chargeform == 0) amountnull
let a = toS $ showPrice (amount chargeform)
$(logInfo) $ "Form validated: <"
<> email chargeform <> "> (" <> a <> ")"
$(logInfo) $ toS $ encode chargeform
sendSMS $ SMS (getConfigSMSApiUser cfg) (getConfigSMSApiPassword cfg) (toS $ Yaml.encode chargeform)
$(logInfo) $ toS "SMS sent: <"
<> phone chargeform <> "> (" <> a <> ")"
uuid <- liftIO nextRandom
sendCustomMail' cfg (chmail uuid cfg)
$(logInfo) $ toS "Admin email sent: <"
<> email chargeform <> "> (" <> a <> ") " <> toS (UUID.toString uuid)
sendCustomMail' cfg (comail cfg)
$(logInfo) $ toS "Client email sent: <"
<> email chargeform <> "> (" <> a <> ")"
return "Success"
-- ^ TODO: add real client message
where
emailempty = errorempty "email is empty" "Vous devez renseigner une adresse email."
nameempty = errorempty "name is empty" "Vous devez renseigner votre nom."
dateempty = errorempty "date is empty" "Vous devez renseigner votre date de naissance."
amountnull = errorempty "amount is null" "Le montant total de la commande est nul."
errorempty log err = do
$(logWarn) $ "Form validation failed: " <> log
throwError err400 { errBody = toS err }
comail cfg = confirmationMail
(Address (getConfigSMTPFromName cfg) (getConfigSMTPFromEmail cfg))
(Address (Just $ firstname chargeform <> " " <> lastname chargeform) (email chargeform))
chargeform
(showPrice (amount chargeform))
chmail uuid cfg = chargeMail
(Address (getConfigSMTPFromName cfg) (getConfigSMTPFromEmail cfg))
(Address (getConfigSMTPFromName cfg) (getConfigSMTPFromEmail cfg))
chargeform
(showPrice (amount chargeform))
uuid
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 -> UUID.UUID -> Mail
chargeMail from to chargeform stotal uuid = addAttachmentBS
"application/json"
(toS (UUID.toString uuid) <> ".json")
(toS (encode chargeform))
$ simpleMail
from
[to]
[]
[]
("[fermedegouet-api] Nouveau prêt de " <> lastname chargeform <> " (" <> stotal <> ")")
[ plainTextPart $ toS $ T.unlines
[ "Prénom : " <> firstname chargeform
, "Nom : " <> lastname chargeform
, "Date de naissance : " <> birthdate chargeform
, "Lieu de naissance : " <> birthcity chargeform
, "Adresse : " <> address chargeform
, "Code postal : " <> postalcode chargeform
, "Ville : " <> city chargeform
, "Pays : " <> country chargeform
, "Email : " <> email chargeform
, "Téléphone : " <> phone chargeform
, "Montant : " <> stotal
, "Taux : " <> show (rate chargeform)
, "Colis de viande : " <> if meat chargeform then "true" else "false"
, "Message : " <> fromMaybe "" (message chargeform)
]
]
confirmationMail :: Address -> Address -> ChargeForm -> Text -> Mail
confirmationMail from to chargeform stotal = simpleMail
from
[ to ]
[]
[]
("[fermedegouet.fr] Formulaire de prêt validé: (" <> stotal <> ")")
[ plainTextPart $ toS $ T.unlines $ intersperse "" textlines
, htmlPart $ renderText $ htmlContent "Ferme de Gouet: Formulaire de prêt validé." $ mapM (p_ . toHtml) textlines
]
where
textlines =
[ "Votre formulaire de prêt a bien été validé. Pour rappel, le montant que vous avez saisi est " <> stotal <> ", avec un taux d'intérêt de " <> show (rate chargeform) <> "%. Un grand merci !"
, "Je vous recontacterai rapidement pour mettre en place le prêt."
, "À bientôt !"
]
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
$(logDebug) "Email rendered"
connection <- liftIO $ connectSMTPSTARTTLSWithSettings server (defaultSettingsSMTPSTARTTLS { sslPort = port })
$(logDebug) $ "Connected to SMTP server" <> toS server <> ":" <> show port
authSucceed <- liftIO $ authenticate LOGIN (toS username) (toS password) connection
$(logDebug) $ "Authenticated to SMTP server" <> toS server <> ":" <> show port
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 <> " (recipients: <" <> T.intercalate "> ,<" (map (toS . addressEmail) (mailTo msg)) <> ">)"
else $(logError) $ "SMTP authentication error on " <> toS server
liftIO $ closeSMTP connection
instance Semigroup (App a) where
(<>) = mappend
instance Monoid (App a) where
mempty = mempty
a1 `mappend` a2 = do
a1
a2
instance MonadHttp App where
handleHttpException e = do
uuid <- liftIO nextRandom
$(logError) $ toS (displayException e) <> " " <> toS (UUID.toString uuid)
throwError err500 { errBody = "Erreur serveur " <> toS (UUID.toString uuid) }
sendSMS :: SMS -> App ()
sendSMS sms = do
r <- req POST
(https "smsapi.free-mobile.fr" /: "sendmsg")
(ReqBodyJson sms)
bsResponse
mempty
$(logInfo) $ "SMS API response: " <> toS (responseBody r)
|
