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