@@ -1,341 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Endpoint.Donate
3− ( Manager
4− , endpoint
5− , getManager
6− )
7− where
8−
9−
10−import Prelude hiding (id)
11−import qualified Control.Exception as E
12−import Control.Monad.Except (ExceptT(ExceptT), runExceptT)
13−import Control.Monad.Trans (liftIO)
14−import Data.Aeson ((.:))
15−import qualified Data.Aeson as Json
16−import Data.Char (chr)
17−import qualified Data.ByteString as BS
18−import qualified Data.ByteString.Builder as B
19−import qualified Data.ByteString.Base64 as Base64
20−import qualified Data.ByteString.Char8 as BSC
21−import qualified Data.ByteString.Lazy as LBS
22−import qualified Data.Text as T
23−import qualified Data.Text.Encoding as T
24−import Snap.Core
25−import qualified Network.HTTP.Client as Http
26−import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
27−import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
28−import qualified Network.HTTP.Types.Method as Http (methodPost)
29−import qualified Network.HTTP.Types.Status as Http (statusCode)
30−
31−import qualified Cors
32−
33−
34−
35−-- ALLOWED ORIGINS
36−
37−
38−allowedOrigins :: [String]
39−allowedOrigins =
40− [ "https://foundation.elm-lang.org"
41− ]
42−
43−
44−
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−--
59−
60−
61−data Manager =
62− Manager
63− { _manager :: Http.Manager
64− , _authToken :: BS.ByteString
65− }
66−
67−
68−getManager :: String -> IO Manager
69−getManager secret =
70− do manager <- Http.newManager Http.tlsManagerSettings
71− return (Manager manager ("Basic " <> Base64.encode (BSC.pack secret)))
72−
73−
74−addAuthorization :: BS.ByteString -> Http.Request -> Http.Request
75−addAuthorization authToken req =
76− req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
77−
78−
79−
80−-- ENDPOINT
81−
82−
83−endpoint :: Manager -> Snap ()
84−endpoint manager =
85− Cors.allow POST allowedOrigins $
86− do cents <- requireParameter "cents" toCents
87− frequency <- requireParameter "frequency" toFrequency
88− result <- liftIO $ runExceptT $ getStripeCheckoutSessionID manager cents frequency
89− case result of
90− Right (StripeCheckoutSession id) ->
91− do modifyResponse $ setContentType "text/plain; charset=utf-8"
92− writeText id
93−
94− Left _ ->
95− do writeBuilder $ "Problem creating Stripe session ID for checkout."
96− finishWith
97− . setResponseStatus 500 "Internal Server Error"
98− . setContentType "text/plain; charset=utf-8"
99− =<< getResponse
100−
101−
102−data Frequency
103− = OneTime
104− | Monthly
105−
106−
107−toFrequency :: BS.ByteString -> Either B.Builder Frequency
108−toFrequency bytes =
109− case bytes of
110− "onetime" -> Right OneTime
111− "monthly" -> Right Monthly
112− _ -> Left "The only valid values are frequency=onetime and frequency=monthly."
113−
114−
115−toCents :: BS.ByteString -> Either B.Builder Int
116−toCents bytes =
117− if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes && not (BS.isPrefixOf "0" bytes) then
118− let
119− cents = BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes
120− in
121− if cents >= 500
122− then Right cents
123− else
124− Left
125− "Processing fees are (2.2% + $0.30) per transaction, so the minimum\n\
126− \donation is $5 (cents=500) to limit the worst case fee to ~8%"
127− else
128− Left "Must be a value like cents=1000 for $10 or cents=2500 for $25."
129−
130−
131−
132−-- GET STRIPE CHECKOUT SESSION ID
133−
134−
135−newtype StripeCheckoutSession =
136− StripeCheckoutSession { _id :: T.Text }
137−
138−
139−instance Json.FromJSON StripeCheckoutSession where
140− parseJSON =
141− Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
142− StripeCheckoutSession <$> obj .: "id"
143−
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
150−
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− , "submit_type" ==> "donate"
167− , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
168− , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
169− ]
170−
171−
172−
173−-- SET UP MONTHLY DONATION
174−
175−
176−setupMonthlyDonation :: Manager -> Int -> Http StripeCheckoutSession
177−setupMonthlyDonation manager cents =
178− do (Plan id) <- getMonthlyPlan manager cents
179− post manager
180− "https://api.stripe.com/v1/checkout/sessions"
181− [ "payment_method_types[]" ==> "card"
182− , "subscription_data[items][][plan]" ==> id
183− , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
184− , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
185− ]
186−
187−
188−
189−-- GET MONTHLY PLAN
190−
191−
192−getMonthlyPlan :: Manager -> Int -> Http Plan
193−getMonthlyPlan manager cents =
194− do result <- try $ get manager ("https://api.stripe.com/v1/plans/" ++ toPlanID cents)
195− case result of
196− Right plan -> return plan
197− Left _ -> createMonthlyPlan manager cents
198−
199−
200−newtype Plan =
201− Plan BS.ByteString
202−
203−
204−instance Json.FromJSON Plan where
205− parseJSON =
206− Json.withObject "StripeResponse" $ \obj ->
207− Plan . T.encodeUtf8 <$> obj .: "id"
208−
209−
210−toPlanID :: Int -> String
211−toPlanID cents =
212− "monthly_" ++ show cents
213−
214−
215−
216−-- CREATE MONTHLY PLAN
217−
218−
219−createMonthlyPlan :: Manager -> Int -> Http Plan
220−createMonthlyPlan manager cents =
221− post manager
222− "https://api.stripe.com/v1/plans"
223− [ "id" ==> BSC.pack (toPlanID cents)
224− , "amount" ==> BSC.pack (show cents)
225− , "currency" ==> "usd"
226− , "interval" ==> "month"
227− , "nickname" ==> toPlanNickname cents
228− , "product" ==> "prod_GtPzOm0QbweJIE"
229− ]
230−
231−
232−toPlanNickname :: Int -> BS.ByteString
233−toPlanNickname cents =
234− let
235− (dollars, leftovers) = divMod cents 100
236− (dimes,pennies) = divMod leftovers 10
237− in
238− BSC.pack $
239− "Monthly $" ++ show dollars ++ [ '.', chr (0x30 + dimes), chr (0x30 + pennies) ]
240−
241−
242−
243−-- HTTP
244−
245−
246−type Http a = ExceptT Error IO a
247−
248−
249−data Error
250− = StripeError LBS.ByteString
251− | UnexpectedJson LBS.ByteString
252− | SomethingElse E.SomeException
253−
254−
255−try :: Http a -> ExceptT x IO (Either Error a)
256−try http =
257− liftIO (runExceptT http)
258−
259−
260−
261−-- HTTP GET
262−
263−
264−get :: (Json.FromJSON a) => Manager -> String -> Http a
265−get (Manager manager authToken) url =
266− request manager $
267− addAuthorization authToken <$> Http.parseRequest url
268−
269−
270−
271−-- HTTP POST
272−
273−
274−post :: (Json.FromJSON a) => Manager -> String -> [(BS.ByteString, BS.ByteString)] -> Http a
275−post (Manager manager authToken) url parts =
276− request manager $
277− Http.urlEncodedBody parts . addAuthorization authToken <$> Http.parseRequest url
278−
279−
280−(==>) :: a -> b -> (a,b)
281−(==>) = (,)
282−
283−
284−
285−-- HTTP REQUEST
286−
287−
288−request :: (Json.FromJSON a) => Http.Manager -> IO Http.Request -> Http a
289−request manager mkReq =
290− ExceptT $ E.handle handleSomeException $
291− do req <- mkReq
292− Http.withResponse req manager $ \response ->
293− do chunks <- Http.brConsume (Http.responseBody response)
294− let code = Http.statusCode (Http.responseStatus response)
295− let body = LBS.fromChunks chunks
296− return $
297− if 200 <= code && code < 300
298− then
299− case Json.decode body of
300− Just a -> Right a
301− Nothing -> Left (UnexpectedJson body)
302− else
303− Left (StripeError body)
304−
305−
306−handleSomeException :: E.SomeException -> IO (Either Error a)
307−handleSomeException exception =
308− return (Left (SomethingElse exception))
309−
310−
311−
312−-- REQUIRE PARAMETER
313−
314−
315−requireParameter :: BS.ByteString -> (BS.ByteString -> Either B.Builder a) -> Snap a
316−requireParameter name toValue =
317− do params <- getsRequest (rqParam name)
318− case params of
319− Just [bytes] ->
320− case toValue bytes of
321− Right value ->
322− return value
323−
324− Left message ->
325− badParam $
326− "Ran into invalid query parameter:\n\n "
327− <> B.byteString name <> "=" <> B.byteString bytes
328− <> "\n\n" <> message
329−
330− _ ->
331− badParam $
332− "Missing parameter '" <> B.byteString name <> "' in requset."
333−
334−
335−badParam :: B.Builder -> Snap a
336−badParam message =
337− do writeBuilder message
338− finishWith
339− . setResponseStatus 400 "Bad Request"
340− . setContentType "text/plain; charset=utf-8"
341− =<< getResponse