@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -Wall #-}
12{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
23module Main
34 ( main
@@ -5,7 +6,6 @@ module Main
56 where
67
78
8−import Control.Applicative ((<|>))
99import Control.Concurrent (readMVar)
1010import Control.Monad (liftM2, msum)
1111import qualified Data.ByteString as B
@@ -20,23 +20,24 @@ import qualified Data.OneOrMore as OneOrMore
2020import Network.URI (parseURI)
2121import Snap.Core
2222import Snap.Http.Server
23−import Snap.Util.CORS
24−import Snap.Util.FileServe (serveFile)
23+import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)
2524import Snap.Util.FileUploads
2625import qualified System.Directory as Dir
27−import qualified System.Exit as Exit
2826import qualified System.IO.Streams as Stream
2927import Text.RawString.QQ (r)
3028
3129import qualified AST.Source as Src
3230import qualified AST.Canonical as Can
3331import qualified AST.Optimized as Opt
32+import qualified BackgroundWriter as BW
33+import qualified Build
3434import qualified Compile
3535import qualified Elm.Details as Details
3636import qualified Elm.Interface as I
3737import qualified Elm.ModuleName as ModuleName
3838import qualified Elm.Package as Pkg
3939import qualified File
40+import qualified Generate
4041import qualified Generate.Html as Html
4142import qualified Generate.JavaScript as Generate
4243import qualified Generate.Mode as Mode
@@ -47,6 +48,7 @@ import qualified Reporting.Annotation as A
4748import qualified Reporting.Error as Error
4849import qualified Reporting.Error.Import as Import
4950import qualified Reporting.Exit as Exit
51+import qualified Reporting.Task as Task
5052
5153
5254
@@ -56,10 +58,10 @@ import qualified Reporting.Exit as Exit
5658main :: IO ()
5759main =
5860 do artifacts <- loadArtifacts
59− errorJS <- compileErrorViewer artifacts
61+ errorJS <- compileErrorViewer
6062 httpServe config $ msum $
6163 [ path "compile" $ compile artifacts
62− , path "compile/error.js" $ writeBS errorJS
64+ , path "compile/errors.js" $ writeBS errorJS
6365 , notFound
6466 ]
6567
@@ -67,7 +69,6 @@ main =
6769config :: Config Snap a
6870config =
6971 defaultConfig
70− |> setVerbose False
7172 |> setPort 8000
7273 |> setAccessLog ConfigNoLog
7374 |> setErrorLog ConfigNoLog
@@ -96,22 +97,27 @@ notFound =
9697compile :: Artifacts -> Snap ()
9798compile artifacts =
9899 applyCORS corsOptions $ method POST $
99− do parts <- handleMultipart defaultUploadPolicy handlePart
100− case parts of
101− [Just source] ->
102− case compileToBuilder artifacts source of
103− Right builder -> writeBuilder builder
104− Left exit -> writeBuilder (exitToHtmlBuilder exit)
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)
105107
106108 _ ->
107− pass
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>"
108116
109117
110−handlePart :: PartInfo -> Stream.InputStream B.ByteString -> IO (Maybe B.ByteString)
111−handlePart info stream =
112− if partFieldName info == "code" && partDisposition info == DispositionFormData
113− then Just . LBS.toStrict <$> storeAsLazyByteString stream
114− else return Nothing
118+ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
119+ignoreFile _ _ count =
120+ return (count + 1)
115121
116122
117123exitToHtmlBuilder :: Exit.Worker -> B.Builder
@@ -124,11 +130,12 @@ exitToHtmlBuilder exit =
124130<html>
125131<head>
126132 <meta charset="UTF-8">
127− <style>body { padding: 0; margin: 0; }</style>
128− <script src="https://worker.elm-lang.org/compile/error.js"></script>
129− <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
133+ <style>body { padding: 0; margin: 0; background-color: black; }</style>
134+ <script src="http://localhost:8000/compile/errors.js"></script>
130135</head>
131−<body></body>
136+<body>
137+ <script>Elm.Errors.init({flags:|] <> json <> [r|});</script>
138+</body>
132139</html>|]
133140
134141
@@ -152,17 +159,17 @@ compileToBuilder (Artifacts interfaces objects) source =
152159 Left err ->
153160 Left $ toInputError (Src.getName modul) source err
154161
155− Right artifacts@(Compile.Artifacts modul _ locals) ->
162+ Right (Compile.Artifacts canModule _ locals) ->
156163 case locals of
157164 Opt.LocalGraph Nothing _ _ ->
158165 Left Exit.WorkerNoMain
159166
160− Opt.LocalGraph (Just main) _ _ ->
167+ Opt.LocalGraph (Just main_) _ _ ->
161168 let
162169 mode = Mode.Dev Nothing
163− home = Can._name modul
170+ home = Can._name canModule
164171 name = ModuleName._module home
165− mains = Map.singleton home main
172+ mains = Map.singleton home main_
166173 graph = Opt.addLocalGraph locals objects
167174 in
168175 Right $ Html.sandwich name $ Generate.generate mode graph mains
@@ -197,17 +204,21 @@ toInputError name source err =
197204-- COMPILE ERROR VIEWER
198205
199206
200−compileErrorViewer :: Artifacts -> IO B.ByteString
201−compileErrorViewer artifacts =
202− do source <- File.readUtf8 "src/Error.elm"
203− case compileToBuilder artifacts source of
204− Left exit ->
205− do putStrLn "Problem in src/Error.elm"
206− Exit.toStderr (Exit.workerToReport exit)
207− Exit.exitFailure
208−
209− Right builder ->
210− return (LBS.toStrict (B.toLazyByteString builder))
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
211222
212223
213224
@@ -250,9 +261,10 @@ data Artifacts =
250261
251262loadArtifacts :: IO Artifacts
252263loadArtifacts =
264+ BW.withScope $ \scope ->
253265 do style <- Reporting.terminal
254266 root <- Dir.getCurrentDirectory
255− result <- Details.load style root
267+ result <- Details.load style scope root
256268 case result of
257269 Left _ ->
258270 error "Ran into some problem loading elm.json details"