@@ -60,9 +60,9 @@ getManager secret =
6060endpoint :: Manager -> Snap ()
6161endpoint manager =
6262 Cors.allow POST allowedOrigins $
63− do amount <- requireParameter "amount" toAmount
63+ do cents <- requireParameter "cents" toCents
6464 frequency <- requireParameter "frequency" toFrequency
65− mabyeSession <- liftIO $ getStripeCheckoutSessionID manager amount
65+ mabyeSession <- liftIO $ getStripeCheckoutSessionID manager cents
6666 case mabyeSession of
6767 Just (StripeCheckoutSession id) ->
6868 do modifyResponse $ setContentType "text/plain; charset=utf-8"
@@ -81,20 +81,28 @@ data Frequency
8181 | Monthly
8282
8383
84−toFrequency :: BS.ByteString -> Maybe Frequency
84+toFrequency :: BS.ByteString -> Either B.Builder Frequency
8585toFrequency bytes =
8686 case bytes of
87− "onetime" -> Just OneTime
88− "monthly" -> Just Monthly
89− _ -> Nothing
87+ "onetime" -> Right OneTime
88+ "monthly" -> Right Monthly
89+ _ -> Left "The only valid values are frequency=onetime and frequency=monthly."
9090
9191
92−toAmount :: BS.ByteString -> Maybe Int
93−toAmount bytes =
94− if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes
95− && not (BS.isPrefixOf "0" bytes)
96− then Just (BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes)
97− else Nothing
92+toCents :: BS.ByteString -> Either B.Builder Int
93+toCents bytes =
94+ if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes && not (BS.isPrefixOf "0" bytes) then
95+ let
96+ cents = BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes
97+ in
98+ if cents >= 500
99+ then Right cents
100+ else
101+ Left
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%"
104+ else
105+ Left "Must be a value like cents=1000 for $10 or cents=2500 for $25."
98106
99107
100108
@@ -106,10 +114,10 @@ newtype StripeCheckoutSession =
106114
107115
108116getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)
109−getStripeCheckoutSessionID (Manager manager authToken) amount =
117+getStripeCheckoutSessionID (Manager manager authToken) cents =
110118 E.handle handleSomeException $
111119 do req <-
112− configureRequest authToken amount <$>
120+ configureRequest authToken cents <$>
113121 Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
114122
115123 Http.withResponse req manager $ \response ->
@@ -125,18 +133,18 @@ getStripeCheckoutSessionID (Manager manager authToken) amount =
125133-- Setting the -u flag appears to add a base64 encoded "Authorization" header.
126134--
127135configureRequest :: BS.ByteString -> Int -> Http.Request -> Http.Request
128−configureRequest authToken amount req =
129− Http.urlEncodedBody (toOneTimeParts amount) $
136+configureRequest authToken cents req =
137+ Http.urlEncodedBody (toOneTimeParts cents) $
130138 req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
131139
132140
133141toOneTimeParts :: Int -> [(BS.ByteString, BS.ByteString)]
134−toOneTimeParts amount =
142+toOneTimeParts cents =
135143 [ "payment_method_types[]" ==> "card"
136144 , "line_items[][name]" ==> "One-time donation"
137145 , "line_items[][description]" ==> "One-time donation to Elm Software Foundation"
138146 , "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)
140148 , "line_items[][currency]" ==> "usd"
141149 , "line_items[][quantity]" ==> "1"
142150 , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
@@ -163,22 +171,29 @@ instance Json.FromJSON StripeCheckoutSession where
163171-- REQUIRE PARAMETER
164172
165173
166−requireParameter :: BS.ByteString -> (BS.ByteString -> Maybe a) -> Snap a
174+requireParameter :: BS.ByteString -> (BS.ByteString -> Either B.Builder a) -> Snap a
167175requireParameter name toValue =
168176 do params <- getsRequest (rqParam name)
169177 case params of
170178 Just [bytes] ->
171179 case toValue bytes of
172− Just value -> return value
173− Nothing -> bailForMissingParam name
180+ Right value ->
181+ return value
182+
183+ Left message ->
184+ badParam $
185+ "Ran into invalid query parameter:\n\n "
186+ <> B.byteString name <> "=" <> B.byteString bytes
187+ <> "\n\n" <> message
174188
175189 _ ->
176− bailForMissingParam name
190+ badParam $
191+ "Missing parameter '" <> B.byteString name <> "' in requset."
177192
178193
179−bailForMissingParam :: BS.ByteString -> Snap a
180−bailForMissingParam name =
181− do writeBuilder $ "Missing parameter '" <> B.byteString name <> "' in requset."
194+badParam :: B.Builder -> Snap a
195+badParam message =
196+ do writeBuilder message
182197 finishWith
183198 . setResponseStatus 400 "Bad Request"
184199 . setContentType "text/plain; charset=utf-8"