@@ -1,341 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
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
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)
38−allowedOrigins :: [String]
40− [ "https://foundation.elm-lang.org"
47−-- To talk to Stripe you need a header like this:
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:
56−-- https://stripe.com/docs/payments/checkout/one-time
57−-- https://stackoverflow.com/a/35442984
63− { _manager :: Http.Manager
64− , _authToken :: BS.ByteString
68−getManager :: String -> IO Manager
70− do manager <- Http.newManager Http.tlsManagerSettings
71− return (Manager manager ("Basic " <> Base64.encode (BSC.pack secret)))
74−addAuthorization :: BS.ByteString -> Http.Request -> Http.Request
75−addAuthorization authToken req =
76− req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
83−endpoint :: Manager -> Snap ()
85− Cors.allow POST allowedOrigins $
86− do cents <- requireParameter "cents" toCents
87− frequency <- requireParameter "frequency" toFrequency
88− result <- liftIO $ runExceptT $ getStripeCheckoutSessionID manager cents frequency
90− Right (StripeCheckoutSession id) ->
91− do modifyResponse $ setContentType "text/plain; charset=utf-8"
95− do writeBuilder $ "Problem creating Stripe session ID for checkout."
97− . setResponseStatus 500 "Internal Server Error"
98− . setContentType "text/plain; charset=utf-8"
107−toFrequency :: BS.ByteString -> Either B.Builder Frequency
110− "onetime" -> Right OneTime
111− "monthly" -> Right Monthly
112− _ -> Left "The only valid values are frequency=onetime and frequency=monthly."
115−toCents :: BS.ByteString -> Either B.Builder Int
117− if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes && not (BS.isPrefixOf "0" bytes) then
119− cents = BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes
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%"
128− Left "Must be a value like cents=1000 for $10 or cents=2500 for $25."
132−-- GET STRIPE CHECKOUT SESSION ID
135−newtype StripeCheckoutSession =
136− StripeCheckoutSession { _id :: T.Text }
139−instance Json.FromJSON StripeCheckoutSession where
141− Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
142− StripeCheckoutSession <$> obj .: "id"
145−getStripeCheckoutSessionID :: Manager -> Int -> Frequency -> Http StripeCheckoutSession
146−getStripeCheckoutSessionID manager cents frequency =
148− OneTime -> setupOnetimeDonation manager cents
149− Monthly -> setupMonthlyDonation manager cents
153−-- SET UP ONE-TIME DONATION
156−setupOnetimeDonation :: Manager -> Int -> Http StripeCheckoutSession
157−setupOnetimeDonation manager cents =
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"
173−-- SET UP MONTHLY DONATION
176−setupMonthlyDonation :: Manager -> Int -> Http StripeCheckoutSession
177−setupMonthlyDonation manager cents =
178− do (Plan id) <- getMonthlyPlan manager cents
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"
192−getMonthlyPlan :: Manager -> Int -> Http Plan
193−getMonthlyPlan manager cents =
194− do result <- try $ get manager ("https://api.stripe.com/v1/plans/" ++ toPlanID cents)
196− Right plan -> return plan
197− Left _ -> createMonthlyPlan manager cents
204−instance Json.FromJSON Plan where
206− Json.withObject "StripeResponse" $ \obj ->
207− Plan . T.encodeUtf8 <$> obj .: "id"
210−toPlanID :: Int -> String
212− "monthly_" ++ show cents
216−-- CREATE MONTHLY PLAN
219−createMonthlyPlan :: Manager -> Int -> Http Plan
220−createMonthlyPlan manager cents =
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"
232−toPlanNickname :: Int -> BS.ByteString
233−toPlanNickname cents =
235− (dollars, leftovers) = divMod cents 100
236− (dimes,pennies) = divMod leftovers 10
239− "Monthly $" ++ show dollars ++ [ '.', chr (0x30 + dimes), chr (0x30 + pennies) ]
246−type Http a = ExceptT Error IO a
250− = StripeError LBS.ByteString
251− | UnexpectedJson LBS.ByteString
252− | SomethingElse E.SomeException
255−try :: Http a -> ExceptT x IO (Either Error a)
257− liftIO (runExceptT http)
264−get :: (Json.FromJSON a) => Manager -> String -> Http a
265−get (Manager manager authToken) url =
267− addAuthorization authToken <$> Http.parseRequest url
274−post :: (Json.FromJSON a) => Manager -> String -> [(BS.ByteString, BS.ByteString)] -> Http a
275−post (Manager manager authToken) url parts =
277− Http.urlEncodedBody parts . addAuthorization authToken <$> Http.parseRequest url
280−(==>) :: a -> b -> (a,b)
288−request :: (Json.FromJSON a) => Http.Manager -> IO Http.Request -> Http a
289−request manager mkReq =
290− ExceptT $ E.handle handleSomeException $
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
297− if 200 <= code && code < 300
299− case Json.decode body of
301− Nothing -> Left (UnexpectedJson body)
303− Left (StripeError body)
306−handleSomeException :: E.SomeException -> IO (Either Error a)
307−handleSomeException exception =
308− return (Left (SomethingElse exception))
315−requireParameter :: BS.ByteString -> (BS.ByteString -> Either B.Builder a) -> Snap a
316−requireParameter name toValue =
317− do params <- getsRequest (rqParam name)
320− case toValue bytes of
326− "Ran into invalid query parameter:\n\n "
327− <> B.byteString name <> "=" <> B.byteString bytes
328− <> "\n\n" <> message
332− "Missing parameter '" <> B.byteString name <> "' in requset."
335−badParam :: B.Builder -> Snap a
337− do writeBuilder message
339− . setResponseStatus 400 "Bad Request"
340− . setContentType "text/plain; charset=utf-8"