git.iko.soy/elk
on 6c19c6e help sign in
elk/worker/src/Main.hs
302 lines 9.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
3module Main
4 ( main
5 )
6 where
9import Control.Concurrent (readMVar)
10import Control.Monad (liftM2, msum)
11import qualified Data.ByteString as B
12import qualified Data.ByteString.Builder as B
13import qualified Data.ByteString.Lazy as LBS
14import qualified Data.HashSet as HashSet
15import qualified Data.Map as Map
16import qualified Data.Map.Utils as Map
17import qualified Data.Name as N
18import qualified Data.NonEmptyList as NE
19import qualified Data.OneOrMore as OneOrMore
20import Network.URI (parseURI)
21import Snap.Core
22import Snap.Http.Server
23import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)
24import Snap.Util.FileUploads
25import qualified System.Directory as Dir
26import qualified System.IO.Streams as Stream
27import Text.RawString.QQ (r)
29import qualified AST.Source as Src
30import qualified AST.Canonical as Can
31import qualified AST.Optimized as Opt
32import qualified BackgroundWriter as BW
33import qualified Build
34import qualified Compile
35import qualified Elm.Details as Details
36import qualified Elm.Interface as I
37import qualified Elm.ModuleName as ModuleName
38import qualified Elm.Package as Pkg
39import qualified File
40import qualified Generate
41import qualified Generate.Html as Html
42import qualified Generate.JavaScript as Generate
43import qualified Generate.Mode as Mode
44import qualified Json.Encode as Encode
45import qualified Parse.Module as Parse
46import qualified Reporting
47import qualified Reporting.Annotation as A
48import qualified Reporting.Error as Error
49import qualified Reporting.Error.Import as Import
50import qualified Reporting.Exit as Exit
51import qualified Reporting.Task as Task
55-- RUN THE DEV SERVER
58main :: IO ()
59main =
60 do artifacts <- loadArtifacts
61 errorJS <- compileErrorViewer
62 httpServe config $ msum $
63 [ path "compile" $ compile artifacts
64 , path "compile/errors.js" $ writeBS errorJS
65 , notFound
66 ]
69config :: Config Snap a
70config =
71 defaultConfig
72 |> setPort 8000
73 |> setAccessLog ConfigNoLog
74 |> setErrorLog ConfigNoLog
77(|>) :: a -> (a -> b) -> b
78(|>) value func =
79 func value
83-- NOT FOUND
86notFound :: Snap ()
87notFound =
88 do modifyResponse $ setResponseStatus 404 "Not Found"
89 modifyResponse $ setContentType "text/html; charset=utf-8"
90 writeBS "Not Found"
94-- COMPILE ENDPOINT
97compile :: Artifacts -> Snap ()
98compile 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)
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>"
118ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
119ignoreFile _ _ count =
120 return (count + 1)
123exitToHtmlBuilder :: Exit.Worker -> B.Builder
124exitToHtmlBuilder 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="http://localhost:8000/compile/errors.js"></script>
135</head>
136<body>
137 <script>Elm.Errors.init({flags:|] <> json <> [r|});</script>
138</body>
139</html>|]
143-- COMPILE TO BUILDER
146compileToBuilder :: Artifacts -> B.ByteString -> Either Exit.Worker B.Builder
147compileToBuilder (Artifacts interfaces objects) source =
148 case Parse.fromByteString Pkg.dummyName source of
149 Left err ->
150 Left $ toInputError N._Main source (Error.BadSyntax err)
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)
157 Right ifaces ->
158 case Compile.compile Pkg.dummyName ifaces modul of
159 Left err ->
160 Left $ toInputError (Src.getName modul) source err
162 Right (Compile.Artifacts canModule _ locals) ->
163 case locals of
164 Opt.LocalGraph Nothing _ _ ->
165 Left Exit.WorkerNoMain
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
178checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
179checkImports 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)
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))
197toInputError :: ModuleName.Raw -> B.ByteString -> Error.Error -> Exit.Worker
198toInputError name source err =
199 Exit.WorkerInputError $
200 Error.Module name "/try" File.zeroTime source err
204-- COMPILE ERROR VIEWER
207compileErrorViewer :: IO B.ByteString
208compileErrorViewer =
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
225-- CORS OPTIONS
228corsOptions :: (Monad m) => CORSOptions m
229corsOptions =
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 }
243toOriginList :: [String] -> OriginList
244toOriginList origins =
245 Origins $ mkOriginSet $
246 case traverse parseURI origins of
247 Just uris -> uris
248 Nothing -> error "invalid entry given to toOriginList list"
252-- ARTIFACTS
255data Artifacts =
256 Artifacts
257 { _ifaces :: Map.Map ModuleName.Raw I.Interface
258 , _graph :: Opt.GlobalGraph
259 }
262loadArtifacts :: IO Artifacts
263loadArtifacts =
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"
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"
281 Just (deps, objs) ->
282 return $ Artifacts (toInterfaces deps) objs
285toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
286toInterfaces deps =
287 Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
288 Map.elems (Map.mapMaybeWithKey getPublic deps)
291getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
292getPublic (ModuleName.Canonical _ name) dep =
293 case dep of
294 I.Public iface -> Just (name, OneOrMore.one iface)
295 I.Private _ _ _ -> Nothing
298toUnique :: OneOrMore.OneOrMore a -> Maybe a
299toUnique oneOrMore =
300 case oneOrMore of
301 OneOrMore.One value -> Just value
302 OneOrMore.More _ _ -> Nothing