summaryrefslogtreecommitdiff
path: root/src/Shop/Handler.hs
blob: 6f230405026ab10bbd6aa458acfaf111ca4e1741 (plain)
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