787a7c9 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

add code for loading in secret

787a7c9Evan Czaplicki7 years ago

worker/elm.cabal+1

compare with master

unifiedsplit

@@ -174,6 +174,7 @@ Executable worker

174 ansi-terminal >= 0.8 && < 0.9,

175 ansi-wl-pprint >= 0.6.8 && < 0.7,

176 base >=4.11 && <5,

177+ base64-bytestring,

177 binary >= 0.8 && < 0.9,

178 binary >= 0.8 && < 0.9,

178 bytestring >= 0.9 && < 0.11,

179 bytestring >= 0.9 && < 0.11,

179 containers >= 0.5.8.2 && < 0.6,

180 containers >= 0.5.8.2 && < 0.6,

worker/src/Endpoint/Donate.hs+29−9

@@ -13,6 +13,7 @@ import Data.Aeson ((.:))

13import qualified Data.Aeson as Json

14import qualified Data.ByteString as BS

15import qualified Data.ByteString.Builder as B

16+import qualified Data.ByteString.Base64 as Base64

16import qualified Data.ByteString.Char8 as BSC

17import qualified Data.ByteString.Char8 as BSC

17import qualified Data.ByteString.Lazy as LBS

18import qualified Data.ByteString.Lazy as LBS

18import qualified Data.Text as T

19import qualified Data.Text as T

@@ -41,13 +42,17 @@ allowedOrigins =

41-- GET MANAGER

42-- GET MANAGER

44−newtype Manager =

45+data Manager =

46+ Manager

45− Manager Http.Manager

47+ { _manager :: Http.Manager

48+ , _authToken :: BS.ByteString

49+ }

48−getManager :: IO Manager

52+getManager :: String -> IO Manager

49−getManager =

53+getManager secret =

50− Manager <$> Http.newManager Http.tlsManagerSettings

54+ do manager <- Http.newManager Http.tlsManagerSettings

55+ return (Manager manager ("Basic " <> Base64.encode (BSC.pack secret)))

@@ -55,7 +60,7 @@ getManager =

57endpoint :: Manager -> Snap ()

62endpoint :: Manager -> Snap ()

58−endpoint (Manager manager) =

63+endpoint manager =

59 Cors.allow POST allowedOrigins $

64 Cors.allow POST allowedOrigins $

60 do amount <- requireParameter "amount" toAmount

65 do amount <- requireParameter "amount" toAmount

61 frequency <- requireParameter "frequency" toFrequency

66 frequency <- requireParameter "frequency" toFrequency

@@ -102,16 +107,31 @@ newtype StripeCheckoutSession =

102 StripeCheckoutSession { _id :: T.Text }

107 StripeCheckoutSession { _id :: T.Text }

103

108

104

109

105−getStripeCheckoutSessionID :: Http.Manager -> Int -> IO (Maybe StripeCheckoutSession)

110+getStripeCheckoutSessionID :: Manager -> Int -> IO (Maybe StripeCheckoutSession)

106−getStripeCheckoutSessionID manager amount =

111+getStripeCheckoutSessionID (Manager manager authToken) amount =

107 E.handle handleSomeException $

112 E.handle handleSomeException $

108 do req0 <- Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"

113 do req0 <- Http.parseRequest "https://api.stripe.com/v1/checkout/sessions"

109− req1 <- Multi.formDataBody (toOneTimeParts amount) $ req0 { Http.method = Http.methodPost }

114+ req1 <- Multi.formDataBody (toOneTimeParts amount) (configureRequest authToken req0)

110 Http.withResponse req1 manager $ \response ->

115 Http.withResponse req1 manager $ \response ->

111 do chunks <- Http.brConsume (Http.responseBody response)

116 do chunks <- Http.brConsume (Http.responseBody response)

112 return $ Json.decode $ LBS.fromChunks chunks

117 return $ Json.decode $ LBS.fromChunks chunks

113

118

114

119

120+-- The "Authorization" header is set based on combining these instructions:

121+--

122+-- https://stripe.com/docs/payments/checkout/one-time

123+-- https://stackoverflow.com/a/35442984

124+--

125+-- Setting the -u flag appears to add a base64 encoded "Authorization" header.

126+--

127+configureRequest :: BS.ByteString -> Http.Request -> Http.Request

128+configureRequest authToken req =

129+ req

130+ { Http.method = Http.methodPost

131+ , Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req

132+ }

133+

134+

115toOneTimeParts :: Int -> [Multi.Part]

135toOneTimeParts :: Int -> [Multi.Part]

116toOneTimeParts amount =

136toOneTimeParts amount =

117 [ Multi.partBS "payment_method_types[]" "card"

137 [ Multi.partBS "payment_method_types[]" "card"

worker/src/Main.hs+25−1

@@ -10,6 +10,9 @@ import Control.Monad (msum)

10import qualified Data.ByteString as BS

11import Snap.Core

12import Snap.Http.Server

13+import qualified System.Environment as Env

14+import qualified System.Exit as Exit

15+import qualified System.IO as IO

14import qualified Artifacts

17import qualified Artifacts

15import qualified Cors

18import qualified Cors

@@ -27,7 +30,7 @@ main =

27 do rArtifacts <- Artifacts.loadRepl

30 do rArtifacts <- Artifacts.loadRepl

28 cArtifacts <- Artifacts.loadCompile

31 cArtifacts <- Artifacts.loadCompile

29 errorJS <- Compile.loadErrorJS

32 errorJS <- Compile.loadErrorJS

30− manager <- Donate.getManager

33+ manager <- Donate.getManager =<< getSecret

31 let depsInfo = Artifacts.toDepsInfo cArtifacts

34 let depsInfo = Artifacts.toDepsInfo cArtifacts

33 httpServe config $ msum $

36 httpServe config $ msum $

@@ -70,3 +73,24 @@ serveDepsInfo json =

70 Cors.allow GET ["https://elm-lang.org"] $

73 Cors.allow GET ["https://elm-lang.org"] $

71 do modifyResponse $ setContentType "application/json"

74 do modifyResponse $ setContentType "application/json"

72 writeBS json

75 writeBS json

76+

77+

78+

79+-- GET SECRET

80+

81+

82+getSecret :: IO String

83+getSecret =

84+ do args <- Env.getArgs

85+ case args of

86+ [secret] ->

87+ return secret

88+

89+ _ ->

90+ do IO.hPutStrLn IO.stderr

91+ "Expecting a secret for /donate page:\n\

92+ \\n\

93+ \ ./run-worker sk_test_abcdefghijklmnopqrstuvwxyz\n\

94+ \\n\

95+ \Needed for handling donations with Stripe."

96+ Exit.exitFailure