@@ -7,21 +7,26 @@ module Endpoint.Donate
77 where
88
99
10+import Prelude hiding (id)
1011import qualified Control.Exception as E
12+import Control.Monad.Except (ExceptT(ExceptT), runExceptT)
1113import Control.Monad.Trans (liftIO)
1214import Data.Aeson ((.:))
1315import qualified Data.Aeson as Json
16+import Data.Char (chr)
1417import qualified Data.ByteString as BS
1518import qualified Data.ByteString.Builder as B
1619import qualified Data.ByteString.Base64 as Base64
1720import qualified Data.ByteString.Char8 as BSC
1821import qualified Data.ByteString.Lazy as LBS
1922import qualified Data.Text as T
23+import qualified Data.Text.Encoding as T
2024import Snap.Core
2125import qualified Network.HTTP.Client as Http
2226import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
2327import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
2428import qualified Network.HTTP.Types.Method as Http (methodPost)
29+import qualified Network.HTTP.Types.Status as Http (statusCode)
2530
2631import qualified Cors
2732
@@ -38,6 +43,19 @@ allowedOrigins =
3843
3944
4045-- 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+--
4159
4260
4361data Manager =
@@ -53,6 +71,11 @@ getManager secret =
5371 return (Manager manager ("Basic " <> Base64.encode (BSC.pack secret)))
5472
5573
74+addAuthorization :: BS.ByteString -> Http.Request -> Http.Request
75+addAuthorization authToken req =
76+ req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
77+
78+
5679
5780-- ENDPOINT
5881
@@ -62,13 +85,13 @@ endpoint manager =
6285 Cors.allow POST allowedOrigins $
6386 do cents <- requireParameter "cents" toCents
6487 frequency <- requireParameter "frequency" toFrequency
65− mabyeSession <- liftIO $ getStripeCheckoutSessionID manager cents
66− case mabyeSession of
67− Just (StripeCheckoutSession id) ->
88+ result <- liftIO $ runExceptT $ getStripeCheckoutSessionID manager cents frequency
89+ case result of
90+ Right (StripeCheckoutSession id) ->
6891 do modifyResponse $ setContentType "text/plain; charset=utf-8"
6992 writeText id
7093
71− Nothing ->
94+ Left _ ->
7295 do writeBuilder $ "Problem creating Stripe session ID for checkout."
7396 finishWith
7497 . setResponseStatus 500 "Internal Server Error"
@@ -113,57 +136,175 @@ newtype StripeCheckoutSession =
113136 StripeCheckoutSession { _id :: T.Text }
114137
115138
116−getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
117−getStripeCheckoutSessionID (Manager manager authToken) cents =
118− E.handle handleSomeException $
119− do req <-
120− configureRequest authToken cents <$>
121− Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
139+instance Json.FromJSON StripeCheckoutSession where
140+ parseJSON =
141+ Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
142+ StripeCheckoutSession <$> obj .: "id"
122143
123− Http.withResponse req manager $ \response ->
124− do chunks <- Http.brConsume (Http.responseBody response)
125− return $ Json.decode $ LBS.fromChunks chunks
126144
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
127150
128−-- The "Authorization" header is set based on combining these instructions:
129−--
130−-- https://stripe.com/docs/payments/checkout/one-time
131−-- https://stackoverflow.com/a/35442984
132−--
133−-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
134−--
135−configureRequest :: BS.ByteString -> Int -> Http.Request -> Http.Request
136−configureRequest authToken cents req =
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"
144− , "line_items[][name]" ==> "One-time donation"
145− , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
146− , "line_items[][amount]" ==> BSC.pack (show cents)
147− , "line_items[][currency]" ==> "usd"
148− , "line_items[][quantity]" ==> "1"
149− , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
150− , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
151− ]
151+
152+
153+-- SET UP ONE-TIME DONATION
154+
155+
156+setupOnetimeDonation :: Manager -> Int -> Http StripeCheckoutSession
157+setupOnetimeDonation manager cents =
158+ post manager
159+ "https://api.stripe.com/v1/checkout/sessions"
160+ [ "payment_method_types[]" ==> "card"
161+ , "line_items[][name]" ==> "One-time donation"
162+ , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
163+ , "line_items[][amount]" ==> BSC.pack (show cents)
164+ , "line_items[][currency]" ==> "usd"
165+ , "line_items[][quantity]" ==> "1"
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}"
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"
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
152277
153278
154279(==>) :: a -> b -> (a,b)
155280(==>) = (,)
156281
157282
158−handleSomeException :: E.SomeException -> IO (Maybe a)
159−handleSomeException exception =
160− return Nothing
161283
284+-- HTTP REQUEST
162285
163−instance Json.FromJSON StripeCheckoutSession where
164− parseJSON =
165− Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
166− StripeCheckoutSession <$> obj .: "id"
286+
287+request :: (Json.FromJSON a) => Http.Manager -> IO Http.Request -> Http a
288+request manager mkReq =
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))
167308
168309
169310