packages feed

snaplet-stripe (empty) → 0.1.0

raw patch · 4 files changed

+255/−0 lines, 4 filesdep +basedep +bytestringdep +configuratorsetup-changed

Dependencies added: base, bytestring, configurator, heist, mtl, snap, stripe, text, text-format, transformers, xmlhtml

Files

+ Setup.hs view
@@ -0,0 +1,3 @@+import           Distribution.Simple++main = defaultMain
+ resources/stripe/devel.cfg view
@@ -0,0 +1,3 @@+secret_key = ""+public_key = ""+client_id = ""
+ snaplet-stripe.cabal view
@@ -0,0 +1,42 @@+name:           snaplet-stripe+version:        0.1.0+synopsis:       Stripe snaplet for the Snap Framework+description:    This snaplet contains support for using the Stripe+                payment platform with a Snap Framework application.+license:        BSD3+author:         Luke Hoersten+maintainer:     luke@hoersten.org+build-type:     Simple+cabal-version:  >= 1.6+homepage:       https://github.com/LukeHoersten/snaplet-stripe+category:       Web, Snap++data-files:+  resources/stripe/devel.cfg++source-repository head+  type:     git+  location: https://github.com/LukeHoersten/snaplet-stripe++Library+  hs-source-dirs: src++  exposed-modules:+    Snap.Snaplet.Stripe++  build-depends:+    base         >= 4.4     && < 5,+    bytestring   >= 0.9.1   && < 0.11,+    snap         >= 0.11    && < 0.14,+    heist        >= 0.11    && < 0.14,+    text         >= 0.11    && < 0.12,+    text-format  >= 0.3     && < 0.4,+    configurator >= 0.2     && < 0.3,+    transformers >= 0.3     && < 0.4,+    mtl          >= 2       && < 3,+    xmlhtml      >= 0.2     && < 0.3,+    stripe       >= 0.3     && < 0.4+++  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+               -fno-warn-orphans -fno-warn-unused-do-bind
+ src/Snap/Snaplet/Stripe.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Stripe+       ( HasStripe (..)+       , StripeState (..)+       , initStripe+       , addStripeSplices+       , addCustomer+       , addCustomerWithCard+       , addCardByCustId+       , chargeCustomer+       , chargeConnectCustomer+       , fromAmount+       , toAmount+       , charge+       , connectCharge+       , customer+       , getAuthURL+       ) where+++import           Control.Applicative        ((<$>), (<*>))+import           Control.Monad              (when)+import           Control.Monad.State        (get)+import           Control.Monad.Trans        (MonadIO, lift, liftIO)+import           Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import qualified Data.Configurator          as C+import           Data.List                  (intercalate)+import           Data.Maybe                 (fromMaybe, isNothing)+import           Data.Monoid                (mempty)+import           Data.Text                  (Text)+import           Data.Text.Encoding         (decodeUtf8)+import           Data.Text.Format           (Format, Only (..), format)+import qualified Data.Text.Lazy             as TL+import           Heist                      (HeistConfig (..))+import           Heist.Compiled             (nodeSplice, pureSplice)+import           Heist.SpliceAPI            (( ## ))+import           Snap.Snaplet               (Handler, Initializer, Snaplet,+                                             SnapletInit, SnapletLens,+                                             getSnapletUserConfig, makeSnaplet,+                                             with)+import           Snap.Snaplet.Heist         (HasHeist, Heist, SnapletCSplice,+                                             SnapletISplice, addConfig)+import           Text.XmlHtml               (Node (..))++import           Web.Stripe.Charge          (Amount (..), Charge, ChargeId,+                                             Currency, chargeCustomerById,+                                             chargeTokenById, getCharge)+import           Web.Stripe.Client          (APIKey (..), StripeConfig (..),+                                             StripeFailure, key, runStripeT)+import           Web.Stripe.Connect         (AccessToken, ClientId, Landing,+                                             Scope, URL, authURL,+                                             createCustomerToken)+import           Web.Stripe.Coupon          (CpnId)+import           Web.Stripe.Customer        (Customer, CustomerId, Description,+                                             Email, createCustomerByTokenId,+                                             getCustomer,+                                             updateCustomerByIdByTokenId)+import           Web.Stripe.Plan            (PlanId)+import           Web.Stripe.Token           (TokenId, tokId)+++newtype PublicKey = PublicKey { unPublicKey :: Text } deriving (Show, Eq)++data StripeState = StripeState+    { stripeConfig          :: StripeConfig+    , stripePublicKey       :: PublicKey+    , stripeConnectClientId :: ClientId+    } deriving Show+++class HasStripe b where+    getStripeState :: b StripeState+++instance HasStripe (Handler b StripeState) where+    getStripeState = get+++logErr :: MonadIO m => t -> IO (Maybe a) -> WriterT [t] m (Maybe a)+logErr err m = do+  res <- liftIO m+  when (isNothing res) (tell [err])+  return res+++initStripe :: SnapletInit b StripeState+initStripe = makeSnaplet "stripe" "Stripe credit card payment" Nothing $ do+  config <- getSnapletUserConfig++  (stripeState, errors) <- runWriterT $ do+    secretKey <- logErr "Must specify Strip secret key" $ C.lookup config "secret_key"+    publicKey <- logErr "Must specify Strip public key" $ C.lookup config "public_key"+    clientId  <- logErr "Must specify Strip client ID"  $ C.lookup config "client_id"+    let caFilePath = Just "" -- This is unused by Stripe but vestigial in the Haskell library.++    return $ StripeState <$> (StripeConfig <$> (APIKey <$> secretKey) <*> caFilePath) <*> (PublicKey <$> publicKey) <*> clientId+  return $ fromMaybe (error $ intercalate "\n" errors) stripeState+++withSC :: (Functor m, HasStripe m, MonadIO m) => (StripeConfig -> m b) -> m b+withSC = (stripeConfig <$> getStripeState >>=)+++withSS :: (HasStripe m, MonadIO m) => (StripeState -> m b) -> m b+withSS = (getStripeState >>=)+++addCustomer' :: (Functor m, HasStripe m, MonadIO m) => Maybe TokenId -> Maybe CpnId+             -> Maybe Email -> Maybe Description -> Maybe PlanId -> Maybe Int+             -> m (Either StripeFailure Customer)+addCustomer' mti mcid me md mpid mtime =+    withSC . flip runStripeT $ createCustomerByTokenId mti mcid me md mpid mtime+++customer :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> m (Either StripeFailure Customer)+customer = withSC . flip runStripeT . getCustomer+++getAuthURL :: (MonadIO m, HasStripe m) => Maybe Scope -> Maybe Text -> Maybe Landing -> m URL+getAuthURL msc mst mld = withSS $ return . authURL msc mst mld . stripeConnectClientId+++chargeCustomer :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> Amount -> Currency+               -> Maybe Description -> m (Either StripeFailure Charge)+chargeCustomer cid a c md =+  withSC . flip runStripeT $ chargeCustomerById cid a c md Nothing+++chargeConnectCustomer :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> Amount -> Currency+                      -> Maybe Description -> AccessToken -> Maybe Amount+                      -> m (Either StripeFailure Charge)+chargeConnectCustomer cid am cu md k maf = withSC $ \sc -> do+  let sc' = sc { key = accessTokenToKey k }+  let ch = tokId <$> createCustomerToken cid >>=+          (\tid -> chargeTokenById tid am cu md maf)+  runStripeT sc' ch+++updateCustomerById :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> Maybe TokenId+                   -> Maybe CpnId -> Maybe Email -> Maybe Description+                   -> m (Either StripeFailure Customer)+updateCustomerById cid mti mcid me md =+  withSC . flip runStripeT $ updateCustomerByIdByTokenId cid mti mcid me md+++connectCharge :: (Functor m, HasStripe m, MonadIO m) => AccessToken -> ChargeId+                 -> m (Either StripeFailure Charge)+connectCharge k c = withSC $ \sc -> do+  let sc' = sc { key = accessTokenToKey k }+  runStripeT sc' (getCharge c)+++charge :: (Functor m, HasStripe m, MonadIO m) => ChargeId -> m (Either StripeFailure Charge)+charge = withSC . flip runStripeT . getCharge+++-- Simple API helpers --+addCustomer :: (Functor m, HasStripe m, MonadIO m) => Email -> m (Either StripeFailure Customer)+addCustomer email = addCustomer' Nothing Nothing (Just email) Nothing Nothing Nothing+++addCustomerWithCard :: (Functor m, HasStripe m, MonadIO m) => Email -> TokenId+                    -> m (Either StripeFailure Customer)+addCustomerWithCard email tid =+    addCustomer' (Just tid) Nothing (Just email) Nothing Nothing Nothing+++addCardByCustId :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> TokenId+                -> m (Either StripeFailure Customer)+addCardByCustId cid tid = updateCustomerById cid (Just tid) Nothing Nothing Nothing+++-- Functional Helpers+toAmount :: Float -> Amount+toAmount = Amount . truncate . (* 100)+++fromAmount :: Amount -> Float+fromAmount = (/ 100) . fromIntegral . unAmount+++accessTokenToKey :: AccessToken -> APIKey+accessTokenToKey = APIKey . decodeUtf8+++-- Public Key Splice+addStripeSplices :: HasHeist b => Snaplet (Heist b) -> SnapletLens b StripeState -> Initializer b v ()+addStripeSplices h stripe = addConfig h $ mempty+    { hcCompiledSplices    = ("stripePublicKeyJs" ## stripePublicKeyJsCSplice stripe)+    , hcInterpretedSplices = ("stripePublicKeyJs" ## stripePublicKeyJsISplice stripe)+    }+++stripePublicKeyJsISplice :: SnapletLens b StripeState -> SnapletISplice b+stripePublicKeyJsISplice stripe = return . ssNodes =<< (lift $ with stripe getStripeState)+++stripePublicKeyJsCSplice :: SnapletLens b StripeState -> SnapletCSplice b+stripePublicKeyJsCSplice stripe = (pureSplice . nodeSplice) ssNodes . lift $ with stripe getStripeState+++ssNodes :: StripeState -> [Node]+ssNodes = scriptNodes . renderJs . unPublicKey . stripePublicKey+  where renderJs = TL.toStrict . format ("var stripePublicKey = '{}';" :: Format) . Only . TL.fromStrict+        scriptNodes t = [Element "script" [("type", "text/javascript")] [TextNode t]]