on master help sign in
15 files changed+296−431
since splitsnapshots
unifiedsplit
.github/CONTRIBUTING.md+18−20 .github/workflows/set-issue-expectations.yml+1−1 .github/workflows/set-pull-expectations.yml+11−13 ContributorAgreement.pdf compiler/src/Data/Utf8.hs+3−1 compiler/src/Reporting/Error/Pattern.hs+2−2 compiler/src/Reporting/Error/Syntax.hs+1−1 hints/implicit-casts.md−3 hints/optimize.md+2−2 roadmap.md+29 worker/elm.cabal+2−1 worker/src/Endpoint/Compile.hs+109−19 worker/src/Endpoint/Donate.hs−341 worker/src/Endpoint/Quotes.hs+114 worker/src/Main.hs+4−27
.github/CONTRIBUTING.md+18−20
@@ -4,10 +4,15 @@ Thanks helping with the development of Elm! This document describes the basic
44standards for opening pull requests and making the review process as smooth as
55possible.
66
7−## Licensing
87
9−You need to sign the [contributor agreement](ContributorAgreement.pdf)
10−and send it to <info@elm-lang.org> before opening your pull request.
8+## Expectations
9+
10+- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
11+- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).
12+- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.
13+
14+Finally, please be patient with the core team. They are trying their best with limited resources!
15+
1116
1217## Style Guide
1318
@@ -17,27 +22,20 @@ and send it to <info@elm-lang.org> before opening your pull request.
1722[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be
1823[js]: https://google.github.io/styleguide/javascriptguide.xml
1924
20−## Branches
2125
22− * [The master branch][master] is the home of the next release of the compiler
23− so new features and improvements get merged there. Most pull requests
24− should target this branch!
26+## Branches
2527
26− * [The stable branch][stable] is for tagging releases and critical bug fixes.
27− This branch is handy for folks who want to build the most recent public
28− release from source.
28+[The master branch][master] is the home of the next release of the compiler
29+so new features and improvements get merged there. Most pull requests
30+should target this branch!
2931
3032[master]: http://github.com/elm-lang/elm/tree/master
31−[stable]: http://github.com/elm-lang/elm/tree/stable
3233
33−If you are working on a fairly large feature, we will probably want to merge it
34−in as its own branch and do some testing before bringing it into the master
35−branch. This way we can keep releases of the master branch independent of new
36−features.
3734
38−Note that the master branch of the compiler should always be in sync with the
39−master branch of the [website][], and the stable branch of the compiler should
40−always be in sync with the stable branch of the [website][]. Make sure that
41−your changes maintain this compatibility.
35+## Licensing
36+
37+Nothing extra to do for this. The default on GitHub described [here](https://docs.github.com/en/github/site-policy/github-terms-of-service#6-contributions-under-repository-license) is that:
38+
39+> Whenever you add Content to a repository containing notice of a license, you license that Content under the same terms, and you agree that you have the right to license that Content under those terms. If you have a separate agreement to license that Content under different terms, such as a contributor license agreement, that agreement will supersede.
40+
4241
43−[website]: https://github.com/elm-lang/elm-lang.org
.github/workflows/set-issue-expectations.yml+1−1
@@ -15,7 +15,7 @@ jobs:
1515 comment "Thanks for reporting this! To set expectations:
1616
1717 - Issues are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
18− - Ask questions a [community forum](https://elm-lang.org/community). You will get an answer quicker that way!
18+ - Ask questions in a [community forum](https://elm-lang.org/community). You will get an answer quicker that way!
1919 - If you experience something similar, open a new issue. [We like duplicates](https://github.com/elm/expectations/blob/master/duplicates.md).
2020
2121 Finally, please be patient with the core team. They are trying their best with limited resources."
.github/workflows/set-pull-expectations.yml+11−13
@@ -1,21 +1,19 @@
1−name: Set Pull Expectations
21on:
3− pull_request:
2+ pull_request_target:
43 types: [opened]
4+
55jobs:
66 comment-on-pull:
77 name: Comment On Pull
88 runs-on: ubuntu-latest
99 steps:
10− - uses: actions/github@v1.0.0
11− env:
12− GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
10+ - uses: actions/github-script@v3
1311 with:
14− args: |
15− comment "Thanks for suggesting these code changes. To set expectations:
16−
17− - Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
18− - Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).
19− - Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.
20−
21− Finally, please be patient with the core team. They are trying their best with limited resources."
12+ github-token: ${{secrets.GITHUB_TOKEN}}
13+ script: |
14+ github.issues.createComment({
15+ issue_number: context.issue.number,
16+ owner: context.repo.owner,
17+ repo: context.repo.repo,
18+ body: "Thanks for suggesting these code changes. To set expectations:\n\n- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.\n- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).\n- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.\n\nFinally, please be patient with the core team. They are trying their best with limited resources."
19+ })
ContributorAgreement.pdfdeleted

Binary file not shown.

compiler/src/Data/Utf8.hs+3−1
@@ -261,7 +261,9 @@ instance Eq (Utf8 t) where
261261
262262
263263-- COMPARE
264−
264+--
265+-- TODO: is it fine to sort by length and only compare bytes on length ties?
266+--
265267
266268instance Ord (Utf8 t) where
267269 compare (Utf8 ba1#) (Utf8 ba2#) =
compiler/src/Reporting/Error/Pattern.hs+2−2
@@ -41,7 +41,7 @@ toReport source err =
4141 Report.Report "UNSAFE PATTERN" region [] $
4242 Code.toSnippet source region Nothing
4343 (
44− "This pattern does not cover all possiblities:"
44+ "This pattern does not cover all possibilities:"
4545 ,
4646 D.stack
4747 [ "Other possibilities include:"
@@ -64,7 +64,7 @@ toReport source err =
6464 , unhandledPatternsToDocBlock unhandled
6565 , D.reflow $
6666 "I would have to crash if I saw one of those! You can use\
67− \ `let` to deconstruct values only if there is ONE possiblity.\
67+ \ `let` to deconstruct values only if there is ONE possibility.\
6868 \ Switch to a `case` expression to account for all possibilities."
6969 , D.toSimpleHint $
7070 "Are you calling a function that definitely returns values\
compiler/src/Reporting/Error/Syntax.hs+1−1
@@ -2591,7 +2591,7 @@ toExprReport source context expr startRow startCol =
25912591 ,"give","a","more","specific","hint!"
25922592 ]
25932593 , D.toSimpleNote $
2594− "This can also happen if run into reserved words like `let` or `as` unexpectedly.\
2594+ "This can also happen if I run into reserved words like `let` or `as` unexpectedly.\
25952595 \ Or if I run into operators in unexpected spots. Point is, there are a\
25962596 \ couple ways I can get confused and give sort of weird advice!"
25972597 ]
hints/implicit-casts.md−3
@@ -16,9 +16,6 @@ Languages that will add in implicit casts for addition include:
1616
1717These languages generally agree that an `Int` may be implicitly cast to a `Float` when necessary. So everyone is doing it, why not Elm?!
1818
19−> **Note:** Ruby does not follow the trend. They implicitly cast a `Float` to an `Int`, truncating all the decimal points!
20−
21−
2219## Type Inference + Implicit Casts
2320
2421Elm comes from the ML-family of languages. Languages in the ML-family that **never** do implicit casts include:
hints/optimize.md+2−2
@@ -21,7 +21,7 @@ Putting those together, here is how I would optimize `src/Main.elm` with two ter
2121
2222```bash
2323elm make src/Main.elm --optimize --output=elm.js
24−uglifyjs elm.js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output=elm.min.js
24+uglifyjs elm.js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output elm.min.js
2525```
2626
2727After this you will have an `elm.js` and a significantly smaller `elm.min.js` file!
@@ -46,7 +46,7 @@ min="elm.min.js"
4646
4747elm make --optimize --output=$js $@
4848
49−uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output=$min
49+uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min
5050
5151echo "Initial size: $(cat $js | wc -c) bytes ($js)"
5252echo "Minified size:$(cat $min | wc -c) bytes ($min)"
roadmap.mdnew file+29
@@ -0,0 +1,29 @@
1+# Roadmap
2+
3+If you like what you see now, that's pretty much what Elm is going to be for a while.
4+
5+I'm currently doing some exploratory work with compiler techniques and targets, but it is still too early to tell which parts of that might work out. I know many readers take "exploring X" as a promise that "X will definitely happen", so I want to be careful in setting expectations low since there is still so much uncertainty in the work. So while there is no real news to share at this point, I can give some expectations about future stability of Elm:
6+
7+**If this exploratory work goes well**, even in the wildest version of success, I wouldn't expect the language or core packages to change very much. Maybe two or three years down the line it could reveal something that'd be good to fix up, but I don't really foresee notable changes right now.
8+
9+**If this exploratory work does not work out**, I have some more conservative projects that are good ideas that I want to circle back to at some point. Things like:
10+
11+- add a constrained type variable `eq` to get rid of the runtime error for `(==)` on functions
12+- try to integrate `elm test` so it can run only tests that changed
13+- try to get `elm format` using the latest parsing infrastructure so it's not a perf bottleneck during development anymore
14+- do another round on perf because I have one last idea that can squeeze out a bit more speed
15+
16+These are all nice quality of life things, but with 0.19.0 and 0.19.1 taking so long, I got pretty burnt out on "incremental improvements that are good ideas, but take a very long time and aren't very exciting to non-Elm users." Without getting too into the details, I really needed to change things up before returning to these particular ideas.
17+
18+If someone has a security issue from the compiler or core libraries, please DM me about it on the Elm Slack. Outside of security issues, I think capacity for more discretionary changes will increase once the lessons from the compiler explorations become more clear. Hopefully the discussion [here](https://discourse.elm-lang.org/t/costs-funding-in-open-source-languages/5722) clarifies the thinking on these capacity questions a bit.
19+
20+<br>
21+<br>
22+
23+**Taking a step back**, I have found that working in this looser style has produced a high baseline of quality, and I think that is an important part of Elm. For example, all the error message work in Elm began as a project to implement the `--report=json` flag. That work happened to reveal some cool ideas on improving error messages, and if I had been using a rigid roadmap, I might have skipped those ideas to meet the publicly-stated arbitrary deadline. We'd have a clearer roadmap, but error messages no different than other type-inferred languages.
24+
25+So I think having more flexibility in planning is a competitive advantage for Elm in certain ways, but it is obviously a trade off that does not work for everyone. If someone needs more certainty, I generally recommend looking into other languages to see if they have a balance that works better for their needs. For example, languages made by big corporations are generally "less risky" on things like this, but I think you see the fruits of that kind of process in the design decisions as well. Trade offs!
26+
27+Anyway, like I said at the beginning, if you like what you see now, that's what it's going to be for a while. Even in the best case scenario with my current explorations!
28+
29+I hope this is helpful information, and I hope you have a good experience with Elm, even if you ultimately find a different language that works better for you!
worker/elm.cabal+2−1
@@ -52,7 +52,7 @@ Executable worker
5252 Artifacts
5353 Cors
5454 Endpoint.Compile
55− Endpoint.Donate
55+ Endpoint.Quotes
5656 Endpoint.Repl
5757
5858 AST.Canonical
@@ -195,6 +195,7 @@ Executable worker
195195 network-uri,
196196 parsec,
197197 process,
198+ random,
198199 raw-strings-qq,
199200 scientific,
200201 SHA,
worker/src/Endpoint/Compile.hs+109−19
@@ -1,7 +1,8 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
33module Endpoint.Compile
4− ( endpoint
4+ ( endpoint_V1
5+ , endpoint_V2
56 , loadErrorJS
67 )
78 where
@@ -63,26 +64,50 @@ allowedOrigins =
6364
6465
6566
67+-- ENDPOINT (V1)
68+
69+
70+endpoint_V1 :: A.Artifacts -> Snap ()
71+endpoint_V1 artifacts =
72+ endpoint artifacts $ \result ->
73+ case result of
74+ Ok name js -> writeBuilder $ Html.sandwich name js
75+ Err report -> writeBuilder $ renderProblem_V1 report
76+
77+
78+
79+-- ENDPOINT (V2)
80+
81+
82+endpoint_V2 :: A.Artifacts -> Snap ()
83+endpoint_V2 artifacts =
84+ endpoint artifacts $ \result ->
85+ case result of
86+ Ok name js -> writeBuilder $ renderSuccess_V2 name js
87+ Err report -> writeBuilder $ renderProblem_V2 report
88+
89+
90+
6691-- ENDPOINT
6792
6893
69−endpoint :: A.Artifacts -> Snap ()
70−endpoint artifacts =
94+data Result
95+ = Ok N.Name B.Builder
96+ | Err Help.Report
97+
98+
99+endpoint :: A.Artifacts -> (Result -> Snap ()) -> Snap ()
100+endpoint artifacts callback =
71101 Cors.allow POST allowedOrigins $
72102 do result <- foldMultipart defaultUploadPolicy ignoreFile 0
73103 case result of
74104 ([("code",source)], 0) ->
75105 do modifyResponse $ setContentType "text/html; charset=utf-8"
76− case compile artifacts source of
77− Success builder ->
78− writeBuilder builder
79−
80− NoMain ->
81− writeBuilder $ renderReport noMain
82−
83− BadInput name err ->
84− writeBuilder $ renderReport $
85− Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []
106+ callback $
107+ case compile artifacts source of
108+ Success name js -> Ok name js
109+ NoMain -> Err noMain
110+ BadInput name err -> Err $ Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []
86111
87112 _ ->
88113 do modifyResponse $ setResponseStatus 400 "Bad Request"
@@ -104,7 +129,7 @@ ignoreFile _ _ count =
104129
105130
106131data Outcome
107− = Success B.Builder
132+ = Success N.Name B.Builder
108133 | NoMain
109134 | BadInput ModuleName.Raw Error.Error
110135
@@ -138,7 +163,7 @@ compile (A.Artifacts interfaces objects) source =
138163 mains = Map.singleton home main_
139164 graph = Opt.addLocalGraph locals objects
140165 in
141− Success $ Html.sandwich name $ JS.generate mode graph mains
166+ Success name $ JS.generate mode graph mains
142167
143168
144169checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
@@ -163,11 +188,11 @@ checkImports interfaces imports =
163188
164189
165190
166−-- RENDER REPORT
191+-- RENDER PROBLEM (V1)
167192
168193
169−renderReport :: Help.Report -> B.Builder
170−renderReport report =
194+renderProblem_V1 :: Help.Report -> B.Builder
195+renderProblem_V1 report =
171196 [r|<!DOCTYPE HTML>
172197<html>
173198<head>
@@ -179,7 +204,7 @@ renderReport report =
179204 <script>
180205 var app = Elm.Errors.init({flags:|] <> Encode.encodeUgly (Exit.toJson report) <> [r|});
181206 app.ports.jumpTo.subscribe(function(region) {
182− window.parent.postMessage(JSON.stringify(region), '*');
207+ window.parent.postMessage(JSON.stringify(region), "*");
183208 });
184209 </script>
185210</body>
@@ -187,6 +212,71 @@ renderReport report =
187212
188213
189214
215+-- RENDER SUCCESS (V2)
216+
217+
218+renderSuccess_V2 :: N.Name -> B.Builder -> B.Builder
219+renderSuccess_V2 moduleName javascript =
220+ let name = N.toBuilder moduleName in
221+ [r|<!DOCTYPE HTML>
222+<html>
223+<head>
224+ <meta charset="UTF-8">
225+ <title>|] <> name <> [r|</title>
226+ <style>body { padding: 0; margin: 0; }</style>
227+</head>
228+
229+<body>
230+
231+<pre id="elm"></pre>
232+
233+<script>
234+window.parent.postMessage("SUCCESS", "*");
235+
236+try {
237+|] <> javascript <> [r|
238+
239+ var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
240+}
241+catch (e)
242+{
243+ // display initialization errors (e.g. bad flags, infinite recursion)
244+ var header = document.createElement("h1");
245+ header.style.fontFamily = "monospace";
246+ header.innerText = "Initialization Error";
247+ var pre = document.getElementById("elm");
248+ document.body.insertBefore(header, pre);
249+ pre.innerText = e;
250+ throw e;
251+}
252+</script>
253+
254+</body>
255+</html>|]
256+
257+
258+
259+-- RENDER PROBLEM (V2)
260+
261+
262+renderProblem_V2 :: Help.Report -> B.Builder
263+renderProblem_V2 report =
264+ [r|<!DOCTYPE HTML>
265+<html>
266+<head>
267+ <meta charset="UTF-8">
268+ <style>body { padding: 0; margin: 0; display: none; }</style>
269+</head>
270+<body>
271+ <script>
272+ var errors = |] <> Encode.encodeUgly (Exit.toJson report) <> [r|;
273+ window.parent.postMessage(JSON.stringify(errors), "*");
274+ </script>
275+</body>
276+</html>|]
277+
278+
279+
190280-- NO MAIN
191281
192282
worker/src/Endpoint/Donate.hsdeleted−341
@@ -1,341 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Endpoint.Donate
3− ( Manager
4− , endpoint
5− , getManager
6− )
7− where
8−
9−
10−import Prelude hiding (id)
11−import qualified Control.Exception as E
12−import Control.Monad.Except (ExceptT(ExceptT), runExceptT)
13−import Control.Monad.Trans (liftIO)
14−import Data.Aeson ((.:))
15−import qualified Data.Aeson as Json
16−import Data.Char (chr)
17−import qualified Data.ByteString as BS
18−import qualified Data.ByteString.Builder as B
19−import qualified Data.ByteString.Base64 as Base64
20−import qualified Data.ByteString.Char8 as BSC
21−import qualified Data.ByteString.Lazy as LBS
22−import qualified Data.Text as T
23−import qualified Data.Text.Encoding as T
24−import Snap.Core
25−import qualified Network.HTTP.Client as Http
26−import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings)
27−import qualified Network.HTTP.Types.Header as Http (Header, hAccept, hAcceptEncoding, hUserAgent)
28−import qualified Network.HTTP.Types.Method as Http (methodPost)
29−import qualified Network.HTTP.Types.Status as Http (statusCode)
30−
31−import qualified Cors
32−
33−
34−
35−-- ALLOWED ORIGINS
36−
37−
38−allowedOrigins :: [String]
39−allowedOrigins =
40− [ "https://foundation.elm-lang.org"
41− ]
42−
43−
44−
45−-- GET MANAGER
46−--
47−-- To talk to Stripe you need a header like this:
48−--
49−-- Authorization: Basic dXNlcm5hbWU6cGFzc3dvcmQ=
50−-- ^^^^^^^^^^^^^^^^^^^^^^^^
51−-- Where the underlined part is the base64 encoded version of your Stripe
52−-- secret key. The secret key is given as an environment variable, and then
53−-- stored in the Manager as the "Authorization" value we will be using.
54−-- I figured this out based on the following links:
55−--
56−-- https://stripe.com/docs/payments/checkout/one-time
57−-- https://stackoverflow.com/a/35442984
58−--
59−
60−
61−data Manager =
62− Manager
63− { _manager :: Http.Manager
64− , _authToken :: BS.ByteString
65− }
66−
67−
68−getManager :: String -> IO Manager
69−getManager secret =
70− do manager <- Http.newManager Http.tlsManagerSettings
71− return (Manager manager ("Basic " <> Base64.encode (BSC.pack secret)))
72−
73−
74−addAuthorization :: BS.ByteString -> Http.Request -> Http.Request
75−addAuthorization authToken req =
76− req { Http.requestHeaders = ("Authorization", authToken) : Http.requestHeaders req }
77−
78−
79−
80−-- ENDPOINT
81−
82−
83−endpoint :: Manager -> Snap ()
84−endpoint manager =
85− Cors.allow POST allowedOrigins $
86− do cents <- requireParameter "cents" toCents
87− frequency <- requireParameter "frequency" toFrequency
88− result <- liftIO $ runExceptT $ getStripeCheckoutSessionID manager cents frequency
89− case result of
90− Right (StripeCheckoutSession id) ->
91− do modifyResponse $ setContentType "text/plain; charset=utf-8"
92− writeText id
93−
94− Left _ ->
95− do writeBuilder $ "Problem creating Stripe session ID for checkout."
96− finishWith
97− . setResponseStatus 500 "Internal Server Error"
98− . setContentType "text/plain; charset=utf-8"
99− =<< getResponse
100−
101−
102−data Frequency
103− = OneTime
104− | Monthly
105−
106−
107−toFrequency :: BS.ByteString -> Either B.Builder Frequency
108−toFrequency bytes =
109− case bytes of
110− "onetime" -> Right OneTime
111− "monthly" -> Right Monthly
112− _ -> Left "The only valid values are frequency=onetime and frequency=monthly."
113−
114−
115−toCents :: BS.ByteString -> Either B.Builder Int
116−toCents bytes =
117− if BS.all (\w -> 0x30 <= w && w <= 0x39) bytes && not (BS.isPrefixOf "0" bytes) then
118− let
119− cents = BS.foldl (\n w -> 10 * n + fromIntegral (w - 0x30)) 0 bytes
120− in
121− if cents >= 500
122− then Right cents
123− else
124− Left
125− "Processing fees are (2.2% + $0.30) per transaction, so the minimum\n\
126− \donation is $5 (cents=500) to limit the worst case fee to ~8%"
127− else
128− Left "Must be a value like cents=1000 for $10 or cents=2500 for $25."
129−
130−
131−
132−-- GET STRIPE CHECKOUT SESSION ID
133−
134−
135−newtype StripeCheckoutSession =
136− StripeCheckoutSession { _id :: T.Text }
137−
138−
139−instance Json.FromJSON StripeCheckoutSession where
140− parseJSON =
141− Json.withObject "StripeCheckoutSessionResponse" $ \obj ->
142− StripeCheckoutSession <$> obj .: "id"
143−
144−
145−getStripeCheckoutSessionID :: Manager -> Int -> Frequency -> Http StripeCheckoutSession
146−getStripeCheckoutSessionID manager cents frequency =
147− case frequency of
148− OneTime -> setupOnetimeDonation manager cents
149− Monthly -> setupMonthlyDonation manager cents
150−
151−
152−
153−-- SET UP ONE-TIME DONATION
154−
155−
156−setupOnetimeDonation :: Manager -> Int -> Http StripeCheckoutSession
157−setupOnetimeDonation manager cents =
158− post manager
159− "https://api.stripe.com/v1/checkout/sessions"
160− [ "payment_method_types[]" ==> "card"
161− , "line_items[][name]" ==> "One-time donation"
162− , "line_items[][images][]" ==> "https://foundation.elm-lang.org/donation.png"
163− , "line_items[][amount]" ==> BSC.pack (show cents)
164− , "line_items[][currency]" ==> "usd"
165− , "line_items[][quantity]" ==> "1"
166− , "submit_type" ==> "donate"
167− , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
168− , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
169− ]
170−
171−
172−
173−-- SET UP MONTHLY DONATION
174−
175−
176−setupMonthlyDonation :: Manager -> Int -> Http StripeCheckoutSession
177−setupMonthlyDonation manager cents =
178− do (Plan id) <- getMonthlyPlan manager cents
179− post manager
180− "https://api.stripe.com/v1/checkout/sessions"
181− [ "payment_method_types[]" ==> "card"
182− , "subscription_data[items][][plan]" ==> id
183− , "success_url" ==> "https://foundation.elm-lang.org/thank_you?session_id={CHECKOUT_SESSION_ID}"
184− , "cancel_url" ==> "https://foundation.elm-lang.org/donate"
185− ]
186−
187−
188−
189−-- GET MONTHLY PLAN
190−
191−
192−getMonthlyPlan :: Manager -> Int -> Http Plan
193−getMonthlyPlan manager cents =
194− do result <- try $ get manager ("https://api.stripe.com/v1/plans/" ++ toPlanID cents)
195− case result of
196− Right plan -> return plan
197− Left _ -> createMonthlyPlan manager cents
198−
199−
200−newtype Plan =
201− Plan BS.ByteString
202−
203−
204−instance Json.FromJSON Plan where
205− parseJSON =
206− Json.withObject "StripeResponse" $ \obj ->
207− Plan . T.encodeUtf8 <$> obj .: "id"
208−
209−
210−toPlanID :: Int -> String
211−toPlanID cents =
212− "monthly_" ++ show cents
213−
214−
215−
216−-- CREATE MONTHLY PLAN
217−
218−
219−createMonthlyPlan :: Manager -> Int -> Http Plan
220−createMonthlyPlan manager cents =
221− post manager
222− "https://api.stripe.com/v1/plans"
223− [ "id" ==> BSC.pack (toPlanID cents)
224− , "amount" ==> BSC.pack (show cents)
225− , "currency" ==> "usd"
226− , "interval" ==> "month"
227− , "nickname" ==> toPlanNickname cents
228− , "product" ==> "prod_GtPzOm0QbweJIE"
229− ]
230−
231−
232−toPlanNickname :: Int -> BS.ByteString
233−toPlanNickname cents =
234− let
235− (dollars, leftovers) = divMod cents 100
236− (dimes,pennies) = divMod leftovers 10
237− in
238− BSC.pack $
239− "Monthly $" ++ show dollars ++ [ '.', chr (0x30 + dimes), chr (0x30 + pennies) ]
240−
241−
242−
243−-- HTTP
244−
245−
246−type Http a = ExceptT Error IO a
247−
248−
249−data Error
250− = StripeError LBS.ByteString
251− | UnexpectedJson LBS.ByteString
252− | SomethingElse E.SomeException
253−
254−
255−try :: Http a -> ExceptT x IO (Either Error a)
256−try http =
257− liftIO (runExceptT http)
258−
259−
260−
261−-- HTTP GET
262−
263−
264−get :: (Json.FromJSON a) => Manager -> String -> Http a
265−get (Manager manager authToken) url =
266− request manager $
267− addAuthorization authToken <$> Http.parseRequest url
268−
269−
270−
271−-- HTTP POST
272−
273−
274−post :: (Json.FromJSON a) => Manager -> String -> [(BS.ByteString, BS.ByteString)] -> Http a
275−post (Manager manager authToken) url parts =
276− request manager $
277− Http.urlEncodedBody parts . addAuthorization authToken <$> Http.parseRequest url
278−
279−
280−(==>) :: a -> b -> (a,b)
281−(==>) = (,)
282−
283−
284−
285−-- HTTP REQUEST
286−
287−
288−request :: (Json.FromJSON a) => Http.Manager -> IO Http.Request -> Http a
289−request manager mkReq =
290− ExceptT $ E.handle handleSomeException $
291− do req <- mkReq
292− Http.withResponse req manager $ \response ->
293− do chunks <- Http.brConsume (Http.responseBody response)
294− let code = Http.statusCode (Http.responseStatus response)
295− let body = LBS.fromChunks chunks
296− return $
297− if 200 <= code && code < 300
298− then
299− case Json.decode body of
300− Just a -> Right a
301− Nothing -> Left (UnexpectedJson body)
302− else
303− Left (StripeError body)
304−
305−
306−handleSomeException :: E.SomeException -> IO (Either Error a)
307−handleSomeException exception =
308− return (Left (SomethingElse exception))
309−
310−
311−
312−-- REQUIRE PARAMETER
313−
314−
315−requireParameter :: BS.ByteString -> (BS.ByteString -> Either B.Builder a) -> Snap a
316−requireParameter name toValue =
317− do params <- getsRequest (rqParam name)
318− case params of
319− Just [bytes] ->
320− case toValue bytes of
321− Right value ->
322− return value
323−
324− Left message ->
325− badParam $
326− "Ran into invalid query parameter:\n\n "
327− <> B.byteString name <> "=" <> B.byteString bytes
328− <> "\n\n" <> message
329−
330− _ ->
331− badParam $
332− "Missing parameter '" <> B.byteString name <> "' in requset."
333−
334−
335−badParam :: B.Builder -> Snap a
336−badParam message =
337− do writeBuilder message
338− finishWith
339− . setResponseStatus 400 "Bad Request"
340− . setContentType "text/plain; charset=utf-8"
341− =<< getResponse
worker/src/Endpoint/Quotes.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+module Endpoint.Quotes
3+ ( endpoint
4+ )
5+ where
6+
7+
8+import Control.Monad.IO.Class (liftIO)
9+import qualified Data.ByteString as BS
10+import GHC.Int (Int(I#))
11+import GHC.Prim
12+import GHC.ST (ST(ST), runST)
13+import qualified System.Random as Random
14+
15+import Snap.Core
16+
17+
18+
19+-- ENDPOINT
20+
21+
22+endpoint :: Snap ()
23+endpoint =
24+ do modifyResponse
25+ $ setContentType "application/json"
26+ . setHeader "Access-Control-Allow-Origin" "*"
27+ writeBS =<< liftIO getQuote
28+
29+
30+getQuote :: IO BS.ByteString
31+getQuote =
32+ let
33+ (Quotes sa#) = quotes
34+ in
35+ do (I# i#) <- Random.randomRIO (0, I# (sizeofSmallArray# sa# -# 1#))
36+ case indexSmallArray# sa# i# of
37+ (# json #) ->
38+ return json
39+
40+
41+
42+-- QUOTES
43+
44+
45+data Quotes =
46+ Quotes (SmallArray# BS.ByteString)
47+
48+
49+quotes :: Quotes
50+quotes =
51+ let
52+ !(I# len#) = length quoteList
53+ in
54+ runST $ ST $ \s ->
55+ case newSmallArray# len# "" s of
56+ (# s, sma# #) ->
57+ case quotesHelp# sma# quoteList s of
58+ s ->
59+ case unsafeFreezeSmallArray# sma# s of
60+ (# s, sa# #) ->
61+ (# s, Quotes sa# #)
62+
63+
64+quotesHelp# :: SmallMutableArray# s a -> [a] -> State# s -> State# s
65+quotesHelp# sma# =
66+ go 0#
67+ where
68+ go i# list s =
69+ case list of
70+ [] ->
71+ s
72+
73+ x:xs ->
74+ case writeSmallArray# sma# i# x s of
75+ s ->
76+ go (i# +# 1#) xs s
77+
78+
79+quoteList :: [BS.ByteString]
80+quoteList =
81+ [ "{\"source\":\"Civilization and its Discontents\",\"author\":\"Sigmund Freud\",\"year\":1902,\"quote\":\"The enormous expansion of communications, due to the world-wide telegraph and telephone networks, has entirely transformed the conditions of trade and commerce. Everything is done in haste, at fever pitch. The night is used for travel, the day for business; even \\u201Choliday trips\\u201D put a strain on the nervous system. Great political, industrial and financial crises carry this excitement into far wider areas of the population than ever before. Interest in political life has become universal: tempers are inflamed by political, religious and social struggles, party politics, electioneering and the immense growth of trade-unionism; people are forced to engage in constant mental activity and robbed of the time the need for relaxation, sleep and rest.\"}"
82+ , "{\"source\":\"A Preface to Politics\",\"author\":\"Walter Lippmann\",\"year\":1913,\"quote\":\"The Economic Man\\u2014that lazy abstraction\\u2014is still paraded in the lecture room.\"}"
83+ , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"You ask me to say what you should consider it particularly important to avoid. My answer is this: a mass crowd. It is something to which you cannot entrust yourself yet without risk. I at any rate am ready to confess my own frailty in this respect. I never come back home with quite the same moral character as I went out with.\"}"
84+ , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"December used to be a month but it is now a year\"}"
85+ , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"But nothing is as ruinous to the character as sitting away one\\u2019s time at a show - for it is then, through the medium of entertainment, that vices creep into one with more than usual ease.\"}"
86+ , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"All this hurrying from place to place won\\u2019t bring you any relief, for you\\u2019re travelling in the company of your own emotions, followed by your troubles all the way. If only they were really following you! They\\u2019d be farther away from you: as it is they\\u2019re not at your back, but on it! That\\u2019s why they weigh you down with just the same uncomfortable chafing wherever you are. It\\u2019s medicine, not a particular part of the world, that a person needs if he\\u2019s ill. Suppose someone has broken his leg or dislocated a joint; he doesn\\u2019t get into a carriage or board a ship: he calls in a doctor to have the fracture set or the dislocation reduced. Well then, when a person\\u2019s spirit is wrenched or broken at so many points, do you imagine that it can be put right by a change of scenery, that that sort of trouble isn\\u2019t so serious that it can\\u2019t be cured by an outing?\"}"
87+ , "{\"source\":\"Progress and Poverty\",\"author\":\"Henry George\",\"year\":1879,\"quote\":\"The present century has been marked by a prodigious increase in wealth-producing power. The utilization of steam and electricity, the introduction of improved processes and laborsaving machinery, the greater subdivision and grander scale of production, the wonderful facilitation of exchanges, have multiplied enormously the effectiveness of labor. At the beginning of this marvelous era it was natural to expect, and it was expected, that laborsaving inventions would lighten the toil and improve the condition of the laborer; that the enormous increase in the power of producing wealth would make real poverty a thing of the past.\"}"
88+ , "{\"source\":\"Imperialism\",\"author\":\"John Hobson\",\"year\":1902,\"quote\":\"Although the new Imperialism has been bad business for the nation, it has been good business for certain classes and certain trades within the nation. The vast expenditure on armaments, the costly wars, the grave risks and embarrassments of foreign policy, the stoppage of political and social reforms within Great Britain, though fraught with great injury to the nation, have served well the present business interests of certain industries and professions.\"}"
89+ , "{\"source\":\"Neo-Colonialism\",\"author\":\"Kwame Nkrumah\",\"year\":1965,\"quote\":\"The essence of neo-colonialism is that the State which is subject to it is, in theory, independent and has all the outward trappings of international sovereignty. In reality its economic system and thus its political policy is directed from the outside. The methods and form of this direction can take various shapes. For example, in an extreme case the troops of the imperial power may garrison the territory of the neo-colonial State and control the government of it. More often, however, neo-colonialist control is exercised through economic or monetary means. The neo-colonial State may be obliged to take the manufactured products of the imperialist power to the exclusion of competing products from elsewhere. Control over government policy in the neo-colonial State may be secured by payments towards the cost of running the State, by the provision of civil servants in positions where they can dictate policy, and by monetary control over foreign exchange through the imposition of a banking system controlled by the imperial power.\"}"
90+ , "{\"source\":\"Neo-Colonialism\",\"author\":\"Kwame Nkrumah\",\"year\":1965,\"quote\":\"In the end the situation arises that the only type of aid which the neo-colonialist masters consider as safe is \\u2018military aid\\u2019. Once a neo-colonialist territory is brought to such a state of economic chaos and misery that revolt actually breaks out then, and only then, is there no limit to the generosity of the neo-colonial overlord, provided, of course, that the funds supplied are utilised exclusively for military purposes. Military aid in fact marks the last stage of neo-colonialism and its effect is self-destructive. Sooner or later the weapons supplied pass into the hands of the opponents of the neo-colonialist regime and the war itself increases the social misery which originally provoked it.\"}"
91+ , "{\"source\":\"Barnyard in your Backyard\",\"author\":\"Gail Damerow\",\"year\":2002,\"quote\":\"Wild jungle fowl, the ancestors of modern chickens, met their nutritional needs by consuming a variety of plants and insects. Given enough room to roam, some of today\\u2019s breeds remain active foragers.\"}"
92+ , "{\"source\":\"Barnyard in your Backyard\",\"author\":\"Gail Damerow\",\"year\":2002,\"quote\":\"Another way to reduce the cost of feed is to let your chickens roam on a lawn or in a pasture for part of the day. By eating plants, seeds, and insects, they will balance their diet and eat less of the expensive commercial stuff. Take care not to put your chickens on grass or around buildings that have been sprayed with toxins.\"}"
93+ , "{\"source\":\"Co-operation in Danish Agriculture\",\"author\":\"Harald Faber\",\"year\":1918,\"quote\":\"A plan for improving the butter made from the milk from peasant farms by collecting the milk to be worked at one place was submitted to the Royal Agricultural Society of Denmark as early as 1852, and it pointed out that this could be done on co-operative lines, the peasants being the owners of the factory and sharing the proceeds.\"}"
94+ , "{\"source\":\"Co-operation in Danish Agriculture\",\"author\":\"Harald Faber\",\"year\":1918,\"quote\":\"It was the Danish peasants themselves who found a practical way of developing the dairy industry, and they found this by applying the co-operative principles introduced by the Rochdale weavers. They received no support and only lukewarm sympathy from large farmers and estate owners, until later on when the co-operative dairies were doing so well that even owners of estates with two to three hundred cows found it to their advantage to close their private dairies and to join co-operative dairies.\"}"
95+ , "{\"source\":\"Beekeeping: A Practical Guide\",\"author\":\"Richard Bonney\",\"year\":1993,\"quote\":\"How many of you have been in a classroom or a training program where the instructor says at the outset, \\u201CLook at the person on your right; now look at the person on your left. One of you won\\u2019t be here next year.\\u201D Beekeeping is like that. Furthermore, not all beekeepers are truly beekeepers. Some are beehavers.\"}"
96+ , "{\"source\":\"The Rodale Book of Composting\",\"author\":\"Deborah Martin and Grace Gershuny\",\"year\":1992,\"quote\":\"Earthworms. If bacteria are the champion microscopic decomposers, then the heavyweight champion is doubtless the earthworm. Pages of praise have been written to the earthworm, ever since it became known that this creature spends most of its time tilling and enriching the soil.\"}"
97+ , "{\"source\":\"War is a Racket\",\"author\":\"General Smedley Butler\",\"year\":1935,\"quote\":\"There are 40,000,000 men under arms in the world today, and our statesmen and diplomats have the temerity to say that war is not in the making. Hell\\u2019s bells! Are these 40,000,000 men being trained to be dancers?\"}"
98+ , "{\"source\":\"Root Cellaring\",\"author\":\"Mike and Nancy Bubel\",\"year\":1991,\"quote\":\"What is not so widely acknowledged is that the soil in which your plants grow can influence the keeping quality of the vegetables you harvest. According to studies reported in E. P. Shirakov\\u2019s \\u201CPractical Course in Storage and Processing of Fruits and Vegetables\\u201D, abundant potash in the soil promotes long storage life of fruits and vegetables grown on that soil.\"}"
99+ , "{\"source\":\"Angora Goats the Northern Way\",\"author\":\"Susan Black Drummond\",\"year\":1985,\"quote\":\"Because of its long wearing qualities and resistance to soil, mohair was once a major upholstery fabric in this country, and was the seat cover material in many cars and in British Railroad seats. The synthetic fiber craze put an end to mohair use as upholstery fabric here.\"}"
100+ , "{\"source\":\"Making a Newspaper\",\"author\":\"John Given\",\"year\":1912,\"quote\":\"Yellow journalism originated through a desire to gain readers and advertisers, and it produced results. Its original disciples have readers by the hundred thousand and they have about all the advertising that they can well handle.\"}"
101+ , "{\"source\":\"Making a Newspaper\",\"author\":\"John Given\",\"year\":1912,\"quote\":\"With the adding of every new train and the improvement of every new time-table, the building of every new trolley road, and the establishment of every new mail route, the big city papers are enabled to reach out further, and, wherever they reach, the local papers suffer [...] There is not a paper published in any city between New York and Boston that has not in the last ten years been hurt by the papers of these two cities.\"}"
102+ , "{\"source\":\"Muscles: Testing and Function (4th Edition)\",\"author\":\"Florence Kendall, Elizabeth McCreary, Patricia Provance\",\"year\":1993,\"quote\":\"The mechanics of the low back is inseparable from that of the overall posture but especially that of the pelvis and the lower extremities. Pain manifested in the leg may be due to an underlying problem in the back. Conversely, the symptoms appearing in the low back may be due to underlying faulty mechanics of the feet, legs, or pelvis.\"}"
103+ , "{\"source\":\"Farmers of Forty Centuries\",\"author\":\"F. H. King\",\"year\":1911,\"quote\":\"The Sikiang is one of the great rivers of China and indeed of the world. Its width at Wuchow at low water was nearly a mile and our steamer anchored in twenty-four feet of water to a floating dock made fast by huge iron chains reaching three hundred feet up the slop to the city proper, thus providing for a rise of twenty-six feet in the river at its flood stage during the rainy season.\"}"
104+ , "{\"source\":\"How to Grow More Vegetables\",\"author\":\"John Jeavons\",\"year\":1974,\"quote\":\"If you are having trouble with birds eating the berries in your berry patch, you could erect a wren house in the middle of it. Wrens are insectivores, and they will not bother the berries. But they will attack any bird, however large, that comes near their nest.\"}"
105+ , "{\"source\":\"Confidence Men and Painted Women\",\"author\":\"Karen Halttunen\",\"year\":1982,\"quote\":\"Even one\\u2019s neighbor next door, as a visitor to Pittsburgh commented in 1818, might be a stranger: \\u201CA next door neighbor is, with them, frequently unknown, and months and years pass, without their exchanging with each other the ordinary compliments of friendship and goodwill.\\u201D\"}"
106+ , "{\"source\":\"Secondhand Time\",\"author\":\"Svetlana Alexievich\",\"year\":2016,\"quote\":\"I couldn\\u2019t understand what was going on. I remember seeing Gaidar on TV saying, \\u201Clearn how to sell... The market will save us...\\u201D You buy a bottle of mineral water on one corner and sell it on another\\u2014that\\u2019s business. The people listened, bewildered. I would come home, lock the door, and weep.\"}"
107+ , "{\"source\":\"Hiroshima\",\"author\":\"John Hersey\",\"year\":1985,\"quote\":\"At exactly fifteen minutes past eight in the morning, on August 6, 1945, Japanese time, at the moment when the atomic bomb flashed above Hiroshima, Miss Toshiko Sasaki, a clerk in the personnel department of the East Asia Tin Works, had just sat down at her place in the plant office and was turning her head to speak to the girl at the next desk.\"}"
108+ , "{\"source\":\"The Orphan\",\"author\":\"Maxim Gorky\",\"year\":1899,\"quote\":\"On a foggy and rainy day, by the cemetery gate, a small group of people standing in a muddy puddle were bargaining with the cabman. \\u201CFifteen kopeks!\\u201D The tall and heavy-set priest exclaimed in a deep bass, in response to the cabman\\u2019s shouts asking for twenty-five kopecks.\"}"
109+ , "{\"source\":\"Shah of Shahs\",\"author\":\"Ryszard Kapuściński\",\"year\":1982,\"quote\":\"This plane flies out of Teheran every day and lands at Munich at noon. Waiting limousines carry the passengers to elegant restaurants for lunch. After lunch they all fly back to Teheran in the same airplane and eat their suppers at home. Hardly an expensive entertainment, the jaunt costs only two thousand dollars a head. For people in the Shah\\u2019s favor, such a sum is nothing.\"}"
110+ , "{\"source\":\"Introduction to Fortran IV\",\"author\":\"Paul Chirlian\",\"year\":1973,\"quote\":\"There are many programming languages that can be used. We shall discuss a language that is almost universally used, and which is particularly applicable to mathematical and scientific computations. This language is FORTRAN IV.\"}"
111+ ]
112+
113+
114+
worker/src/Main.hs+4−27
@@ -10,14 +10,11 @@ import Control.Monad (msum)
1010import qualified Data.ByteString as BS
1111import Snap.Core
1212import Snap.Http.Server
13−import qualified System.Environment as Env
14−import qualified System.Exit as Exit
15−import qualified System.IO as IO
1613
1714import qualified Artifacts
1815import qualified Cors
1916import qualified Endpoint.Compile as Compile
20−import qualified Endpoint.Donate as Donate
17+import qualified Endpoint.Quotes as Quotes
2118import qualified Endpoint.Repl as Repl
2219
2320
@@ -30,16 +27,16 @@ main =
3027 do rArtifacts <- Artifacts.loadRepl
3128 cArtifacts <- Artifacts.loadCompile
3229 errorJS <- Compile.loadErrorJS
33− manager <- Donate.getManager =<< getSecret
3430 let depsInfo = Artifacts.toDepsInfo cArtifacts
3531
3632 httpServe config $ msum $
3733 [ ifTop $ status
3834 , path "repl" $ Repl.endpoint rArtifacts
39− , path "compile" $ Compile.endpoint cArtifacts
35+ , path "compile" $ Compile.endpoint_V1 cArtifacts
36+ , path "compile/v2" $ Compile.endpoint_V2 cArtifacts
4037 , path "compile/errors.js" $ serveJavaScript errorJS
4138 , path "compile/deps-info.json" $ serveDepsInfo depsInfo
42− , path "donate" $ Donate.endpoint manager
39+ , path "quotes" $ Quotes.endpoint
4340 , notFound
4441 ]
4542
@@ -74,23 +71,3 @@ serveDepsInfo json =
7471 do modifyResponse $ setContentType "application/json"
7572 writeBS json
7673
77−
78−
79−-- GET SECRET
80−
81−
82−getSecret :: IO String
83−getSecret =
84− do maybeValue <- Env.lookupEnv "STRIPE_SECRET"
85− case maybeValue of
86− Just secret ->
87− return secret
88−
89− Nothing ->
90− do IO.hPutStrLn IO.stderr
91− "Expecting environment variable STRIPE_SECRET to be defined:\n\
92− \\n\
93− \ STRIPE_SECRET=sk_test_abcdefghijklmnopqrstuvwxyz\n\
94− \\n\
95− \It is needed for handling donations with Stripe."
96− Exit.exitFailure