summaryrefslogtreecommitdiff
path: root/src/Shop/Handler.hs
blob: 5298897be4839905033f16880a2b2e1e56e4b4be (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
{-# 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)