@@ -1,54 +1,18 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2+{-# LANGUAGE OverloadedStrings #-}
33module Main
44 ( main
55 )
66 where
77
88
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.Map.Utils as Map
17−import qualified Data.Name as N
18−import qualified Data.NonEmptyList as NE
19−import qualified Data.OneOrMore as OneOrMore
20−import Network.URI (parseURI)
9+import Control.Monad (msum)
2110import Snap.Core
2211import Snap.Http.Server
23−import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)
24−import Snap.Util.FileUploads
25−import qualified System.Directory as Dir
26−import qualified System.IO.Streams as Stream
27−import Text.RawString.QQ (r)
2812
29−import qualified AST.Source as Src
30−import qualified AST.Canonical as Can
31−import qualified AST.Optimized as Opt
32−import qualified BackgroundWriter as BW
33−import qualified Build
34−import qualified Compile
35−import qualified Elm.Details as Details
36−import qualified Elm.Interface as I
37−import qualified Elm.ModuleName as ModuleName
38−import qualified Elm.Package as Pkg
39−import qualified File
40−import qualified Generate
41−import qualified Generate.Html as Html
42−import qualified Generate.JavaScript as Generate
43−import qualified Generate.Mode as Mode
44−import qualified Json.Encode as Encode
45−import qualified Parse.Module as Parse
46−import qualified Reporting
47−import qualified Reporting.Annotation as A
48−import qualified Reporting.Error as Error
49−import qualified Reporting.Error.Import as Import
50−import qualified Reporting.Exit as Exit
51−import qualified Reporting.Task as Task
13+import qualified Artifacts
14+import qualified Endpoint.Compile as Compile
15+import qualified Endpoint.Repl as Repl
5216
5317
5418
@@ -57,10 +21,13 @@ import qualified Reporting.Task as Task
5721
5822main :: IO ()
5923main =
60− do artifacts <- loadArtifacts
61− errorJS <- compileErrorViewer
24+ do rArtifacts <- Artifacts.loadRepl
25+ cArtifacts <- Artifacts.loadCompile
26+ errorJS <- Compile.loadErrorJS
6227 httpServe config $ msum $
63− [ path "compile" $ compile artifacts
28+ [ ifTop $ status
29+ , path "repl" $ Repl.endpoint rArtifacts
30+ , path "compile" $ Compile.endpoint cArtifacts
6431 , path "compile/errors.js" $ writeBS errorJS
6532 , notFound
6633 ]
@@ -68,235 +35,17 @@ main =
6835
6936config :: Config Snap a
7037config =
71− defaultConfig
72− |> setPort 8000
73− |> setAccessLog ConfigNoLog
74− |> setErrorLog ConfigNoLog
38+ setPort 8000 $ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
7539
7640
77−(|>) :: a -> (a -> b) -> b
78−(|>) value func =
79− func value
80−
81−
82−
83−-- NOT FOUND
41+status :: Snap ()
42+status =
43+ do modifyResponse $ setContentType "text/plain"
44+ writeBuilder "Status: OK"
8445
8546
8647notFound :: Snap ()
8748notFound =
8849 do modifyResponse $ setResponseStatus 404 "Not Found"
8950 modifyResponse $ setContentType "text/html; charset=utf-8"
90− writeBS "Not Found"
91−
92−
93−
94−-- COMPILE ENDPOINT
95−
96−
97−compile :: Artifacts -> Snap ()
98−compile artifacts =
99− applyCORS corsOptions $ method POST $
100− do result <- foldMultipart defaultUploadPolicy ignoreFile 0
101− case result of
102− ([("code",source)], 0) ->
103− do modifyResponse $ setContentType "text/html; charset=utf-8"
104− case compileToBuilder artifacts source of
105− Right builder -> writeBuilder builder
106− Left exit -> writeBuilder (exitToHtmlBuilder exit)
107−
108− _ ->
109− do modifyResponse $ setResponseStatus 400 "Bad Request"
110− modifyResponse $ setContentType "text/html; charset=utf-8"
111− writeBS
112− "<p>Unexpected request format. This should not be possible!</p>\
113− \<p>Please report this\
114− \ <a href=\"https://github.com/elm/compiler/issues\">here</a>\
115− \ along with the URL and your browser version.</p>"
116−
117−
118−ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
119−ignoreFile _ _ count =
120− return (count + 1)
121−
122−
123−exitToHtmlBuilder :: Exit.Worker -> B.Builder
124−exitToHtmlBuilder exit =
125− let
126− json =
127− Encode.encodeUgly $ Exit.toJson $ Exit.workerToReport exit
128− in
129− [r|<!DOCTYPE HTML>
130−<html>
131−<head>
132− <meta charset="UTF-8">
133− <style>body { padding: 0; margin: 0; background-color: black; }</style>
134− <script src="https://worker.elm-lang.org/compile/errors.js"></script>
135−</head>
136−<body>
137− <script>Elm.Errors.init({flags:|] <> json <> [r|});</script>
138−</body>
139−</html>|]
140−
141−
142−
143−-- COMPILE TO BUILDER
144−
145−
146−compileToBuilder :: Artifacts -> B.ByteString -> Either Exit.Worker B.Builder
147−compileToBuilder (Artifacts interfaces objects) source =
148− case Parse.fromByteString Parse.Application source of
149− Left err ->
150− Left $ toInputError N._Main source (Error.BadSyntax err)
151−
152− Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
153− case checkImports interfaces imports of
154− Left err ->
155− Left $ toInputError (Src.getName modul) source (Error.BadImports err)
156−
157− Right ifaces ->
158− case Compile.compile Pkg.dummyName ifaces modul of
159− Left err ->
160− Left $ toInputError (Src.getName modul) source err
161−
162− Right (Compile.Artifacts canModule _ locals) ->
163− case locals of
164− Opt.LocalGraph Nothing _ _ ->
165− Left Exit.WorkerNoMain
166−
167− Opt.LocalGraph (Just main_) _ _ ->
168− let
169− mode = Mode.Dev Nothing
170− home = Can._name canModule
171− name = ModuleName._module home
172− mains = Map.singleton home main_
173− graph = Opt.addLocalGraph locals objects
174− in
175− Right $ Html.sandwich name $ Generate.generate mode graph mains
176−
177−
178−checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
179−checkImports interfaces imports =
180− let
181− importDict = Map.fromValues Src.getImportName imports
182− missing = Map.difference importDict interfaces
183− in
184− case Map.elems missing of
185− [] ->
186− Right (Map.intersection interfaces importDict)
187−
188− i:is ->
189− let
190− unimported = Map.keysSet (Map.difference interfaces importDict)
191− toError (Src.Import (A.At region name) _ _) =
192− Import.Error region name unimported Import.NotFound
193− in
194− Left (fmap toError (NE.List i is))
195−
196−
197−toInputError :: ModuleName.Raw -> B.ByteString -> Error.Error -> Exit.Worker
198−toInputError name source err =
199− Exit.WorkerInputError $
200− Error.Module name "/try" File.zeroTime source err
201−
202−
203−
204−-- COMPILE ERROR VIEWER
205−
206−
207−compileErrorViewer :: IO B.ByteString
208−compileErrorViewer =
209− let
210− run work =
211− do result <- work
212− case result of
213− Right a -> return a
214− Left _ -> error "problem building reactor/src/Errors.elm"
215− in
216− Dir.withCurrentDirectory "../reactor" $ BW.withScope $ \scope ->
217− do let root = "."
218− details <- run $ Details.load Reporting.silent scope root
219− artifacts <- run $ Build.fromMains Reporting.silent root details (NE.List "src/Errors.elm" [])
220− javascript <- run $ Task.run $ Generate.prod root details artifacts
221− return $ LBS.toStrict $ B.toLazyByteString javascript
222−
223−
224−
225−-- CORS OPTIONS
226−
227−
228−corsOptions :: (Monad m) => CORSOptions m
229−corsOptions =
230− let
231− allowedOrigins = toOriginList [ "https://elm-lang.org", "https://package.elm-lang.org" ]
232− allowedMethods = HashSet.singleton (HashableMethod POST)
233− in
234− CORSOptions
235− { corsAllowOrigin = return allowedOrigins
236− , corsAllowCredentials = return True
237− , corsExposeHeaders = return HashSet.empty
238− , corsAllowedMethods = return allowedMethods
239− , corsAllowedHeaders = return
240− }
241−
242−
243−toOriginList :: [String] -> OriginList
244−toOriginList origins =
245− Origins $ mkOriginSet $
246− case traverse parseURI origins of
247− Just uris -> uris
248− Nothing -> error "invalid entry given to toOriginList list"
249−
250−
251−
252−-- ARTIFACTS
253−
254−
255−data Artifacts =
256− Artifacts
257− { _ifaces :: Map.Map ModuleName.Raw I.Interface
258− , _graph :: Opt.GlobalGraph
259− }
260−
261−
262−loadArtifacts :: IO Artifacts
263−loadArtifacts =
264− BW.withScope $ \scope ->
265− do style <- Reporting.terminal
266− root <- Dir.getCurrentDirectory
267− result <- Details.load style scope root
268− case result of
269− Left _ ->
270− error "Ran into some problem loading elm.json details"
271−
272− Right details ->
273− do omvar <- Details.loadObjects root details
274− imvar <- Details.loadInterfaces root details
275− mdeps <- readMVar imvar
276− mobjs <- readMVar omvar
277− case liftM2 (,) mdeps mobjs of
278− Nothing ->
279− error "Ran into some weird problem loading elm.json details"
280−
281− Just (deps, objs) ->
282− return $ Artifacts (toInterfaces deps) objs
283−
284−
285−toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
286−toInterfaces deps =
287− Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
288− Map.elems (Map.mapMaybeWithKey getPublic deps)
289−
290−
291−getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
292−getPublic (ModuleName.Canonical _ name) dep =
293− case dep of
294− I.Public iface -> Just (name, OneOrMore.one iface)
295− I.Private _ _ _ -> Nothing
296−
297−
298−toUnique :: OneOrMore.OneOrMore a -> Maybe a
299−toUnique oneOrMore =
300− case oneOrMore of
301− OneOrMore.One value -> Just value
302− OneOrMore.More _ _ -> Nothing
51+ writeBuilder "Not Found"