@@ -0,0 +1,150 @@
1+module Endpoint.Donate
2+ ( Manager
3+ , endpoint
4+ , getManager
5+ )
6+ where
7+
8+
9+import qualified Control.Exception as E
10+import qualified Data.ByteString as BS
11+import qualified Data.ByteString.Lazy as LBS
12+import Snap.Core
13+import qualified Network.HTTP.Client as Http (parseRequest)
14+import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
15+import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
16+import qualified Network.HTTP.Types.Method as Http (methodPost)
17+import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
18+import qualified Network.HTTP.Client.MultipartFormData as Multi
19+
20+import qualified Cors
21+
22+
23+
24+-- ALLOWED ORIGINS
25+
26+
27+allowedOrigins :: [String]
28+allowedOrigins =
29+ [ "https://foundation.elm-lang.org"
30+ ]
31+
32+
33+
34+-- GET MANAGER
35+
36+
37+newtype Manager =
38+ Manager Http.Manager
39+
40+
41+getManager :: IO Manager
42+getManager =
43+ Manager <$> Http.newManager Http.tlsManagerSettings
44+
45+
46+
47+-- ENDPOINT
48+
49+
50+endpoint :: Manager -> Snap ()
51+endpoint (Manager manager) =
52+ Cors.allow POST allowedOrigins $
53+ do amount <- requireParameter "amount" toAmount
54+ frequency <- requireParameter "frequency" toFrequency
55+ mabyeSession <- liftIO $ getStripeCheckoutSessionID manager amount
56+ case mabyeSession of
57+ Nothing ->
58+
59+ Just (StripeCheckoutSession id) ->
60+ do modifyResponse $ setContentType "text/plain"
61+ writeBS id
62+
63+
64+data Frequency
65+ = OneTime
66+ | Monthly
67+
68+
69+toFrequency :: BS.ByteString -> Maybe Frequency
70+toFrequency bytes =
71+ case bytes of
72+ "onetime" -> Just OneTime
73+ "monthly" -> Just Monthly
74+ _ -> Nothing
75+
76+
77+toAmount :: BS.ByteString -> Maybe Int
78+toAmount bytes =
79+ if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes
80+ && not (BS.isPrefixOf "0" bytes)
81+ then Just (BS.foldr (\w n -> 10 * n + fromIntegral (w - 0x30)) 0 bytes)
82+ else Nothing
83+
84+
85+
86+-- GET STRIPE CHECKOUT SESSION ID
87+
88+
89+newtype StripeCheckoutSession =
90+ StripeCheckoutSession { _id :: BS.ByteString }
91+
92+
93+getStripeCheckoutSessionID :: Http.Manager -> Int -> IO (Maybe StripeCheckoutSession)
94+getStripeCheckoutSessionID manager amount =
95+ E.handle handleSomeException $
96+ do req0 <- Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
97+ req1 <- Multi.formDataBody (toOneTimeParts amount) $ req0 { method = Http.methodPost }
98+ Http.withResponse req1 manager $ \response ->
99+ do chunks <- brConsume (responseBody response)
100+ return $ Json.decode $ LBS.fromChunks chunks
101+
102+
103+toOneTimeParts :: Int -> [Multi.Part]
104+toOneTimeParts amount =
105+ [ Multi.partBS "payment_method_types[]" "card"
106+ , Multi.partBS "line_items[][name]" "One-time donation"
107+ , Multi.partBS "line_items[][description]" "One-time donation to Elm Software Foundation"
108+ , Multi.partBS "line_items[][images][]" "https://foundation.elm-lang.org/donation.png"
109+ , Multi.partBS "line_items[][amount]" (BS.pack (show amount))
110+ , Multi.partBS "line_items[][currency]" "usd"
111+ , Multi.partBS "line_items[][quantity]" "1"
112+ , Multi.partBS "success_url" "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
113+ , Multi.partBS "cancel_url" "https://foundation.elm-lang.org/donate"
114+ ]
115+
116+
117+handleSomeException :: E.SomeException -> IO (Maybe a)
118+handleSomeException exception =
119+ return Nothing
120+
121+
122+instance Json.FromJSON StripeCheckoutSession where
123+ parseJSON =
124+ withObject "StripeCheckoutSessionResponse" $ \obj ->
125+ StripeCheckoutSession <$> obj .: "id"
126+
127+
128+
129+-- REQUIRE PARAMETER
130+
131+
132+requireParameter :: BS.ByteString -> (BS.ByteString -> Maybe a) -> Snap a
133+requireParameter name toValue =
134+ do params <- getsRequest (rqParam name)
135+ case params of
136+ Just [bytes] ->
137+ case toValue bytes of
138+ Just value -> return value
139+ Nothing -> bailForMissingParam name
140+
141+ _ ->
142+ bailForMissingParam name
143+
144+
145+bailForMissingParam :: BS.ByteString -> Snap a
146+bailForMissingParam name =
147+ do modifyResponse $ setResponseStatus 400 "Bad Request"
148+ modifyResponse $ setContentType "text/plain; charset=utf-8"
149+ writeBuilder $ "Missing parameter '" <> B.fromByteString name <> "' in requset."
150+ finishWith =<< getResponse