diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,12 @@ +# Changelog + +All notable changes to this package will be documented in this file. + +The format is based on +[Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## 1.0.0.0 - 2018-12-20 + +- Initial release diff --git a/library/Stripe/Wreq.hs b/library/Stripe/Wreq.hs new file mode 100644 --- /dev/null +++ b/library/Stripe/Wreq.hs @@ -0,0 +1,362 @@ +{-# OPTIONS_GHC -Wall #-} + +{- | Typical use of this module: + +1. Run 'get', 'post', or 'delete' to get a 'WreqResponse'. +2. Use 'wreqResponse' to convert the Wreq response to a 'Response'. +3. Use 'responseValue' to obtain the response payload as an Aeson + 'Data.Aeson.Value' (or an 'Error' if the request was not successful). -} + +module Stripe.Wreq + ( + -- * Request + -- ** GET + get, Get (..) + -- ** POST + , post, Post (..) + -- ** DELETE + , delete, Delete (..) + + -- * Response + , WreqResponse, Response (..) + , wreqResponse, responseValue, responseValueError + + -- * Error + , Error (..), UserMessage (..), LogMessage (..), userError, logError + + -- * Status code + , StatusCode (..) + -- ** Predicates + -- $predicates + , isSuccess, isError, isClientError, isServerError + -- ** Client error codes + -- $constants + , badRequest400, unauthorized401, requestFailed402 + , notFound404, conflict409, tooManyRequests429 + + -- * Re-exports from Wreq + , FormParam (..), Session, Network.Wreq.Session.newAPISession + + ) where + +-- aeson +import qualified Data.Aeson + +-- base +import qualified Control.Exception +import Control.Monad ((>=>)) +import qualified Data.Bifunctor +import qualified Data.Semigroup +import Prelude hiding (userError) + +-- bytestring +import qualified Data.ByteString +import qualified Data.ByteString.Lazy + +-- lens +import Control.Lens ((&), (.~), (?~), (^.)) + +-- stripe-concepts +import Stripe.Concepts (ApiSecretKey (..)) + +-- text +import Data.Text (Text) +import qualified Data.Text + +-- unordered-containers +import qualified Data.HashMap.Strict + +-- wreq +import Network.Wreq (FormParam (..)) +import qualified Network.Wreq +import Network.Wreq.Session (Session) +import qualified Network.Wreq.Session + +------------------------------------------------------------ + +{- | An HTTP status code returned by Stripe. + +"Stripe uses conventional HTTP response codes to indicate the success or failure +of an API request." - -} + +newtype StatusCode = StatusCode Int deriving Eq + +{- $predicates + +Some basic functions for interpreting status codes. -} + +{- | "Codes in the 2xx range indicate success." - + -} + +isSuccess :: StatusCode -> Bool +isSuccess (StatusCode x) = x >= 200 && x < 300 + +{- | @isError x@ is equivalent to @'isClientError' x || 'isServerError' x@. -} + +isError :: StatusCode -> Bool +isError (StatusCode x) = x >= 400 && x < 600 + +{- | "Codes in the 4xx range indicate an error that failed given the information +provided (e.g., a required parameter was omitted, a charge failed, etc.)." - + -} + +isClientError :: StatusCode -> Bool +isClientError (StatusCode x) = x >= 400 && x < 500 + +{- | "Codes in the 5xx range indicate an error with Stripe's servers." - + -} + +isServerError :: StatusCode -> Bool +isServerError (StatusCode x) = x >= 500 && x < 600 + +{- $constants + +Constants for each of the error codes enumerated in the Stripe API +documentation, for your convenience. -} + +{- | 400 - Bad Request + +"The request was unacceptable, often due to missing a required parameter." - + -} + +badRequest400 :: StatusCode +badRequest400 = StatusCode 400 + +{- | 401 - Unauthorized + +"No valid API key provided." - -} + +unauthorized401 :: StatusCode +unauthorized401 = StatusCode 401 + +{- | 402 - Request Failed + +"The parameters were valid but the request failed." - + -} + +requestFailed402 :: StatusCode +requestFailed402 = StatusCode 402 + +{- | 404 - Not Found + +"The requested resource doesn't exist." - + -} + +notFound404 :: StatusCode +notFound404 = StatusCode 404 + +{- | 409 - Conflict + +"The request conflicts with another request (perhaps due to using the same +idempotent key)." - -} + +conflict409 :: StatusCode +conflict409 = StatusCode 409 + +{- | 429 - Too Many Requests + +"Too many requests hit the API too quickly. We recommend an exponential backoff +of your requests." - -} + +tooManyRequests429 :: StatusCode +tooManyRequests429 = StatusCode 429 + +------------------------------------------------------------ + +data Get = + Get + { getPath :: [Text] -- ^ URL path components + , getParams :: [(Text, Text)] -- ^ Query params + } + +data Post = + Post + { postPath :: [Text] -- ^ URL path components + , postParams :: [FormParam] -- ^ Parameters to send in the request body + } + +data Delete = + Delete + { deletePath :: [Text] -- ^ URL path components + , deleteParams :: [(Text, Text)] -- ^ Query params + } + +get :: Session -> ApiSecretKey -> Get -> IO WreqResponse +get session key x = Network.Wreq.Session.getWith opts session url + where + url = makeUrl (getPath x) + opts = wreqDefaults & Network.Wreq.auth ?~ auth key + & Network.Wreq.params .~ (getParams x) + +post :: Session -> ApiSecretKey -> Post -> IO WreqResponse +post session key x = Network.Wreq.Session.postWith opts session url params + where + url = makeUrl (postPath x) + params = postParams x + opts = wreqDefaults & Network.Wreq.auth ?~ auth key + +delete :: Session -> ApiSecretKey -> Delete -> IO WreqResponse +delete session key x = Network.Wreq.Session.deleteWith opts session url + where + url = makeUrl (deletePath x) + opts = wreqDefaults & Network.Wreq.auth ?~ auth key + & Network.Wreq.params .~ (deleteParams x) + +urlBase :: Text +urlBase = Data.Text.pack "https://api.stripe.com/v1" + +makeUrl :: [Text] -> String +makeUrl = + Data.Text.unpack + . Data.Text.intercalate (Data.Text.pack "/") + . (urlBase :) + +wreqDefaults :: Network.Wreq.Options +wreqDefaults = Network.Wreq.defaults & noCheckResponse + +{- | Set a "response checker" that overrides Wreq's default one which causes +exceptions to be thrown for non-2xx HTTP status codes -} + +noCheckResponse :: Network.Wreq.Options -> Network.Wreq.Options +noCheckResponse = Network.Wreq.checkResponse ?~ (\_ _ -> return ()) + +{- | Represent a Stripe API key as a Wreq 'Network.Wreq.Auth' value. + +"Authentication to the API is performed via HTTP Basic Auth. Provide your API +key as the basic auth username value. You do not need to provide a password." - + -} + +auth :: ApiSecretKey -> Network.Wreq.Auth +auth (ApiSecretKey key) = Network.Wreq.basicAuth key Data.ByteString.empty + +------------------------------------------------------------ + +{- | An error message suitable for being shown to a user. -} + +newtype UserMessage = UserMessage Text deriving (Eq, Show) + +{- | An error message that should go into an error log, /not/ shown to a user. +-} + +newtype LogMessage = LogMessage Text deriving (Eq, Show) + +data Error = + Error + { userMessages :: [UserMessage] + , logMessages :: [LogMessage] + } + deriving (Eq, Show) + +instance Data.Semigroup.Semigroup Error + where + Error x y <> Error x' y' = + Error + ((Data.Semigroup.<>) x x') + ((Data.Semigroup.<>) y y') + +instance Monoid Error + where + mappend = (Data.Semigroup.<>) + mempty = Error mempty mempty + +instance Control.Exception.Exception Error + +userError + :: Text -- ^ An error message intended to be shown to a user. + -> Error + +userError x = Error { userMessages = [UserMessage x], logMessages = [] } + +logError + :: Text -- ^ An error message intended to go into a log file, + -- /not/ to be shown to a user. + -> Error + +logError x = Error { userMessages = [], logMessages = [LogMessage x] } + +------------------------------------------------------------ + +type WreqResponse = Network.Wreq.Response Data.ByteString.Lazy.ByteString + +data Response = + Response + { responseBody :: Either Text Data.Aeson.Value + -- ^ Every Stripe response should have a JSON body; but if not, this + -- will be a 'Left' value with an error message from the JSON parser. + , responseCode :: StatusCode + -- ^ The status code of the HTTP response. + } + +{- | Convert a 'WreqResponse' into a 'Response' by parsing the JSON response +body (the Stripe API always returns JSON) and getting the HTTP status code. -} + +wreqResponse :: WreqResponse -> Response +wreqResponse r = + Response + { responseBody = + r ^. Network.Wreq.responseBody + & Data.Aeson.eitherDecode + & Data.Bifunctor.first Data.Text.pack + , responseCode = + r ^. Network.Wreq.responseStatus + . Network.Wreq.statusCode + & StatusCode + } + +{- | Interpret a response, returning 'Right' with the parsed JSON payload if +everything is okay, or 'Left' with an error if the response contains any +indication that something went wrong. -} + +responseValue :: Response -> Either Error Data.Aeson.Value +responseValue r = + case (responseBody r) of + Left e -> Left (logError e) + Right val -> + case isSuccess (responseCode r) of + True -> Right val + False -> Left (responseValueError val) + +{- | If the response object looks like this: + +> { +> "error": { +> "type": "card_error", +> "message": "..." +> } +> } +> } + +then we use the value of the @message@ field as a 'UserMessage'. Otherwise it is +a 'LogMessage'. + +"@message@: A human-readable message providing more details about the error. For +card errors, these messages can be shown to your users. [...] Card errors are +the most common type of error you should expect to handle. They result when the +user enters a card that can't be charged for some reason." - + -} + +responseValueError :: Data.Aeson.Value -> Error +responseValueError val + | isCardError = foldMap userError (msg val) + | otherwise = foldMap logError (msg val) + where + + isCardError = typ val == Just (Data.Text.pack "card_error") + + msg = aesonAttr "error" >=> aesonAttr "message" >=> aesonText + typ = aesonAttr "error" >=> aesonAttr "type" >=> aesonText + +------------------------------------------------------------ + +-- Internal Aeson decoding functions + +aesonAttr :: String -> Data.Aeson.Value -> Maybe Data.Aeson.Value +aesonAttr x = aesonObject >=> Data.HashMap.Strict.lookup (Data.Text.pack x) + +aesonObject :: Data.Aeson.Value -> Maybe Data.Aeson.Object +aesonObject (Data.Aeson.Object x) = Just x +aesonObject _ = Nothing + +aesonText :: Data.Aeson.Value -> Maybe Text +aesonText (Data.Aeson.String x) = Just x +aesonText _ = Nothing diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,18 @@ +Copyright 2018 Typeclass Consulting, LLC + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/stripe-wreq.cabal b/stripe-wreq.cabal new file mode 100644 --- /dev/null +++ b/stripe-wreq.cabal @@ -0,0 +1,48 @@ +name: stripe-wreq +version: 1.0.0.0 + +synopsis: Use the Stripe API via Wreq +category: Web + +description: + This package helps you make requests to the + API in conjunction with + the package. + This is a minimal library that makes no attempt obscure + either its underpinnings in Wreq or any of the details of the + Stripe API. Responses are returned as + values. + +homepage: https://github.com/typeclasses/stripe +bug-reports: https://github.com/typeclasses/stripe/issues + +author: Chris Martin +maintainer: Chris Martin, Julie Moronuki + +copyright: 2018 Typeclass Consulting, LLC +license: MIT +license-file: license.txt + +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==8.2.2, GHC==8.4.3, GHC==8.6.1 + +extra-source-files: + changelog.md + +library + hs-source-dirs: library + default-language: Haskell2010 + + exposed-modules: + Stripe.Wreq + + build-depends: + aeson + , base >=4.10 && <5 + , bytestring + , lens + , stripe-concepts + , text + , unordered-containers + , wreq