diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2018 Christopher Reichert + +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Web/Stripe/Client/HttpClient.hs b/src/Web/Stripe/Client/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Client/HttpClient.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.Stripe.Client.HttpClient + ( + StripeRequest(..) + , StripeError(..) + , StripeConfig(..) + + , stripe + , stripeManager + , stripeConn + + -- * low-level + , withConnection + , withManager + , callAPI + + ) where + +import qualified Control.Arrow +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text.Encoding as TE +import qualified Network.HTTP.Types as Http + +import Data.Aeson as A +import Data.ByteString (ByteString) +import Data.Monoid ((<>)) +#if MIN_VERSION_http_client(0,5,13) +import Network.HTTP.Client as Http hiding (withManager, withConnection) +#else +import Network.HTTP.Client as Http hiding (withManager) +#endif +import Network.HTTP.Client.TLS as TLS + +import qualified Web.Stripe.StripeRequest as S + +import Web.Stripe.Client (APIVersion (..), StripeConfig (..), + StripeError (..), StripeKey (..), + StripeRequest, StripeReturn, + attemptDecode, handleStream, + parseFail, toBytestring, unknownCode) + + +-- | Create a request to 'Stripe's API. +-- +-- This function uses the global TLS manager from @http-client-tls@ +-- via 'getGlobalManager'. +stripe :: FromJSON (StripeReturn a) + => StripeConfig + -> StripeRequest a + -> IO (Either StripeError (StripeReturn a)) +stripe config request = do + man <- TLS.getGlobalManager + callAPI man fromJSON config request + +-- | Create a request to 'Stripe's API using a 'Manager'. +stripeManager :: FromJSON (StripeReturn a) + => Manager + -> StripeConfig + -> StripeRequest a + -> IO (Either StripeError (StripeReturn a)) +stripeManager manager config request = callAPI manager fromJSON config request + +-- | Create a request to 'Stripe's API using a 'Manager'. +-- +-- This function is used to maintain compatibility w/ +-- @stripe-http-streams@. However, the terminology in @http-streams@ +-- uses 'Connection' whereas @http-client@ uses connection 'Manager'. +stripeConn :: FromJSON (StripeReturn a) + => Manager + -> StripeConfig + -> StripeRequest a + -> IO (Either StripeError (StripeReturn a)) +stripeConn = stripeManager + +withConnection :: (Manager -> IO (Either StripeError a)) + -> IO (Either StripeError a) +withConnection = withManager + +withManager :: (Manager -> IO (Either StripeError a)) + -> IO (Either StripeError a) +withManager m = do + + -- @http-client@ has a set of deprecated `withManager` functions + -- that are not necessary to safely prevent a 'Manager' from + -- leaking resources. "Manager's will be closed and shutdown + -- automatically (and safely) via gargage collection. + manager <- TLS.getGlobalManager + m manager + +-- | Create a request to 'Stripe's API using an existing 'Manager' +-- +-- This is a low-level function. In most cases you probably want to +-- use 'stripe' or 'stripeManager'. +callAPI :: Manager + -> (Value -> Result b) + -> StripeConfig + -> StripeRequest a + -> IO (Either StripeError b) +callAPI man fromJSON' config stripeRequest = do + + res <- httpLbs mkStripeRequest man + + let status = Http.statusCode (Http.responseStatus res) + + if not (attemptDecode status) then + return unknownCode + + else do + case A.eitherDecode (Http.responseBody res) of + Left e -> pure $ parseFail e + Right a -> pure $ handleStream fromJSON' status $ return a + where + mkStripeRequest = + + let req = Http.applyBasicAuth (getStripeKey (secretKey config)) mempty $ + defaultRequest { + Http.method = m2m (S.method stripeRequest) + , Http.secure = True + , Http.host = "api.stripe.com" + , Http.port = 443 + , Http.path = "/v1/" <> TE.encodeUtf8 (S.endpoint stripeRequest) + , Http.requestHeaders = [ + ("Stripe-Version", toBytestring stripeVersion) + , ("Connection", "Keep-Alive") + ] + , Http.checkResponse = \_ _ -> return () + } + + stripeQueryParams = fmap + (Control.Arrow.second Just) + (S.queryParams stripeRequest) + + in if S.GET == S.method stripeRequest then + Http.setQueryString stripeQueryParams req + else + urlEncodeBody (S.queryParams stripeRequest) req + +m2m :: S.Method -> Http.Method +m2m S.GET = Http.methodGet +m2m S.POST = Http.methodPost +m2m S.DELETE = Http.methodDelete + +-- | This function is used instead of http-client's built-in 'urlEncodedBody' as +-- the request method is set explicitly to POST in 'urlEncodeBody' but Stripe +-- uses POST\/PUT\/DELETE. A PR should be submitted to http-client to fix +-- eventually. +urlEncodeBody :: [(ByteString, ByteString)] -> Request -> Request +urlEncodeBody headers req = req { + requestBody = RequestBodyLBS (BSL.fromChunks body) + , requestHeaders = + ("Content-Type", "application/x-www-form-urlencoded") + : filter (\(x, _) -> x /= "Content-Type") (requestHeaders req) + } + where + body = pure (Http.renderSimpleQuery False headers) + +stripeVersion :: APIVersion +stripeVersion = V20141007 diff --git a/stripe-http-client.cabal b/stripe-http-client.cabal new file mode 100644 --- /dev/null +++ b/stripe-http-client.cabal @@ -0,0 +1,53 @@ +name: stripe-http-client +version: 2.4.0 +license: MIT +license-file: LICENSE +author: Christopher Reichert +synopsis: Stripe API for Haskell - http-client backend +maintainer: creichert07@gmail.com +copyright: Copyright (c) 2018 Christopher Reichert +category: Web +build-type: Simple +cabal-version: >=1.10 +Description: + . + <> + . + [Access Stripe API using http-client] + This package provides access to the Stripe API using `stripe-core` + and `http-client`. See also the `stripe` package. + +library + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Web.Stripe.Client.HttpClient + ghc-options: -Wall + other-extensions: OverloadedStrings + RecordWildCards + build-depends: base >= 4.7 && < 5 + , bytestring >= 0.10 && < 0.11 + , text >= 1.1 && < 1.3 + , aeson >= 0.8 && < 0.10 || >= 0.11 && < 1.3 + , http-client + , http-client-tls + , http-types + , stripe-core + +Test-Suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , free >= 4.10 && < 6 + , hspec >= 2.1.0 && < 2.5 + , stripe-core + , stripe-tests + , http-client + , stripe-http-client + ghc-options: -Wall -threaded -rtsopts + +source-repository head + type: git + subdir: stripe-http-client + location: git://github.com/dmjio/stripe-haskell.git diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Control.Monad.Trans.Free (FreeF(..), FreeT(..)) +#if MIN_VERSION_http_client(0,5,13) +import Network.HTTP.Client hiding (withConnection) +#else +import Network.HTTP.Client +#endif +import Web.Stripe.Client (StripeConfig(..), StripeError(..)) +import Web.Stripe.Client.HttpClient (withConnection, callAPI) +import Web.Stripe.Test.AllTests (allTests) +import Web.Stripe.Test.Prelude (Stripe, StripeRequestF(..)) + +main :: IO () +main = allTests runStripe + +runStripe :: StripeConfig + -> Stripe a + -> IO (Either StripeError a) +runStripe config stripe = + withConnection $ \conn -> + runStripe' conn config stripe + +runStripe' :: Manager + -> StripeConfig + -> Stripe a + -> IO (Either StripeError a) +runStripe' manager config (FreeT m) = + do f <- m + case f of + (Pure a) -> return (Right a) + (Free (StripeRequestF req decode')) -> + do r <- callAPI manager decode' config req + case r of + (Left e) -> return (Left e) + (Right next) -> runStripe' manager config next