git.iko.soy/elk
on master help sign in
actually serve something on error / make some cosmetic changes
5ad0888Evan Czaplicki
worker/src/Main.hs+82−70
compare with master
unifiedsplit
@@ -53,9 +53,10 @@ import qualified Reporting.Render.Code as Code
53main :: IO ()
53main :: IO ()
54main =
54main =
55 do artifacts <- loadArtifacts
55 do artifacts <- loadArtifacts
56+ errorHtml <- compileErrorViewer artifacts
56 httpServe config $ msum $
57 httpServe config $ msum $
57 [ path "compile" $ compile artifacts
58 [ path "compile" $ compile artifacts
58− , path "compile/error.js" $ serveFile "error.js"
59+ , path "compile/error.js" $ writeBS errorHtml
59 , notFound
60 , notFound
60 ]
61 ]
61
62
@@ -63,14 +64,14 @@ main =
63config :: Config Snap a
64config :: Config Snap a
64config =
65config =
65 defaultConfig
66 defaultConfig
66− # setVerbose False
67+ |> setVerbose False
67− # setPort 8000
68+ |> setPort 8000
68− # setAccessLog ConfigNoLog
69+ |> setAccessLog ConfigNoLog
69− # setErrorLog ConfigNoLog
70+ |> setErrorLog ConfigNoLog
70
71
71
72
72−(#) :: a -> (a -> b) -> b
73+(|>) :: a -> (a -> b) -> b
73−(#) value func =
74+(|>) value func =
74 func value
75 func value
75
76
76
77
@@ -90,23 +91,17 @@ notFound =
90
91
91
92
92compile :: Artifacts -> Snap ()
93compile :: Artifacts -> Snap ()
93−compile (Artifacts ifaces objs) =
94+compile artifacts =
94 applyCORS corsOptions $ method POST $
95 applyCORS corsOptions $ method POST $
95 do parts <- handleMultipart defaultUploadPolicy handlePart
96 do parts <- handleMultipart defaultUploadPolicy handlePart
96 case parts of
97 case parts of
97 [Just source] ->
98 [Just source] ->
98− case compileByteString ifaces source of
99+ case compileToBuilder artifacts source of
99 Left err ->
100 Left err ->
100 writeBuilder $ errorToHtmlBuilder source err
101 writeBuilder $ errorToHtmlBuilder source err
101
102
102− Right (home, locals, main) ->
103+ Right builder ->
103− let
104+ writeBuilder builder
104− mode = Mode.Dev Nothing
105− name = ModuleName._module home
106− mains = Map.singleton home main
107− graph = Opt.addLocalGraph locals objs
108− in
109− writeBuilder $ Html.sandwich name $ Generate.generate mode graph mains
110
105
111 _ ->
106 _ ->
112 pass
107 pass
@@ -119,8 +114,26 @@ handlePart info stream =
119 else return Nothing
114 else return Nothing
120
115
121
116
122−compileByteString :: Map.Map ModuleName.Raw I.Interface -> B.ByteString -> Either Error.Error (ModuleName.Canonical, Opt.LocalGraph, Opt.Main)
117+errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
123−compileByteString interfaces source =
118+errorToHtmlBuilder source err =
119+ let
120+ json = Encode.encodeUgly (Error.errorToJson (Code.toSource source) err)
121+ in
122+ [r|<!DOCTYPE HTML>
123+<html>
124+<head>
125+ <meta charset="UTF-8">
126+ <style>body { padding: 0; margin: 0; }</style>
127+ <script src="https://worker.elm-lang.org/compile/error.js"></script>
128+ <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
129+</head>
130+<body></body>
131+</html>|]
132+
133+
134+
135+compileToBuilder :: Artifacts -> B.ByteString -> Either Error.Error B.Builder
136+compileToBuilder (Artifacts interfaces objects) source =
124 case Parse.fromByteString Pkg.dummyName source of
137 case Parse.fromByteString Pkg.dummyName source of
125 Left err ->
138 Left err ->
126 Left (Error.BadSyntax err)
139 Left (Error.BadSyntax err)
@@ -137,8 +150,18 @@ compileByteString interfaces source =
137
150
138 Right artifacts@(Compile.Artifacts modul _ locals@(Opt.LocalGraph maybeMain _ _)) ->
151 Right artifacts@(Compile.Artifacts modul _ locals@(Opt.LocalGraph maybeMain _ _)) ->
139 case maybeMain of
152 case maybeMain of
153+ Nothing ->
154+ Left (error "TODO no main")
155+
156+ Just main ->
157+ let
158+ mode = Mode.Dev Nothing
140− Just main -> Right (Can._name modul, locals, main)
159+ home = Can._name modul
141− Nothing -> Left (error "TODO no main")
160+ name = ModuleName._module home
161+ mains = Map.singleton home main
162+ graph = Opt.addLocalGraph locals objects
163+ in
164+ Right $ Html.sandwich name $ Generate.generate mode graph mains
142
165
143
166
144checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either Error.Error (Map.Map ModuleName.Raw I.Interface)
167checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either Error.Error (Map.Map ModuleName.Raw I.Interface)
@@ -160,21 +183,46 @@ checkImports interfaces imports =
160 Left (Error.BadImports (fmap toError (NE.List i is)))
183 Left (Error.BadImports (fmap toError (NE.List i is)))
161
184
162
185
163−errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
186+
164−errorToHtmlBuilder source err =
187+-- COMPILE ERROR VIEWER
188+
189+
190+compileErrorViewer :: Artifacts -> B.ByteString
191+compileErrorViewer artifacts =
192+ do source <- File.readUtf8 "src/Error.elm"
193+ case compileToBuilder artifacts source of
194+ Left err ->
195+ error "problem compiling src/Error.elm"
196+
197+ Right builder ->
198+ return (LBS.toStrict (B.toLazyByteString builder))
199+
200+
201+
202+-- CORS OPTIONS
203+
204+
205+corsOptions :: (Monad m) => CORSOptions m
206+corsOptions =
165 let
207 let
166− json = Encode.encodeUgly (Error.errorToJson (Code.toSource source) err)
208+ allowedOrigins = toOriginList [ "https://elm-lang.org", "https://package.elm-lang.org" ]
209+ allowedMethods = HashSet.singleton (HashableMethod POST)
167 in
210 in
168− [r|<!DOCTYPE HTML>
211+ CORSOptions
169−<html>
212+ { corsAllowOrigin = return allowedOrigins
170−<head>
213+ , corsAllowCredentials = return True
171− <meta charset="UTF-8">
214+ , corsExposeHeaders = return HashSet.empty
172− <style>body { padding: 0; margin: 0; }</style>
215+ , corsAllowedMethods = return allowedMethods
173− <script src="https://worker.elm-lang.org/compile/error.js"></script>
216+ , corsAllowedHeaders = return
174− <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
217+ }
175−</head>
218+
176−<body></body>
219+
177−</html>|]
220+toOriginList :: [String] -> OriginList
221+toOriginList origins =
222+ Origins $ mkOriginSet $
223+ case traverse parseURI origins of
224+ Just uris -> uris
225+ Nothing -> error "invalid entry given to toOriginList list"
178
226
179
227
180
228
@@ -228,39 +276,3 @@ toUnique oneOrMore =
228 case oneOrMore of
276 case oneOrMore of
229 OneOrMore.One value -> Just value
277 OneOrMore.One value -> Just value
230 OneOrMore.More _ _ -> Nothing
278 OneOrMore.More _ _ -> Nothing
231−
232−
233−
234−-- CORS
235−
236−
237−corsOptions :: (Monad m) => CORSOptions m
238−corsOptions =
239− CORSOptions
240− { corsAllowOrigin = return allowedOrigins
241− , corsAllowCredentials = return True
242− , corsExposeHeaders = return HashSet.empty
243− , corsAllowedMethods = return allowedMethods
244− , corsAllowedHeaders = return
245− }
246−
247−
248−{-# NOINLINE allowedMethods #-}
249−allowedMethods :: HashSet.HashSet HashableMethod
250−allowedMethods =
251− HashSet.singleton (HashableMethod POST)
252−
253−
254−{-# NOINLINE allowedOrigins #-}
255−allowedOrigins :: OriginList
256−allowedOrigins =
257− let
258− origins =
259− [ "https://elm-lang.org"
260− , "https://package.elm-lang.org"
261− ]
262− in
263− Origins $ mkOriginSet $
264− case traverse parseURI origins of
265− Just uris -> uris
266− Nothing -> error "Invalid entry in allowedOrigins list"