stripe (empty) → 0.1
raw patch · 13 files changed
+1499/−0 lines, 13 filesdep +basedep +bytestringdep +curlsetup-changed
Dependencies added: base, bytestring, curl, http-types, json, mtl, network, text, time
Files
- LICENSE +30/−0
- README.mkd +64/−0
- Setup.hs +2/−0
- src/Web/Stripe/Card.hs +68/−0
- src/Web/Stripe/Charge.hs +179/−0
- src/Web/Stripe/Client.hs +364/−0
- src/Web/Stripe/Coupon.hs +162/−0
- src/Web/Stripe/Customer.hs +148/−0
- src/Web/Stripe/Plan.hs +146/−0
- src/Web/Stripe/Subscription.hs +138/−0
- src/Web/Stripe/Token.hs +82/−0
- src/Web/Stripe/Utils.hs +79/−0
- stripe.cabal +37/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011, Spearhead Development, L.L.C.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Spearhead Development, L.L.C. nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.mkd view
@@ -0,0 +1,64 @@+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].++**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/).++Example Usage+=============++```haskell+import Web.Stripe.Charge ( Charge(..), Amount(..), Count(..), Currency(..)+ , Offset(..), getCharges+ )+import Web.Stripe.Client ( APIKey(..), SConfig, defaultConfig, runStripeT )++conf :: SConfig+conf = defaultConfig $ APIKey ""++main :: IO ()+main = do+ amounts <- runStripeT conf $ do+ charges <- getCharges Nothing (Just $ Count 5) (Just $ Offset 1)+ return $ map getAmt charges+ either err (putStrLn . show) amounts+ where+ getAmt c = (unAmount $ chargeAmount c, unCurrency $ chargeCurrency c)+ err _ = putStrLn "Uh-oh! It didn't work :-("+```++Which produces the output along the lines of:+`[(842,"usd"),(2048,"usd"),(1010,"usd"),(4096,"usd"),(4200,"usd")]`.++Limitations+===========++* This package currently does not implement Stripe invoices.++Help+====++First, consult the Haddock and [Stripe API][sapi] docs to be certain you're+using the API correctly. It's a good idea to+[try another library](https://stripe.com/docs/libraries) first to see if it+works there. If you think you might be misunderstanding the API, or having an+issue with Stripe itself, it's best to+[contact them](https://stripe.com/help/contact).++If all of that fails, or if you otherwise think it's an issue with this+implementation of the API, please submit an issue here. Better yet, submit+a pull request with a proposed solution!++License+=======++I like the MIT license. See `LICENSE`.++[sapi]: https://stripe.com/docs/api "Stripe API"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Web/Stripe/Card.hs view
@@ -0,0 +1,68 @@+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 )++-- | Represents a credit card in the Stripe system.+data Card = Card+ { cardType :: String+ , cardCountry :: String+ , cardLastFour :: String+ , 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+ } 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 rc = fd ++ optionalArgs md+ where+ -- Required+ fd = [ ("card[number]", rCardNumber rc)+ , ("card[exp_month]", show $ rCardExpMonth rc)+ , ("card[exp_year]", show $ 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)+ ]++------------------+-- JSON Parsing --+------------------++-- | 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
+ src/Web/Stripe/Charge.hs view
@@ -0,0 +1,179 @@+module Web.Stripe.Charge+ ( Charge(..)+ , ChargeId(..)+ , chargeToken+ , chargeTokenById+ , chargeCustomer+ , chargeCustomerById+ , chargeRCard+ , getCharge+ , getCharges+ , partialRefund+ , partialRefundById+ , fullRefund+ , fullRefundById++ {- Re-Export -}+ , Amount(..)+ , Count(..)+ , Currency(..)+ , Description(..)+ , Offset(..)+ , UTCTime(..)+ , SConfig(..)+ , 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+ )++----------------+-- Data Types --+----------------++-- | Represents a charge in the Stripe system.+data Charge = Charge+ { chargeId :: ChargeId+ , chargeCreated :: UTCTime+ , chargeDescription :: Maybe Description+ , chargeCurrency :: Currency+ , chargeAmount :: Amount+ , chargeFee :: Int+ , chargeLive :: Bool+ , chargePaid :: Bool+ , chargeRefunded :: Bool+ , chargeCard :: Card+ } deriving Show++-- | Represents the identifier for a given 'Charge' in the Stripe system.+newtype ChargeId = ChargeId { unChargeId :: String } deriving Show++-- | Submit a 'Charge' to the Stripe API using an already constructed 'Token'.+chargeToken :: MonadIO m => Token -> Amount -> Currency+ -> Maybe Description -> 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)]++-- | 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+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)]++-- | 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+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 =+ 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)+ ]++-- | Retrieve a 'Charge' from the Stripe API, identified by 'ChargeId'.+getCharge :: MonadIO m => ChargeId -> StripeT m Charge+getCharge (ChargeId cid) = snd `liftM` query (chargeRq [cid])++-- | Retrieve a list of 'Charge's from the Stripe API. The query can optionally+-- be refined to a specific:+--+-- * number of charges, via 'Count',+-- * page of results, via 'Offset', and+-- * '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."++-- | Requests that Stripe issue a partial refund to a specific 'Charge' for a+-- particular 'Amount'.+partialRefund :: MonadIO m => Charge -> Amount -> StripeT m Charge+partialRefund = partialRefundById . chargeId++-- | Requests that Stripe issue a partial refund to a specific 'Charge',+-- identified by 'ChargeId', for a particular 'Amount'.+partialRefundById :: MonadIO m => ChargeId -> Amount -> StripeT m Charge+partialRefundById cid = refundChargeById cid . Just++-- | Requests that Stripe issue a full refund to a specific 'Charge'.+fullRefund :: MonadIO m => Charge -> StripeT m Charge+fullRefund = fullRefundById . chargeId++-- | Requests that Stripe issue a full refund to a specific 'Charge',+-- identified by 'ChargeId'.+fullRefundById :: MonadIO m => ChargeId -> StripeT m Charge+fullRefundById cid = refundChargeById cid Nothing++-- | Internal convenience function used to handle submitting a refund request+-- to Stripe.+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)]++-- | Convenience function to create a 'SRequest' specific to coupon-related+-- actions.+chargeRq :: [String] -> SRequest+chargeRq pcs = baseSReq { sDestination = "charges":pcs }++------------------+-- JSON Parsing --+------------------++-- | 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
+ src/Web/Stripe/Client.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Web.Stripe.Client+ ( SConfig(..)+ , APIKey(..)+ , SResponseCode(..)+ , SFailure(..)+ , SError(..)+ , SErrorCode(..)+ , SRequest(..)+ , Stripe+ , StripeT(StripeT)+ , defaultConfig+ , runStripeT+ , baseSReq+ , query+ , 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++------------------------+-- General Data Types --+------------------------++-- | Configuration for the 'StripeT' monad transformer.+data SConfig = SConfig+ { key :: APIKey+ , caFile :: FilePath+ } deriving Show++-- | A key used when authenticating to the Stripe API.+newtype APIKey = APIKey { unAPIKey :: String } 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+-- error codes, and so the same is true in this data type.+--+-- 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++-- | 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)+ | OtherFailure (Maybe Text)+ deriving Show++-- | Describes a 'SFailure' 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+-- error message should be displayed.+--+-- In case the appropriate error could not be determined from the specified+-- type, 'UnkownError' will be returned with the supplied type and message.+--+-- 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++-- | 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+ = InvalidNumber+ | IncorrectNumber+ | InvalidExpiryMonth+ | InvalidExpiryYear+ | InvalidCVC+ | ExpiredCard+ | InvalidAmount+ | IncorrectCVC+ | CardDeclined+ | Missing+ | DuplicateTransaction+ | ProcessingError+ | UnknownErrorCode Text -- ^ Could not be matched; text gives error name.+ deriving Show++-- | 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)]+ } deriving Show++------------------+-- Stripe Monad --+------------------++-- | A convenience specialization of the 'StripeT' monad transformer in which+-- the underlying monad is IO.+type Stripe a = StripeT IO a++-- | 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+ } deriving ( Functor, Monad, MonadIO, MonadPlus+ , MonadError SFailure+ , MonadState SConfig+ )++-- | Runs the 'StripeT' monad transformer with a given 'SConfig'. 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 cfg m =+ runErrorT . liftM fst . (`runStateT` cfg) . unStripeT $ m++--------------+-- Querying --+--------------++-- | Provides a default 'SConfig'. 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 ""++-- | The basic 'SRequest' 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+ { sMethod = GET+ , sDestination = []+ , sData = []+ , sQString = []+ }++-- | Queries the Stripe API. This returns the response body along with the+-- 'SResponseCode' undecoded. Use 'query' to try to decode it into a 'JSON'+-- type. E.g.,+--+-- > let conf = SConfig "key" "secret"+-- >+-- > runStripeT conf $+-- > query' baseSReq { sDestination = ["charges"] }+query' :: MonadIO m => SRequest -> StripeT m (SResponseCode, String)+query' req = 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_++-- | 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"+-- >+-- > 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++-- | 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_ 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"]++-- | Transforms a 'SRequest' 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 = ""+ }++--------------------+-- Error Handling --+--------------------++-- | 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+-- 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+ -- Successes+ 200 -> return OK+ -- Failures+ 400 -> throwError $ BadRequest e+ 401 -> throwError $ Unauthorized e+ 404 -> throwError $ NotFound e+ 402 -> throwError $ PaymentRequired e+ 500 -> throwError $ InternalServerError e+ 502 -> throwError $ BadGateway e+ 503 -> throwError $ ServiceUnavailable e+ 504 -> throwError $ GatewayTimeout e+ -- Unknown; assume success+ _ -> return $ Unknown c+ where e = errorMsg body++-- | Converts a 'String'-represented error code into the 'SErrorCode' 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+ "invalid_number" -> InvalidNumber+ "incorrect_number" -> IncorrectNumber+ "invalid_expiry_month" -> InvalidExpiryMonth+ "invalid_expiry_year" -> InvalidExpiryYear+ "invalid_cvc" -> InvalidCVC+ "expired_card" -> ExpiredCard+ "invalid_amount" -> InvalidAmount+ "incorrect_cvc" -> IncorrectCVC+ "card_declined" -> CardDeclined+ "missing" -> Missing+ "duplicate_transaction" -> DuplicateTransaction+ "processing_error" -> ProcessingError+ _ -> UnknownErrorCode $ T.pack 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++-- | 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+-- 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+ "card_error" -> do+ code <- jGet err "code"+ param <- mjGet err "param"+ return $ CardError msg (toCECode code) param+ _ -> return $ UnknownError type_ msg+ readJSON _ = Error "Unable to read Stripe error."+ showJSON _ = undefined++-- | Defines the behavior for more general error messages that can be thrown+-- with 'noMsg' and 'strMsg' in combination with 'throwError'.+instance Error SFailure where+ noMsg = OtherFailure Nothing+ strMsg = OtherFailure . Just . T.pack
+ src/Web/Stripe/Coupon.hs view
@@ -0,0 +1,162 @@+module Web.Stripe.Coupon+ ( Coupon(..)+ , CpnId(..)+ , CpnDuration(..)+ , CpnPercentOff(..)+ , CpnMaxRedeems(..)+ , CpnRedeemBy(..)+ , createCoupon+ , getCoupon+ , getCoupons+ , delCoupon+ , delCouponById++ {- Re-Export -}+ , Count(..)+ , Offset(..)+ , SConfig(..)+ , 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 )++----------------+-- Data Types --+----------------++-- | Represents a coupon in the Stripe system.+data Coupon = Coupon+ { cpnId :: Maybe CpnId+ , cpnDuration :: CpnDuration+ , cpnPercentOff :: CpnPercentOff+ } deriving Show++-- | Represents the identifier for a given 'Coupon' in the Stripe system.+newtype CpnId = CpnId { unCpnId :: String } deriving Show++-- | Represents the duration of a coupon. If an interval identifier is not+-- known, 'UnknownDuration' is used to carry the original identifier supplied+-- by Stripe.+data CpnDuration+ = Once+ | Repeating Int -- ^ Field specifies how long (months) discount is in effect+ | Forever+ | UnknownDuration String+ deriving Show++-- | Represents the percent off that is applied by a coupon. This must be+-- between 1 and 100.+newtype CpnPercentOff = CpnPercentOff { unCpnPercentOff :: Int } deriving Show++-- | A positive number representing the maximum number of times that a coupon+-- can be redeemed. +newtype CpnMaxRedeems = CpnMaxRedeems { unCpnMaxRedeems :: Int } deriving Show++-- | UTC timestamp specifying the last time at which the coupon can be+-- redeemed.+newtype CpnRedeemBy = CpnRedeemBy { unCpnRedeemBy :: Int } deriving Show++-- | Creates a 'Coupon' in the Stripe system.+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)+ ]++-- | Retrieves a specific 'Coupon' based on its 'CpnId'.+getCoupon :: MonadIO m => CpnId -> StripeT m Coupon+getCoupon (CpnId cid) = return . snd =<< query (cpnRq [cid])++-- | Retrieves a list of all 'Coupon's. The query can optionally be refined to+-- a specific:+--+-- * 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."++-- | Deletes a 'Coupon' if it exists. If it does not, an+-- 'InvalidRequestError' will be thrown indicating this.+delCoupon :: MonadIO m => Coupon -> StripeT m Bool+delCoupon = handleCpnId . cpnId+ where+ handleCpnId Nothing = throwError $ strMsg "No coupon ID provided."+ handleCpnId (Just cid) = delCouponById cid++-- | 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."++-- | Convenience function to create a 'SRequest' specific to coupon-related+-- actions.+cpnRq :: [String] -> SRequest+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 d = [ ("duration", fromCpnDuration d) ]++------------------+-- JSON Parsing --+------------------++-- | 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 Once = "once"+fromCpnDuration (Repeating _) = "repeating"+fromCpnDuration Forever = "forever"+fromCpnDuration (UnknownDuration d) = d++-- | 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+ "once" -> Once+ "forever" -> Forever+ _ -> UnknownDuration d+toCpnDuration d (Just ms) = case 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
+ src/Web/Stripe/Customer.hs view
@@ -0,0 +1,148 @@+module Web.Stripe.Customer+ ( Customer(..)+ , CustomerId(..)+ , Email(..)+ , createCustomer+ , updateCustomer+ , updateCustomerById+ , getCustomer+ , getCustomers+ , delCustomer+ , delCustomerById++ {- Re-Export -}+ , Count(..)+ , Offset(..)+ , Description(..)+ , UTCTime(..)+ , SConfig(..)+ , 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+ )++----------------+-- Data Types --+----------------++-- | Represents a customer in the Stripe system.+data Customer = Customer+ { 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++-- | Represents a standard email address.+newtype Email = Email { unEmail :: String } deriving Show++-- | Create a new 'Customer' in the Stripe system.+createCustomer :: MonadIO m => Maybe RequestCard -> Maybe CpnId -> Maybe Email+ -> Maybe Description -> Maybe PlanId -> Maybe Int+ -> StripeT m Customer+createCustomer mrc mcid me md mpid mtime =+ 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)+ ]++-- | Update an existing 'Customer' in the Stripe system.+updateCustomer :: MonadIO m => Customer -> Maybe RequestCard -> Maybe CpnId+ -> Maybe Email -> Maybe Description -> StripeT m Customer+updateCustomer = updateCustomerById . custId++-- | Update an existing 'Customer', identified by 'CustomerId', in the Stripe+-- system.+updateCustomerById :: MonadIO m => CustomerId -> Maybe RequestCard+ -> Maybe CpnId -> Maybe Email -> Maybe Description+ -> StripeT m Customer+updateCustomerById (CustomerId cid) mrc mcid me md =+ 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)+ ]++-- | Retrieves a specific 'Customer' based on its 'CustomerId'.+getCustomer :: MonadIO m => CustomerId -> StripeT m Customer+getCustomer (CustomerId cid) =+ return . snd =<< query (customerRq [cid])++-- | Retrieves a list of all 'Customer's. The query can optionally be refined+-- to a specific:+--+-- * 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+ 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.+delCustomer :: MonadIO m => Customer -> StripeT m Bool+delCustomer = delCustomerById . custId++-- | 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 }++-- | Convenience function to create a 'SRequest' specific to customer-related+-- actions.+customerRq :: [String] -> SRequest+customerRq pcs = baseSReq { sDestination = "customers":pcs }++------------------+-- JSON Parsing --+------------------++-- | 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
+ src/Web/Stripe/Plan.hs view
@@ -0,0 +1,146 @@+module Web.Stripe.Plan+ ( Plan(..)+ , PlanInterval(..)+ , PlanId(..)+ , PlanTrialDays(..)+ , createPlan+ , getPlan+ , getPlans+ , delPlan+ , delPlanById++ {- Re-Export -}+ , Amount(..)+ , Count(..)+ , Currency(..)+ , Offset(..)+ , SConfig(..)+ , 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+ )++----------------+-- Data Types --+----------------++-- | Represents a plan in the Stripe system.+data Plan = Plan+ { planId :: PlanId+ , planAmount :: Amount+ , planInterval :: PlanInterval+ , planName :: String+ , planCurrency :: Currency+ , planTrialDays :: Maybe PlanTrialDays+ } deriving Show++-- | 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++-- | Represents the identifier for a given 'Plan' in the Stripe system.+newtype PlanId = PlanId { unPlanId :: String } deriving Show++-- | 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++-- | 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)+ ]+ odata = [ ( "trial_period_days"+ , show . 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])++-- | Retrieves a list of all 'Plan's. The query can optionally be refined to+-- a specific:+--+-- * 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."++-- | Deletes a 'Plan' if it exists. If it does not, an 'InvalidRequestError'+-- will be thrown indicating this.+delPlan :: MonadIO m => Plan -> StripeT m Bool+delPlan = delPlanById . planId++-- | 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 }++-- | Convenience function to create a 'SRequest' specific to plan-related+-- actions.+planRq :: [String] -> SRequest+planRq pcs = baseSReq { sDestination = "plans":pcs }++------------------+-- JSON Parsing --+------------------++-- | Converts a 'PlanInterval' to a string for input into the Stripe API. For+-- 'UnknownPlan's, the original interval code will be used.+fromPlanInterval :: PlanInterval -> String+fromPlanInterval Monthly = "month"+fromPlanInterval Yearly = "year"+fromPlanInterval (UnknownPlan p) = p++-- | Convert a string to a 'PlanInterval'. Used for parsing output from the+-- Stripe API.+toPlanInterval :: String -> PlanInterval+toPlanInterval p = case 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
+ src/Web/Stripe/Subscription.hs view
@@ -0,0 +1,138 @@+module Web.Stripe.Subscription+ ( Subscription(..)+ , SubStatus(..)+ , SubProrate(..)+ , SubTrialEnd(..)+ , SubAtPeriodEnd(..)+ , updateSubRCard+ , updateSubToken+ , cancelSub++ {- Re-Export -}+ , UTCTime(..)+ , SConfig(..)+ , 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 )++------------------+-- 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+ } deriving Show++-- | Describes the various stages that a+data SubStatus = Trialing | Active | PastDue | Unpaid | Canceled+ | UnknownStatus String deriving Show++-- | A boolean flag that determines whether or not to prorate switching plans+-- during a billing cycle.+newtype SubProrate = SubProrate { unSubProrate :: Bool } deriving Show++-- | 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++-- | 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++-- | Update the subscription associated with a 'Customer', identified by+-- 'CustomerId', in the Stripe system.+--+-- If 'SubTrialEnd' is provided, this will override the default trial period+-- of the plan to which the customer is subscribed.+updateSubRCard :: MonadIO m => RequestCard -> CustomerId -> PlanId+ -> Maybe CpnId -> Maybe SubProrate -> Maybe SubTrialEnd+ -> StripeT m Subscription+updateSubRCard = updateSub . rCardKV++-- | Behaves precisely like 'updateSubRCard', but uses a 'Token', identified by+-- 'TokenId', rather than a 'RequestCard'.+updateSubToken :: MonadIO m => TokenId -> CustomerId -> PlanId -> Maybe CpnId+ -> Maybe SubProrate -> Maybe SubTrialEnd+ -> StripeT m Subscription+updateSubToken (TokenId tid) = updateSub [("token", tid)]++-- | Internal convenience function to update a 'Subscription'.+updateSub :: MonadIO m => [(String, String)] -> 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)+ ]++-- | Cancels the 'Subscription' associated with a 'Customer', identified by+-- 'CustomerId', in the Stripe system.+cancelSub :: MonadIO m => CustomerId -> Maybe SubAtPeriodEnd+ -> StripeT m Subscription+cancelSub cid mspe = snd `liftM`+ query (subRq cid []) { sMethod = DELETE, sData = optionalArgs odata }+ where odata = [("at_period_end", show . unSubAtPeriodEnd <$> mspe)]++-- | Convenience function to create a 'SRequest' specific to+-- subscription-related actions.+subRq :: CustomerId -> [String] -> SRequest+subRq (CustomerId cid) pcs =+ baseSReq { sDestination = "customers":cid:"subscription":pcs }++------------------+-- JSON Parsing --+------------------++-- | 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+ "trialing" -> Trialing+ "active" -> Active+ "past_due" -> PastDue+ "canceled" -> Canceled+ "unpaid" -> Unpaid+ _ -> 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
+ src/Web/Stripe/Token.hs view
@@ -0,0 +1,82 @@+module Web.Stripe.Token+ ( Token(..)+ , TokenId(..)+ , createToken+ , getToken++ {- Re-Export -}+ , UTCTime(..)+ , Amount(..)+ , Card(..)+ , Currency(..)+ , SConfig(..)+ , 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+ )++----------------+-- Data Types --+----------------++-- | Represents a token in the Stripe system.+data Token = Token+ { tokId :: TokenId+ , tokLive :: Bool+ , tokUsed :: Bool+ , tokCreated :: UTCTime+ , tokAmount :: Amount+ , tokCurrency :: Currency+ , tokCard :: Card+ } deriving Show++-- | Represents the identifier for a given 'Token' in the Stripe system.+newtype TokenId = TokenId { unTokenId :: String } deriving Show++-- | 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)+ ]++-- | 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+tokRq pcs = baseSReq { sDestination = "tokens":pcs }++------------------+-- JSON Parsing --+------------------++-- | 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
+ src/Web/Stripe/Utils.hs view
@@ -0,0 +1,79 @@+module Web.Stripe.Utils+ ( Amount(..)+ , Count(..)+ , Currency(..)+ , Description(..)+ , Offset(..)+ , optionalArgs+ , jGet+ , mjGet++ {- Re-Export -}+ , UTCTime(..)+ , fromSeconds+ , toSeconds+ ) 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+ )++-----------------------+-- Common Data Types --+-----------------------++-- | Represents an amount in cents in the Stripe system.+newtype Amount = Amount { unAmount :: Int } deriving Show++-- | 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++-- | Represents a currency (e.g., "usd") in the Stripe system. This is+-- a 3-letter ISO code.+newtype Currency = Currency { unCurrency :: String } deriving Show++-- | Describes an object in the Stripe system.+newtype Description = Description { unDescription :: String } deriving Show++-- | A positive integer that is an offset into the array of objects returned+-- by the Stripe API.+newtype Offset = Offset { unOffset :: Int } deriving Show++-----------------------+-- Utility Functions --+-----------------------++-- | Convert a time in seconds (from Stripe's servers) to 'UTCTime'. See+-- "Data.Time.Format" for more on working with 'UTCTime'.+fromSeconds :: Integer -> UTCTime+fromSeconds = posixSecondsToUTCTime . fromInteger++-- | Convert a 'UTCTime' back to an Integer suitable for use with Stripe's API.+toSeconds :: UTCTime -> Integer+toSeconds = round . utcTimeToPOSIXSeconds++-- | Takes a list of key-value arguments, where the value is optional, and+-- returns a list of key-value pairs with only the supplied values.+--+-- Essentially, this filters out all 'Nothing's and unwraps the 'Just's.+--+-- >>> 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
+ stripe.cabal view
@@ -0,0 +1,37 @@+Name: stripe+Version: 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>+Copyright: (c) 2011 Spearhead Development, L.L.C.+Category: Web+Build-type: Simple+Extra-source-files: README.mkd+Cabal-version: >=1.6++Library+ -- Modules exported by the library.+ ghc-options: -Wall -fwarn-tabs+ Hs-Source-Dirs: src+ Exposed-modules: Web.Stripe.Card+ , Web.Stripe.Charge+ , Web.Stripe.Client+ , Web.Stripe.Coupon+ , Web.Stripe.Customer+ , Web.Stripe.Plan+ , Web.Stripe.Subscription+ , Web.Stripe.Token+ , Web.Stripe.Utils+ Build-depends: base >= 3 && < 5+ , text == 0.11.*+ , json >= 0.3.6+ , network == 2.3.*+ , time >= 1.0+ , http-types >= 0.2.0+ , curl >= 1.3.4+ , mtl >= 1.1.0.0+ , bytestring >= 0.9