|
| 1 | +{-# LANGUAGE FlexibleContexts #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | + |
| 4 | +module Web.Stripe.Client.HttpClient |
| 5 | + ( |
| 6 | + StripeRequest(..) |
| 7 | + , StripeError(..) |
| 8 | + , StripeConfig(..) |
| 9 | + |
| 10 | + , stripe |
| 11 | + , stripeManager |
| 12 | + , stripeConn |
| 13 | + |
| 14 | + -- * low-level |
| 15 | + , withConnection |
| 16 | + , withManager |
| 17 | + , callAPI |
| 18 | + |
| 19 | + ) where |
| 20 | + |
| 21 | +import qualified Control.Arrow |
| 22 | +import qualified Data.ByteString.Lazy as BSL |
| 23 | +import qualified Data.Text.Encoding as TE |
| 24 | +import qualified Network.HTTP.Types as Http |
| 25 | + |
| 26 | +import Data.Aeson as A |
| 27 | +import Data.ByteString (ByteString) |
| 28 | +import Data.Monoid ((<>)) |
| 29 | +import Network.HTTP.Client as Http hiding (withManager) |
| 30 | +import Network.HTTP.Client.TLS as TLS |
| 31 | + |
| 32 | +import qualified Web.Stripe.StripeRequest as S |
| 33 | + |
| 34 | +import Web.Stripe.Client (APIVersion (..), StripeConfig (..), |
| 35 | + StripeError (..), StripeKey (..), |
| 36 | + StripeRequest, StripeReturn, |
| 37 | + attemptDecode, handleStream, |
| 38 | + parseFail, toBytestring, unknownCode) |
| 39 | + |
| 40 | + |
| 41 | +-- | Create a request to 'Stripe's API. |
| 42 | +-- |
| 43 | +-- This function uses the global TLS manager from @http-client-tls@ |
| 44 | +-- via 'getGlobalManager'. |
| 45 | +stripe :: FromJSON (StripeReturn a) |
| 46 | + => StripeConfig |
| 47 | + -> StripeRequest a |
| 48 | + -> IO (Either StripeError (StripeReturn a)) |
| 49 | +stripe config request = do |
| 50 | + man <- TLS.getGlobalManager |
| 51 | + callAPI man fromJSON config request |
| 52 | + |
| 53 | +-- | Create a request to 'Stripe's API using a 'Manager'. |
| 54 | +stripeManager :: FromJSON (StripeReturn a) |
| 55 | + => Manager |
| 56 | + -> StripeConfig |
| 57 | + -> StripeRequest a |
| 58 | + -> IO (Either StripeError (StripeReturn a)) |
| 59 | +stripeManager manager config request = callAPI manager fromJSON config request |
| 60 | + |
| 61 | +-- | Create a request to 'Stripe's API using a 'Manager'. |
| 62 | +-- |
| 63 | +-- This function is used to maintain compatibility w/ |
| 64 | +-- @stripe-http-streams@. However, the terminology in @http-streams@ |
| 65 | +-- uses 'Connection' whereas @http-client@ uses connection 'Manager'. |
| 66 | +stripeConn :: FromJSON (StripeReturn a) |
| 67 | + => Manager |
| 68 | + -> StripeConfig |
| 69 | + -> StripeRequest a |
| 70 | + -> IO (Either StripeError (StripeReturn a)) |
| 71 | +stripeConn = stripeManager |
| 72 | + |
| 73 | +withConnection :: (Manager -> IO (Either StripeError a)) |
| 74 | + -> IO (Either StripeError a) |
| 75 | +withConnection = withManager |
| 76 | + |
| 77 | +withManager :: (Manager -> IO (Either StripeError a)) |
| 78 | + -> IO (Either StripeError a) |
| 79 | +withManager m = do |
| 80 | + |
| 81 | + -- @http-client@ has a set of deprecated `withManager` functions |
| 82 | + -- that are not necessary to safely prevent a 'Manager' from |
| 83 | + -- leaking resources. "Manager's will be closed and shutdown |
| 84 | + -- automatically (and safely) via gargage collection. |
| 85 | + manager <- TLS.getGlobalManager |
| 86 | + m manager |
| 87 | + |
| 88 | +-- | Create a request to 'Stripe's API using an existing 'Manager' |
| 89 | +-- |
| 90 | +-- This is a low-level function. In most cases you probably want to |
| 91 | +-- use 'stripe' or 'stripeManager'. |
| 92 | +callAPI :: Manager |
| 93 | + -> (Value -> Result b) |
| 94 | + -> StripeConfig |
| 95 | + -> StripeRequest a |
| 96 | + -> IO (Either StripeError b) |
| 97 | +callAPI man fromJSON' config stripeRequest = do |
| 98 | + |
| 99 | + res <- httpLbs mkStripeRequest man |
| 100 | + |
| 101 | + let status = Http.statusCode (Http.responseStatus res) |
| 102 | + |
| 103 | + if not (attemptDecode status) then |
| 104 | + return unknownCode |
| 105 | + |
| 106 | + else do |
| 107 | + case A.eitherDecode (Http.responseBody res) of |
| 108 | + Left e -> pure $ parseFail e |
| 109 | + Right a -> pure $ handleStream fromJSON' status $ return a |
| 110 | + where |
| 111 | + mkStripeRequest = |
| 112 | + |
| 113 | + let req = Http.applyBasicAuth (getStripeKey (secretKey config)) mempty $ |
| 114 | + defaultRequest { |
| 115 | + Http.method = m2m (S.method stripeRequest) |
| 116 | + , Http.secure = True |
| 117 | + , Http.host = "api.stripe.com" |
| 118 | + , Http.port = 443 |
| 119 | + , Http.path = "/v1/" <> TE.encodeUtf8 (S.endpoint stripeRequest) |
| 120 | + , Http.requestHeaders = [ |
| 121 | + ("Stripe-Version", toBytestring stripeVersion) |
| 122 | + , ("Connection", "Keep-Alive") |
| 123 | + ] |
| 124 | + , Http.checkResponse = \_ _ -> return () |
| 125 | + } |
| 126 | + |
| 127 | + stripeQueryParams = fmap |
| 128 | + (Control.Arrow.second Just) |
| 129 | + (S.queryParams stripeRequest) |
| 130 | + |
| 131 | + in if S.GET == S.method stripeRequest then |
| 132 | + Http.setQueryString stripeQueryParams req |
| 133 | + else |
| 134 | + urlEncodeBody (S.queryParams stripeRequest) req |
| 135 | + |
| 136 | +m2m :: S.Method -> Http.Method |
| 137 | +m2m S.GET = Http.methodGet |
| 138 | +m2m S.POST = Http.methodPost |
| 139 | +m2m S.DELETE = Http.methodDelete |
| 140 | + |
| 141 | +-- | This function is used instead of http-client's built-in 'urlEncodedBody' as |
| 142 | +-- the request method is set explicitly to POST in 'urlEncodeBody' but Stripe |
| 143 | +-- uses POST\/PUT\/DELETE. A PR should be submitted to http-client to fix |
| 144 | +-- eventually. |
| 145 | +urlEncodeBody :: [(ByteString, ByteString)] -> Request -> Request |
| 146 | +urlEncodeBody headers req = req { |
| 147 | + requestBody = RequestBodyLBS (BSL.fromChunks body) |
| 148 | + , requestHeaders = |
| 149 | + ("Content-Type", "application/x-www-form-urlencoded") |
| 150 | + : filter (\(x, _) -> x /= "Content-Type") (requestHeaders req) |
| 151 | + } |
| 152 | + where |
| 153 | + body = pure (Http.renderSimpleQuery False headers) |
| 154 | + |
| 155 | +stripeVersion :: APIVersion |
| 156 | +stripeVersion = V20141007 |
0 commit comments