@@ -1,3 +1,4 @@
1+{-# LANGUAGE OverloadedStrings #-}
12module Endpoint.Donate
23 ( Manager
34 , endpoint
@@ -7,10 +8,16 @@ module Endpoint.Donate
78
89
910import qualified Control.Exception as E
11+import Control.Monad.Trans (liftIO)
12+import Data.Aeson ((.:))
13+import qualified Data.Aeson as Json
1014import qualified Data.ByteString as BS
15+import qualified Data.ByteString.Builder as B
16+import qualified Data.ByteString.Char8 as BSC
1117import qualified Data.ByteString.Lazy as LBS
18+import qualified Data.Text as T
1219import Snap.Core
13−import qualified Network.HTTP.Client as Http (parseRequest)
20+import qualified Network.HTTP.Client as Http
1421import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
1522import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
1623import qualified Network.HTTP.Types.Method as Http (methodPost)
@@ -54,11 +61,16 @@ endpoint (Manager manager) =
5461 frequency <- requireParameter "frequency" toFrequency
5562 mabyeSession <- liftIO $ getStripeCheckoutSessionID manager amount
5663 case mabyeSession of
57− Nothing ->
58−
5964 Just (StripeCheckoutSession id) ->
60− do modifyResponse $ setContentType "text/plain"
61− writeBS id
65+ do modifyResponse $ setContentType "text/plain; charset=utf-8"
66+ writeText id
67+
68+ Nothing ->
69+ do writeBuilder $ "Problem creating Stripe session ID for checkout."
70+ finishWith
71+ . setResponseStatus 500 "Internal Server Error"
72+ . setContentType "text/plain; charset=utf-8"
73+ =<< getResponse
6274
6375
6476data Frequency
@@ -87,16 +99,16 @@ toAmount bytes =
8799
88100
89101newtype StripeCheckoutSession =
90− StripeCheckoutSession { _id :: BS.ByteString }
102+ StripeCheckoutSession { _id :: T.Text }
91103
92104
93105getStripeCheckoutSessionID :: Http.Manager -> Int -> IO (Maybe StripeCheckoutSession)
94106getStripeCheckoutSessionID manager amount =
95107 E.handle handleSomeException $
96108 do req0 <- Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
97− req1 <- Multi.formDataBody (toOneTimeParts amount) $ req0 { method = Http.methodPost }
109+ req1 <- Multi.formDataBody (toOneTimeParts amount) $ req0 { Http.method = Http.methodPost }
98110 Http.withResponse req1 manager $ \response ->
99− do chunks <- brConsume (responseBody response)
111+ do chunks <- Http.brConsume (Http.responseBody response)
100112 return $ Json.decode $ LBS.fromChunks chunks
101113
102114
@@ -106,7 +118,7 @@ toOneTimeParts amount =
106118 , Multi.partBS "line_items[][name]" "One-time donation"
107119 , Multi.partBS "line_items[][description]" "One-time donation to Elm Software Foundation"
108120 , Multi.partBS "line_items[][images][]" "https://foundation.elm-lang.org/donation.png"
109− , Multi.partBS "line_items[][amount]" (BS.pack (show amount))
121+ , Multi.partBS "line_items[][amount]" (BSC.pack (show amount))
110122 , Multi.partBS "line_items[][currency]" "usd"
111123 , Multi.partBS "line_items[][quantity]" "1"
112124 , Multi.partBS "success_url" "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
@@ -121,7 +133,7 @@ handleSomeException exception =
121133
122134instance Json.FromJSON StripeCheckoutSession where
123135 parseJSON =
124− withObject "StripeCheckoutSessionResponse" $ \obj ->
136+ Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
125137 StripeCheckoutSession <$> obj .: "id"
126138
127139
@@ -144,7 +156,8 @@ requireParameter name toValue =
144156
145157bailForMissingParam :: BS.ByteString -> Snap a
146158bailForMissingParam 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
159+ do writeBuilder $ "Missing parameter '" <> B.byteString name <> "' in requset."
160+ finishWith
161+ . setResponseStatus 400 "Bad Request"
162+ . setContentType "text/plain; charset=utf-8"
163+ =<< getResponse