diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.mkd b/README.mkd new file mode 100644 --- /dev/null +++ b/README.mkd @@ -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" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Web/Stripe/Card.hs b/src/Web/Stripe/Card.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Card.hs @@ -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 diff --git a/src/Web/Stripe/Charge.hs b/src/Web/Stripe/Charge.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Charge.hs @@ -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 diff --git a/src/Web/Stripe/Client.hs b/src/Web/Stripe/Client.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Client.hs @@ -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 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 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 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 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 diff --git a/src/Web/Stripe/Coupon.hs b/src/Web/Stripe/Coupon.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Coupon.hs @@ -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 diff --git a/src/Web/Stripe/Customer.hs b/src/Web/Stripe/Customer.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Customer.hs @@ -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 diff --git a/src/Web/Stripe/Plan.hs b/src/Web/Stripe/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Plan.hs @@ -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 diff --git a/src/Web/Stripe/Subscription.hs b/src/Web/Stripe/Subscription.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Subscription.hs @@ -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 diff --git a/src/Web/Stripe/Token.hs b/src/Web/Stripe/Token.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Token.hs @@ -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 diff --git a/src/Web/Stripe/Utils.hs b/src/Web/Stripe/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Utils.hs @@ -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 diff --git a/stripe.cabal b/stripe.cabal new file mode 100644 --- /dev/null +++ b/stripe.cabal @@ -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 +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