git.iko.soy/elk
on master help sign in
switch to application/x-www-form-urlencoded for stripe
b303abdEvan Czaplicki
worker/src/Endpoint/Donate.hs+24−22
compare with master
unifiedsplit
@@ -22,8 +22,6 @@ import qualified Network.HTTP.Client as Http
22import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
22import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
23import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
23import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
24import qualified Network.HTTP.Types.Method as Http (methodPost)
24import 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
27
25
28import qualified Cors
26import qualified Cors
29
27
@@ -95,7 +93,7 @@ toAmount :: BS.ByteString -> Maybe Int
95toAmount bytes =
93toAmount bytes =
96 if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes
94 if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes
97 && not (BS.isPrefixOf "0" bytes)
95 && 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)
99 else Nothing
97 else Nothing
100
98
101
99
@@ -110,9 +108,11 @@ newtype StripeCheckoutSession =
110getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
108getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
111getStripeCheckoutSessionID (Manager manager authToken) amount =
109getStripeCheckoutSessionID (Manager manager authToken) amount =
112 E.handle handleSomeException $
110 E.handle handleSomeException $
111+ do req <-
112+ configureRequest authToken amount <$>
113− do req0 <- Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
113+ Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
114− req1 <- Multi.formDataBody (toOneTimeParts amount) (configureRequest authToken req0)
114+
115− Http.withResponse req1 manager $ \response ->
115+ Http.withResponse req manager $ \response ->
116 do chunks <- Http.brConsume (Http.responseBody response)
116 do chunks <- Http.brConsume (Http.responseBody response)
117 return $ Json.decode $ LBS.fromChunks chunks
117 return $ Json.decode $ LBS.fromChunks chunks
118
118
@@ -124,28 +124,30 @@ getStripeCheckoutSessionID (Manager manager authToken) amount =
124--
124--
125-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
125-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
126--
126--
127−configureRequest :: BS.ByteString -> Http.Request -> Http.Request
127+configureRequest :: BS.ByteString -> Int -> Http.Request -> Http.Request
128−configureRequest authToken req =
128+configureRequest authToken amount req =
129− req
129+ Http.urlEncodedBody (toOneTimeParts amount) $
130− { Http.method = Http.methodPost
131− , Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req
130+ req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
132− }
133
131
134
132
135−toOneTimeParts :: Int -> [Multi.Part]
133+toOneTimeParts :: Int -> [(BS.ByteString, BS.ByteString)]
136toOneTimeParts amount =
134toOneTimeParts amount =
137− [ Multi.partBS "payment_method_types[]" "card"
135+ [ "payment_method_types[]" ==> "card"
138− , Multi.partBS "line_items[][name]" "One-time donation"
136+ , "line_items[][name]" ==> "One-time donation"
139− , Multi.partBS "line_items[][description]" "One-time donation to Elm Software Foundation"
137+ , "line_items[][description]" ==> "One-time donation to Elm Software Foundation"
140− , Multi.partBS "line_items[][images][]" "https://foundation.elm-lang.org/donation.png"
138+ , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
141− , Multi.partBS "line_items[][amount]" (BSC.pack (show amount))
139+ , "line_items[][amount]" ==> BSC.pack (show amount)
142− , Multi.partBS "line_items[][currency]" "usd"
140+ , "line_items[][currency]" ==> "usd"
143− , Multi.partBS "line_items[][quantity]" "1"
141+ , "line_items[][quantity]" ==> "1"
144− , Multi.partBS "success_url" "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
142+ , "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"
143+ , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
146 ]
144 ]
147
145
148
146
147+(==>) :: a -> b -> (a,b)
148+(==>) = (,)
149+
150+
149handleSomeException :: E.SomeException -> IO (Maybe a)
151handleSomeException :: E.SomeException -> IO (Maybe a)
150handleSomeException exception =
152handleSomeException exception =
151 return Nothing
153 return Nothing