Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 16 commits
  • 13 files changed
  • 5 commit comments
  • 3 contributors
3  .ghci
View
@@ -0,0 +1,3 @@
+:set -XTupleSections
+:set -XOverloadedStrings
+:cd src
2  .gitignore
View
@@ -1,3 +1,5 @@
dist/
+dist_*/
.DS_Store
*.swp
+.hsenv
81 src/Web/Stripe/Card.hs
View
@@ -1,55 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Web.Stripe.Card
( Card(..)
, RequestCard(..)
, rCardKV
) where
-import Control.Monad ( liftM, ap )
-import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject) )
-import Web.Stripe.Utils ( jGet, optionalArgs )
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (mzero)
+import Data.Aeson (FromJSON (..), Value (..), (.:))
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import Web.Stripe.Utils (optionalArgs, showByteString,
+ textToByteString)
-- | Represents a credit card in the Stripe system.
data Card = Card
- { cardType :: String
- , cardCountry :: String
- , cardLastFour :: String
- , cardExpMonth :: Int
- , cardExpYear :: Int
+ { cardType :: T.Text
+ , cardCountry :: T.Text
+ , cardLastFour :: T.Text
+ , cardExpMonth :: Int
+ , cardExpYear :: Int
} deriving Show
-- | Represents a credit car (with full details) that is used as input to the
-- Stripe API.
data RequestCard = RequestCard
- { rCardNumber :: String
- , rCardExpMonth :: Int
- , rCardExpYear :: Int
- , rCardCVC :: Maybe String -- ^ Highly recommended to supply
- , rCardFullName :: Maybe String
- , rCardAddrLineOne :: Maybe String
- , rCardAddrLineTwo :: Maybe String
- , rCardAddrZip :: Maybe String
- , rCardAddrState :: Maybe String
- , rCardAddrCountry :: Maybe String
+ { rCardNumber :: T.Text
+ , rCardExpMonth :: Int
+ , rCardExpYear :: Int
+ , rCardCVC :: Maybe T.Text -- ^ Highly recommended to supply
+ , rCardFullName :: Maybe T.Text
+ , rCardAddrLineOne :: Maybe T.Text
+ , rCardAddrLineTwo :: Maybe T.Text
+ , rCardAddrZip :: Maybe T.Text
+ , rCardAddrState :: Maybe T.Text
+ , rCardAddrCountry :: Maybe T.Text
} deriving Show
-- | Turns a 'RequestCard' into a list of key-value pairs that can be submitted
-- to the Stripe API in a query.
-rCardKV :: RequestCard -> [(String, String)]
+rCardKV :: RequestCard -> [(B.ByteString, B.ByteString)]
rCardKV rc = fd ++ optionalArgs md
where
-- Required
- fd = [ ("card[number]", rCardNumber rc)
- , ("card[exp_month]", show $ rCardExpMonth rc)
- , ("card[exp_year]", show $ rCardExpYear rc)
+ fd = [ ("card[number]", textToByteString $ rCardNumber rc)
+ , ("card[exp_month]", showByteString $ rCardExpMonth rc)
+ , ("card[exp_year]", showByteString $ rCardExpYear rc)
]
-- Optional
- md = [ ("card[cvc]", rCardCVC rc)
- , ("card[name]", rCardFullName rc)
- , ("card[address_line_1]", rCardAddrLineOne rc)
- , ("card[address_line_2]", rCardAddrLineTwo rc)
- , ("card[address_zip]", rCardAddrZip rc)
- , ("card[address_state]", rCardAddrState rc)
- , ("card[address_country]", rCardAddrCountry rc)
+ md = [ ("card[cvc]", textToByteString <$> rCardCVC rc)
+ , ("card[name]", textToByteString <$> rCardFullName rc)
+ , ("card[address_line_1]", textToByteString <$> rCardAddrLineOne rc)
+ , ("card[address_line_2]", textToByteString <$> rCardAddrLineTwo rc)
+ , ("card[address_zip]", textToByteString <$> rCardAddrZip rc)
+ , ("card[address_state]", textToByteString <$> rCardAddrState rc)
+ , ("card[address_country]", textToByteString <$> rCardAddrCountry rc)
]
------------------
@@ -57,12 +63,11 @@ rCardKV rc = fd ++ optionalArgs md
------------------
-- | 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
104 src/Web/Stripe/Charge.hs
View
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Web.Stripe.Charge
( Charge(..)
, ChargeId(..)
@@ -20,28 +22,28 @@ module Web.Stripe.Charge
, 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 --
@@ -62,7 +64,7 @@ data Charge = Charge
} 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
-- | Submit a 'Charge' to the Stripe API using an already constructed 'Token'.
chargeToken :: MonadIO m => Token -> Amount -> Currency
@@ -72,7 +74,7 @@ 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)]
+chargeTokenById (TokenId tid) = charge [("card", textToByteString tid)]
-- | Submit a 'Charge' to the Stripe for a specific 'Customer' that already has
-- payment details on file.
@@ -84,7 +86,7 @@ chargeCustomer = chargeCustomerById . custId
-- 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)]
+chargeCustomerById (CustomerId cid) = charge [("customer", textToByteString cid)]
-- | Submit a 'Charge' to the Stripe API using a 'RequestCard' to describe
-- payment details.
@@ -94,15 +96,15 @@ 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
+charge :: MonadIO m => [(B.ByteString, B.ByteString)] -> 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)
+ fdata = optionalArgs odata ++ adata ++ bdata
+ odata = [ ("description", textToByteString . unDescription <$> mcd) ]
+ bdata = [ ("amount", showByteString . unAmount $ a)
+ , ("currency", textToByteString $ unCurrency c)
]
-- | Retrieve a 'Charge' from the Stripe API, identified by 'ChargeId'.
@@ -117,15 +119,14 @@ getCharge (ChargeId cid) = snd `liftM` query (chargeRq [cid])
-- * '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 +152,11 @@ fullRefundById cid = refundChargeById cid Nothing
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 +164,16 @@ chargeRq pcs = baseSReq { sDestination = "charges":pcs }
------------------
-- | 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 .: "fee"
+ <*> v .: "livemode"
+ <*> v .: "paid"
+ <*> v .: "refunded"
+ <*> v .: "card"
+ parseJSON _ = mzero
305 src/Web/Stripe/Client.hs
View
@@ -1,60 +1,59 @@
{-# 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.Monad.State (MonadState, StateT, get, runStateT)
+import Control.Monad.Trans (liftIO)
+import Data.Aeson (FromJSON (..), Value (..), decode',
+ (.:), (.:?))
+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 --
+-- General Data T\ypes --
------------------------
-- | 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 +61,29 @@ newtype APIKey = APIKey { unAPIKey :: String } deriving Show
--
-- Please consult the official Stripe REST API documentation on error codes
-- at <https://stripe.com/docs/api#errors> for more information.
-data SResponseCode = OK | Unknown Int deriving Show
+data StripeResponseCode = OK | Unknown Int deriving Show
-- | This represents the possible failures that a connection to the Stripe API
-- can encounter.
--
-- Please consult the official Stripe REST API documentation on error codes
-- at <https://stripe.com/docs/api#errors> for more information.
-data SFailure
- = BadRequest (Maybe SError)
- | Unauthorized (Maybe SError)
- | NotFound (Maybe SError)
- | PaymentRequired (Maybe SError)
- | InternalServerError (Maybe SError)
- | BadGateway (Maybe SError)
- | ServiceUnavailable (Maybe SError)
- | GatewayTimeout (Maybe SError)
+data StripeFailure
+ = BadRequest (Maybe StripeError)
+ | Unauthorized (Maybe StripeError)
+ | NotFound (Maybe StripeError)
+ | PaymentRequired (Maybe StripeError)
+ | InternalServerError (Maybe StripeError)
+ | BadGateway (Maybe StripeError)
+ | ServiceUnavailable (Maybe StripeError)
+ | GatewayTimeout (Maybe StripeError)
| OtherFailure (Maybe Text)
deriving Show
--- | 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,20 +91,11 @@ data SFailure
--
-- Please consult the official Stripe REST API documentation on error codes
-- at <https://stripe.com/docs/api#errors> for more information.
-data SError
- = InvalidRequestError
- { ireMessage :: String }
- | APIError
- { apiMessage :: String }
- | CardError
- { ceMessage :: String
- , ceCode :: SErrorCode
- , ceParam :: Maybe String
- }
- | UnknownError
- { ueType :: String
- , ueMessage :: String
- }
+data StripeError
+ = InvalidRequestError Text
+ | APIError Text
+ | CardError Text StripeErrorCode (Maybe Text) -- message, code, params
+ | UnknownError Text Text -- type, message
deriving Show
-- | Attempts to describe a 'CardError' in more detail, classifying in what
@@ -113,7 +103,7 @@ data SError
--
-- Please consult the official Stripe REST API documentation on error codes
-- at <https://stripe.com/docs/api#errors> for more information.
-data SErrorCode
+data StripeErrorCode
= InvalidNumber
| IncorrectNumber
| InvalidExpiryMonth
@@ -132,11 +122,11 @@ data SErrorCode
-- | 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 +140,18 @@ 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
+ { 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 +159,20 @@ runStripeT cfg m =
-- 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 +180,75 @@ baseSReq = SRequest
}
-- | 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}
+ -- _TODO we should be able to pass in a manager rather thanusing the default manager
+ rsp <- liftIO . withManager $ httpLbs req
+ 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) ->
+ maybe (throwError $ strMsg "could not parse JSON") (return . (code, )) $ decode' 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 <- maybe (throwError $ strMsg "could not parse JSON") return $ decode' 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 +256,15 @@ baseURI k = URI
-- | 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 +277,16 @@ toCode c body = case c of
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 +299,39 @@ toCECode c = case map toLower c of
"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
122 src/Web/Stripe/Connect.hs
View
@@ -0,0 +1,122 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Web.Stripe.Connect
+ ( authURL
+ , getAccessToken
+
+ , APIKey(..)
+ , StripeConnectTokens(..)
+ ) where
+
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Exception (Exception, SomeException (..))
+import Control.Monad (mzero)
+import Data.Aeson (FromJSON (..), Value (..), decode, (.:))
+import Data.ByteString.Char8 (ByteString, pack)
+import qualified Data.ByteString.Char8 as B
+import Data.Text (Text, append)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Typeable (Typeable)
+import Network.HTTP.Conduit (Request (..), Response (..), httpLbs,
+ parseUrl, urlEncodedBody, withManager)
+import Network.HTTP.Types (Query, Status (..), hAccept,
+ renderQuery)
+import Web.Stripe.Client (APIKey (..))
+import Web.Stripe.Utils (optionalArgs)
+
+
+type URL = ByteString
+type AccessToken = ByteString
+type RefreshToken = ByteString
+type UserId = ByteString
+type ClientId = ByteString
+type AuthCode = ByteString
+
+data StripeConnectException = StripeConnectException String deriving (Show, Eq, Typeable)
+data Scope = ReadOnly | ReadWrite
+data Landing = Login | Register
+data StripeConnectTokens = StripeConnectTokens
+ { scAccessToken :: AccessToken
+ , scRefreshToken :: RefreshToken
+ , scUserId :: UserId
+ } deriving Show
+
+
+-- URIs ------------------------------------------------------------------------
+authURL :: ClientId -> Maybe Scope -> Maybe Text -> Maybe Landing -> URL
+authURL clientId mScope mState mLanding =
+ B.append "https://connect.stripe.com/oauth/authorize" query
+ where query = renderQuery True
+ [ ("response_type", Just "code")
+ , ("client_id", Just clientId)
+ , ("scope", pack . show <$> mScope)
+ , ("state", encodeUtf8 <$> mState)
+ , ("stripe_landing", pack . show <$> mLanding)
+ ]
+
+
+accessTokenURL :: URL
+accessTokenURL = "https://connect.stripe.com/oauth/token"
+
+
+accessTokenQuery :: Maybe Scope -> AuthCode -> Query
+accessTokenQuery mScope code =
+ [ ("grant_type", Just "authorization_code")
+ , ("scope", pack . show <$> mScope)
+ , ("code", Just code)
+ ]
+
+
+refreshTokenQuery :: Maybe Scope -> RefreshToken -> Query
+refreshTokenQuery mScope token =
+ [ ("grant_type", Just "refresh_token")
+ , ("scope", pack . show <$> mScope)
+ , ("refresh_token", Just token)
+ ]
+
+
+-- HTTP ------------------------------------------------------------------------
+getAccessToken :: APIKey -> AuthCode -> IO (Maybe StripeConnectTokens)
+getAccessToken key code = do
+ req <- updateHeaders <$> parseUrl (B.unpack accessTokenURL)
+ decode . responseBody <$> (withManager . httpLbs $ urlEncodedBody body req)
+ where
+ body = optionalArgs $ accessTokenQuery Nothing code
+ headers req = json : auth : requestHeaders req
+ auth = ("Authorization", encodeUtf8 . append "Bearer " $ unAPIKey key)
+ json = (hAccept, "application/json")
+ updateHeaders req =
+ req
+ { requestHeaders = headers req
+ , checkStatus = statusCodeChecker
+ }
+
+
+statusCodeChecker :: Show a => Status -> a -> Maybe SomeException
+statusCodeChecker s@(Status c _) h
+ | 200 <= c && c < 300 = Nothing
+ | otherwise = Just . SomeException . StripeConnectException $ show s ++ show h
+
+
+-- Instances ----------------------------------------------------------------------
+instance Show Scope where
+ show ReadOnly = "read_only"
+ show ReadWrite = "read_write"
+
+
+instance Show Landing where
+ show Login = "login"
+ show Register = "register"
+
+
+instance FromJSON StripeConnectTokens where
+ parseJSON (Object o) = StripeConnectTokens
+ <$> o .: "access_token"
+ <*> o .: "refresh_token"
+ <*> o .: "stripe_user_id"
+ parseJSON _ = mzero
+
+
+instance Exception StripeConnectException
106 src/Web/Stripe/Coupon.hs
View
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Web.Stripe.Coupon
( Coupon(..)
, CpnId(..)
@@ -14,23 +16,25 @@ module Web.Stripe.Coupon
{- 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 @@ data Coupon = Coupon
} 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
-- | Represents the duration of a coupon. If an interval identifier is not
-- known, 'UnknownDuration' is used to carry the original identifier supplied
@@ -53,7 +57,7 @@ data CpnDuration
= Once
| Repeating Int -- ^ Field specifies how long (months) discount is in effect
| Forever
- | UnknownDuration String
+ | UnknownDuration T.Text
deriving Show
-- | Represents the percent off that is applied by a coupon. This must be
@@ -61,7 +65,7 @@ data CpnDuration
newtype CpnPercentOff = CpnPercentOff { unCpnPercentOff :: Int } deriving Show
-- | A positive number representing the maximum number of times that a coupon
--- can be redeemed.
+-- can be redeemed.
newtype CpnMaxRedeems = CpnMaxRedeems { unCpnMaxRedeems :: Int } deriving Show
-- | UTC timestamp specifying the last time at which the coupon can be
@@ -69,15 +73,19 @@ newtype CpnMaxRedeems = CpnMaxRedeems { unCpnMaxRedeems :: Int } deriving Show
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
+ :: 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 @@ getCoupon (CpnId cid) = return . snd =<< query (cpnRq [cid])
-- * 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 @@ delCoupon = handleCpnId . cpnId
-- | 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 @@ cpnDurationKV d = [ ("duration", fromCpnDuration d) ]
-- | 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 @@ 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
+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
145 src/Web/Stripe/Customer.hs
View
@@ -1,10 +1,15 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Web.Stripe.Customer
- ( Customer(..)
+ ( Customer(..)
, CustomerId(..)
, Email(..)
, createCustomer
+ , createCustomerByTokenId
, updateCustomer
, updateCustomerById
+ , updateCustomerByTokenId
+ , updateCustomerByIdByTokenId
, getCustomer
, getCustomers
, delCustomer
@@ -15,28 +20,27 @@ module Web.Stripe.Customer
, 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 (..), optionalArgs,
+ showByteString, textToByteString)
----------------
-- Data Types --
@@ -44,19 +48,19 @@ import Web.Stripe.Utils ( Count(..), Offset(..), Description(..)
-- | 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
-- | Represents a standard email address.
-newtype Email = Email { unEmail :: String } deriving Show
+newtype Email = Email { unEmail :: T.Text } deriving Show
-- | Create a new 'Customer' in the Stripe system.
createCustomer :: MonadIO m => Maybe RequestCard -> Maybe CpnId -> Maybe Email
@@ -66,13 +70,29 @@ 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)
+ 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 @@ 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)
+ 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 @@ getCustomer (CustomerId cid) =
-- * 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 @@ 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 }
+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 @@ customerRq pcs = baseSReq { sDestination = "customers":pcs }
------------------
-- | 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"
+ <*> o .: "created"
+ <*> o .:? "active_card"
+ parseJSON _ = mzero
103 src/Web/Stripe/Plan.hs
View
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Web.Stripe.Plan
( Plan(..)
, PlanInterval(..)
@@ -14,25 +16,24 @@ module Web.Stripe.Plan
, 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 @@ data Plan = Plan
{ planId :: PlanId
, planAmount :: Amount
, planInterval :: PlanInterval
- , planName :: String
+ , planName :: T.Text
, planCurrency :: Currency
, planTrialDays :: Maybe PlanTrialDays
} deriving Show
@@ -51,10 +52,10 @@ data Plan = Plan
-- | 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
-- | 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
-- | Represents the length of the trial period. That is, the number of days
-- before the customer is billed.
@@ -65,20 +66,20 @@ 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 @@ getPlan (PlanId pid) = return . snd =<< query (planRq [pid])
-- * 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 @@ 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 }
+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
100 src/Web/Stripe/Subscription.hs
View
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Web.Stripe.Subscription
( Subscription(..)
, SubStatus(..)
@@ -10,26 +12,29 @@ module Web.Stripe.Subscription
{- 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 --
@@ -37,19 +42,19 @@ import Web.Stripe.Utils ( UTCTime(..), fromSeconds, jGet, optionalArgs )
-- | 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
-- | A boolean flag that determines whether or not to prorate switching plans
-- during a billing cycle.
@@ -79,19 +84,19 @@ updateSubRCard = updateSub . rCardKV
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 @@ 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)]
+ 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 @@ subRq (CustomerId cid) pcs =
-- | 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 @@ toSubStatus s = case map toLower s of
_ -> 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
73 src/Web/Stripe/Token.hs
View
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Web.Stripe.Token
( Token(..)
, TokenId(..)
@@ -9,23 +11,23 @@ module Web.Stripe.Token
, 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, optionalArgs, showByteString,
+ textToByteString)
----------------
-- Data Types --
@@ -33,17 +35,17 @@ import Web.Stripe.Utils ( Amount(..), Currency(..), UTCTime(..), fromSeconds
-- | 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
+ , 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
+newtype TokenId = TokenId { unTokenId :: T.Text } deriving Show
-- | Creates a 'Token' in the Stripe system.
createToken :: MonadIO m => RequestCard -> Maybe Amount -> Maybe Currency
@@ -52,16 +54,16 @@ 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)
+ mdata = [ ("amount", showByteString . unAmount <$> ma)
+ , ("currency", textToByteString . 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
+-- | Convenience function to create a 'StripeRequest' specific to tokens.
+tokRq :: [T.Text] -> StripeRequest
tokRq pcs = baseSReq { sDestination = "tokens":pcs }
------------------
@@ -69,14 +71,13 @@ tokRq pcs = baseSReq { sDestination = "tokens":pcs }
------------------
-- | 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")
+ <*> (Amount <$> o .: "amount")
+ <*> (Currency <$> o .: "currency")
+ <*> o .: "card"
+ parseJSON _ = mzero
50 src/Web/Stripe/Utils.hs
View
@@ -5,22 +5,33 @@ module Web.Stripe.Utils
, 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 --
@@ -35,10 +46,10 @@ 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
+newtype Currency = Currency { unCurrency :: T.Text } deriving Show
-- | Describes an object in the Stripe system.
-newtype Description = Description { unDescription :: String } deriving Show
+newtype Description = Description { unDescription :: T.Text } deriving Show
-- | A positive integer that is an offset into the array of objects returned
-- by the Stripe API.
@@ -64,16 +75,5 @@ toSeconds = round . utcTimeToPOSIXSeconds
--
-- >>> 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 . (,)
15 stripe.cabal
View
@@ -1,5 +1,5 @@
Name: stripe
-Version: 0.1
+Version: 0.3
Synopsis: A Haskell implementation of the Stripe API.
Description: This is an implementation of the Stripe API as it is
documented at https://stripe.com/docs/api
@@ -20,6 +20,7 @@ Library
Exposed-modules: Web.Stripe.Card
, Web.Stripe.Charge
, Web.Stripe.Client
+ , Web.Stripe.Connect
, Web.Stripe.Coupon
, Web.Stripe.Customer
, Web.Stripe.Plan
@@ -28,10 +29,12 @@ Library
, Web.Stripe.Utils
Build-depends: base >= 3 && < 5
, text == 0.11.*
- , json >= 0.3.6
- , network == 2.3.*
+ , aeson >= 0.6
+ , 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

Showing you all comments on commits in this comparison.

Max Cantor

A pretty import is a happy import.

Max Cantor

point{ free | less } programming FTW!

to be honest, I'm always conflicted about these kind of changes. they're slicker but do make the code a bit harder to read. anyway, I'm mostly indifferent and fine with it.

Max Cantor

nice

Max Cantor

Always a fan of commits that start with "Following Max's lead"

Luke Hoersten

Agreed. I figured in this case the function is simple enough that it's worth it and the signature is clear enough.

Something went wrong with that request. Please try again.