summaryrefslogtreecommitdiff
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
parent1dade9829ff89d8b7613951847d6dbdf2bdab330 (diff)
add initial stripe support
-rw-r--r--fournilsipma-server.cabal4
-rw-r--r--package.yaml2
-rw-r--r--src/Shop/Config.hs52
-rw-r--r--src/Shop/Handler.hs53
-rw-r--r--src/Shop/Types.hs13
5 files changed, 84 insertions, 40 deletions
diff --git a/fournilsipma-server.cabal b/fournilsipma-server.cabal
index 1c448a5..cd3a602 100644
--- a/fournilsipma-server.cabal
+++ b/fournilsipma-server.cabal
@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 887fb6444d7b21115e3338b2e175b7ddca7fb44258f2a5f9f82aa3036b50d19a
+-- hash: 9db70464a79256d67e19c7dd4ca09395cde41b1c3f99368127e2606053a66310
name: fournilsipma-server
version: 0.1.0
@@ -49,6 +49,8 @@ library
, servant
, servant-server
, smtp-mail
+ , stripe-core
+ , stripe-haskell
, text
, uuid
, wai
diff --git a/package.yaml b/package.yaml
index b42dcac..79bf400 100644
--- a/package.yaml
+++ b/package.yaml
@@ -38,6 +38,8 @@ library:
- servant-server
- servant
- smtp-mail
+ - stripe-core
+ - stripe-haskell
- text
- uuid
- wai
diff --git a/src/Shop/Config.hs b/src/Shop/Config.hs
index 1986744..88d67bb 100644
--- a/src/Shop/Config.hs
+++ b/src/Shop/Config.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Shop.Config where
-import Protolude
+import Protolude hiding (show)
import Control.Monad.Logger (MonadLogger,
runNoLoggingT,
runStdoutLoggingT)
@@ -16,8 +16,18 @@ import Path
import Data.ByteString.Char8 (pack)
import GHC.Show (Show(..))
import Network.Socket (HostName, PortNumber)
+import Web.Stripe (StripeConfig(..),
+ StripeKey(..))
+data StripeKeyEnvError = StripeKeyEnvError
+
+instance Show StripeKeyEnvError where
+ show StripeKeyEnvError = "SHOP_STRIPEKEY required"
+-- ^ TODO: replace by displayException
+
+instance Exception StripeKeyEnvError
+
data Environment =
Development
| Test
@@ -34,13 +44,13 @@ data Config = Config
, getConfigHost :: !HostPreference
, getConfigPort :: !Int
, getConfigSocket :: !(Maybe FilePath)
- , getConfigUrlPath :: !Text
, getConfigSMTPServer :: !HostName
, getConfigSMTPPort :: !PortNumber
, getConfigSMTPUser :: !Text
, getConfigSMTPPassword :: !Text
, getConfigSMTPFromName :: !(Maybe Text)
, getConfigSMTPFromEmail :: !Text
+ , getConfigStripe :: !StripeConfig
}
data ConfigMonoid = ConfigMonoid
@@ -48,13 +58,13 @@ data ConfigMonoid = ConfigMonoid
, configMonoidHost :: !(Maybe HostPreference)
, configMonoidPort :: !(Maybe Int)
, configMonoidSocket :: !(Maybe FilePath)
- , configMonoidUrlPath :: !(Maybe Text)
, configMonoidSMTPServer :: !(Maybe HostName)
, configMonoidSMTPPort :: !(Maybe PortNumber)
, configMonoidSMTPUser :: !(Maybe Text)
, configMonoidSMTPPassword :: !(Maybe Text)
, configMonoidSMTPFromName :: !(Maybe Text)
, configMonoidSMTPFromEmail :: !(Maybe Text)
+ , configMonoidStripeKey :: !(Maybe StripeKey)
} deriving Show
instance Monoid ConfigMonoid where
@@ -63,26 +73,26 @@ instance Monoid ConfigMonoid where
, configMonoidHost = Nothing
, configMonoidPort = Nothing
, configMonoidSocket = Nothing
- , configMonoidUrlPath = Nothing
, configMonoidSMTPServer = Nothing
, configMonoidSMTPPort = Nothing
, configMonoidSMTPUser = Nothing
, configMonoidSMTPPassword = Nothing
, configMonoidSMTPFromName = Nothing
, configMonoidSMTPFromEmail = Nothing
+ , configMonoidStripeKey = Nothing
}
mappend l r = ConfigMonoid
{ configMonoidEnv = configMonoidEnv l <|> configMonoidEnv r
, configMonoidHost = configMonoidHost l <|> configMonoidHost r
, configMonoidPort = configMonoidPort l <|> configMonoidPort r
, configMonoidSocket = configMonoidSocket l <|> configMonoidSocket r
- , configMonoidUrlPath = configMonoidUrlPath l <|> configMonoidUrlPath r
, configMonoidSMTPServer = configMonoidSMTPServer l <|> configMonoidSMTPServer r
, configMonoidSMTPPort = configMonoidSMTPPort l <|> configMonoidSMTPPort r
, configMonoidSMTPUser = configMonoidSMTPUser l <|> configMonoidSMTPUser r
, configMonoidSMTPPassword = configMonoidSMTPPassword l <|> configMonoidSMTPPassword r
, configMonoidSMTPFromName = configMonoidSMTPFromName l <|> configMonoidSMTPFromName r
, configMonoidSMTPFromEmail = configMonoidSMTPFromEmail l <|> configMonoidSMTPFromEmail r
+ , configMonoidStripeKey = configMonoidStripeKey l <|> configMonoidStripeKey r
}
configMonoidToConfig :: ConfigMonoid -> Config
@@ -91,13 +101,13 @@ configMonoidToConfig c = Config
, getConfigHost = fromMaybe "127.0.0.1" (configMonoidHost c)
, getConfigPort = fromMaybe 8080 (configMonoidPort c)
, getConfigSocket = configMonoidSocket c
- , getConfigUrlPath = fromMaybe "" (configMonoidUrlPath c)
, getConfigSMTPServer = fromMaybe "127.0.0.1" (configMonoidSMTPServer c)
, getConfigSMTPPort = fromMaybe 25 (configMonoidSMTPPort c)
, getConfigSMTPUser = fromMaybe "" (configMonoidSMTPUser c)
, getConfigSMTPPassword = fromMaybe "" (configMonoidSMTPPassword c)
, getConfigSMTPFromName = configMonoidSMTPFromName c
, getConfigSMTPFromEmail = fromMaybe "" (configMonoidSMTPFromEmail c)
+ , getConfigStripe = StripeConfig $ fromMaybe (StripeKey "") (configMonoidStripeKey c)
}
getEnvConfig :: IO ConfigMonoid
@@ -106,26 +116,28 @@ getEnvConfig = do
host <- lookupEnv "SHOP_HOST"
port <- lookupEnv "SHOP_PORT"
socket <- lookupEnv "SHOP_SOCKET"
- urlpath <- lookupEnv "SHOP_URLPATH"
smtpserver <- lookupEnv "SHOP_SMTP_SERVER"
smtpport <- lookupEnv "SHOP_SMTP_PORT"
smtpuser <- lookupEnv "SHOP_SMTP_USER"
smtppassword <- lookupEnv "SHOP_SMTP_PASSWORD"
smtpfromname <- lookupEnv "SHOP_SMTP_FROM_NAME"
smtpfromemail <- lookupEnv "SHOP_SMTP_FROM_EMAIL"
- return $ mempty
- { configMonoidEnv = readMaybe =<< env
- , configMonoidHost = readMaybe =<< host
- , configMonoidPort = readMaybe =<< port
- , configMonoidSocket = socket
- , configMonoidUrlPath = readMaybe =<< urlpath
- , configMonoidSMTPServer = readMaybe =<< smtpserver
- , configMonoidSMTPPort = readMaybe =<< smtpport
- , configMonoidSMTPUser = readMaybe =<< smtpuser
- , configMonoidSMTPPassword = readMaybe =<< smtppassword
- , configMonoidSMTPFromName = toS <$> smtpfromname
- , configMonoidSMTPFromEmail = readMaybe =<< smtpfromemail
- }
+ stripekey <- lookupEnv "SHOP_STRIPEKEY"
+ case stripekey of
+ Nothing -> throwIO StripeKeyEnvError
+ Just s -> return $ mempty
+ { configMonoidEnv = readMaybe =<< env
+ , configMonoidHost = readMaybe =<< host
+ , configMonoidPort = readMaybe =<< port
+ , configMonoidSocket = socket
+ , configMonoidSMTPServer = smtpserver
+ , configMonoidSMTPPort = readMaybe =<< smtpport
+ , configMonoidSMTPUser = toS <$> smtpuser
+ , configMonoidSMTPPassword = toS <$> smtppassword
+ , configMonoidSMTPFromName = toS <$> smtpfromname
+ , configMonoidSMTPFromEmail = toS <$> smtpfromemail
+ , configMonoidStripeKey = Just (StripeKey (pack s))
+ }
getConfig :: IO Config
getConfig = do
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
diff --git a/src/Shop/Types.hs b/src/Shop/Types.hs
index 058317d..639c123 100644
--- a/src/Shop/Types.hs
+++ b/src/Shop/Types.hs
@@ -2,6 +2,7 @@
module Shop.Types
( Product(..)
, Article(..)
+ , TokenId(..)
, ChargeForm(..)
, ChargeResponse(..)
)
@@ -10,6 +11,7 @@ module Shop.Types
import Protolude hiding (Product(..))
import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))
import Servant.API
+import Web.Stripe.Types (TokenId(..))
data ChargeResponse = ChargeResponse
@@ -45,12 +47,23 @@ data Article = Article
instance ToJSON Article
instance FromJSON Article
+instance FromHttpApiData TokenId where
+ parseUrlPiece = Right . TokenId . toS
+
+instance FromJSON TokenId where
+ parseJSON (String v) = return $ TokenId (toS v)
+ parseJSON _ = mzero
+
+instance ToJSON TokenId where
+ toJSON (TokenId tid) = String tid
+
data ChargeForm = ChargeForm
{ name :: Text
, email :: Text
, phone :: Text
, date :: Text
, articles :: [Article]
+ , tokenid :: TokenId
}
deriving (Show, Read, Generic, Eq)