{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Web.Stripe.Client ( SConfig(..) , APIKey(..) , SResponseCode(..) , SFailure(..) , SError(..) , SErrorCode(..) , SRequest(..) , Stripe , StripeT(StripeT) , defaultConfig , runStripeT , baseSReq , query , query_ {- Re-Export -} , StdMethod(..) ) where import Control.Monad ( MonadPlus, liftM ) import Control.Monad.Error ( Error, ErrorT, MonadIO, MonadError, runErrorT , throwError, strMsg, noMsg ) import Control.Monad.State ( MonadState, StateT, runStateT, get ) import Control.Monad.Trans ( liftIO ) import Data.Char ( toLower ) import Data.List ( intercalate ) import Data.Text ( Text ) import Network.Curl ( CurlOption(..), CurlResponse, CurlResponse_(..) , curlGetResponse_, method_GET, method_HEAD , method_POST ) import Network.HTTP.Types ( StdMethod(..), renderQuery ) import Network.URI ( URI(..), URIAuth(..) ) import Text.JSON ( Result(..), JSObject, JSON(..), JSValue(..) , decode, resultToEither, toJSObject, valFromObj ) import Web.Stripe.Utils ( jGet, mjGet ) import qualified Data.ByteString.Char8 as C8 import qualified Data.Text as T ------------------------ -- General Data Types -- ------------------------ -- | Configuration for the 'StripeT' monad transformer. data SConfig = SConfig { key :: APIKey , caFile :: FilePath } deriving Show -- | A key used when authenticating to the Stripe API. newtype APIKey = APIKey { unAPIKey :: String } deriving Show -- | This represents the possible successes that a connection to the Stripe -- API can encounter. For specificity, a success can be represented by other -- error codes, and so the same is true in this data type. -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information. data SResponseCode = OK | Unknown Int deriving Show -- | This represents the possible failures that a connection to the Stripe API -- can encounter. -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information. data SFailure = BadRequest (Maybe SError) | Unauthorized (Maybe SError) | NotFound (Maybe SError) | PaymentRequired (Maybe SError) | InternalServerError (Maybe SError) | BadGateway (Maybe SError) | ServiceUnavailable (Maybe SError) | GatewayTimeout (Maybe SError) | OtherFailure (Maybe Text) deriving Show -- | Describes a 'SFailure' in more detail, categorizing the error and -- providing additional information about it. At minimum, this is a message, -- and for 'CardError', this is a message, even more precise code -- ('SErrorCode'), and potentially a paramter that helps suggest where an -- error message should be displayed. -- -- In case the appropriate error could not be determined from the specified -- type, 'UnkownError' will be returned with the supplied type and message. -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information. data SError = InvalidRequestError { ireMessage :: String } | APIError { apiMessage :: String } | CardError { ceMessage :: String , ceCode :: SErrorCode , ceParam :: Maybe String } | UnknownError { ueType :: String , ueMessage :: String } deriving Show -- | Attempts to describe a 'CardError' in more detail, classifying in what -- specific way it failed. -- -- Please consult the official Stripe REST API documentation on error codes -- at <https://stripe.com/docs/api#errors> for more information. data SErrorCode = InvalidNumber | IncorrectNumber | InvalidExpiryMonth | InvalidExpiryYear | InvalidCVC | ExpiredCard | InvalidAmount | IncorrectCVC | CardDeclined | Missing | DuplicateTransaction | ProcessingError | UnknownErrorCode Text -- ^ Could not be matched; text gives error name. deriving Show -- | Represents a request to the Stripe API, providing the fields necessary to -- specify a Stripe resource. More generally, 'baseSReq' will be desired as -- it provides sensible defaults that can be overriden as needed. data SRequest = SRequest { sMethod :: StdMethod , sDestination :: [String] , sData :: [(String, String)] , sQString :: [(String, String)] } deriving Show ------------------ -- Stripe Monad -- ------------------ -- | A convenience specialization of the 'StripeT' monad transformer in which -- the underlying monad is IO. type Stripe a = StripeT IO a -- | Defines the monad transformer under which all Stripe REST API resource -- calls take place. newtype StripeT m a = StripeT { unStripeT :: StateT SConfig (ErrorT SFailure m) a } deriving ( Functor, Monad, MonadIO, MonadPlus , MonadError SFailure , MonadState SConfig ) -- | Runs the 'StripeT' monad transformer with a given 'SConfig'. This will -- handle all of the authorization dance steps necessary to utilize the -- Stripe API. -- -- Its use is demonstrated in other functions, such as 'query'. runStripeT :: MonadIO m => SConfig -> StripeT m a -> m (Either SFailure a) runStripeT cfg m = runErrorT . liftM fst . (`runStateT` cfg) . unStripeT $ m -------------- -- Querying -- -------------- -- | Provides a default 'SConfig'. Essentially, this inserts the 'APIKey', but -- leaves other fields blank. This is especially relavent due to the current -- CA file check bug. defaultConfig :: APIKey -> SConfig defaultConfig k = SConfig k "" -- | The basic 'SRequest' environment upon which all other Stripe API requests -- will be built. Standard usage involves overriding one or more of the -- fields. E.g., for a request to \"https://api.stripe.com/v1/coupons\", -- one would have: -- -- > baseSReq { sDestinaton = ["charges"] } baseSReq :: SRequest baseSReq = SRequest { sMethod = GET , sDestination = [] , sData = [] , sQString = [] } -- | Queries the Stripe API. This returns the response body along with the -- 'SResponseCode' undecoded. Use 'query' to try to decode it into a 'JSON' -- type. E.g., -- -- > let conf = SConfig "key" "secret" -- > -- > runStripeT conf $ -- > query' baseSReq { sDestination = ["charges"] } query' :: MonadIO m => SRequest -> StripeT m (SResponseCode, String) query' req = do cfg <- get let opts' = opts $ caFile cfg rsp <- liftIO (request (show $ prepRq cfg req) opts' :: IO CurlResponse) code <- toCode (respStatus rsp) (respBody rsp) return (code, respBody rsp) where opts caf = CurlCAInfo caf : CurlFailOnError False : queryOptions req request = curlGetResponse_ -- | Queries the Stripe API and attempts to parse the results into a data type -- that is an instance of 'JSON'. This is primarily for internal use by other -- Stripe submodules, which supply the request values accordingly. However, -- it can also be used directly. E.g., -- -- > let conf = SConfig "key" "CA file" -- > -- > runStripeT conf $ -- > query baseSReq { sDestination = ["charges"] } query :: (MonadIO m, JSON a) => SRequest -> StripeT m (SResponseCode, a) query req = query' req >>= \(code, ans) -> (,) code `liftM` decodeJ ans where decodeJ = tryEither . resultToEither . decode tryEither = either (throwError . strMsg) return -- | Acts just like 'query', but on success, throws away the response. Errors -- contacting the Stripe API will still be reported. query_ :: MonadIO m => SRequest -> StripeT m () query_ req = query' req >> return () -- | Determines the appropriate 'CurlOption's for a given 'SRequest'. -- Presently, this provides a User-Agent string, adds any available HTTP -- 'POST' data, and incorporates the proper HTTP method ('StdMethod'). queryOptions :: SRequest -> [CurlOption] queryOptions req = CurlUserAgent ua : CurlPostFields dopts : mopts where ua = "hs-stripe/0.1 libcurl" dopts = map (\(a, b) -> a ++ "=" ++ b) $ sData req -- Data mopts = case sMethod req of -- HTTP Method GET -> method_GET POST -> method_POST HEAD -> method_HEAD PUT -> [CurlCustomRequest "PUT"] DELETE -> [CurlCustomRequest "DELETE"] TRACE -> [CurlCustomRequest "TRACE"] CONNECT -> [CurlCustomRequest "CONNECT"] OPTIONS -> [CurlCustomRequest "OPTIONS"] -- | Transforms a 'SRequest' into a more general 'URI', which can be used to -- make an authenticated query to the Stripe server. prepRq :: SConfig -> SRequest -> URI prepRq cfg rq = uri { uriPath = intercalate "/" (uriPath uri:sDestination rq) , uriQuery = C8.unpack $ renderQuery True qs } where uri = baseURI (unAPIKey $ key cfg) qs = map (\(a, b) -> (C8.pack a, Just $ C8.pack b)) $ sQString rq -- | Takes a Stripe API key (see 'SConfig') to produce a authentication-ready -- URI to be used when querying the server. API. This defines fields with -- the most sensible defaults, which are then overriden as needed. baseURI :: String -> URI baseURI k = URI { uriScheme = "https:" , uriAuthority = Just $ URIAuth (k ++ ":@") "api.stripe.com" ":443" , uriPath = "/v1" , uriQuery = "" , uriFragment = "" } -------------------- -- Error Handling -- -------------------- -- | Given an HTTP status code and the response body as input, this function -- determines whether or not the status code represents an error as -- per Stripe\'s REST API documentation. If it does, 'SFailure' is thrown as -- an error. Otherwise, 'SResponseCode' is returned, representing the status -- of the request. -- -- If an error is encountered, this function will attempt to decode the -- response body with 'errorMsg' to retrieve (and return) an explanation with -- the 'SFailure'. toCode :: Monad m => Int -> String -> StripeT m SResponseCode toCode c body = case c of -- Successes 200 -> return OK -- Failures 400 -> throwError $ BadRequest e 401 -> throwError $ Unauthorized e 404 -> throwError $ NotFound e 402 -> throwError $ PaymentRequired e 500 -> throwError $ InternalServerError e 502 -> throwError $ BadGateway e 503 -> throwError $ ServiceUnavailable e 504 -> throwError $ GatewayTimeout e -- Unknown; assume success _ -> return $ Unknown c where e = errorMsg body -- | Converts a 'String'-represented error code into the 'SErrorCode' data -- type to more descriptively classify errors. -- -- If the string does not represent a known error code, 'UnknownErrorCode' -- will be returned with the raw text representing the error code. toCECode :: String -> SErrorCode toCECode c = case map toLower c of "invalid_number" -> InvalidNumber "incorrect_number" -> IncorrectNumber "invalid_expiry_month" -> InvalidExpiryMonth "invalid_expiry_year" -> InvalidExpiryYear "invalid_cvc" -> InvalidCVC "expired_card" -> ExpiredCard "invalid_amount" -> InvalidAmount "incorrect_cvc" -> IncorrectCVC "card_declined" -> CardDeclined "missing" -> Missing "duplicate_transaction" -> DuplicateTransaction "processing_error" -> ProcessingError _ -> UnknownErrorCode $ T.pack c -- | This function attempts to decode the contents of a response body as JSON -- and retrieve an error message in an \"error\" field. E.g., -- -- >>> errorMsg "{\"error\":\"Oh no, an error!\"}" -- Just "Oh no, an error!" errorMsg :: String -> Maybe SError errorMsg = either (\_ -> Nothing) Just . resultToEither . valFromObj "error" . toBody -- | Attempts to decode a response body to a 'JSObject' 'JSValue'. This is used -- internally by functions such as 'errorMsg' which need to only grab, a -- single value from a response body, rather than representing it first as a -- more proper data type. toBody :: String -> JSObject JSValue toBody = either (\_ -> toJSObject []) id . resultToEither . decode -- | Attempts to parse error information provided with each error by the Stripe -- API. In the parsing, the error is classified as a specific 'SError' and -- any useful data, such as a message explaining the error, is extracted -- accordingly. instance JSON SError where readJSON (JSObject err) = do type_ <- jGet err "type" msg <- jGet err "message" case map toLower type_ of "invalid_request_error" -> return $ InvalidRequestError msg "api_error" -> return $ APIError msg "card_error" -> do code <- jGet err "code" param <- mjGet err "param" return $ CardError msg (toCECode code) param _ -> return $ UnknownError type_ msg readJSON _ = Error "Unable to read Stripe error." showJSON _ = undefined -- | Defines the behavior for more general error messages that can be thrown -- with 'noMsg' and 'strMsg' in combination with 'throwError'. instance Error SFailure where noMsg = OtherFailure Nothing strMsg = OtherFailure . Just . T.pack