Permalink
Browse files

Added basic Stripe Connect functionality. Fully functional but lackin…

…g a few features (to be added later)
  • Loading branch information...
1 parent 1762c88 commit b7adf6132f4ca946f7e98e694205b1aa37eb8180 @lukehoersten committed Dec 23, 2012
Showing with 124 additions and 2 deletions.
  1. +122 −0 src/Web/Stripe/Connect.hs
  2. +2 −2 stripe.cabal
View
@@ -0,0 +1,122 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Web.Stripe.Connect
+ ( authURL
+ , getAccessToken
+
+ , APIKey(..)
+ , StripeConnectTokens(..)
+ ) where
+
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Exception (Exception, SomeException (..))
+import Control.Monad (mzero)
+import Data.Aeson (FromJSON (..), Value (..), decode, (.:))
+import Data.ByteString.Char8 (ByteString, pack)
+import qualified Data.ByteString.Char8 as B
+import Data.Text (Text, append)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Typeable (Typeable)
+import Network.HTTP.Conduit (Request (..), Response (..), httpLbs,
+ parseUrl, urlEncodedBody, withManager)
+import Network.HTTP.Types (Query, Status (..), hAccept,
+ renderQuery)
+import Web.Stripe.Client (APIKey (..))
+import Web.Stripe.Utils (optionalArgs)
+
+
+type URL = ByteString
+type AccessToken = ByteString
+type RefreshToken = ByteString
+type UserId = ByteString
+type ClientId = ByteString
+type AuthCode = ByteString
+
+data StripeConnectException = StripeConnectException String deriving (Show, Eq, Typeable)
+data Scope = ReadOnly | ReadWrite
+data Landing = Login | Register
+data StripeConnectTokens = StripeConnectTokens
+ { scAccessToken :: AccessToken
+ , scRefreshToken :: RefreshToken
+ , scUserId :: UserId
+ } deriving Show
+
+
+-- URIs ------------------------------------------------------------------------
+authURL :: ClientId -> Maybe Scope -> Maybe Text -> Maybe Landing -> URL
+authURL clientId mScope mState mLanding =
+ B.append "https://connect.stripe.com/oauth/authorize" query
+ where query = renderQuery True
+ [ ("response_type", Just "code")
+ , ("client_id", Just clientId)
+ , ("scope", pack . show <$> mScope)
+ , ("state", encodeUtf8 <$> mState)
+ , ("stripe_landing", pack . show <$> mLanding)
+ ]
+
+
+accessTokenURL :: URL
+accessTokenURL = "https://connect.stripe.com/oauth/token"
+
+
+accessTokenQuery :: Maybe Scope -> AuthCode -> Query
+accessTokenQuery mScope code =
+ [ ("grant_type", Just "authorization_code")
+ , ("scope", pack . show <$> mScope)
+ , ("code", Just code)
+ ]
+
+
+refreshTokenQuery :: Maybe Scope -> RefreshToken -> Query
+refreshTokenQuery mScope token =
+ [ ("grant_type", Just "refresh_token")
+ , ("scope", pack . show <$> mScope)
+ , ("refresh_token", Just token)
+ ]
+
+
+-- HTTP ------------------------------------------------------------------------
+getAccessToken :: APIKey -> AuthCode -> IO (Maybe StripeConnectTokens)
+getAccessToken key code = do
+ req <- updateHeaders <$> parseUrl (B.unpack accessTokenURL)
+ decode . responseBody <$> (withManager . httpLbs $ urlEncodedBody body req)
+ where
+ body = optionalArgs $ accessTokenQuery Nothing code
+ headers req = json : auth : requestHeaders req
+ auth = ("Authorization", encodeUtf8 . append "Bearer " $ unAPIKey key)
+ json = (hAccept, "application/json")
+ updateHeaders req =
+ req
+ { requestHeaders = headers req
+ , checkStatus = statusCodeChecker
+ }
+
+
+statusCodeChecker :: Show a => Status -> a -> Maybe SomeException
+statusCodeChecker s@(Status c _) h
+ | 200 <= c && c < 300 = Nothing
+ | otherwise = Just . SomeException . StripeConnectException $ show s ++ show h
+
+
+-- Instances ----------------------------------------------------------------------
+instance Show Scope where
+ show ReadOnly = "read_only"
+ show ReadWrite = "read_write"
+
+
+instance Show Landing where
+ show Login = "login"
+ show Register = "register"
+
+
+instance FromJSON StripeConnectTokens where
+ parseJSON (Object o) = StripeConnectTokens
+ <$> o .: "access_token"
+ <*> o .: "refresh_token"
+ <*> o .: "stripe_user_id"
+ parseJSON _ = mzero
+
+
+instance Exception StripeConnectException
View
@@ -1,5 +1,5 @@
Name: stripe
-Version: 0.2
+Version: 0.3
Synopsis: A Haskell implementation of the Stripe API.
Description: This is an implementation of the Stripe API as it is
documented at https://stripe.com/docs/api
@@ -20,6 +20,7 @@ Library
Exposed-modules: Web.Stripe.Card
, Web.Stripe.Charge
, Web.Stripe.Client
+ , Web.Stripe.Connect
, Web.Stripe.Coupon
, Web.Stripe.Customer
, Web.Stripe.Plan
@@ -37,4 +38,3 @@ Library
, mtl >= 2.1
, utf8-string >= 0.3.7
extensions: OverloadedStrings, TupleSections
-

0 comments on commit b7adf61

Please sign in to comment.