git.iko.soy/elk
on master help sign in
Add beginnings of worker.elm-lang.org server
407b1cfEvan Czaplicki
worker/elm.cabalnew file+188
compare with master
unifiedsplit
@@ -0,0 +1,188 @@
1+
2+Name: elm
3+Version: 0.19.1
4+
5+Synopsis:
6+ Perform tasks for various Elm websites
7+
8+Description:
9+ Compile code for the online editor. Maybe do more someday!
10+
11+Homepage: https://elm-lang.org
12+
13+License: BSD3
14+License-file: ../LICENSE
15+
16+Author: Evan Czaplicki
17+Maintainer: info@elm-lang.org
18+Copyright: Copyright (c) 2019-present, Evan Czaplicki
19+
20+Category: Compiler, Language
21+
22+Cabal-version: >=1.9
23+Build-type: Simple
24+
25+source-repository head
26+ type: git
27+ location: git://github.com/elm/compiler.git
28+
29+
30+Flag dev {
31+ Description: Turn off optimization and make warnings errors
32+ Default: False
33+}
34+
35+
36+Executable worker
37+ if flag(dev)
38+ ghc-options: -O0 -Wall -Werror
39+ else
40+ ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg"
41+
42+ Hs-Source-Dirs:
43+ src
44+ ../compiler/src
45+ ../builder/src
46+
47+ Main-Is:
48+ Main.hs
49+
50+ other-modules:
51+ AST.Canonical
52+ AST.Optimized
53+ AST.Source
54+ AST.Utils.Binop
55+ AST.Utils.Shader
56+ AST.Utils.Type
57+ Canonicalize.Effects
58+ Canonicalize.Environment
59+ Canonicalize.Environment.Dups
60+ Canonicalize.Environment.Foreign
61+ Canonicalize.Environment.Local
62+ Canonicalize.Expression
63+ Canonicalize.Module
64+ Canonicalize.Pattern
65+ Canonicalize.Type
66+ Compile
67+ Data.Bag
68+ Data.Index
69+ Data.Map.Utils
70+ Data.Name
71+ Data.NonEmptyList
72+ Data.OneOrMore
73+ Data.Utf8
74+ Deps.Registry
75+ Deps.Solver
76+ Deps.Website
77+ Elm.Compiler.Imports
78+ Elm.Compiler.Type
79+ Elm.Compiler.Type.Extract
80+ Elm.Constraint
81+ Elm.Details
82+ Elm.Interface
83+ Elm.Kernel
84+ Elm.Licenses
85+ Elm.Magnitude
86+ Elm.ModuleName
87+ Elm.Outline
88+ Elm.Package
89+ Elm.Version
90+ File
91+ Generate.Html
92+ Generate.JavaScript
93+ Generate.JavaScript.Builder
94+ Generate.JavaScript.Expression
95+ Generate.JavaScript.Functions
96+ Generate.JavaScript.Name
97+ Generate.Mode
98+ Http
99+ Json.Decode
100+ Json.Encode
101+ Nitpick.PatternMatches
102+ Optimize.Case
103+ Optimize.DecisionTree
104+ Optimize.Expression
105+ Optimize.Module
106+ Optimize.Names
107+ Optimize.Port
108+ Parse.Declaration
109+ Parse.Expression
110+ Parse.Keyword
111+ Parse.Module
112+ Parse.Number
113+ Parse.Pattern
114+ Parse.Primitives
115+ Parse.Shader
116+ Parse.Space
117+ Parse.Symbol
118+ Parse.Type
119+ Parse.Utf8
120+ Parse.Variable
121+ Paths_elm
122+ Reporting
123+ Reporting.Annotation
124+ Reporting.Doc
125+ Reporting.Error
126+ Reporting.Error.Canonicalize
127+ Reporting.Error.Import
128+ Reporting.Error.Json
129+ Reporting.Error.Main
130+ Reporting.Error.Pattern
131+ Reporting.Error.Syntax
132+ Reporting.Error.Type
133+ Reporting.Exit
134+ Reporting.Exit.Help
135+ Reporting.Render.Code
136+ Reporting.Render.Type
137+ Reporting.Render.Type.Localizer
138+ Reporting.Report
139+ Reporting.Result
140+ Reporting.Suggest
141+ Reporting.Task
142+ Reporting.Warning
143+ Stuff
144+ Type.Constrain.Expression
145+ Type.Constrain.Module
146+ Type.Constrain.Pattern
147+ Type.Error
148+ Type.Instantiate
149+ Type.Occurs
150+ Type.Solve
151+ Type.Type
152+ Type.Unify
153+ Type.UnionFind
154+
155+ Build-depends:
156+ ansi-terminal >= 0.8 && < 0.9,
157+ ansi-wl-pprint >= 0.6.8 && < 0.7,
158+ base >=4.11 && <5,
159+ binary >= 0.8 && < 0.9,
160+ bytestring >= 0.9 && < 0.11,
161+ containers >= 0.5.8.2 && < 0.6,
162+ directory >= 1.2.3.0 && < 2.0,
163+ edit-distance >= 0.2 && < 0.3,
164+ file-embed,
165+ filelock,
166+ filepath >= 1 && < 2.0,
167+ ghc-prim >= 0.5.2,
168+ HTTP >= 4000.2.5 && < 4000.4,
169+ http-client >= 0.6 && < 0.7,
170+ http-client-tls >= 0.3 && < 0.4,
171+ http-types >= 0.12 && < 1.0,
172+ io-streams,
173+ language-glsl >= 0.3,
174+ mtl >= 2.2.1 && < 3,
175+ network >= 2.4 && < 2.7,
176+ network-uri,
177+ parsec,
178+ raw-strings-qq,
179+ scientific,
180+ SHA,
181+ snap-core,
182+ snap-server,
183+ template-haskell,
184+ time,
185+ unordered-containers,
186+ utf8-string,
187+ vector,
188+ zip-archive
worker/src/Main.hsnew file+238
@@ -0,0 +1,238 @@
1+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2+module Main
3+ ( main
4+ )
5+ where
6+
7+
8+import Control.Applicative ((<|>))
9+import Control.Concurrent (readMVar)
10+import Control.Monad (liftM2, msum)
11+import qualified Data.ByteString as B
12+import qualified Data.ByteString.Builder as B
13+import qualified Data.ByteString.Lazy as LBS
14+import qualified Data.HashSet as HashSet
15+import qualified Data.Map as Map
16+import qualified Data.OneOrMore as OneOrMore
17+import Network.URI (parseURI)
18+import Snap.Core
19+import Snap.Http.Server
20+import Snap.Util.CORS
21+import Snap.Util.FileServe (serveFile)
22+import Snap.Util.FileUploads
23+import qualified System.Directory as Dir
24+import qualified System.IO.Streams as Stream
25+import Text.RawString.QQ (r)
26+
27+import qualified AST.Source as Src
28+import qualified AST.Canonical as Can
29+import qualified AST.Optimized as Opt
30+import qualified Compile
31+import qualified Elm.Details as Details
32+import qualified Elm.Interface as I
33+import qualified Elm.ModuleName as ModuleName
34+import qualified Elm.Package as Pkg
35+import qualified Generate.Html as Html
36+import qualified Generate.JavaScript as Generate
37+import qualified Generate.Mode as Mode
38+import qualified Json.Encode as Encode
39+import qualified Parse.Module as Parse
40+import qualified Reporting
41+import qualified Reporting.Error as Error
42+import qualified Reporting.Render.Code as Code
43+
44+
45+
46+-- RUN THE DEV SERVER
47+
48+
49+main :: IO ()
50+main =
51+ do artifacts <- loadArtifacts
52+ httpServe config $ msum $
53+ [ path "compile" $ compile artifacts
54+ , path "compile/error.js" $ serveFile "error.js"
55+ , notFound
56+ ]
57+
58+
59+config :: Config Snap a
60+config =
61+ defaultConfig
62+ # setVerbose False
63+ # setPort 8000
64+ # setAccessLog ConfigNoLog
65+ # setErrorLog ConfigNoLog
66+
67+
68+(#) :: a -> (a -> b) -> b
69+(#) value func =
70+ func value
71+
72+
73+
74+-- NOT FOUND
75+
76+
77+notFound :: Snap ()
78+notFound =
79+ do modifyResponse $ setResponseStatus 404 "Not Found"
80+ modifyResponse $ setContentType "text/html; charset=utf-8"
81+ writeBS "Not Found"
82+
83+
84+
85+-- COMPILE
86+
87+
88+compile :: Artifacts -> Snap ()
89+compile (Artifacts ifaces objs) =
90+ applyCORS corsOptions $ method POST $
91+ do parts <- handleMultipart defaultUploadPolicy handlePart
92+ case parts of
93+ [Just source] ->
94+ case compileByteString ifaces source of
95+ Left err ->
96+ writeBuilder $ errorToHtmlBuilder source err
97+
98+ Right (home, locals, main) ->
99+ let
100+ mode = Mode.Dev Nothing
101+ name = ModuleName._module home
102+ mains = Map.singleton home main
103+ graph = Opt.addLocalGraph locals objs
104+ in
105+ writeBuilder $ Html.sandwich name $ Generate.generate mode graph mains
106+
107+ _ ->
108+ pass
109+
110+
111+handlePart :: PartInfo -> Stream.InputStream B.ByteString -> IO (Maybe B.ByteString)
112+handlePart info stream =
113+ if partFieldName info == "code" && partDisposition info == DispositionFormData
114+ then Just . LBS.toStrict <$> storeAsLazyByteString stream
115+ else return Nothing
116+
117+
118+compileByteString :: Map.Map ModuleName.Raw I.Interface -> B.ByteString -> Either Error.Error (ModuleName.Canonical, Opt.LocalGraph, Opt.Main)
119+compileByteString ifaces source =
120+ case Parse.fromByteString Pkg.dummyName source of
121+ Left err ->
122+ Left (Error.BadSyntax err)
123+
124+ Right modul ->
125+ case Compile.compile Pkg.dummyName ifaces modul of
126+ Left err ->
127+ Left err
128+
129+ Right artifacts@(Compile.Artifacts modul _ locals@(Opt.LocalGraph maybeMain _ _)) ->
130+ case maybeMain of
131+ Just main -> Right (Can._name modul, locals, main)
132+ Nothing -> Left (error "TODO no main")
133+
134+
135+errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
136+errorToHtmlBuilder source err =
137+ let
138+ json = Encode.encodeUgly (Error.errorToJson (Code.toSource source) err)
139+ in
140+ [r|<!DOCTYPE HTML>
141+<html>
142+<head>
143+ <meta charset="UTF-8">
144+ <style>body { padding: 0; margin: 0; }</style>
145+ <script src="https://worker.elm-lang.org/compile/error.js"></script>
146+ <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
147+</head>
148+<body></body>
149+</html>|]
150+
151+
152+
153+-- ARTIFACTS
154+
155+
156+data Artifacts =
157+ Artifacts
158+ { _ifaces :: Map.Map ModuleName.Raw I.Interface
159+ , _graph :: Opt.GlobalGraph
160+ }
161+
162+
163+loadArtifacts :: IO Artifacts
164+loadArtifacts =
165+ do style <- Reporting.terminal
166+ root <- Dir.getCurrentDirectory
167+ result <- Details.load style root
168+ case result of
169+ Left _ ->
170+ error "Ran into some problem loading elm.json details"
171+
172+ Right details ->
173+ do omvar <- Details.loadObjects root details
174+ imvar <- Details.loadInterfaces root details
175+ mdeps <- readMVar imvar
176+ mobjs <- readMVar omvar
177+ case liftM2 (,) mdeps mobjs of
178+ Nothing ->
179+ error "Ran into some weird problem loading elm.json details"
180+
181+ Just (deps, objs) ->
182+ return $ Artifacts (toInterfaces deps) objs
183+
184+
185+toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
186+toInterfaces deps =
187+ Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
188+ Map.elems (Map.mapMaybeWithKey getPublic deps)
189+
190+
191+getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
192+getPublic (ModuleName.Canonical _ name) dep =
193+ case dep of
194+ I.Public iface -> Just (name, OneOrMore.one iface)
195+ I.Private _ _ _ -> Nothing
196+
197+
198+toUnique :: OneOrMore.OneOrMore a -> Maybe a
199+toUnique oneOrMore =
200+ case oneOrMore of
201+ OneOrMore.One value -> Just value
202+ OneOrMore.More _ _ -> Nothing
203+
204+
205+
206+-- CORS
207+
208+
209+corsOptions :: (Monad m) => CORSOptions m
210+corsOptions =
211+ CORSOptions
212+ { corsAllowOrigin = return allowedOrigins
213+ , corsAllowCredentials = return True
214+ , corsExposeHeaders = return HashSet.empty
215+ , corsAllowedMethods = return allowedMethods
216+ , corsAllowedHeaders = return
217+ }
218+
219+
220+{-# NOINLINE allowedMethods #-}
221+allowedMethods :: HashSet.HashSet HashableMethod
222+allowedMethods =
223+ HashSet.singleton (HashableMethod POST)
224+
225+
226+{-# NOINLINE allowedOrigins #-}
227+allowedOrigins :: OriginList
228+allowedOrigins =
229+ let
230+ origins =
231+ [ "https://elm-lang.org"
232+ , "https://package.elm-lang.org"
233+ ]
234+ in
235+ Origins $ mkOriginSet $
236+ case traverse parseURI origins of
237+ Just uris -> uris
238+ Nothing -> error "Invalid entry in allowedOrigins list"