git.iko.soy/elk
on master help sign in
get /donate endpoint compiling
4554978Evan Czaplicki
worker/elm.cabal+1
compare with master
unifiedsplit
@@ -52,6 +52,7 @@ Executable worker
52 Artifacts
52 Artifacts
53 Cors
53 Cors
54 Endpoint.Compile
54 Endpoint.Compile
55+ Endpoint.Donate
55 Endpoint.Repl
56 Endpoint.Repl
56
57
57 AST.Canonical
58 AST.Canonical
worker/src/Endpoint/Donate.hs+27−14
@@ -1,3 +1,4 @@
1+{-# LANGUAGE OverloadedStrings #-}
1module Endpoint.Donate
2module Endpoint.Donate
2 ( Manager
3 ( Manager
3 , endpoint
4 , endpoint
@@ -7,10 +8,16 @@ module Endpoint.Donate
7
8
8
9
9import qualified Control.Exception as E
10import qualified Control.Exception as E
11+import Control.Monad.Trans (liftIO)
12+import Data.Aeson ((.:))
13+import qualified Data.Aeson as Json
10import qualified Data.ByteString as BS
14import qualified Data.ByteString as BS
15+import qualified Data.ByteString.Builder as B
16+import qualified Data.ByteString.Char8 as BSC
11import qualified Data.ByteString.Lazy as LBS
17import qualified Data.ByteString.Lazy as LBS
18+import qualified Data.Text as T
12import Snap.Core
19import Snap.Core
13−import qualified Network.HTTP.Client as Http (parseRequest)
20+import qualified Network.HTTP.Client as Http
14import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
21import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
15import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
22import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
16import qualified Network.HTTP.Types.Method as Http (methodPost)
23import qualified Network.HTTP.Types.Method as Http (methodPost)
@@ -54,11 +61,16 @@ endpoint (Manager manager) =
54 frequency <- requireParameter "frequency" toFrequency
61 frequency <- requireParameter "frequency" toFrequency
55 mabyeSession <- liftIO $ getStripeCheckoutSessionID manager amount
62 mabyeSession <- liftIO $ getStripeCheckoutSessionID manager amount
56 case mabyeSession of
63 case mabyeSession of
57− Nothing ->
58−
59 Just (StripeCheckoutSession id) ->
64 Just (StripeCheckoutSession id) ->
60− do modifyResponse $ setContentType "text/plain"
65+ do modifyResponse $ setContentType "text/plain; charset=utf-8"
61− writeBS id
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
62
74
63
75
64data Frequency
76data Frequency
@@ -87,16 +99,16 @@ toAmount bytes =
87
99
88
100
89newtype StripeCheckoutSession =
101newtype StripeCheckoutSession =
90− StripeCheckoutSession { _id :: BS.ByteString }
102+ StripeCheckoutSession { _id :: T.Text }
91
103
92
104
93getStripeCheckoutSessionID :: Http.Manager -> Int -> IO (Maybe StripeCheckoutSession)
105getStripeCheckoutSessionID :: Http.Manager -> Int -> IO (Maybe StripeCheckoutSession)
94getStripeCheckoutSessionID manager amount =
106getStripeCheckoutSessionID manager amount =
95 E.handle handleSomeException $
107 E.handle handleSomeException $
96 do req0 <- Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"
108 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 }
98 Http.withResponse req1 manager $ \response ->
110 Http.withResponse req1 manager $ \response ->
99− do chunks <- brConsume (responseBody response)
111+ do chunks <- Http.brConsume (Http.responseBody response)
100 return $ Json.decode $ LBS.fromChunks chunks
112 return $ Json.decode $ LBS.fromChunks chunks
101
113
102
114
@@ -106,7 +118,7 @@ toOneTimeParts amount =
106 , Multi.partBS "line_items[][name]" "One-time donation"
118 , Multi.partBS "line_items[][name]" "One-time donation"
107 , Multi.partBS "line_items[][description]" "One-time donation to Elm Software Foundation"
119 , 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"
120 , 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))
110 , Multi.partBS "line_items[][currency]" "usd"
122 , Multi.partBS "line_items[][currency]" "usd"
111 , Multi.partBS "line_items[][quantity]" "1"
123 , Multi.partBS "line_items[][quantity]" "1"
112 , Multi.partBS "success_url" "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
124 , Multi.partBS "success_url" "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
@@ -121,7 +133,7 @@ handleSomeException exception =
121
133
122instance Json.FromJSON StripeCheckoutSession where
134instance Json.FromJSON StripeCheckoutSession where
123 parseJSON =
135 parseJSON =
124− withObject "StripeCheckoutSessionResponse" $ \obj ->
136+ Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
125 StripeCheckoutSession <$> obj .: "id"
137 StripeCheckoutSession <$> obj .: "id"
126
138
127
139
@@ -144,7 +156,8 @@ requireParameter name toValue =
144
156
145bailForMissingParam :: BS.ByteString -> Snap a
157bailForMissingParam :: BS.ByteString -> Snap a
146bailForMissingParam name =
158bailForMissingParam name =
159+ do writeBuilder $ "Missing parameter '" <> B.byteString name <> "' in requset."
160+ finishWith
147− do modifyResponse $ setResponseStatus 400 "Bad Request"
161+ . setResponseStatus 400 "Bad Request"
148− modifyResponse $ setContentType "text/plain; charset=utf-8"
162+ . setContentType "text/plain; charset=utf-8"
149− writeBuilder $ "Missing parameter '" <> B.fromByteString name <> "' in requset."
150− finishWith =<< getResponse
163+ =<< getResponse
worker/src/Main.hs+1
@@ -14,6 +14,7 @@ import Snap.Http.Server
14import qualified Artifacts
14import qualified Artifacts
15import qualified Cors
15import qualified Cors
16import qualified Endpoint.Compile as Compile
16import qualified Endpoint.Compile as Compile
17+import qualified Endpoint.Donate as Donate
17import qualified Endpoint.Repl as Repl
18import qualified Endpoint.Repl as Repl
18
19
19
20