add initial stripe support

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