@@ -22,8 +22,6 @@ import qualified Network.HTTP.Client as Http
2222import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
2323import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
2424import qualified Network.HTTP.Types.Method as Http (methodPost)
25−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
26−import qualified Network.HTTP.Client.MultipartFormData as Multi
2725
2826import qualified Cors
2927
@@ -95,7 +93,7 @@ toAmount :: BS.ByteString -> Maybe Int
9593toAmount bytes =
9694 if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes
9795 && not (BS.isPrefixOf "0" bytes)
98− then Just (BS.foldr (\w n -> 10 * n + fromIntegral (w - 0x30)) 0 bytes)
96+ then Just (BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes)
9997 else Nothing
10098
10199
@@ -110,9 +108,11 @@ newtype StripeCheckoutSession =
110108getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
111109getStripeCheckoutSessionID (Manager manager authToken) amount =
112110 E.handle handleSomeException $
113− do req0 <- Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
114− req1 <- Multi.formDataBody (toOneTimeParts amount) (configureRequest authToken req0)
115− Http.withResponse req1 manager $ \response ->
111+ do req <-
112+ configureRequest authToken amount <$>
113+ Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
114+
115+ Http.withResponse req manager $ \response ->
116116 do chunks <- Http.brConsume (Http.responseBody response)
117117 return $ Json.decode $ LBS.fromChunks chunks
118118
@@ -124,28 +124,30 @@ getStripeCheckoutSessionID (Manager manager authToken) amount =
124124--
125125-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
126126--
127−configureRequest :: BS.ByteString -> Http.Request -> Http.Request
128−configureRequest authToken req =
129− req
130− { Http.method = Http.methodPost
131− , Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req
132− }
127+configureRequest :: BS.ByteString -> Int -> Http.Request -> Http.Request
128+configureRequest authToken amount req =
129+ Http.urlEncodedBody (toOneTimeParts amount) $
130+ req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
133131
134132
135−toOneTimeParts :: Int -> [Multi.Part]
133+toOneTimeParts :: Int -> [(BS.ByteString, BS.ByteString)]
136134toOneTimeParts amount =
137− [ Multi.partBS "payment_method_types[]" "card"
138− , Multi.partBS "line_items[][name]" "One-time donation"
139− , Multi.partBS "line_items[][description]" "One-time donation to Elm Software Foundation"
140− , Multi.partBS "line_items[][images][]" "https://foundation.elm-lang.org/donation.png"
141− , Multi.partBS "line_items[][amount]" (BSC.pack (show amount))
142− , Multi.partBS "line_items[][currency]" "usd"
143− , Multi.partBS "line_items[][quantity]" "1"
144− , Multi.partBS "success_url" "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
145− , Multi.partBS "cancel_url" "https://foundation.elm-lang.org/donate"
135+ [ "payment_method_types[]" ==> "card"
136+ , "line_items[][name]" ==> "One-time donation"
137+ , "line_items[][description]" ==> "One-time donation to Elm Software Foundation"
138+ , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
139+ , "line_items[][amount]" ==> BSC.pack (show amount)
140+ , "line_items[][currency]" ==> "usd"
141+ , "line_items[][quantity]" ==> "1"
142+ , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
143+ , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
146144 ]
147145
148146
147+(==>) :: a -> b -> (a,b)
148+(==>) = (,)
149+
150+
149151handleSomeException :: E.SomeException -> IO (Maybe a)
150152handleSomeException exception =
151153 return Nothing