Skip to content

Commit 3e9455d

Browse files
evanczevancz
committed
get worker/ working
This includes a couple important changes: - Switch to using reactor/src/Errors.elm to show error messages. It may be better to have two separate versions such that the two can have different styles though. - get the multipart/form-data logic working. Files are treated differently than non-files in foldMulitpart, which was pretty confusing! - move the initialization of Elm.Errors into <body> so that it could take over that node. Otherwise the code runs before it exists. - resolve some of the -Wall errors
1 parent e562ca4 commit 3e9455d

File tree

1 file changed

+51
-39
lines changed

1 file changed

+51
-39
lines changed

‎worker/src/Main.hs‎

Lines changed: 51 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,11 @@
1+
{-# OPTIONS_GHC -Wall #-}
12
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
23
module Main
34
( main
45
)
56
where
67

78

8-
import Control.Applicative ((<|>))
99
import Control.Concurrent (readMVar)
1010
import Control.Monad (liftM2, msum)
1111
import qualified Data.ByteString as B
@@ -20,23 +20,24 @@ import qualified Data.OneOrMore as OneOrMore
2020
import Network.URI (parseURI)
2121
import Snap.Core
2222
import 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)
2524
import Snap.Util.FileUploads
2625
import qualified System.Directory as Dir
27-
import qualified System.Exit as Exit
2826
import qualified System.IO.Streams as Stream
2927
import Text.RawString.QQ (r)
3028

3129
import qualified AST.Source as Src
3230
import qualified AST.Canonical as Can
3331
import qualified AST.Optimized as Opt
32+
import qualified BackgroundWriter as BW
33+
import qualified Build
3434
import qualified Compile
3535
import qualified Elm.Details as Details
3636
import qualified Elm.Interface as I
3737
import qualified Elm.ModuleName as ModuleName
3838
import qualified Elm.Package as Pkg
3939
import qualified File
40+
import qualified Generate
4041
import qualified Generate.Html as Html
4142
import qualified Generate.JavaScript as Generate
4243
import qualified Generate.Mode as Mode
@@ -47,6 +48,7 @@ import qualified Reporting.Annotation as A
4748
import qualified Reporting.Error as Error
4849
import qualified Reporting.Error.Import as Import
4950
import qualified Reporting.Exit as Exit
51+
import qualified Reporting.Task as Task
5052

5153

5254

@@ -56,18 +58,17 @@ import qualified Reporting.Exit as Exit
5658
main :: IO ()
5759
main =
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

6668

6769
config :: Config Snap a
6870
config =
6971
defaultConfig
70-
|> setVerbose False
7172
|> setPort 8000
7273
|> setAccessLog ConfigNoLog
7374
|> setErrorLog ConfigNoLog
@@ -96,22 +97,27 @@ notFound =
9697
compile :: Artifacts -> Snap ()
9798
compile 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

117123
exitToHtmlBuilder :: 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

251262
loadArtifacts :: IO Artifacts
252263
loadArtifacts =
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"

0 commit comments

Comments
 (0)