git.iko.soy/elk
on 5e73421 help sign in
elk/worker/src/Main.hs
290 lines 8.2 kB history raw
1{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2module Main
3 ( main
4 )
5 where
8import Control.Applicative ((<|>))
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
24import Snap.Util.FileServe (serveFile)
25import Snap.Util.FileUploads
26import qualified System.Directory as Dir
27import qualified System.Exit as Exit
28import qualified System.IO.Streams as Stream
29import Text.RawString.QQ (r)
31import qualified AST.Source as Src
32import qualified AST.Canonical as Can
33import qualified AST.Optimized as Opt
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.Html as Html
41import qualified Generate.JavaScript as Generate
42import qualified Generate.Mode as Mode
43import qualified Json.Encode as Encode
44import qualified Parse.Module as Parse
45import qualified Reporting
46import qualified Reporting.Annotation as A
47import qualified Reporting.Error as Error
48import qualified Reporting.Error.Import as Import
49import qualified Reporting.Exit as Exit
53-- RUN THE DEV SERVER
56main :: IO ()
57main =
58 do artifacts <- loadArtifacts
59 errorJS <- compileErrorViewer artifacts
60 httpServe config $ msum $
61 [ path "compile" $ compile artifacts
62 , path "compile/error.js" $ writeBS errorJS
63 , notFound
64 ]
67config :: Config Snap a
68config =
69 defaultConfig
70 |> setVerbose False
71 |> setPort 8000
72 |> setAccessLog ConfigNoLog
73 |> setErrorLog ConfigNoLog
76(|>) :: a -> (a -> b) -> b
77(|>) value func =
78 func value
82-- NOT FOUND
85notFound :: Snap ()
86notFound =
87 do modifyResponse $ setResponseStatus 404 "Not Found"
88 modifyResponse $ setContentType "text/html; charset=utf-8"
89 writeBS "Not Found"
93-- COMPILE ENDPOINT
96compile :: Artifacts -> Snap ()
97compile artifacts =
98 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)
106 _ ->
107 pass
110handlePart :: PartInfo -> Stream.InputStream B.ByteString -> IO (Maybe B.ByteString)
111handlePart info stream =
112 if partFieldName info == "code" && partDisposition info == DispositionFormData
113 then Just . LBS.toStrict <$> storeAsLazyByteString stream
114 else return Nothing
117exitToHtmlBuilder :: Exit.Worker -> B.Builder
118exitToHtmlBuilder exit =
119 let
120 json =
121 Encode.encodeUgly $ Exit.toJson $ Exit.workerToReport exit
122 in
123 [r|<!DOCTYPE HTML>
124<html>
125<head>
126 <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>
130</head>
131<body></body>
132</html>|]
136-- COMPILE TO BUILDER
139compileToBuilder :: Artifacts -> B.ByteString -> Either Exit.Worker B.Builder
140compileToBuilder (Artifacts interfaces objects) source =
141 case Parse.fromByteString Pkg.dummyName source of
142 Left err ->
143 Left $ toInputError N._Main source (Error.BadSyntax err)
145 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
146 case checkImports interfaces imports of
147 Left err ->
148 Left $ toInputError (Src.getName modul) source (Error.BadImports err)
150 Right ifaces ->
151 case Compile.compile Pkg.dummyName ifaces modul of
152 Left err ->
153 Left $ toInputError (Src.getName modul) source err
155 Right artifacts@(Compile.Artifacts modul _ locals) ->
156 case locals of
157 Opt.LocalGraph Nothing _ _ ->
158 Left Exit.WorkerNoMain
160 Opt.LocalGraph (Just main) _ _ ->
161 let
162 mode = Mode.Dev Nothing
163 home = Can._name modul
164 name = ModuleName._module home
165 mains = Map.singleton home main
166 graph = Opt.addLocalGraph locals objects
167 in
168 Right $ Html.sandwich name $ Generate.generate mode graph mains
171checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
172checkImports interfaces imports =
173 let
174 importDict = Map.fromValues Src.getImportName imports
175 missing = Map.difference importDict interfaces
176 in
177 case Map.elems missing of
178 [] ->
179 Right (Map.intersection interfaces importDict)
181 i:is ->
182 let
183 unimported = Map.keysSet (Map.difference interfaces importDict)
184 toError (Src.Import (A.At region name) _ _) =
185 Import.Error region name unimported Import.NotFound
186 in
187 Left (fmap toError (NE.List i is))
190toInputError :: ModuleName.Raw -> B.ByteString -> Error.Error -> Exit.Worker
191toInputError name source err =
192 Exit.WorkerInputError $
193 Error.Module name "/try" File.zeroTime source err
197-- COMPILE ERROR VIEWER
200compileErrorViewer :: Artifacts -> IO B.ByteString
201compileErrorViewer 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
209 Right builder ->
210 return (LBS.toStrict (B.toLazyByteString builder))
214-- CORS OPTIONS
217corsOptions :: (Monad m) => CORSOptions m
218corsOptions =
219 let
220 allowedOrigins = toOriginList [ "https://elm-lang.org", "https://package.elm-lang.org" ]
221 allowedMethods = HashSet.singleton (HashableMethod POST)
222 in
223 CORSOptions
224 { corsAllowOrigin = return allowedOrigins
225 , corsAllowCredentials = return True
226 , corsExposeHeaders = return HashSet.empty
227 , corsAllowedMethods = return allowedMethods
228 , corsAllowedHeaders = return
229 }
232toOriginList :: [String] -> OriginList
233toOriginList origins =
234 Origins $ mkOriginSet $
235 case traverse parseURI origins of
236 Just uris -> uris
237 Nothing -> error "invalid entry given to toOriginList list"
241-- ARTIFACTS
244data Artifacts =
245 Artifacts
246 { _ifaces :: Map.Map ModuleName.Raw I.Interface
247 , _graph :: Opt.GlobalGraph
248 }
251loadArtifacts :: IO Artifacts
252loadArtifacts =
253 do style <- Reporting.terminal
254 root <- Dir.getCurrentDirectory
255 result <- Details.load style root
256 case result of
257 Left _ ->
258 error "Ran into some problem loading elm.json details"
260 Right details ->
261 do omvar <- Details.loadObjects root details
262 imvar <- Details.loadInterfaces root details
263 mdeps <- readMVar imvar
264 mobjs <- readMVar omvar
265 case liftM2 (,) mdeps mobjs of
266 Nothing ->
267 error "Ran into some weird problem loading elm.json details"
269 Just (deps, objs) ->
270 return $ Artifacts (toInterfaces deps) objs
273toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
274toInterfaces deps =
275 Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
276 Map.elems (Map.mapMaybeWithKey getPublic deps)
279getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
280getPublic (ModuleName.Canonical _ name) dep =
281 case dep of
282 I.Public iface -> Just (name, OneOrMore.one iface)
283 I.Private _ _ _ -> Nothing
286toUnique :: OneOrMore.OneOrMore a -> Maybe a
287toUnique oneOrMore =
288 case oneOrMore of
289 OneOrMore.One value -> Just value
290 OneOrMore.More _ _ -> Nothing