@@ -60,9 +60,9 @@ getManager secret =
60endpoint :: Manager -> Snap ()
60endpoint :: Manager -> Snap ()
61endpoint manager =
61endpoint manager =
62 Cors.allow POST allowedOrigins $
62 Cors.allow POST allowedOrigins $
63− do amount <- requireParameter "amount" toAmount
63+ do cents <- requireParameter "cents" toCents
64 frequency <- requireParameter "frequency" toFrequency
64 frequency <- requireParameter "frequency" toFrequency
65− mabyeSession <- liftIO $ getStripeCheckoutSessionID manager amount
65+ mabyeSession <- liftIO $ getStripeCheckoutSessionID manager cents
66 case mabyeSession of
66 case mabyeSession of
67 Just (StripeCheckoutSession id) ->
67 Just (StripeCheckoutSession id) ->
68 do modifyResponse $ setContentType "text/plain; charset=utf-8"
68 do modifyResponse $ setContentType "text/plain; charset=utf-8"
@@ -81,20 +81,28 @@ data Frequency
84−toFrequency :: BS.ByteString -> Maybe Frequency
84+toFrequency :: BS.ByteString -> Either B.Builder Frequency
85toFrequency bytes =
85toFrequency bytes =
86 case bytes of
86 case bytes of
87− "onetime" -> Just OneTime
87+ "onetime" -> Right OneTime
88− "monthly" -> Just Monthly
88+ "monthly" -> Right Monthly
89− _ -> Nothing
89+ _ -> Left "The only valid values are frequency=onetime and frequency=monthly."
92−toAmount :: BS.ByteString -> Maybe Int
92+toCents :: BS.ByteString -> Either B.Builder Int
93−toAmount bytes =
93+toCents bytes =
94− if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes
94+ if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes && not (BS.isPrefixOf "0" bytes) then
95− && not (BS.isPrefixOf "0" bytes)
95+ let
96− then Just (BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes)
96+ cents = BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes
102+ "Processing fees are (2.2% + $0.30) per transaction, so the minimum\n\
103+ \donation is $5 (cents=500) to limit the worst case fee to ~8%"
97− else Nothing
104+ else
105+ Left "Must be a value like cents=1000 for $10 or cents=2500 for $25."
@@ -106,10 +114,10 @@ newtype StripeCheckoutSession =
108getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
116getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
109−getStripeCheckoutSessionID (Manager manager authToken) amount =
117+getStripeCheckoutSessionID (Manager manager authToken) cents =
110 E.handle handleSomeException $
118 E.handle handleSomeException $
111 do req <-
119 do req <-
112− configureRequest authToken amount <$>
120+ configureRequest authToken cents <$>
113 Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
121 Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
115 Http.withResponse req manager $ \response ->
123 Http.withResponse req manager $ \response ->
@@ -125,18 +133,18 @@ getStripeCheckoutSessionID (Manager manager authToken) amount =
125-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
133-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
127configureRequest :: BS.ByteString -> Int -> Http.Request -> Http.Request
135configureRequest :: BS.ByteString -> Int -> Http.Request -> Http.Request
128−configureRequest authToken amount req =
136+configureRequest authToken cents req =
129− Http.urlEncodedBody (toOneTimeParts amount) $
137+ Http.urlEncodedBody (toOneTimeParts cents) $
130 req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
138 req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
133toOneTimeParts :: Int -> [(BS.ByteString, BS.ByteString)]
141toOneTimeParts :: Int -> [(BS.ByteString, BS.ByteString)]
134−toOneTimeParts amount =
142+toOneTimeParts cents =
135 [ "payment_method_types[]" ==> "card"
143 [ "payment_method_types[]" ==> "card"
136 , "line_items[][name]" ==> "One-time donation"
144 , "line_items[][name]" ==> "One-time donation"
137 , "line_items[][description]" ==> "One-time donation to Elm Software Foundation"
145 , "line_items[][description]" ==> "One-time donation to Elm Software Foundation"
138 , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
146 , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
139− , "line_items[][amount]" ==> BSC.pack (show amount)
147+ , "line_items[][amount]" ==> BSC.pack (show cents)
140 , "line_items[][currency]" ==> "usd"
148 , "line_items[][currency]" ==> "usd"
141 , "line_items[][quantity]" ==> "1"
149 , "line_items[][quantity]" ==> "1"
142 , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
150 , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
@@ -163,22 +171,29 @@ instance Json.FromJSON StripeCheckoutSession where
163-- REQUIRE PARAMETER
171-- REQUIRE PARAMETER
166−requireParameter :: BS.ByteString -> (BS.ByteString -> Maybe a) -> Snap a
174+requireParameter :: BS.ByteString -> (BS.ByteString -> Either B.Builder a) -> Snap a
167requireParameter name toValue =
175requireParameter name toValue =
168 do params <- getsRequest (rqParam name)
176 do params <- getsRequest (rqParam name)
169 case params of
177 case params of
170 Just [bytes] ->
178 Just [bytes] ->
171 case toValue bytes of
179 case toValue bytes of
172− Just value -> return value
181+ return value
173− Nothing -> bailForMissingParam name
182+
185+ "Ran into invalid query parameter:\n\n "
186+ <> B.byteString name <> "=" <> B.byteString bytes
187+ <> "\n\n" <> message
176− bailForMissingParam name
190+ badParam $
191+ "Missing parameter '" <> B.byteString name <> "' in requset."
179−bailForMissingParam :: BS.ByteString -> Snap a
194+badParam :: B.Builder -> Snap a
180−bailForMissingParam name =
195+badParam message =
181− do writeBuilder $ "Missing parameter '" <> B.byteString name <> "' in requset."
196+ do writeBuilder message
182 finishWith
197 finishWith
183 . setResponseStatus 400 "Bad Request"
198 . setResponseStatus 400 "Bad Request"
184 . setContentType "text/plain; charset=utf-8"
199 . setContentType "text/plain; charset=utf-8"