diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2014 David Johnson + +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/HttpStreams.hs b/src/Web/Stripe/Client/HttpStreams.hs new file mode 100644 --- /dev/null +++ b/src/Web/Stripe/Client/HttpStreams.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Web.Stripe.Client.Internal +-- Copyright : (c) David Johnson, 2014 +-- Maintainer : djohnson.m@gmail.com +-- Stability : experimental +-- Portability : POSIX +module Web.Stripe.Client.HttpStreams + ( stripe + , stripeConn + , withConnection + , StripeRequest (..) + , StripeError (..) + , StripeConfig (..) + -- * low-level + , callAPI + ) where + +import Control.Exception (SomeException, finally, try) +import Control.Monad (when) +import Data.Aeson (Result(..), FromJSON, Value, fromJSON, json') +import qualified Data.ByteString as S +import Data.Monoid (mempty, (<>)) +import qualified Data.Text.Encoding as T +import Network.Http.Client (Connection, + baselineContextSSL, buildRequest, + closeConnection, + getStatusCode, http, + inputStreamBody, openConnectionSSL, + receiveResponse, sendRequest, + setAuthorizationBasic, encodedFormBody, + setContentType, setHeader) +import qualified Network.Http.Client as C +import OpenSSL (withOpenSSL) +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Attoparsec as Streams +import System.IO.Streams.Attoparsec (ParseException(..)) +import Web.Stripe.Client (APIVersion (..), Method(..), StripeConfig (..), + StripeError (..), + StripeErrorType (..), StripeRequest (..), + StripeReturn, getStripeKey, + toBytestring, toText, + paramsToByteString, attemptDecode, unknownCode, + handleStream + ) + +------------------------------------------------------------------------------ +-- | Create a request to `Stripe`'s API +stripe + :: (FromJSON (StripeReturn a)) => + StripeConfig + -> StripeRequest a + -> IO (Either StripeError (StripeReturn a)) +stripe config request = + withConnection $ \conn -> do + stripeConn conn config request + +------------------------------------------------------------------------------ +-- | Create a request to `Stripe`'s API using a connection opened +-- with `withConnection` +stripeConn + :: (FromJSON (StripeReturn a)) => + Connection + -> StripeConfig + -> StripeRequest a + -> IO (Either StripeError (StripeReturn a)) +stripeConn conn config request = + callAPI conn fromJSON config request + +------------------------------------------------------------------------------ +-- | Open a connection to the stripe API server +withConnection :: (Connection -> IO (Either StripeError a)) + -> IO (Either StripeError a) +withConnection f = + withOpenSSL $ do + ctx <- baselineContextSSL + result <- try (openConnectionSSL ctx "api.stripe.com" 443) :: IO (Either SomeException Connection) + case result of + Left msg -> return $ Left $ StripeError ConnectionFailure (toText msg) Nothing Nothing Nothing + Right conn -> (f conn) `finally` (closeConnection conn) + +------------------------------------------------------------------------------ +-- | Debug Helper +debug :: Bool +debug = False + +------------------------------------------------------------------------------ +-- | convert from stripe-core Method type to http-stream Method type +m2m :: Method -> C.Method +m2m GET = C.GET +m2m POST = C.POST +m2m DELETE = C.DELETE + +------------------------------------------------------------------------------ +-- | Create a request to `Stripe`'s API over an existing connection +-- +-- see also: 'withConnection' +-- FIXME: all connection errors should be +-- turned into a `StripeError`. But that is not yet implemented. +-- +-- NOTES: this a pretty low-level function. You probably want `stripe` +-- or `stripeConn`. If you call this function directly, you are +-- responsible for ensuring the JSON conversion function supplied is +-- correct for `StripeRequest`. In the rest of the library this +-- property is enforced automatically by the type-system. But adding +-- that constraint here made implementing the `Stripe` testing monad +-- difficult. +callAPI + :: Connection -- ^ an open connection to the server (`withConnection`) + -> (Value -> Result b) -- ^ function to convert JSON result to Haskell Value + -> StripeConfig -- ^ StripeConfig + -> StripeRequest a -- ^ StripeRequest + -> IO (Either StripeError b) +callAPI conn fromJSON' StripeConfig {..} StripeRequest{..} = do + let reqBody | method == GET = mempty + | otherwise = queryParams + reqURL | method == GET = S.concat [ + T.encodeUtf8 endpoint + , "?" + , paramsToByteString queryParams + ] + | otherwise = T.encodeUtf8 endpoint + req <- buildRequest $ do + http (m2m method) $ "/v1/" <> reqURL + setAuthorizationBasic (getStripeKey secretKey) mempty + setContentType "application/x-www-form-urlencoded" + setHeader "Stripe-Version" (toBytestring V20141007) + setHeader "Connection" "Keep-Alive" + sendRequest conn req (encodedFormBody reqBody) + receiveResponse conn $ \response inputStream -> + do when debug $ print response + let statusCode = getStatusCode response + if not (attemptDecode statusCode) + then return unknownCode + else do -- FIXME: should we check the content-type instead + -- assuming it is application/json? --DMJ: Stripe + -- gaurantees it to be JSON + v <- try (Streams.parseFromStream json' inputStream) + let r = + case v of + (Left (ParseException msg)) -> Error msg + (Right a) -> Success a + return $ handleStream fromJSON' statusCode r diff --git a/stripe-http-streams.cabal b/stripe-http-streams.cabal new file mode 100644 --- /dev/null +++ b/stripe-http-streams.cabal @@ -0,0 +1,51 @@ +name: stripe-http-streams +version: 2.0.0 +license: MIT +license-file: LICENSE +author: David Johnson +maintainer: djohnson.m@gmail.com +copyright: Copyright (c) 2014 David M. Johnson +category: Web +build-type: Simple +cabal-version: >=1.10 +Description: + . + <> + . + [Access Stripe API using http-streams] + This package provides access to the Stripe API using `stripe-core` and `http-streams`. See also the `stripe` package. + +library + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Web.Stripe.Client.HttpStreams + other-extensions: OverloadedStrings, RecordWildCards + build-depends: base >= 4.7 && < 5 + , aeson >= 0.8 && < 0.10 + , bytestring >= 0.10 && < 0.11 + , HsOpenSSL >= 0.11 && < 0.12 + , http-streams >= 0.7 && < 0.9 + , io-streams >= 1.2 && < 1.4 + , stripe-core >= 2.0 && < 2.1 + , text >= 1.1 && < 1.3 + ghc-options: -Wall + +Test-Suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests + build-depends: HsOpenSSL + , base >= 4.7 && < 5 + , free >= 4.10 && < 4.13 + , hspec >= 2.1.0 && < 2.3 + , http-streams >= 0.7 && < 0.9 + , stripe-core >= 2.0 && < 2.1 + , stripe-http-streams >= 2.0 && < 2.1 + , stripe-tests >= 2.0 && < 2.1 + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts + +source-repository head + type: git + subdir: stripe-http-streams + 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,32 @@ +module Main where + +import Control.Monad.Trans.Free (FreeF(..), FreeT(..)) +import Network.Http.Client (Connection) +import Web.Stripe.Client (StripeConfig(..), StripeError(..)) +import Web.Stripe.Client.HttpStreams (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' :: Connection + -> StripeConfig + -> Stripe a + -> IO (Either StripeError a) +runStripe' conn config (FreeT m) = + do f <- m + case f of + (Pure a) -> return (Right a) + (Free (StripeRequestF req decode')) -> + do r <- callAPI conn decode' config req + case r of + (Left e) -> return (Left e) + (Right next) -> runStripe' conn config next