summaryrefslogtreecommitdiff
path: root/src/Shop/Handler.hs
diff options
context:
space:
mode:
authorFélix Sipma <felix.sipma@no-log.org>2018-02-27 19:56:09 +0100
committerFélix Sipma <felix.sipma@no-log.org>2018-02-27 19:56:09 +0100
commitae2cd91c3616a1dcd6147904116b4a502f4d544b (patch)
treebaf18ff502be325951711f75dd4f33a7481dd52e /src/Shop/Handler.hs
parent1dade9829ff89d8b7613951847d6dbdf2bdab330 (diff)
add initial stripe support
Diffstat (limited to 'src/Shop/Handler.hs')
-rw-r--r--src/Shop/Handler.hs53
1 files changed, 34 insertions, 19 deletions
diff --git a/src/Shop/Handler.hs b/src/Shop/Handler.hs
index 56b4701..923a58c 100644
--- a/src/Shop/Handler.hs
+++ b/src/Shop/Handler.hs
@@ -10,8 +10,6 @@ module Shop.Handler where
import Control.Monad.Logger (LoggingT, runStdoutLoggingT,
logInfo, logWarn, logError, logDebug)
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
@@ -24,11 +22,14 @@ import Network.Mail.Mime (Address(..), Mail(..),
renderAddress, renderMail')
import Network.Mail.SMTP (simpleMail, plainTextPart, htmlPart)
import Network.Socket (HostName, PortNumber)
-import Protolude hiding (product, (%))
+import Protolude hiding (MetaData, product, (%))
import Servant (throwError)
import Servant.Server (ServantErr(..), 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
@@ -57,16 +58,30 @@ handlerToApp = lift
charge :: ChargeForm -> App ChargeResponse
charge chargeform = do
cfg <- ask
- cid <- liftIO UUID.nextRandom
- sendCustomMail' cfg (chmail cfg cid)
- sendCustomMail' cfg (comail cfg cid)
- $(logInfo) $ "Charge successfully created: \"" <> email chargeform <> "\" (" <> showPrice total <> ")"
- return ChargeResponse
- { chargeid = UUID.toText cid
- , chargeamount = show total
- , chargeemail = email chargeform
- , chargedate = date chargeform
- }
+ 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
total = foldl (\n a -> n + quantity a * prix (product a)) 0 (articles chargeform)
comail cfg = confirmationMail
@@ -84,7 +99,7 @@ charge chargeform = do
showPrice :: Int -> Text
showPrice p = toS $ format (fixed 2) (fromIntegral p / 100) <> "€"
-chargeMail :: Address -> Address -> ChargeForm -> Text -> UUID.UUID -> Mail
+chargeMail :: Address -> Address -> ChargeForm -> Text -> Text -> Mail
chargeMail from to chargeform stotal cid = simpleMail
from
[to]
@@ -97,7 +112,7 @@ chargeMail from to chargeform stotal cid = simpleMail
, "Téléphone : " <> phone chargeform
, "Date : " <> date chargeform
, "Total : " <> stotal
- , "Référence de la commande : " <> UUID.toText cid
+ , "Référence de la commande : " <> cid
, "Détails :"
]
<> details (articles chargeform)
@@ -121,7 +136,7 @@ chargeMail from to chargeform stotal cid = simpleMail
td_ (toHtml stotal)
tr_ $ do
td_ "Référence de la commande"
- td_ (toHtml $ UUID.toText cid)
+ td_ (toHtml cid)
div_ "Détails"
table_ $ do
thead_ $ do
@@ -139,7 +154,7 @@ chargeMail from to chargeform stotal cid = simpleMail
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 -> UUID.UUID -> Mail
+confirmationMail :: Address -> Address -> ChargeForm -> Text -> Text -> Mail
confirmationMail from to chargeform stotal cid = simpleMail
from
[ to ]
@@ -153,7 +168,7 @@ confirmationMail from to chargeform stotal cid = simpleMail
, ""
, "À bientôt!"
, ""
- , "Référence de la commande : " <> UUID.toText cid
+ , "Référence de la commande : " <> cid
, ""
, "Détails de la commande :"
, ""
@@ -163,7 +178,7 @@ confirmationMail from to chargeform stotal cid = simpleMail
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 (UUID.toText cid)
+ p_ $ "Référence de la commande : " <> toHtml cid
p_ "Détails de la commande :"
table_ $ do
thead_ $ do