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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
module Shop.Handler where
import Control.Monad.Logger (LoggingT, runStdoutLoggingT,
logInfo, logWarn, logError, logDebug)
import qualified Data.Text as T
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,
doSMTPSTARTTLSWithSettings, connectSMTPSTARTTLSWithSettings)
import Network.Mail.Mime (Address(..), Mail(..),
renderAddress, renderMail')
import Network.Mail.SMTP (simpleMail, plainTextPart, htmlPart)
import Network.Socket (HostName, PortNumber)
import Protolude hiding (MetaData, product, (%))
import Servant (throwError)
import Servant.Server (ServantErr(..), err400, err500,
(:~>)(..))
import qualified Servant.Server.Internal.Handler as SH
import Text.PrettyPrint.Boxes hiding ((<>))
import Web.Stripe
import Web.Stripe.Charge
import Web.Stripe.Error (StripeError(..))
type Handler = LoggingT SH.Handler
type App = ReaderT Config Handler
runHandler :: Handler a -> (a -> Handler a) -> (ServantErr -> Handler a) -> Handler a
runHandler ha fa ferr = do
ha' <- liftIO $ runHandlerIO ha
case ha' of
Right a -> fa a
Left err -> ferr err
appToInternalHandler :: Config -> App :~> SH.Handler
appToInternalHandler cfg = NT appHandlerToHandler'
where
appHandlerToHandler' :: App a -> SH.Handler a
appHandlerToHandler' h = runStdoutLoggingT $ runReaderT h cfg
runHandlerIO :: Handler a -> IO (Either ServantErr a)
runHandlerIO = SH.runHandler . runStdoutLoggingT
handlerToApp :: Handler a -> App a
handlerToApp = lift
charge :: ChargeForm -> App ChargeResponse
charge chargeform = do
cfg <- ask
when (tokenid chargeform == TokenId "") tokenempty
when (email chargeform == "") emailempty
when (name chargeform == "") nameempty
when (date chargeform == "") dateempty
when (total == 0) amountnull
result <- liftIO $ stripe (getConfigStripe cfg) $ createCharge (Amount total) EUR
-&- tokenid chargeform
-&- Description (name chargeform <> " <" <> email chargeform <> ">")
-&- MetaData
[ ("phone", phone chargeform)
]
case result of
Right c -> do
let (ChargeId cid) = chargeId c
a = toS $ showPrice (getAmount (chargeAmount c))
$(logInfo) $ "Charge successfully created: <"
<> email chargeform <> "> \""
<> cid <> "\" (" <> a <> ")"
sendCustomMail' cfg (chmail cfg cid)
sendCustomMail' cfg (comail cfg cid)
return ChargeResponse
{ chargeid = cid
, chargeamount = show total
, chargeemail = email chargeform
, chargedate = date chargeform
}
Left stripeerror -> do
$(logWarn) $ "Creating charge failed: \"" <> errorMsg stripeerror <> "\""
throwError err500 { errBody = toS $ errorMsg stripeerror }
where
tokenempty = errorempty "empty Stripe tokenid" "La vérification de la commande a échoué. Merci de recharger la page et de recommencer la commande. Si le problème persiste, merci de contacter l'administrateur du site."
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 une date."
amountnull = errorempty "amount is null" "Le montant total de la commande est nul."
errorempty log err = do
$(logWarn) $ "Creating charge failed: " <> log
throwError err400 { errBody = toS err }
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)
, 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_ "Total"
td_ (toHtml stotal)
tr_ $ do
td_ "Référence de la commande"
td_ (toHtml 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 ]
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)
, 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 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 filteredarticles
rowarticle a =
[ nom $ product a
, show $ quantity a
, show (poids $ product a) <> "g"
, showPrice $ prix $ product a
, 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
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 <> " (recipients: <" <> T.intercalate "> ,<" (map (toS . addressEmail) (mailTo msg)) <> ">)"
else $(logError) $ "SMTP authentication error on " <> toS server
liftIO $ closeSMTP connection
|
