stripe 0.1 → 0.3.0.1
raw patch · 12 files changed
+745/−575 lines, 12 filesdep +aesondep +http-conduitdep +unordered-containersdep −curldep −jsondep −networkdep ~http-typesdep ~mtldep ~text
Dependencies added: aeson, http-conduit, unordered-containers, utf8-string
Dependencies removed: curl, json, network
Dependency ranges changed: http-types, mtl, text
Files
- README.mkd +26/−11
- src/Web/Stripe/Card.hs +43/−38
- src/Web/Stripe/Charge.hs +60/−60
- src/Web/Stripe/Client.hs +146/−168
- src/Web/Stripe/Connect.hs +146/−0
- src/Web/Stripe/Coupon.hs +58/−56
- src/Web/Stripe/Customer.hs +89/−56
- src/Web/Stripe/Plan.hs +49/−56
- src/Web/Stripe/Subscription.hs +55/−51
- src/Web/Stripe/Token.hs +34/−43
- src/Web/Stripe/Utils.hs +28/−28
- stripe.cabal +11/−8
README.mkd view
@@ -1,27 +1,35 @@-Created by [Michael Schade](http://mschade.me/)-([@michaelschade](https://twitter.com/intent/user?screen_name=michaelschade)).--Description-===========--This is an *unofficial* Haskell implementation of the [Stripe API][sapi].+This is an unofficial Haskell implementation of the [Stripe API][sapi]. **Note** that this has worked in my tests, but I have not used it in production yet. Try it thoroughly and let me know if you [find any bugs](https://github.com/michaelschade/hs-stripe/issues) or [have any improvements](http://help.github.com/send-pull-requests/). +Installation+============++Installation is simple. If you have [cabal](http://www.haskell.org/cabal/)+installed, just run:++ cabal install stripe++and you'll be on your way!+ Example Usage ============= ```haskell+{-# LANGUAGE OverloadedStrings #-}+ import Web.Stripe.Charge ( Charge(..), Amount(..), Count(..), Currency(..) , Offset(..), getCharges )-import Web.Stripe.Client ( APIKey(..), SConfig, defaultConfig, runStripeT )+import Web.Stripe.Client ( APIKey(..), StripeConfig, defaultConfig, runStripeT ) -conf :: SConfig-conf = defaultConfig $ APIKey ""+-- The secret key below is used on the live Stripe API documentation. In+-- practice, you should always store your secret key securely.+conf :: StripeConfig+conf = defaultConfig $ APIKey "sk_test_mkGsLqEW6SLnZa487HYfJVLf" main :: IO () main = do@@ -56,9 +64,16 @@ implementation of the API, please submit an issue here. Better yet, submit a pull request with a proposed solution! +Contributors+============++* [Michael Schade](https://twitter.com/sch)+* [Luke Hoersten](https://twitter.com/LukeHoersten)+* [Max Cantor](https://twitter.com/maxcan)+ License ======= -I like the MIT license. See `LICENSE`.+We like the MIT license. See `LICENSE`. [sapi]: https://stripe.com/docs/api "Stripe API"
src/Web/Stripe/Card.hs view
@@ -1,55 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+ module Web.Stripe.Card ( Card(..) , RequestCard(..) , rCardKV ) where -import Control.Monad ( liftM, ap )-import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject) )-import Web.Stripe.Utils ( jGet, optionalArgs )+import Control.Applicative ((<$>), (<*>))+import Control.Monad (mzero)+import Data.Aeson (FromJSON (..), Value (..), (.:))+import qualified Data.ByteString as B+import qualified Data.Text as T+import Web.Stripe.Utils (optionalArgs, showByteString,+ textToByteString) -- | Represents a credit card in the Stripe system. data Card = Card- { cardType :: String- , cardCountry :: String- , cardLastFour :: String- , cardExpMonth :: Int- , cardExpYear :: Int+ { cardType :: T.Text+ , cardCountry :: T.Text+ , cardLastFour :: T.Text+ , cardExpMonth :: Int+ , cardExpYear :: Int } deriving Show -- | Represents a credit car (with full details) that is used as input to the -- Stripe API. data RequestCard = RequestCard- { rCardNumber :: String- , rCardExpMonth :: Int- , rCardExpYear :: Int- , rCardCVC :: Maybe String -- ^ Highly recommended to supply- , rCardFullName :: Maybe String- , rCardAddrLineOne :: Maybe String- , rCardAddrLineTwo :: Maybe String- , rCardAddrZip :: Maybe String- , rCardAddrState :: Maybe String- , rCardAddrCountry :: Maybe String+ { rCardNumber :: T.Text+ , rCardExpMonth :: Int+ , rCardExpYear :: Int+ , rCardCVC :: Maybe T.Text -- ^ Highly recommended to supply+ , rCardFullName :: Maybe T.Text+ , rCardAddrLineOne :: Maybe T.Text+ , rCardAddrLineTwo :: Maybe T.Text+ , rCardAddrZip :: Maybe T.Text+ , rCardAddrState :: Maybe T.Text+ , rCardAddrCountry :: Maybe T.Text } deriving Show -- | Turns a 'RequestCard' into a list of key-value pairs that can be submitted -- to the Stripe API in a query.-rCardKV :: RequestCard -> [(String, String)]+rCardKV :: RequestCard -> [(B.ByteString, B.ByteString)] rCardKV rc = fd ++ optionalArgs md where -- Required- fd = [ ("card[number]", rCardNumber rc)- , ("card[exp_month]", show $ rCardExpMonth rc)- , ("card[exp_year]", show $ rCardExpYear rc)+ fd = [ ("card[number]", textToByteString $ rCardNumber rc)+ , ("card[exp_month]", showByteString $ rCardExpMonth rc)+ , ("card[exp_year]", showByteString $ rCardExpYear rc) ] -- Optional- md = [ ("card[cvc]", rCardCVC rc)- , ("card[name]", rCardFullName rc)- , ("card[address_line_1]", rCardAddrLineOne rc)- , ("card[address_line_2]", rCardAddrLineTwo rc)- , ("card[address_zip]", rCardAddrZip rc)- , ("card[address_state]", rCardAddrState rc)- , ("card[address_country]", rCardAddrCountry rc)+ md = [ ("card[cvc]", textToByteString <$> rCardCVC rc)+ , ("card[name]", textToByteString <$> rCardFullName rc)+ , ("card[address_line_1]", textToByteString <$> rCardAddrLineOne rc)+ , ("card[address_line_2]", textToByteString <$> rCardAddrLineTwo rc)+ , ("card[address_zip]", textToByteString <$> rCardAddrZip rc)+ , ("card[address_state]", textToByteString <$> rCardAddrState rc)+ , ("card[address_country]", textToByteString <$> rCardAddrCountry rc) ] ------------------@@ -57,12 +63,11 @@ ------------------ -- | Attempts to parse JSON into a credit 'Card'.-instance JSON Card where- readJSON (JSObject c) =- Card `liftM` jGet c "type"- `ap` jGet c "country"- `ap` jGet c "last4"- `ap` jGet c "exp_month"- `ap` jGet c "exp_year"- readJSON _ = Error "Unable to read Stripe credit card."- showJSON _ = undefined+instance FromJSON Card where+ parseJSON (Object v) = Card+ <$> v .: "type"+ <*> v .: "country"+ <*> v .: "last4"+ <*> v .: "exp_month"+ <*> v .: "exp_year"+ parseJSON _ = mzero
src/Web/Stripe/Charge.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Web.Stripe.Charge ( Charge(..) , ChargeId(..)@@ -20,28 +22,28 @@ , Description(..) , Offset(..) , UTCTime(..)- , SConfig(..)+ , StripeConfig(..) , StripeT(StripeT) , runStripeT ) where -import Control.Applicative ( (<$>) )-import Control.Monad ( liftM, ap )-import Control.Monad.Error ( MonadIO, throwError, strMsg )-import Network.HTTP.Types ( StdMethod(..) )-import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject)- , resultToEither, valFromObj- )-import Web.Stripe.Card ( Card, RequestCard, rCardKV )-import Web.Stripe.Customer ( Customer(..), CustomerId(..) )-import Web.Stripe.Client ( StripeT(..), SConfig(..), SRequest(..), baseSReq- , query, runStripeT- )-import Web.Stripe.Token ( Token(..), TokenId(..) )-import Web.Stripe.Utils ( Amount(..), Count(..), Currency(..)- , Description(..), Offset(..), UTCTime(..)- , fromSeconds, jGet, mjGet, optionalArgs- )+import Control.Applicative ((<$>), (<*>))+import Control.Monad (liftM, mzero)+import Control.Monad.Error (MonadIO)+import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?))+import qualified Data.ByteString as B+import qualified Data.Text as T+import Network.HTTP.Types (StdMethod (..))+import Web.Stripe.Card (Card, RequestCard, rCardKV)+import Web.Stripe.Client (StripeConfig (..), StripeRequest (..),+ StripeT (..), baseSReq, query, queryData,+ runStripeT)+import Web.Stripe.Customer (Customer (..), CustomerId (..))+import Web.Stripe.Token (Token (..), TokenId (..))+import Web.Stripe.Utils (Amount (..), Count (..), Currency (..),+ Description (..), Offset (..),+ UTCTime (..), fromSeconds, optionalArgs,+ showByteString, textToByteString) ---------------- -- Data Types --@@ -54,7 +56,6 @@ , chargeDescription :: Maybe Description , chargeCurrency :: Currency , chargeAmount :: Amount- , chargeFee :: Int , chargeLive :: Bool , chargePaid :: Bool , chargeRefunded :: Bool@@ -62,48 +63,50 @@ } deriving Show -- | Represents the identifier for a given 'Charge' in the Stripe system.-newtype ChargeId = ChargeId { unChargeId :: String } deriving Show+newtype ChargeId = ChargeId { unChargeId :: T.Text } deriving (Show, Eq) -- | Submit a 'Charge' to the Stripe API using an already constructed 'Token'. chargeToken :: MonadIO m => Token -> Amount -> Currency- -> Maybe Description -> StripeT m Charge+ -> Maybe Description -> Maybe Amount -> StripeT m Charge chargeToken = chargeTokenById . tokId -- | Submit a 'Charge' to the Stripe API using a 'TokenId'. chargeTokenById :: MonadIO m => TokenId -> Amount -> Currency- -> Maybe Description -> StripeT m Charge-chargeTokenById (TokenId tid) = charge [("card", tid)]+ -> Maybe Description -> Maybe Amount -> StripeT m Charge+chargeTokenById (TokenId tid) = charge [("card", textToByteString tid)] -- | Submit a 'Charge' to the Stripe for a specific 'Customer' that already has -- payment details on file. chargeCustomer :: MonadIO m => Customer -> Amount -> Currency- -> Maybe Description -> StripeT m Charge+ -> Maybe Description -> Maybe Amount -> StripeT m Charge chargeCustomer = chargeCustomerById . custId -- | Submit a 'Charge' to the Stripe for a specific 'Customer', identified by -- its 'CustomerId', that already has payment details on file. chargeCustomerById :: MonadIO m => CustomerId -> Amount -> Currency- -> Maybe Description -> StripeT m Charge-chargeCustomerById (CustomerId cid) = charge [("customer", cid)]+ -> Maybe Description -> Maybe Amount -> StripeT m Charge+chargeCustomerById (CustomerId cid) = charge [("customer", textToByteString cid)] -- | Submit a 'Charge' to the Stripe API using a 'RequestCard' to describe -- payment details. chargeRCard :: MonadIO m => RequestCard -> Amount -> Currency- -> Maybe Description -> StripeT m Charge+ -> Maybe Description -> Maybe Amount -> StripeT m Charge chargeRCard rc = charge (rCardKV rc) -- | Internal convenience function to handle actually submitting a 'Charge' -- request to the Stripe API.-charge :: MonadIO m => [(String, String)] -> Amount -> Currency- -> Maybe Description -> StripeT m Charge-charge adata a c mcd =+charge :: MonadIO m => [(B.ByteString, B.ByteString)] -> Amount -> Currency+ -> Maybe Description -> Maybe Amount -> StripeT m Charge+charge adata a c mcd maf = snd `liftM` query (chargeRq []) { sMethod = POST, sData = fdata } where- fdata = head (optionalArgs odata) : adata ++ bdata- odata = [ ("description", unDescription <$> mcd) ]- bdata = [ ("amount", show . unAmount $ a)- , ("currency", unCurrency c)+ fdata = optionalArgs odata ++ adata ++ bdata+ odata = [ ("description", textToByteString . unDescription <$> mcd)+ , ("application_fee", showByteString . unAmount <$> maf) ]+ bdata = [ ("amount", showByteString . unAmount $ a)+ , ("currency", textToByteString $ unCurrency c)+ ] -- | Retrieve a 'Charge' from the Stripe API, identified by 'ChargeId'. getCharge :: MonadIO m => ChargeId -> StripeT m Charge@@ -117,15 +120,14 @@ -- * 'Customer'. getCharges :: MonadIO m => Maybe CustomerId -> Maybe Count -> Maybe Offset -> StripeT m [Charge]-getCharges mcid mc mo = do- (_, rsp) <- query $ (chargeRq []) { sQString = optionalArgs oqs }- either err return . resultToEither . valFromObj "data" $ rsp- where- oqs = [ ("count", show . unCount <$> mc)- , ("offset", show . unOffset <$> mo)- , ("customer", unCustomerId <$> mcid)- ]- err _ = throwError $ strMsg "Unable to parse charge list."+getCharges mcid mc mo = liftM snd $+ queryData ((chargeRq []) { sQString = optionalArgs oqs })+ where+ oqs = [ ("count", show . unCount <$> mc)+ , ("offset", show . unOffset <$> mo)+ , ("customer", T.unpack . unCustomerId <$> mcid)+ ]+ -- err = throwError $ strMsg "Unable to parse charge list." -- | Requests that Stripe issue a partial refund to a specific 'Charge' for a -- particular 'Amount'.@@ -151,11 +153,11 @@ refundChargeById :: MonadIO m => ChargeId -> Maybe Amount -> StripeT m Charge refundChargeById (ChargeId cid) ma = snd `liftM` query (chargeRq [cid, "refund"]) { sMethod = POST, sData = fd }- where fd = optionalArgs [("amount", show . unAmount <$> ma)]+ where fd = optionalArgs [("amount", showByteString . unAmount <$> ma)] --- | Convenience function to create a 'SRequest' specific to coupon-related+-- | Convenience function to create a 'StripeRequest' specific to coupon-related -- actions.-chargeRq :: [String] -> SRequest+chargeRq :: [T.Text] -> StripeRequest chargeRq pcs = baseSReq { sDestination = "charges":pcs } ------------------@@ -163,17 +165,15 @@ ------------------ -- | Attempts to parse JSON into a 'Charge'.-instance JSON Charge where- readJSON (JSObject c) =- Charge `liftM` (ChargeId <$> jGet c "id")- `ap` (fromSeconds <$> jGet c "created")- `ap` ((Description <$>) <$> mjGet c "description")- `ap` (Currency <$> jGet c "currency")- `ap` (Amount <$> jGet c "amount")- `ap` jGet c "fee"- `ap` jGet c "livemode"- `ap` jGet c "paid"- `ap` jGet c "refunded"- `ap` jGet c "card"- readJSON _ = Error "Unable to read Stripe charge."- showJSON _ = undefined+instance FromJSON Charge where+ parseJSON (Object v) = Charge+ <$> (ChargeId <$> v .: "id")+ <*> (fromSeconds <$> v .: "created")+ <*> ((Description <$>) <$> v .:? "description")+ <*> (Currency <$> v .: "currency")+ <*> (Amount <$> v .: "amount")+ <*> v .: "livemode"+ <*> v .: "paid"+ <*> v .: "refunded"+ <*> v .: "card"+ parseJSON _ = mzero
src/Web/Stripe/Client.hs view
@@ -1,60 +1,60 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} module Web.Stripe.Client- ( SConfig(..)+ ( StripeConfig(..) , APIKey(..)- , SResponseCode(..)- , SFailure(..)- , SError(..)- , SErrorCode(..)- , SRequest(..)+ , StripeResponseCode(..)+ , StripeFailure(..)+ , StripeError(..)+ , StripeErrorCode(..)+ , StripeRequest(..) , Stripe , StripeT(StripeT) , defaultConfig , runStripeT , baseSReq , query+ , queryData , query_ {- Re-Export -} , StdMethod(..) ) where -import Control.Monad ( MonadPlus, liftM )-import Control.Monad.Error ( Error, ErrorT, MonadIO, MonadError, runErrorT- , throwError, strMsg, noMsg- )-import Control.Monad.State ( MonadState, StateT, runStateT, get )-import Control.Monad.Trans ( liftIO )-import Data.Char ( toLower )-import Data.List ( intercalate )-import Data.Text ( Text )-import Network.Curl ( CurlOption(..), CurlResponse, CurlResponse_(..)- , curlGetResponse_, method_GET, method_HEAD- , method_POST- )-import Network.HTTP.Types ( StdMethod(..), renderQuery )-import Network.URI ( URI(..), URIAuth(..) )-import Text.JSON ( Result(..), JSObject, JSON(..), JSValue(..)- , decode, resultToEither, toJSObject, valFromObj- )-import Web.Stripe.Utils ( jGet, mjGet )--import qualified Data.ByteString.Char8 as C8-import qualified Data.Text as T+import Control.Monad (MonadPlus, join, liftM, mzero)+import Control.Monad.Error (Error, ErrorT, MonadError, MonadIO,+ noMsg, runErrorT, strMsg, throwError)+import Control.Exception as EX+import Control.Monad.State (MonadState, StateT, get, runStateT)+import Control.Monad.Trans (liftIO)+import Data.Aeson (FromJSON (..), Value (..), decode',+ eitherDecode', (.:), (.:?))+import Data.Aeson.Types (parseMaybe)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL+import Data.Char (toLower)+import qualified Data.HashMap.Lazy as HML+import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Conduit+import Network.HTTP.Types+import Web.Stripe.Utils (textToByteString) ------------------------ -- General Data Types -- ------------------------ -- | Configuration for the 'StripeT' monad transformer.-data SConfig = SConfig+data StripeConfig = StripeConfig { key :: APIKey , caFile :: FilePath } deriving Show -- | A key used when authenticating to the Stripe API.-newtype APIKey = APIKey { unAPIKey :: String } deriving Show+newtype APIKey = APIKey { unAPIKey :: T.Text } deriving Show -- | This represents the possible successes that a connection to the Stripe -- API can encounter. For specificity, a success can be represented by other@@ -62,29 +62,30 @@ -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information.-data SResponseCode = OK | Unknown Int deriving Show+data StripeResponseCode = OK | Unknown Int deriving (Show, Eq) -- | This represents the possible failures that a connection to the Stripe API -- can encounter. -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information.-data SFailure- = BadRequest (Maybe SError)- | Unauthorized (Maybe SError)- | NotFound (Maybe SError)- | PaymentRequired (Maybe SError)- | InternalServerError (Maybe SError)- | BadGateway (Maybe SError)- | ServiceUnavailable (Maybe SError)- | GatewayTimeout (Maybe SError)+data StripeFailure+ = BadRequest (Maybe StripeError)+ | Unauthorized (Maybe StripeError)+ | NotFound (Maybe StripeError)+ | PaymentRequired (Maybe StripeError)+ | InternalServerError (Maybe StripeError)+ | BadGateway (Maybe StripeError)+ | ServiceUnavailable (Maybe StripeError)+ | GatewayTimeout (Maybe StripeError)+ | HttpFailure (Maybe Text) | OtherFailure (Maybe Text)- deriving Show+ deriving (Show, Eq) --- | Describes a 'SFailure' in more detail, categorizing the error and+-- | Describes a 'StripeFailure' in more detail, categorizing the error and -- providing additional information about it. At minimum, this is a message, -- and for 'CardError', this is a message, even more precise code--- ('SErrorCode'), and potentially a paramter that helps suggest where an+-- ('StripeErrorCode'), and potentially a paramter that helps suggest where an -- error message should be displayed. -- -- In case the appropriate error could not be determined from the specified@@ -92,28 +93,19 @@ -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information.-data SError- = InvalidRequestError- { ireMessage :: String }- | APIError- { apiMessage :: String }- | CardError- { ceMessage :: String- , ceCode :: SErrorCode- , ceParam :: Maybe String- }- | UnknownError- { ueType :: String- , ueMessage :: String- }- deriving Show+data StripeError+ = InvalidRequestError Text+ | APIError Text+ | CardError Text StripeErrorCode (Maybe Text) -- message, code, params+ | UnknownError Text Text -- type, message+ deriving (Show, Eq) -- | Attempts to describe a 'CardError' in more detail, classifying in what -- specific way it failed. -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information.-data SErrorCode+data StripeErrorCode = InvalidNumber | IncorrectNumber | InvalidExpiryMonth@@ -127,16 +119,16 @@ | DuplicateTransaction | ProcessingError | UnknownErrorCode Text -- ^ Could not be matched; text gives error name.- deriving Show+ deriving (Show, Eq) -- | Represents a request to the Stripe API, providing the fields necessary to -- specify a Stripe resource. More generally, 'baseSReq' will be desired as -- it provides sensible defaults that can be overriden as needed.-data SRequest = SRequest- { sMethod :: StdMethod- , sDestination :: [String]- , sData :: [(String, String)]- , sQString :: [(String, String)]+data StripeRequest = StripeRequest+ { sMethod :: StdMethod+ , sDestination :: [Text]+ , sData :: [(B.ByteString, B.ByteString)]+ , sQString :: [(String, String)] } deriving Show ------------------@@ -150,18 +142,18 @@ -- | Defines the monad transformer under which all Stripe REST API resource -- calls take place. newtype StripeT m a = StripeT- { unStripeT :: StateT SConfig (ErrorT SFailure m) a+ { unStripeT :: StateT StripeConfig (ErrorT StripeFailure m) a } deriving ( Functor, Monad, MonadIO, MonadPlus- , MonadError SFailure- , MonadState SConfig+ , MonadError StripeFailure+ , MonadState StripeConfig ) --- | Runs the 'StripeT' monad transformer with a given 'SConfig'. This will+-- | Runs the 'StripeT' monad transformer with a given 'StripeConfig'. This will -- handle all of the authorization dance steps necessary to utilize the -- Stripe API. -- -- Its use is demonstrated in other functions, such as 'query'.-runStripeT :: MonadIO m => SConfig -> StripeT m a -> m (Either SFailure a)+runStripeT :: MonadIO m => StripeConfig -> StripeT m a -> m (Either StripeFailure a) runStripeT cfg m = runErrorT . liftM fst . (`runStateT` cfg) . unStripeT $ m @@ -169,20 +161,20 @@ -- Querying -- -------------- --- | Provides a default 'SConfig'. Essentially, this inserts the 'APIKey', but+-- | Provides a default 'StripeConfig'. Essentially, this inserts the 'APIKey', but -- leaves other fields blank. This is especially relavent due to the current -- CA file check bug.-defaultConfig :: APIKey -> SConfig-defaultConfig k = SConfig k ""+defaultConfig :: APIKey -> StripeConfig+defaultConfig k = StripeConfig k "" --- | The basic 'SRequest' environment upon which all other Stripe API requests+-- | The basic 'StripeRequest' environment upon which all other Stripe API requests -- will be built. Standard usage involves overriding one or more of the -- fields. E.g., for a request to \"https://api.stripe.com/v1/coupons\", -- one would have: -- -- > baseSReq { sDestinaton = ["charges"] }-baseSReq :: SRequest-baseSReq = SRequest+baseSReq :: StripeRequest+baseSReq = StripeRequest { sMethod = GET , sDestination = [] , sData = []@@ -190,84 +182,78 @@ } -- | Queries the Stripe API. This returns the response body along with the--- 'SResponseCode' undecoded. Use 'query' to try to decode it into a 'JSON'+-- 'StripeResponseCode' undecoded. Use 'query' to try to decode it into a 'JSON' -- type. E.g., ----- > let conf = SConfig "key" "secret"+-- > let conf = StripeConfig "key" "secret" -- > -- > runStripeT conf $ -- > query' baseSReq { sDestination = ["charges"] }-query' :: MonadIO m => SRequest -> StripeT m (SResponseCode, String)-query' req = do+query' :: MonadIO m => StripeRequest -> StripeT m (StripeResponseCode, BL.ByteString)+query' sReq = do cfg <- get- let opts' = opts $ caFile cfg- rsp <- liftIO (request (show $ prepRq cfg req) opts' :: IO CurlResponse)- code <- toCode (respStatus rsp) (respBody rsp)- return (code, respBody rsp)- where- opts caf = CurlCAInfo caf : CurlFailOnError False : queryOptions req- request = curlGetResponse_+ req' <- maybe (throwError $ strMsg "Error Prepating the Request") return (prepRq cfg sReq)+ let req = req' {checkStatus = \_ _ _ -> Nothing, responseTimeout = Just 10000000}+ -- _TODO we should be able to pass in a manager rather thanusing the default manager+ rsp' <- liftIO (EX.catch (fmap Right $ withManager $ httpLbs req) (return . Left))+ case rsp' of+ Left err -> throwError (HttpFailure $ Just (T.pack (show (err :: HttpException))))+ Right rsp -> do+ code <- toCode (responseStatus rsp) (responseBody rsp)+ return (code, responseBody rsp) -- | Queries the Stripe API and attempts to parse the results into a data type -- that is an instance of 'JSON'. This is primarily for internal use by other -- Stripe submodules, which supply the request values accordingly. However, -- it can also be used directly. E.g., ----- > let conf = SConfig "key" "CA file"+-- > let conf = StripeConfig "key" "CA file" -- > -- > runStripeT conf $ -- > query baseSReq { sDestination = ["charges"] }-query :: (MonadIO m, JSON a) => SRequest -> StripeT m (SResponseCode, a)-query req = query' req >>= \(code, ans) -> (,) code `liftM` decodeJ ans- where- decodeJ = tryEither . resultToEither . decode- tryEither = either (throwError . strMsg) return+query :: (MonadIO m, FromJSON a) => StripeRequest -> StripeT m (StripeResponseCode, a)+query req = query' req >>= \(code, ans) ->+ either (throwError . strMsg . ("JSON parse error: " ++)) (return . (code, )) $ eitherDecode' ans +-- | same as `query` but pulls out the value inside a data field and returns that+queryData :: (MonadIO m, FromJSON a) => StripeRequest -> StripeT m (StripeResponseCode, a)+queryData req = query' req >>= \(code, ans) -> do+ val <- either (throwError . strMsg . ("JSON parse error: " ++)) return $ eitherDecode' ans+ case val of+ Object o -> do+ objVal <- maybe (throwError $ strMsg "no data in json" ) return $+ HML.lookup "data" o+ obj <- maybe (throwError $ strMsg "parsed JSON didn't contain object") return $+ parseMaybe parseJSON objVal+ return (code, obj)+ _ -> throwError $ strMsg "JSON was not object"+ -- | Acts just like 'query', but on success, throws away the response. Errors -- contacting the Stripe API will still be reported.-query_ :: MonadIO m => SRequest -> StripeT m ()+query_ :: MonadIO m => StripeRequest -> StripeT m () query_ req = query' req >> return () --- | Determines the appropriate 'CurlOption's for a given 'SRequest'.--- Presently, this provides a User-Agent string, adds any available HTTP--- 'POST' data, and incorporates the proper HTTP method ('StdMethod').-queryOptions :: SRequest -> [CurlOption]-queryOptions req = CurlUserAgent ua : CurlPostFields dopts : mopts- where- ua = "hs-stripe/0.1 libcurl"- dopts = map (\(a, b) -> a ++ "=" ++ b) $ sData req -- Data- mopts = case sMethod req of -- HTTP Method- GET -> method_GET- POST -> method_POST- HEAD -> method_HEAD- PUT -> [CurlCustomRequest "PUT"]- DELETE -> [CurlCustomRequest "DELETE"]- TRACE -> [CurlCustomRequest "TRACE"]- CONNECT -> [CurlCustomRequest "CONNECT"]- OPTIONS -> [CurlCustomRequest "OPTIONS"]+setUserAgent :: C8.ByteString -> Request m -> Request m+setUserAgent ua req = req { requestHeaders = ("User-Agent", ua) : filteredHeaders }+ where+ filteredHeaders = filter ((/= "User-Agent") . fst) $ requestHeaders req --- | Transforms a 'SRequest' into a more general 'URI', which can be used to+-- | Transforms a 'StripeRequest' into a more general 'URI', which can be used to -- make an authenticated query to the Stripe server.-prepRq :: SConfig -> SRequest -> URI-prepRq cfg rq =- uri { uriPath = intercalate "/" (uriPath uri:sDestination rq)- , uriQuery = C8.unpack $ renderQuery True qs- }- where- uri = baseURI (unAPIKey $ key cfg)- qs = map (\(a, b) -> (C8.pack a, Just $ C8.pack b)) $ sQString rq---- | Takes a Stripe API key (see 'SConfig') to produce a authentication-ready--- URI to be used when querying the server. API. This defines fields with--- the most sensible defaults, which are then overriden as needed.-baseURI :: String -> URI-baseURI k = URI- { uriScheme = "https:"- , uriAuthority = Just $ URIAuth (k ++ ":@") "api.stripe.com" ":443"- , uriPath = "/v1"- , uriQuery = ""- , uriFragment = ""- }+-- _TODO there is lots of sloppy Text <-> String stuff here.. should fix+prepRq :: Monad m => StripeConfig -> StripeRequest -> Maybe (Request m)+prepRq cfg sReq = flip fmap mReq $ \req -> applyBasicAuth k p $+ (addBodyUa req) { queryString = renderQuery False qs+ , method = renderStdMethod $ sMethod sReq+ }+ where+ k = textToByteString . unAPIKey $ key cfg+ p = textToByteString ""+ addBodyUa = urlEncodedBody (sData sReq) . setUserAgent "hs-string/0.2 http-conduit"+ mReq = parseUrl . T.unpack $ T.concat+ [ "https://api.stripe.com:443/v1/"+ , T.intercalate "/" (sDestination sReq) ]+ qs = map (\(a, b) -> (C8.pack a, Just $ C8.pack b)) $ sQString sReq -------------------- -- Error Handling --@@ -275,15 +261,15 @@ -- | Given an HTTP status code and the response body as input, this function -- determines whether or not the status code represents an error as--- per Stripe\'s REST API documentation. If it does, 'SFailure' is thrown as--- an error. Otherwise, 'SResponseCode' is returned, representing the status+-- per Stripe\'s REST API documentation. If it does, 'StripeFailure' is thrown as+-- an error. Otherwise, 'StripeResponseCode' is returned, representing the status -- of the request. -- -- If an error is encountered, this function will attempt to decode the -- response body with 'errorMsg' to retrieve (and return) an explanation with--- the 'SFailure'.-toCode :: Monad m => Int -> String -> StripeT m SResponseCode-toCode c body = case c of+-- the 'StripeFailure'.+toCode :: Monad m => Status -> BL.ByteString -> StripeT m StripeResponseCode+toCode c body = case statusCode c of -- Successes 200 -> return OK -- Failures@@ -296,16 +282,16 @@ 503 -> throwError $ ServiceUnavailable e 504 -> throwError $ GatewayTimeout e -- Unknown; assume success- _ -> return $ Unknown c- where e = errorMsg body+ i -> return $ Unknown i+ where e = errorMsg body --- | Converts a 'String'-represented error code into the 'SErrorCode' data+-- | Converts a 'String'-represented error code into the 'StripeErrorCode' data -- type to more descriptively classify errors. -- -- If the string does not represent a known error code, 'UnknownErrorCode' -- will be returned with the raw text representing the error code.-toCECode :: String -> SErrorCode-toCECode c = case map toLower c of+toCECode :: T.Text -> StripeErrorCode+toCECode c = case T.map toLower c of "invalid_number" -> InvalidNumber "incorrect_number" -> IncorrectNumber "invalid_expiry_month" -> InvalidExpiryMonth@@ -318,47 +304,39 @@ "missing" -> Missing "duplicate_transaction" -> DuplicateTransaction "processing_error" -> ProcessingError- _ -> UnknownErrorCode $ T.pack c+ _ -> UnknownErrorCode c -- | This function attempts to decode the contents of a response body as JSON -- and retrieve an error message in an \"error\" field. E.g., -- -- >>> errorMsg "{\"error\":\"Oh no, an error!\"}" -- Just "Oh no, an error!"-errorMsg :: String -> Maybe SError-errorMsg =- either (\_ -> Nothing) Just . resultToEither . valFromObj "error" . toBody---- | Attempts to decode a response body to a 'JSObject' 'JSValue'. This is used--- internally by functions such as 'errorMsg' which need to only grab, a--- single value from a response body, rather than representing it first as a--- more proper data type.-toBody :: String -> JSObject JSValue-toBody = either (\_ -> toJSObject []) id . resultToEither . decode+errorMsg :: BL.ByteString -> Maybe StripeError+errorMsg bs = join . fmap getErrorVal $ decode' bs+ where+ getErrorVal (Object o) = maybe Nothing (parseMaybe parseJSON) (HML.lookup "error" o)+ getErrorVal _ = Nothing -- | Attempts to parse error information provided with each error by the Stripe--- API. In the parsing, the error is classified as a specific 'SError' and+-- API. In the parsing, the error is classified as a specific 'StripeError' and -- any useful data, such as a message explaining the error, is extracted -- accordingly.-instance JSON SError where- readJSON (JSObject err) = do- type_ <- jGet err "type"- msg <- jGet err "message"- case map toLower type_ of- "invalid_request_error" ->- return $ InvalidRequestError msg- "api_error" ->- return $ APIError msg+instance FromJSON StripeError where+ parseJSON (Object err) = do+ type_ <- err .: "type"+ msg <- err .: "message"+ case T.map toLower type_ of+ "invalid_request_error" -> return $ InvalidRequestError msg+ "api_error" -> return $ APIError msg "card_error" -> do- code <- jGet err "code"- param <- mjGet err "param"+ code <- err .: "code"+ param <- err .:? "param" return $ CardError msg (toCECode code) param _ -> return $ UnknownError type_ msg- readJSON _ = Error "Unable to read Stripe error."- showJSON _ = undefined+ parseJSON _ = mzero -- | Defines the behavior for more general error messages that can be thrown -- with 'noMsg' and 'strMsg' in combination with 'throwError'.-instance Error SFailure where+instance Error StripeFailure where noMsg = OtherFailure Nothing strMsg = OtherFailure . Just . T.pack
+ src/Web/Stripe/Connect.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Stripe.Connect+ ( authURL+ , getAccessToken+ , createCustomerToken++ , APIKey (..)+ , StripeConnectTokens (..)+ , Scope (..)+ , Landing (..)+ , AuthCode+ , AccessToken+ , RefreshToken+ , UserId+ , ClientId+ , URL+ ) where+++import Control.Applicative ((<$>), (<*>))+import Control.Exception (Exception, SomeException (..))+import Control.Monad (liftM, mzero)+import Control.Monad.Error (MonadIO)+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 (..), StdMethod (..),+ hAccept, renderQuery)+import Web.Stripe.Client (APIKey (..), StripeRequest (..),+ StripeT, query)+import Web.Stripe.Customer (CustomerId (..))+import Web.Stripe.Token (Token, tokRq)+import Web.Stripe.Utils (optionalArgs, textToByteString)+++type URL = ByteString+type AccessToken = ByteString+type RefreshToken = ByteString+type UserId = ByteString+type ClientId = ByteString+type AuthCode = ByteString++newtype StripeConnectException = StripeConnectException String deriving (Show, Eq, Typeable)++data Scope = ReadOnly | ReadWrite deriving Eq+data Landing = Login | Register deriving Eq+data StripeConnectTokens = StripeConnectTokens+ { scAccessToken :: AccessToken+ , scRefreshToken :: RefreshToken+ , scUserId :: UserId+ } deriving Show+++-- URIs ------------------------------------------------------------------------+authURL :: Maybe Scope -> Maybe Text -> Maybe Landing -> ClientId -> URL+authURL mScope mState mLanding clientId =+ B.append "https://connect.stripe.com/oauth/authorize" q+ where q = 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 ------------------------------------------------------------------------+-- TODO getAccessToken should get the APIKey from the StripeT monad.+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, Show b) => Status -> a -> b -> Maybe SomeException+statusCodeChecker s@(Status c _) h _+ | 200 <= c && c < 300 = Nothing+ | otherwise = Just . SomeException . StripeConnectException $ show s ++ show h++++-- Stripe API ---------------------------------------------------------------------+createCustomerToken :: MonadIO m => CustomerId -> StripeT m Token+createCustomerToken cid =+ snd `liftM` query (tokRq []) { sMethod = POST, sData = fdata }+ where+ fdata = [("customer", textToByteString $ unCustomerId cid)]+++-- 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
src/Web/Stripe/Coupon.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Web.Stripe.Coupon ( Coupon(..) , CpnId(..)@@ -14,23 +16,25 @@ {- Re-Export -} , Count(..) , Offset(..)- , SConfig(..)+ , StripeConfig(..) , StripeT(StripeT) , runStripeT ) where -import Control.Applicative ( (<$>) )-import Control.Monad ( liftM, ap )-import Control.Monad.Error ( MonadIO, throwError, strMsg )-import Data.Char ( toLower )-import Network.HTTP.Types ( StdMethod(..) )-import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject)- , resultToEither, valFromObj- )-import Web.Stripe.Client ( StripeT(..), SConfig(..), SRequest(..), baseSReq- , query, query_, runStripeT- )-import Web.Stripe.Utils ( Count(..), Offset(..), jGet, mjGet, optionalArgs )+import Control.Applicative ((<$>))+import Control.Monad (liftM, mzero)+import Control.Monad.Error (MonadIO, strMsg, throwError)+import Data.Aeson (FromJSON (..), Value (..), parseJSON,+ (.:), (.:?))+import qualified Data.ByteString as B+import Data.Char (toLower)+import qualified Data.Text as T+import Network.HTTP.Types (StdMethod (..))+import Web.Stripe.Client (StripeConfig (..), StripeRequest (..),+ StripeT (..), baseSReq, query, queryData,+ query_, runStripeT)+import Web.Stripe.Utils (Count (..), Offset (..), optionalArgs,+ showByteString, textToByteString) ---------------- -- Data Types --@@ -44,7 +48,7 @@ } deriving Show -- | Represents the identifier for a given 'Coupon' in the Stripe system.-newtype CpnId = CpnId { unCpnId :: String } deriving Show+newtype CpnId = CpnId { unCpnId :: T.Text } deriving (Show, Eq) -- | Represents the duration of a coupon. If an interval identifier is not -- known, 'UnknownDuration' is used to carry the original identifier supplied@@ -53,31 +57,35 @@ = Once | Repeating Int -- ^ Field specifies how long (months) discount is in effect | Forever- | UnknownDuration String- deriving Show+ | UnknownDuration T.Text+ deriving (Show, Eq) -- | Represents the percent off that is applied by a coupon. This must be -- between 1 and 100.-newtype CpnPercentOff = CpnPercentOff { unCpnPercentOff :: Int } deriving Show+newtype CpnPercentOff = CpnPercentOff { unCpnPercentOff :: Int } deriving (Show, Eq) -- | A positive number representing the maximum number of times that a coupon--- can be redeemed. -newtype CpnMaxRedeems = CpnMaxRedeems { unCpnMaxRedeems :: Int } deriving Show+-- can be redeemed.+newtype CpnMaxRedeems = CpnMaxRedeems { unCpnMaxRedeems :: Int } deriving (Show, Eq) -- | UTC timestamp specifying the last time at which the coupon can be -- redeemed.-newtype CpnRedeemBy = CpnRedeemBy { unCpnRedeemBy :: Int } deriving Show+newtype CpnRedeemBy = CpnRedeemBy { unCpnRedeemBy :: Int } deriving (Show, Eq) -- | Creates a 'Coupon' in the Stripe system.-createCoupon :: MonadIO m => Coupon -> Maybe CpnMaxRedeems -> Maybe CpnRedeemBy- -> StripeT m ()+createCoupon+ :: MonadIO m+ => Coupon+ -> Maybe CpnMaxRedeems+ -> Maybe CpnRedeemBy+ -> StripeT m () createCoupon c mmr mrb = query_ (cpnRq []) { sMethod = POST, sData = fdata } where fdata = poff:cpnDurationKV (cpnDuration c) ++ optionalArgs odata- poff = ("percent_off", show . unCpnPercentOff . cpnPercentOff $ c)- odata = [ ("id", unCpnId <$> cpnId c)- , ("max_redemptions", show . unCpnMaxRedeems <$> mmr)- , ("redeem_by", show . unCpnRedeemBy <$> mrb)+ poff = ("percent_off", showByteString . unCpnPercentOff . cpnPercentOff $ c)+ odata = [ ("id", (textToByteString . unCpnId) <$> cpnId c)+ , ("max_redemptions", showByteString . unCpnMaxRedeems <$> mmr)+ , ("redeem_by", showByteString . unCpnRedeemBy <$> mrb) ] -- | Retrieves a specific 'Coupon' based on its 'CpnId'.@@ -90,14 +98,11 @@ -- * number of charges, via 'Count' and -- * page of results, via 'Offset'. getCoupons :: MonadIO m => Maybe Count -> Maybe Offset -> StripeT m [Coupon]-getCoupons mc mo = do- (_, rsp) <- query (cpnRq []) { sQString = qs }- either err return . resultToEither . valFromObj "data" $ rsp- where- qs = optionalArgs [ ("count", show . unCount <$> mc)- , ("offset", show . unOffset <$> mo)- ]- err _ = throwError $ strMsg "Unable to parse coupon list."+getCoupons mc mo = liftM snd $ queryData (cpnRq []) { sQString = qs }+ where+ qs = optionalArgs [ ("count", show . unCount <$> mc)+ , ("offset", show . unOffset <$> mo)+ ] -- | Deletes a 'Coupon' if it exists. If it does not, an -- 'InvalidRequestError' will be thrown indicating this.@@ -110,22 +115,20 @@ -- | Deletes a 'Coupon', identified by its 'CpnId', if it exists. If it -- does not, an 'InvalidRequestError' will be thrown indicating this. delCouponById :: MonadIO m => CpnId -> StripeT m Bool-delCouponById (CpnId cid) = query (cpnRq [cid]) { sMethod = DELETE } >>=- either err return . resultToEither . valFromObj "deleted" . snd- where err _ = throwError $ strMsg "Unable to parse coupon delete."+delCouponById (CpnId cid) = liftM snd $ queryData (cpnRq [cid]) { sMethod = DELETE } --- | Convenience function to create a 'SRequest' specific to coupon-related+-- | Convenience function to create a 'StripeRequest' specific to coupon-related -- actions.-cpnRq :: [String] -> SRequest+cpnRq :: [T.Text] -> StripeRequest cpnRq pcs = baseSReq { sDestination = "coupons":pcs } -- | Returns a list of key-value pairs representing duration specifications for -- use as input in the Stripe API.-cpnDurationKV :: CpnDuration -> [ (String, String) ]-cpnDurationKV d@(Repeating m) = [ ("duration", fromCpnDuration d)- , ("duration_in_months", show m)+cpnDurationKV :: CpnDuration -> [ (B.ByteString, B.ByteString) ]+cpnDurationKV d@(Repeating m) = [ ("duration", textToByteString $ fromCpnDuration d)+ , ("duration_in_months", showByteString m) ]-cpnDurationKV d = [ ("duration", fromCpnDuration d) ]+cpnDurationKV d = [ ("duration", textToByteString $ fromCpnDuration d) ] ------------------ -- JSON Parsing --@@ -133,7 +136,7 @@ -- | Converts a 'CpnDuration' to a string for input into the Stripe API. For -- 'UnknownDuration's, the original interval code will be used.-fromCpnDuration :: CpnDuration -> String+fromCpnDuration :: CpnDuration -> T.Text fromCpnDuration Once = "once" fromCpnDuration (Repeating _) = "repeating" fromCpnDuration Forever = "forever"@@ -141,22 +144,21 @@ -- | Convert a string to a 'CpnDuration'. Used for parsing output from the -- Stripe API.-toCpnDuration :: String -> Maybe Int -> CpnDuration-toCpnDuration d Nothing = case map toLower d of+toCpnDuration :: T.Text -> Maybe Int -> CpnDuration+toCpnDuration d Nothing = case T.map toLower d of "once" -> Once "forever" -> Forever _ -> UnknownDuration d-toCpnDuration d (Just ms) = case map toLower d of+toCpnDuration d (Just ms) = case T.map toLower d of "repeating" -> Repeating ms _ -> UnknownDuration d -- | Attempts to parse JSON into a 'Coupon'.-instance JSON Coupon where- readJSON (JSObject c) = do- drn <- jGet c "duration"- drns <- mjGet c "duration_in_months"- Coupon `liftM` (return . Just . CpnId =<< jGet c "id")- `ap` return (toCpnDuration drn drns)- `ap` (return . CpnPercentOff =<< jGet c "percent_off")- readJSON _ = Error "Unable to read Stripe coupon."- showJSON _ = undefined+instance FromJSON Coupon where+ parseJSON (Object c) = do+ drn <- c .: "duration"+ drns <- c .: "duration_in_months"+ cId <- c .:? "id"+ pctOff <- c .: "percent_off"+ return $ Coupon (CpnId <$> cId) (toCpnDuration drn drns) (CpnPercentOff pctOff)+ parseJSON _ = mzero
src/Web/Stripe/Customer.hs view
@@ -1,10 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+ module Web.Stripe.Customer- ( Customer(..)+ ( Customer(..) , CustomerId(..) , Email(..) , createCustomer+ , createCustomerByTokenId , updateCustomer , updateCustomerById+ , updateCustomerByTokenId+ , updateCustomerByIdByTokenId , getCustomer , getCustomers , delCustomer@@ -15,28 +20,27 @@ , Offset(..) , Description(..) , UTCTime(..)- , SConfig(..)+ , StripeConfig(..) , StripeT(StripeT) , runStripeT ) where -import Control.Applicative ( (<$>) )-import Control.Monad ( liftM, ap )-import Control.Monad.Error ( Error, MonadIO, MonadError, throwError, strMsg )-import Data.Maybe ( fromMaybe )-import Text.JSON ( Result(..), JSON(..), JSValue(..), resultToEither- , valFromObj- )-import Web.Stripe.Card ( Card, RequestCard, rCardKV )-import Web.Stripe.Client ( StripeT(..), SConfig(..), SRequest(..)- , StdMethod(..), baseSReq, query, runStripeT- )-import Web.Stripe.Coupon ( CpnId(..) )-import Web.Stripe.Plan ( PlanId(..) )-import Web.Stripe.Utils ( Count(..), Offset(..), Description(..)- , UTCTime(..), fromSeconds, jGet, mjGet- , optionalArgs- )+import Control.Applicative ((<$>), (<*>))+import Control.Monad (liftM, mzero)+import Control.Monad.Error (MonadIO)+import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?))+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Web.Stripe.Card (Card, RequestCard, rCardKV)+import Web.Stripe.Client (StdMethod (..), StripeConfig (..),+ StripeRequest (..), StripeT (..),+ baseSReq, query, queryData, runStripeT)+import Web.Stripe.Coupon (CpnId (..))+import Web.Stripe.Plan (PlanId (..))+import Web.Stripe.Token (TokenId (..))+import Web.Stripe.Utils (Count (..), Description (..), Offset (..),+ UTCTime (..), fromSeconds, optionalArgs,+ showByteString, textToByteString) ---------------- -- Data Types --@@ -44,19 +48,19 @@ -- | Represents a customer in the Stripe system. data Customer = Customer- { custId :: CustomerId- , custEmail :: Email- , custDescription :: Maybe Description- , custLive :: Bool- , custCreated :: UTCTime- , custActiveCard :: Maybe Card+ { custId :: CustomerId+ , custEmail :: Email+ , custDescription :: Maybe Description+ , custLive :: Bool+ , custCreated :: UTCTime+ , custActiveCard :: Maybe Card } deriving Show -- | Represents a 'Customer'\'s ID in the Stripe system.-newtype CustomerId = CustomerId { unCustomerId :: String } deriving Show+newtype CustomerId = CustomerId { unCustomerId :: T.Text } deriving (Show, Eq) -- | Represents a standard email address.-newtype Email = Email { unEmail :: String } deriving Show+newtype Email = Email { unEmail :: T.Text } deriving (Show, Eq) -- | Create a new 'Customer' in the Stripe system. createCustomer :: MonadIO m => Maybe RequestCard -> Maybe CpnId -> Maybe Email@@ -66,13 +70,29 @@ snd `liftM` query (customerRq []) { sMethod = POST, sData = fdata } where fdata = fromMaybe [] (rCardKV <$> mrc) ++ optionalArgs odata- odata = [ ("coupon", unCpnId <$> mcid)- , ("email", unEmail <$> me)- , ("description", unDescription <$> md)- , ("plan", unPlanId <$> mpid)- , ("trial_end", show <$> mtime)+ odata = [ ("coupon", textToByteString . unCpnId <$> mcid)+ , ("email", textToByteString . unEmail <$> me)+ , ("description", textToByteString . unDescription <$> md)+ , ("plan", textToByteString . unPlanId <$> mpid)+ , ("trial_end", showByteString <$> mtime) ] +-- | Create a new 'Customer' in the Stripe system using a TokenId.+createCustomerByTokenId :: MonadIO m => Maybe TokenId -> Maybe CpnId -> Maybe Email+ -> Maybe Description -> Maybe PlanId -> Maybe Int+ -> StripeT m Customer+createCustomerByTokenId mrt mcid me md mpid mtime =+ snd `liftM` query (customerRq []) { sMethod = POST, sData = optionalArgs odata }+ where+ odata = [ ("card", textToByteString . unTokenId <$> mrt)+ , ("coupon", textToByteString . unCpnId <$> mcid)+ , ("email", textToByteString . unEmail <$> me)+ , ("description", textToByteString . unDescription <$> md)+ , ("plan", textToByteString . unPlanId <$> mpid)+ , ("trial_end", showByteString <$> mtime)+ ]++ -- | Update an existing 'Customer' in the Stripe system. updateCustomer :: MonadIO m => Customer -> Maybe RequestCard -> Maybe CpnId -> Maybe Email -> Maybe Description -> StripeT m Customer@@ -87,11 +107,31 @@ snd `liftM` query (customerRq [cid]) { sMethod = POST, sData = fdata } where fdata = fromMaybe [] (rCardKV <$> mrc) ++ optionalArgs odata- odata = [ ("coupon", unCpnId <$> mcid)- , ("email", unEmail <$> me)- , ("description", unDescription <$> md)+ odata = [ ("coupon", textToByteString . unCpnId <$> mcid)+ , ("email", textToByteString . unEmail <$> me)+ , ("description", textToByteString . unDescription <$> md) ] +-- | Update an existing 'Customer' in the Stripe system.+updateCustomerByTokenId :: MonadIO m => Customer -> Maybe TokenId -> Maybe CpnId+ -> Maybe Email -> Maybe Description -> StripeT m Customer+updateCustomerByTokenId = updateCustomerByIdByTokenId . custId++-- | Update an existing 'Customer', identified by 'CustomerId', in the Stripe+-- system.+updateCustomerByIdByTokenId :: MonadIO m => CustomerId -> Maybe TokenId+ -> Maybe CpnId -> Maybe Email -> Maybe Description+ -> StripeT m Customer+updateCustomerByIdByTokenId (CustomerId cid) mrt mcid me md =+ snd `liftM` query (customerRq [cid]) { sMethod = POST, sData = optionalArgs odata }+ where+ odata = [ ("card", textToByteString . unTokenId <$> mrt)+ , ("coupon", textToByteString . unCpnId <$> mcid)+ , ("email", textToByteString . unEmail <$> me)+ , ("description", textToByteString . unDescription <$> md)+ ]++ -- | Retrieves a specific 'Customer' based on its 'CustomerId'. getCustomer :: MonadIO m => CustomerId -> StripeT m Customer getCustomer (CustomerId cid) =@@ -103,14 +143,11 @@ -- * number of charges, via 'Count' and -- * page of results, via 'Offset'. getCustomers :: MonadIO m => Maybe Count -> Maybe Offset -> StripeT m [Customer]-getCustomers mc mo = do- (_, rsp) <- query $ (customerRq []) { sQString = qstring }- either err return . resultToEither . valFromObj "data" $ rsp+getCustomers mc mo = liftM snd $ queryData ((customerRq []) { sQString = qstring }) where qstring = optionalArgs [ ("count", show . unCount <$> mc) , ("offset", show . unOffset <$> mo) ]- err _ = throwError $ strMsg "Unable to parse customer list." -- | Deletes a 'Customer' if it exists. If it does not, an -- 'InvalidRequestError' will be thrown indicating this.@@ -120,15 +157,12 @@ -- | Deletes a 'Customer', identified by its 'CustomerId', if it exists. If it -- does not, an 'InvalidRequestError' will be thrown indicating this. delCustomerById :: MonadIO m => CustomerId -> StripeT m Bool-delCustomerById (CustomerId cid) = query req >>=- either err return . resultToEither . valFromObj "deleted" . snd- where- err _ = throwError $ strMsg "Unable to parse customer delete."- req = (customerRq [cid]) { sMethod = DELETE }+delCustomerById (CustomerId cid) = liftM snd $ queryData req+ where req = (customerRq [cid]) { sMethod = DELETE } --- | Convenience function to create a 'SRequest' specific to customer-related+-- | Convenience function to create a 'StripeRequest' specific to customer-related -- actions.-customerRq :: [String] -> SRequest+customerRq :: [T.Text] -> StripeRequest customerRq pcs = baseSReq { sDestination = "customers":pcs } ------------------@@ -136,13 +170,12 @@ ------------------ -- | Attempts to parse JSON into a 'Customer'.-instance JSON Customer where- readJSON (JSObject c) =- Customer `liftM` (CustomerId <$> jGet c "id")- `ap` (Email <$> jGet c "email")- `ap` ((Description <$>) <$> mjGet c "description")- `ap` jGet c "livemode"- `ap` (fromSeconds <$> jGet c "created")- `ap` mjGet c "active_card"- readJSON _ = Error "Unable to read Stripe customer."- showJSON _ = undefined+instance FromJSON Customer where+ parseJSON (Object o) = Customer+ <$> (CustomerId <$> o .: "id")+ <*> (Email <$> o .: "email")+ <*> (fmap . fmap) Description (o .:? "description")+ <*> o .: "livemode"+ <*> (fromSeconds <$> o .: "created")+ <*> o .:? "active_card"+ parseJSON _ = mzero
src/Web/Stripe/Plan.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Web.Stripe.Plan ( Plan(..) , PlanInterval(..)@@ -14,25 +16,24 @@ , Count(..) , Currency(..) , Offset(..)- , SConfig(..)+ , StripeConfig(..) , StripeT(StripeT) , runStripeT ) where -import Control.Applicative ( (<$>) )-import Control.Monad ( liftM, ap )-import Control.Monad.Error ( MonadIO, throwError, strMsg )-import Data.Char ( toLower )-import Network.HTTP.Types ( StdMethod(..) )-import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject)- , resultToEither, valFromObj- )-import Web.Stripe.Client ( StripeT(..), SConfig(..), SRequest(..), baseSReq- , query, query_, runStripeT- )-import Web.Stripe.Utils ( Amount(..), Count(..), Currency(..), Offset(..)- , jGet, mjGet, optionalArgs- )+import Control.Applicative ((<$>), (<*>))+import Control.Monad (liftM, mzero)+import Control.Monad.Error (MonadIO)+import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?))+import Data.Char (toLower)+import qualified Data.Text as T+import Network.HTTP.Types (StdMethod (..))+import Web.Stripe.Client (StripeConfig (..), StripeRequest (..),+ StripeT (..), baseSReq, query, queryData,+ query_, runStripeT)+import Web.Stripe.Utils (Amount (..), Count (..), Currency (..),+ Offset (..), optionalArgs, showByteString,+ textToByteString) ---------------- -- Data Types --@@ -43,7 +44,7 @@ { planId :: PlanId , planAmount :: Amount , planInterval :: PlanInterval- , planName :: String+ , planName :: T.Text , planCurrency :: Currency , planTrialDays :: Maybe PlanTrialDays } deriving Show@@ -51,34 +52,34 @@ -- | Represents the billing cycle for a plan. If an interval identifier is not -- known, 'UnknownPlan' is used to carry the original identifier supplied by -- Stripe.-data PlanInterval = Monthly | Yearly | UnknownPlan String deriving Show+data PlanInterval = Monthly | Yearly | UnknownPlan T.Text deriving (Show, Eq) -- | Represents the identifier for a given 'Plan' in the Stripe system.-newtype PlanId = PlanId { unPlanId :: String } deriving Show+newtype PlanId = PlanId { unPlanId :: T.Text } deriving (Show, Eq) -- | Represents the length of the trial period. That is, the number of days -- before the customer is billed.-newtype PlanTrialDays = PlanTrialDays { unPlanTrialDays :: Int } deriving Show+newtype PlanTrialDays = PlanTrialDays { unPlanTrialDays :: Int } deriving (Show, Eq) -- | Creates a 'Plan' in the Stripe system. createPlan :: MonadIO m => Plan -> StripeT m () createPlan p = query_ (planRq []) { sMethod = POST, sData = fdata } where fdata = pdata ++ optionalArgs odata- pdata = [ ("id", unPlanId $ planId p)- , ("amount", show . unAmount $ planAmount p)- , ("interval", fromPlanInterval $ planInterval p)- , ("name", planName p)- , ("currency", unCurrency $ planCurrency p)+ pdata = [ ("id", textToByteString . unPlanId $ planId p)+ , ("amount", showByteString . unAmount $ planAmount p)+ , ("interval", textToByteString . fromPlanInterval $ planInterval p)+ , ("name", textToByteString $ planName p)+ , ("currency", textToByteString . unCurrency $ planCurrency p) ] odata = [ ( "trial_period_days"- , show . unPlanTrialDays <$> planTrialDays p+ , showByteString . unPlanTrialDays <$> planTrialDays p ) ] -- | Retrieves a specific 'Plan' based on its 'PlanId'. getPlan :: MonadIO m => PlanId -> StripeT m Plan-getPlan (PlanId pid) = return . snd =<< query (planRq [pid])+getPlan (PlanId pid) = liftM snd $ query (planRq [pid]) -- | Retrieves a list of all 'Plan's. The query can optionally be refined to -- a specific:@@ -86,14 +87,11 @@ -- * number of charges, via 'Count' and -- * page of results, via 'Offset'. getPlans :: MonadIO m => Maybe Count -> Maybe Offset -> StripeT m [Plan]-getPlans mc mo = do- (_, rsp) <- query (planRq []) { sQString = qs }- either err return . resultToEither . valFromObj "data" $ rsp- where- qs = optionalArgs [ ("count", show . unCount <$> mc)- , ("offset", show . unOffset <$> mo)- ]- err _ = throwError $ strMsg "Unable to parse plan list."+getPlans mc mo = liftM snd $ queryData (planRq []) { sQString = qs }+ where+ qs = optionalArgs [ ("count", show . unCount <$> mc)+ , ("offset", show . unOffset <$> mo)+ ] -- | Deletes a 'Plan' if it exists. If it does not, an 'InvalidRequestError' -- will be thrown indicating this.@@ -103,44 +101,39 @@ -- | Deletes a 'Plan', identified by its 'PlanId', if it exists. If it does -- not, an 'InvalidRequestError' will be thrown indicating this. delPlanById :: MonadIO m => PlanId -> StripeT m Bool-delPlanById (PlanId pid) = query req >>=- either err return . resultToEither . valFromObj "deleted" . snd- where- err _ = throwError $ strMsg "Unable to parse plan delete."- req = (planRq [pid]) { sMethod = DELETE }+delPlanById (PlanId pid) = liftM snd $ queryData (planRq [pid]) { sMethod = DELETE } --- | Convenience function to create a 'SRequest' specific to plan-related+-- | Convenience function to create a 'StripeRequest' specific to plan-related -- actions.-planRq :: [String] -> SRequest+planRq :: [T.Text] -> StripeRequest planRq pcs = baseSReq { sDestination = "plans":pcs } ------------------ -- JSON Parsing -- ------------------ --- | Converts a 'PlanInterval' to a string for input into the Stripe API. For+-- | Converts a 'PlanInterval' to a T.Text for input into the Stripe API. For -- 'UnknownPlan's, the original interval code will be used.-fromPlanInterval :: PlanInterval -> String+fromPlanInterval :: PlanInterval -> T.Text fromPlanInterval Monthly = "month" fromPlanInterval Yearly = "year" fromPlanInterval (UnknownPlan p) = p --- | Convert a string to a 'PlanInterval'. Used for parsing output from the+-- | Convert a T.Text to a 'PlanInterval'. Used for parsing output from the -- Stripe API.-toPlanInterval :: String -> PlanInterval-toPlanInterval p = case map toLower p of+toPlanInterval :: T.Text -> PlanInterval+toPlanInterval p = case T.map toLower p of "month" -> Monthly "year" -> Yearly _ -> UnknownPlan p -- | Attempts to parse JSON into a 'Plan'.-instance JSON Plan where- readJSON (JSObject c) =- Plan `liftM` (PlanId <$> jGet c "id")- `ap` (Amount <$> jGet c "amount")- `ap` (toPlanInterval <$> jGet c "interval")- `ap` jGet c "name"- `ap` (Currency <$> jGet c "currency")- `ap` ((PlanTrialDays <$>) <$> mjGet c "trial_period_days")- readJSON _ = Error "Unable to read Stripe plan."- showJSON _ = undefined+instance FromJSON Plan where+ parseJSON (Object o) = Plan+ <$> (PlanId <$> o .: "id")+ <*> (Amount <$> o .: "amount")+ <*> (toPlanInterval <$> o .: "interval")+ <*> o .: "name"+ <*> (Currency <$> o .: "currency")+ <*> ((PlanTrialDays <$>) <$> o .:? "trial_period_days")+ parseJSON _ = mzero
src/Web/Stripe/Subscription.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Web.Stripe.Subscription ( Subscription(..) , SubStatus(..)@@ -10,59 +12,62 @@ {- Re-Export -} , UTCTime(..)- , SConfig(..)+ , StripeConfig(..) , StripeT(StripeT) , runStripeT ) where -import Control.Applicative ( (<$>) )-import Control.Monad ( liftM, ap )-import Control.Monad.Error ( MonadIO )-import Data.Char ( toLower )-import Network.HTTP.Types ( StdMethod(..) )-import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject) )-import Web.Stripe.Card ( RequestCard, rCardKV )-import Web.Stripe.Client ( StripeT(..), SConfig(..), SRequest(..), baseSReq- , query, runStripeT- )-import Web.Stripe.Coupon ( CpnId(..) )-import Web.Stripe.Customer ( CustomerId(..) )-import Web.Stripe.Token ( TokenId(..) )-import Web.Stripe.Plan ( Plan, PlanId(..) )-import Web.Stripe.Utils ( UTCTime(..), fromSeconds, jGet, optionalArgs )+import Control.Monad (liftM, mzero)+import Control.Monad.Error (MonadIO)+import Data.Char (toLower)+import Network.HTTP.Types (StdMethod (..))+import Web.Stripe.Card (RequestCard, rCardKV)+import Web.Stripe.Client (StripeConfig (..), StripeRequest (..),+ StripeT (..), baseSReq, query, runStripeT)+import Web.Stripe.Coupon (CpnId (..))+import Web.Stripe.Customer (CustomerId (..))+import Web.Stripe.Plan (Plan, PlanId (..))+import Web.Stripe.Token (TokenId (..))+import Web.Stripe.Utils (UTCTime (..), fromSeconds, optionalArgs,+ showByteString, textToByteString) +import Control.Applicative ((<$>), (<*>))+import Data.Aeson (FromJSON (..), Value (..), (.:))+import qualified Data.ByteString as B+import qualified Data.Text as T+ ------------------ -- Subsriptions -- ------------------ -- | Represents a subscription in the Stripe API. data Subscription = Subscription- { subCustomerId :: CustomerId- , subPlan :: Plan- , subStatus :: SubStatus- , subStart :: UTCTime- , subTrialStart :: UTCTime- , subTrialEnd :: UTCTime- , subPeriodStart :: UTCTime -- ^ Current period start- , subPeriodEnd :: UTCTime -- ^ Current period end+ { subCustomerId :: CustomerId+ , subPlan :: Plan+ , subStatus :: SubStatus+ , subStart :: UTCTime+ , subTrialStart :: UTCTime+ , subTrialEnd :: UTCTime+ , subPeriodStart :: UTCTime -- ^ Current period start+ , subPeriodEnd :: UTCTime -- ^ Current period end } deriving Show -- | Describes the various stages that a data SubStatus = Trialing | Active | PastDue | Unpaid | Canceled- | UnknownStatus String deriving Show+ | UnknownStatus T.Text deriving (Show, Eq) -- | A boolean flag that determines whether or not to prorate switching plans -- during a billing cycle.-newtype SubProrate = SubProrate { unSubProrate :: Bool } deriving Show+newtype SubProrate = SubProrate { unSubProrate :: Bool } deriving (Show, Eq) -- | UTC integer timestamp representing the end of the trial period that the -- customer receives before being charged for the first time.-newtype SubTrialEnd = SubTrialEnd { unSubTrialEnd :: Int } deriving Show+newtype SubTrialEnd = SubTrialEnd { unSubTrialEnd :: Int } deriving (Show, Eq) -- | A boolean flag that determines whether or not the cancellation of the -- 'Subscription' should be delayed until the end of the current period. newtype SubAtPeriodEnd = SubAtPeriodEnd { unSubAtPeriodEnd :: Bool }- deriving Show+ deriving (Show, Eq) -- | Update the subscription associated with a 'Customer', identified by -- 'CustomerId', in the Stripe system.@@ -79,19 +84,19 @@ updateSubToken :: MonadIO m => TokenId -> CustomerId -> PlanId -> Maybe CpnId -> Maybe SubProrate -> Maybe SubTrialEnd -> StripeT m Subscription-updateSubToken (TokenId tid) = updateSub [("token", tid)]+updateSubToken (TokenId tid) = updateSub [("token", textToByteString tid)] -- | Internal convenience function to update a 'Subscription'.-updateSub :: MonadIO m => [(String, String)] -> CustomerId -> PlanId+updateSub :: MonadIO m => [(B.ByteString, B.ByteString)] -> CustomerId -> PlanId -> Maybe CpnId -> Maybe SubProrate -> Maybe SubTrialEnd -> StripeT m Subscription updateSub sdata cid pid mcpnid mspr mste = snd `liftM` query (subRq cid []) { sMethod = POST, sData = fdata } where- fdata = ("plan", unPlanId pid) : sdata ++ optionalArgs odata- odata = [ ("coupon", unCpnId <$> mcpnid)- , ("prorate", show . unSubProrate <$> mspr)- , ("trial_end", show . unSubTrialEnd <$> mste)+ fdata = ("plan", textToByteString $ unPlanId pid) : sdata ++ optionalArgs odata+ odata = [ ("coupon", textToByteString . unCpnId <$> mcpnid)+ , ("prorate", showByteString . unSubProrate <$> mspr)+ , ("trial_end", showByteString . unSubTrialEnd <$> mste) ] -- | Cancels the 'Subscription' associated with a 'Customer', identified by@@ -100,11 +105,11 @@ -> StripeT m Subscription cancelSub cid mspe = snd `liftM` query (subRq cid []) { sMethod = DELETE, sData = optionalArgs odata }- where odata = [("at_period_end", show . unSubAtPeriodEnd <$> mspe)]+ where odata = [("at_period_end", showByteString . unSubAtPeriodEnd <$> mspe)] --- | Convenience function to create a 'SRequest' specific to+-- | Convenience function to create a 'StripeRequest' specific to -- subscription-related actions.-subRq :: CustomerId -> [String] -> SRequest+subRq :: CustomerId -> [T.Text] -> StripeRequest subRq (CustomerId cid) pcs = baseSReq { sDestination = "customers":cid:"subscription":pcs } @@ -114,8 +119,8 @@ -- | Convert a string to a 'SubStatus'. If the code is not known, -- 'UnkownStatus' will be returned with the originally provided code.-toSubStatus :: String -> SubStatus-toSubStatus s = case map toLower s of+toSubStatus :: T.Text -> SubStatus+toSubStatus s = case T.map toLower s of "trialing" -> Trialing "active" -> Active "past_due" -> PastDue@@ -124,15 +129,14 @@ _ -> UnknownStatus s -- | Attempts to parse JSON into a 'Subscription'.-instance JSON Subscription where- readJSON (JSObject c) =- Subscription `liftM` (CustomerId <$> jGet c "customer")- `ap` jGet c "plan"- `ap` (toSubStatus <$> jGet c "status")- `ap` (fromSeconds <$> jGet c "start")- `ap` (fromSeconds <$> jGet c "trial_start")- `ap` (fromSeconds <$> jGet c "trial_end")- `ap` (fromSeconds <$> jGet c "current_period_start")- `ap` (fromSeconds <$> jGet c "current_period_end")- readJSON _ = Error "Unable to read Stripe subscription."- showJSON _ = undefined+instance FromJSON Subscription where+ parseJSON (Object o) = Subscription+ <$> (CustomerId <$> o .: "customer")+ <*> o .: "plan"+ <*> (toSubStatus <$> o .: "status")+ <*> (fromSeconds <$> o .: "start")+ <*> (fromSeconds <$> o .: "trial_start")+ <*> (fromSeconds <$> o .: "trial_end")+ <*> (fromSeconds <$> o .: "current_period_start")+ <*> (fromSeconds <$> o .: "current_period_end")+ parseJSON _ = mzero
src/Web/Stripe/Token.hs view
@@ -1,31 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+ module Web.Stripe.Token ( Token(..) , TokenId(..) , createToken , getToken+ , tokRq {- Re-Export -} , UTCTime(..) , Amount(..) , Card(..) , Currency(..)- , SConfig(..)+ , StripeConfig(..) , StripeT(..) , runStripeT ) where -import Control.Applicative ( (<$>) )-import Control.Monad ( liftM, ap )-import Control.Monad.Error ( MonadIO )-import Network.HTTP.Types ( StdMethod(..) )-import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject) )-import Web.Stripe.Card ( Card(..), RequestCard(..), rCardKV )-import Web.Stripe.Client ( StripeT(..), SConfig(..), SRequest(..), baseSReq- , query, runStripeT- )-import Web.Stripe.Utils ( Amount(..), Currency(..), UTCTime(..), fromSeconds- , jGet, optionalArgs- )+import Control.Applicative ((<$>), (<*>))+import Control.Monad (liftM, mzero)+import Control.Monad.Error (MonadIO)+import Data.Aeson (FromJSON (..), Value (..), (.:))+import qualified Data.Text as T+import Network.HTTP.Types (StdMethod (..))+import Web.Stripe.Card (Card (..), RequestCard (..), rCardKV)+import Web.Stripe.Client (StripeConfig (..), StripeRequest (..),+ StripeT (..), baseSReq, query, runStripeT)+import Web.Stripe.Utils (Amount (..), Currency (..), UTCTime (..),+ fromSeconds) ---------------- -- Data Types --@@ -33,35 +35,27 @@ -- | Represents a token in the Stripe system. data Token = Token- { tokId :: TokenId- , tokLive :: Bool- , tokUsed :: Bool- , tokCreated :: UTCTime- , tokAmount :: Amount- , tokCurrency :: Currency- , tokCard :: Card+ { tokId :: TokenId+ , tokLive :: Bool+ , tokUsed :: Bool+ , tokCreated :: UTCTime+ , tokCard :: Card } deriving Show -- | Represents the identifier for a given 'Token' in the Stripe system.-newtype TokenId = TokenId { unTokenId :: String } deriving Show+newtype TokenId = TokenId { unTokenId :: T.Text } deriving (Show, Eq) -- | Creates a 'Token' in the Stripe system.-createToken :: MonadIO m => RequestCard -> Maybe Amount -> Maybe Currency- -> StripeT m Token-createToken rc ma mc =- snd `liftM` query (tokRq []) { sMethod = POST, sData = fdata }- where- fdata = rCardKV rc ++ optionalArgs mdata- mdata = [ ("amount", show . unAmount <$> ma)- , ("currency", unCurrency <$> mc)- ]+createToken :: MonadIO m => RequestCard -> StripeT m Token+createToken rc =+ snd `liftM` query (tokRq []) { sMethod = POST, sData = rCardKV rc } -- | Retrieves a specific 'Token' based on its 'Token'. getToken :: MonadIO m => TokenId -> StripeT m Token getToken (TokenId tid) = return . snd =<< query (tokRq [tid]) --- | Convenience function to create a 'SRequest' specific to tokens.-tokRq :: [String] -> SRequest+-- | Convenience function to create a 'StripeRequest' specific to tokens.+tokRq :: [T.Text] -> StripeRequest tokRq pcs = baseSReq { sDestination = "tokens":pcs } ------------------@@ -69,14 +63,11 @@ ------------------ -- | Attempts to parse JSON into a 'Token'.-instance JSON Token where- readJSON (JSObject c) =- Token `liftM` (TokenId <$> jGet c "id")- `ap` jGet c "livemode"- `ap` jGet c "used"- `ap` (fromSeconds <$> jGet c "created")- `ap` (Amount <$> jGet c "amount")- `ap` (Currency <$> jGet c "currency")- `ap` jGet c "card"- readJSON _ = Error "Unable to read Stripe token."- showJSON _ = undefined+instance FromJSON Token where+ parseJSON (Object o) = Token+ <$> (TokenId <$> o .: "id")+ <*> o .: "livemode"+ <*> o .: "used"+ <*> (fromSeconds <$> o .: "created")+ <*> o .: "card"+ parseJSON _ = mzero
src/Web/Stripe/Utils.hs view
@@ -5,44 +5,55 @@ , Description(..) , Offset(..) , optionalArgs- , jGet- , mjGet- {- Re-Export -} , UTCTime(..) , fromSeconds , toSeconds+ , stringToByteString+ , textToByteString+ , showByteString ) where -import Data.Time.Clock ( UTCTime(..) )-import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, utcTimeToPOSIXSeconds- )-import Data.Time.Format ( ) -- imports Show instance for UTCTime-import Text.JSON ( Result(..), JSObject, JSON(..), JSValue(..)- , resultToEither, valFromObj- )+import qualified Codec.Binary.UTF8.String as CodecUtf8+import Control.Monad (liftM)+import qualified Data.ByteString as B+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Data.Time.Clock (UTCTime (..))+import Data.Time.Clock.POSIX (posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds)+import Data.Time.Format () +showByteString :: Show a => a -> B.ByteString+showByteString = stringToByteString . show++textToByteString :: T.Text -> B.ByteString+textToByteString = B.pack . CodecUtf8.encode . T.unpack++stringToByteString :: String -> B.ByteString+stringToByteString = B.pack . CodecUtf8.encode+ ----------------------- -- Common Data Types -- ----------------------- -- | Represents an amount in cents in the Stripe system.-newtype Amount = Amount { unAmount :: Int } deriving Show+newtype Amount = Amount { unAmount :: Int } deriving (Show, Eq) -- | A maximum number of objects that the Stripe API will return. This value -- should be between 1 and 100, inclusive.-newtype Count = Count { unCount :: Int } deriving Show+newtype Count = Count { unCount :: Int } deriving (Show, Eq) -- | Represents a currency (e.g., "usd") in the Stripe system. This is -- a 3-letter ISO code.-newtype Currency = Currency { unCurrency :: String } deriving Show+newtype Currency = Currency { unCurrency :: T.Text } deriving (Show, Eq) -- | Describes an object in the Stripe system.-newtype Description = Description { unDescription :: String } deriving Show+newtype Description = Description { unDescription :: T.Text } deriving (Show, Eq) -- | A positive integer that is an offset into the array of objects returned -- by the Stripe API.-newtype Offset = Offset { unOffset :: Int } deriving Show+newtype Offset = Offset { unOffset :: Int } deriving (Show, Eq) ----------------------- -- Utility Functions --@@ -64,16 +75,5 @@ -- -- >>> optionalArgs [("k1", Just "supplied"), ("k2", Nothing)] -- [("k1","supplied")]-optionalArgs :: [(String, Maybe String)] -> [(String, String)]-optionalArgs [] = []-optionalArgs ((_, Nothing):xs) = optionalArgs xs-optionalArgs ((a, Just b):xs) = (a, b):optionalArgs xs---- | Convenience function to get a field from a given 'JSON' object.-jGet :: JSON a => JSObject JSValue -> String -> Result a-jGet = flip valFromObj---- | Attempts to retrieve a field from a given 'JSON' object, failing--- gracefully with 'Nothing' if such a field is not found.-mjGet :: JSON a => JSObject JSValue -> String -> Result (Maybe a)-mjGet obj = return . either (\_ -> Nothing) Just . resultToEither . jGet obj+optionalArgs :: [(a, Maybe b)] -> [(a, b)]+optionalArgs = mapMaybe . uncurry $ liftM . (,)
stripe.cabal view
@@ -1,12 +1,12 @@ Name: stripe-Version: 0.1+Version: 0.3.0.1 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 License: BSD3 License-file: LICENSE Author: Spearhead Development, L.L.C.-Maintainer: Michael Schade <michael@spearheaddev.com>+Maintainer: Michael Schade <m@mschade.me> Copyright: (c) 2011 Spearhead Development, L.L.C. Category: Web Build-type: Simple@@ -20,6 +20,7 @@ Exposed-modules: Web.Stripe.Card , Web.Stripe.Charge , Web.Stripe.Client+ , Web.Stripe.Connect , Web.Stripe.Coupon , Web.Stripe.Customer , Web.Stripe.Plan@@ -27,11 +28,13 @@ , Web.Stripe.Token , Web.Stripe.Utils Build-depends: base >= 3 && < 5- , text == 0.11.*- , json >= 0.3.6- , network == 2.3.*+ , text >= 0.11+ , aeson >= 0.6.1+ , unordered-containers >= 0.1.4.6 , time >= 1.0- , http-types >= 0.2.0- , curl >= 1.3.4- , mtl >= 1.1.0.0+ , http-conduit >= 1.4.1.2+ , http-types >= 0.6.11 , bytestring >= 0.9+ , mtl >= 2.1+ , utf8-string >= 0.3.7+ extensions: OverloadedStrings, TupleSections