git.iko.soy/elk
on master help sign in
add support for monthly donations
97f5045Evan Czaplicki
worker/src/Endpoint/Donate.hs+185−44
compare with master
unifiedsplit
@@ -7,21 +7,26 @@ module Endpoint.Donate
7 where
7 where
8
8
9
9
10+import Prelude hiding (id)
10import qualified Control.Exception as E
11import qualified Control.Exception as E
12+import Control.Monad.Except (ExceptT(ExceptT), runExceptT)
11import Control.Monad.Trans (liftIO)
13import Control.Monad.Trans (liftIO)
12import Data.Aeson ((.:))
14import Data.Aeson ((.:))
13import qualified Data.Aeson as Json
15import qualified Data.Aeson as Json
16+import Data.Char (chr)
14import qualified Data.ByteString as BS
17import qualified Data.ByteString as BS
15import qualified Data.ByteString.Builder as B
18import qualified Data.ByteString.Builder as B
16import qualified Data.ByteString.Base64 as Base64
19import qualified Data.ByteString.Base64 as Base64
17import qualified Data.ByteString.Char8 as BSC
20import qualified Data.ByteString.Char8 as BSC
18import qualified Data.ByteString.Lazy as LBS
21import qualified Data.ByteString.Lazy as LBS
19import qualified Data.Text as T
22import qualified Data.Text as T
23+import qualified Data.Text.Encoding as T
20import Snap.Core
24import Snap.Core
21import qualified Network.HTTP.Client as Http
25import qualified Network.HTTP.Client as Http
22import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
26import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
23import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
27import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
24import qualified Network.HTTP.Types.Method as Http (methodPost)
28import qualified Network.HTTP.Types.Method as Http (methodPost)
29+import qualified Network.HTTP.Types.Status as Http (statusCode)
25
30
26import qualified Cors
31import qualified Cors
27
32
@@ -38,6 +43,19 @@ allowedOrigins =
38
43
39
44
40-- GET MANAGER
45-- GET MANAGER
46+--
47+-- To talk to Stripe you need a header like this:
48+--
49+-- Authorization: Basic dXNlcm5hbWU6cGFzc3dvcmQ=
50+-- ^^^^^^^^^^^^^^^^^^^^^^^^
51+-- Where the underlined part is the base64 encoded version of your Stripe
52+-- secret key. The secret key is given as an environment variable, and then
53+-- stored in the Manager as the "Authorization" value we will be using.
54+-- I figured this out based on the following links:
55+--
56+-- https://stripe.com/docs/payments/checkout/one-time
57+-- https://stackoverflow.com/a/35442984
58+--
41
59
42
60
43data Manager =
61data Manager =
@@ -53,6 +71,11 @@ getManager secret =
53 return (Manager manager ("Basic " <> Base64.encode (BSC.pack secret)))
71 return (Manager manager ("Basic " <> Base64.encode (BSC.pack secret)))
54
72
55
73
74+addAuthorization :: BS.ByteString -> Http.Request -> Http.Request
75+addAuthorization authToken req =
76+ req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
77+
78+
56
79
57-- ENDPOINT
80-- ENDPOINT
58
81
@@ -62,13 +85,13 @@ endpoint manager =
62 Cors.allow POST allowedOrigins $
85 Cors.allow POST allowedOrigins $
63 do cents <- requireParameter "cents" toCents
86 do cents <- requireParameter "cents" toCents
64 frequency <- requireParameter "frequency" toFrequency
87 frequency <- requireParameter "frequency" toFrequency
65− mabyeSession <- liftIO $ getStripeCheckoutSessionID manager cents
88+ result <- liftIO $ runExceptT $ getStripeCheckoutSessionID manager cents frequency
66− case mabyeSession of
89+ case result of
67− Just (StripeCheckoutSession id) ->
90+ Right (StripeCheckoutSession id) ->
68 do modifyResponse $ setContentType "text/plain; charset=utf-8"
91 do modifyResponse $ setContentType "text/plain; charset=utf-8"
69 writeText id
92 writeText id
70
93
71− Nothing ->
94+ Left _ ->
72 do writeBuilder $ "Problem creating Stripe session ID for checkout."
95 do writeBuilder $ "Problem creating Stripe session ID for checkout."
73 finishWith
96 finishWith
74 . setResponseStatus 500 "Internal Server Error"
97 . setResponseStatus 500 "Internal Server Error"
@@ -113,57 +136,175 @@ newtype StripeCheckoutSession =
113 StripeCheckoutSession { _id :: T.Text }
136 StripeCheckoutSession { _id :: T.Text }
114
137
115
138
116−getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
139+instance Json.FromJSON StripeCheckoutSession where
117−getStripeCheckoutSessionID (Manager manager authToken) cents =
140+ parseJSON =
118− E.handle handleSomeException $
141+ Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
119− do req <-
142+ StripeCheckoutSession <$> obj .: "id"
120− configureRequest authToken cents <$>
121− Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
122
143
123− Http.withResponse req manager $ \response ->
124− do chunks <- Http.brConsume (Http.responseBody response)
125− return $ Json.decode $ LBS.fromChunks chunks
126
144
145+getStripeCheckoutSessionID :: Manager -> Int -> Frequency -> Http StripeCheckoutSession
146+getStripeCheckoutSessionID manager cents frequency =
147+ case frequency of
148+ OneTime -> setupOnetimeDonation manager cents
149+ Monthly -> setupMonthlyDonation manager cents
127
150
128−-- The "Authorization" header is set based on combining these instructions:
151+
129−--
152+
130−-- https://stripe.com/docs/payments/checkout/one-time
153+-- SET UP ONE-TIME DONATION
131−-- https://stackoverflow.com/a/35442984
154+
132−--
155+
133−-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
156+setupOnetimeDonation :: Manager -> Int -> Http StripeCheckoutSession
134−--
157+setupOnetimeDonation manager cents =
135−configureRequest :: BS.ByteString -> Int -> Http.Request -> Http.Request
158+ post manager
136−configureRequest authToken cents req =
159+ "https://api.stripe.com/v1/checkout/sessions"
137− Http.urlEncodedBody (toOneTimeParts cents) $
138− req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
139−
140−
141−toOneTimeParts :: Int -> [(BS.ByteString, BS.ByteString)]
142−toOneTimeParts cents =
143− [ "payment_method_types[]" ==> "card"
160+ [ "payment_method_types[]" ==> "card"
144− , "line_items[][name]" ==> "One-time donation"
161+ , "line_items[][name]" ==> "One-time donation"
145− , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
162+ , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
146− , "line_items[][amount]" ==> BSC.pack (show cents)
163+ , "line_items[][amount]" ==> BSC.pack (show cents)
147− , "line_items[][currency]" ==> "usd"
164+ , "line_items[][currency]" ==> "usd"
148− , "line_items[][quantity]" ==> "1"
165+ , "line_items[][quantity]" ==> "1"
149− , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
166+ , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
167+ , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
168+ ]
169+
170+
171+
172+-- SET UP MONTHLY DONATION
173+
174+
175+setupMonthlyDonation :: Manager -> Int -> Http StripeCheckoutSession
176+setupMonthlyDonation manager cents =
177+ do (Plan id) <- getMonthlyPlan manager cents
178+ post manager
179+ "https://api.stripe.com/v1/checkout/sessions"
180+ [ "payment_method_types[]" ==> "card"
181+ , "subscription_data[items][][plan]" ==> id
182+ , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
150− , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
183+ , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
184+ ]
185+
186+
187+
188+-- GET MONTHLY PLAN
189+
190+
191+getMonthlyPlan :: Manager -> Int -> Http Plan
192+getMonthlyPlan manager cents =
193+ do result <- try $ get manager ("https://api.stripe.com/v1/plans/" ++ toPlanID cents)
194+ case result of
195+ Right plan -> return plan
196+ Left _ -> createMonthlyPlan manager cents
197+
198+
199+newtype Plan =
200+ Plan BS.ByteString
201+
202+
203+instance Json.FromJSON Plan where
204+ parseJSON =
205+ Json.withObject "StripeResponse" $ \obj ->
206+ Plan . T.encodeUtf8 <$> obj .: "id"
207+
208+
209+toPlanID :: Int -> String
210+toPlanID cents =
211+ "monthly_" ++ show cents
212+
213+
214+
215+-- CREATE MONTHLY PLAN
216+
217+
218+createMonthlyPlan :: Manager -> Int -> Http Plan
219+createMonthlyPlan manager cents =
220+ post manager
221+ "https://api.stripe.com/v1/plans"
222+ [ "id" ==> BSC.pack (toPlanID cents)
223+ , "amount" ==> BSC.pack (show cents)
224+ , "currency" ==> "usd"
225+ , "interval" ==> "month"
226+ , "nickname" ==> toPlanNickname cents
227+ , "product" ==> "prod_GtPzOm0QbweJIE"
151− ]
228+ ]
229+
230+
231+toPlanNickname :: Int -> BS.ByteString
232+toPlanNickname cents =
233+ let
234+ (dollars, leftovers) = divMod cents 100
235+ (dimes,pennies) = divMod leftovers 10
236+ in
237+ BSC.pack $
238+ "Monthly $" ++ show dollars ++ [ '.', chr (0x30 + dimes), chr (0x30 + pennies) ]
239+
240+
241+
242+-- HTTP
243+
244+
245+type Http a = ExceptT Error IO a
246+
247+
248+data Error
249+ = StripeError LBS.ByteString
250+ | UnexpectedJson LBS.ByteString
251+ | SomethingElse E.SomeException
252+
253+
254+try :: Http a -> ExceptT x IO (Either Error a)
255+try http =
256+ liftIO (runExceptT http)
257+
258+
259+
260+-- HTTP GET
261+
262+
263+get :: (Json.FromJSON a) => Manager -> String -> Http a
264+get (Manager manager authToken) url =
265+ request manager $
266+ addAuthorization authToken <$> Http.parseRequest url
267+
268+
269+
270+-- HTTP POST
271+
272+
273+post :: (Json.FromJSON a) => Manager -> String -> [(BS.ByteString, BS.ByteString)] -> Http a
274+post (Manager manager authToken) url parts =
275+ request manager $
276+ Http.urlEncodedBody parts . addAuthorization authToken <$> Http.parseRequest url
152
277
153
278
154(==>) :: a -> b -> (a,b)
279(==>) :: a -> b -> (a,b)
155(==>) = (,)
280(==>) = (,)
156
281
157
282
158−handleSomeException :: E.SomeException -> IO (Maybe a)
159−handleSomeException exception =
160− return Nothing
161
283
284+-- HTTP REQUEST
162
285
163−instance Json.FromJSON StripeCheckoutSession where
286+
164− parseJSON =
287+request :: (Json.FromJSON a) => Http.Manager -> IO Http.Request -> Http a
165− Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
288+request manager mkReq =
166− StripeCheckoutSession <$> obj .: "id"
289+ ExceptT $ E.handle handleSomeException $
290+ do req <- mkReq
291+ Http.withResponse req manager $ \response ->
292+ do chunks <- Http.brConsume (Http.responseBody response)
293+ let code = Http.statusCode (Http.responseStatus response)
294+ let body = LBS.fromChunks chunks
295+ return $
296+ if 200 <= code && code < 300
297+ then
298+ case Json.decode body of
299+ Just a -> Right a
300+ Nothing -> Left (UnexpectedJson body)
301+ else
302+ Left (StripeError body)
303+
304+
305+handleSomeException :: E.SomeException -> IO (Either Error a)
306+handleSomeException exception =
307+ return (Left (SomethingElse exception))
167
308
168
309
169
310