git.iko.soy/elk
on 075be13 help sign in
elk/worker/src/Main.hs
278 lines 7.8 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.NonEmptyList as NE
18import qualified Data.OneOrMore as OneOrMore
19import Network.URI (parseURI)
20import Snap.Core
21import Snap.Http.Server
22import Snap.Util.CORS
23import Snap.Util.FileServe (serveFile)
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 Compile
33import qualified Elm.Details as Details
34import qualified Elm.Interface as I
35import qualified Elm.ModuleName as ModuleName
36import qualified Elm.Package as Pkg
37import qualified Generate.Html as Html
38import qualified Generate.JavaScript as Generate
39import qualified Generate.Mode as Mode
40import qualified Json.Encode as Encode
41import qualified Parse.Module as Parse
42import qualified Reporting
43import qualified Reporting.Annotation as A
44import qualified Reporting.Error as Error
45import qualified Reporting.Error.Import as Import
46import qualified Reporting.Render.Code as Code
50-- RUN THE DEV SERVER
53main :: IO ()
54main =
55 do artifacts <- loadArtifacts
56 errorHtml <- compileErrorViewer artifacts
57 httpServe config $ msum $
58 [ path "compile" $ compile artifacts
59 , path "compile/error.js" $ writeBS errorHtml
60 , notFound
61 ]
64config :: Config Snap a
65config =
66 defaultConfig
67 |> setVerbose False
68 |> setPort 8000
69 |> setAccessLog ConfigNoLog
70 |> setErrorLog ConfigNoLog
73(|>) :: a -> (a -> b) -> b
74(|>) value func =
75 func value
79-- NOT FOUND
82notFound :: Snap ()
83notFound =
84 do modifyResponse $ setResponseStatus 404 "Not Found"
85 modifyResponse $ setContentType "text/html; charset=utf-8"
86 writeBS "Not Found"
90-- COMPILE
93compile :: Artifacts -> Snap ()
94compile artifacts =
95 applyCORS corsOptions $ method POST $
96 do parts <- handleMultipart defaultUploadPolicy handlePart
97 case parts of
98 [Just source] ->
99 case compileToBuilder artifacts source of
100 Left err ->
101 writeBuilder $ errorToHtmlBuilder source err
103 Right builder ->
104 writeBuilder builder
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
117errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
118errorToHtmlBuilder 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>|]
135compileToBuilder :: Artifacts -> B.ByteString -> Either Error.Error B.Builder
136compileToBuilder (Artifacts interfaces objects) source =
137 case Parse.fromByteString Pkg.dummyName source of
138 Left err ->
139 Left (Error.BadSyntax err)
141 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
142 case checkImports interfaces imports of
143 Left err ->
144 Left err
146 Right ifaces ->
147 case Compile.compile Pkg.dummyName ifaces modul of
148 Left err ->
149 Left err
151 Right artifacts@(Compile.Artifacts modul _ locals@(Opt.LocalGraph maybeMain _ _)) ->
152 case maybeMain of
153 Nothing ->
154 Left (error "TODO no main")
156 Just main ->
157 let
158 mode = Mode.Dev Nothing
159 home = Can._name modul
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
167checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either Error.Error (Map.Map ModuleName.Raw I.Interface)
168checkImports interfaces imports =
169 let
170 importDict = Map.fromValues Src.getImportName imports
171 missing = Map.difference importDict interfaces
172 in
173 case Map.elems missing of
174 [] ->
175 Right (Map.intersection interfaces importDict)
177 i:is ->
178 let
179 unimported = Map.keysSet (Map.difference interfaces importDict)
180 toError (Src.Import (A.At region name) _ _) =
181 Import.Error region name unimported Import.NotFound
182 in
183 Left (Error.BadImports (fmap toError (NE.List i is)))
187-- COMPILE ERROR VIEWER
190compileErrorViewer :: Artifacts -> B.ByteString
191compileErrorViewer 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"
197 Right builder ->
198 return (LBS.toStrict (B.toLazyByteString builder))
202-- CORS OPTIONS
205corsOptions :: (Monad m) => CORSOptions m
206corsOptions =
207 let
208 allowedOrigins = toOriginList [ "https://elm-lang.org", "https://package.elm-lang.org" ]
209 allowedMethods = HashSet.singleton (HashableMethod POST)
210 in
211 CORSOptions
212 { corsAllowOrigin = return allowedOrigins
213 , corsAllowCredentials = return True
214 , corsExposeHeaders = return HashSet.empty
215 , corsAllowedMethods = return allowedMethods
216 , corsAllowedHeaders = return
217 }
220toOriginList :: [String] -> OriginList
221toOriginList origins =
222 Origins $ mkOriginSet $
223 case traverse parseURI origins of
224 Just uris -> uris
225 Nothing -> error "invalid entry given to toOriginList list"
229-- ARTIFACTS
232data Artifacts =
233 Artifacts
234 { _ifaces :: Map.Map ModuleName.Raw I.Interface
235 , _graph :: Opt.GlobalGraph
236 }
239loadArtifacts :: IO Artifacts
240loadArtifacts =
241 do style <- Reporting.terminal
242 root <- Dir.getCurrentDirectory
243 result <- Details.load style root
244 case result of
245 Left _ ->
246 error "Ran into some problem loading elm.json details"
248 Right details ->
249 do omvar <- Details.loadObjects root details
250 imvar <- Details.loadInterfaces root details
251 mdeps <- readMVar imvar
252 mobjs <- readMVar omvar
253 case liftM2 (,) mdeps mobjs of
254 Nothing ->
255 error "Ran into some weird problem loading elm.json details"
257 Just (deps, objs) ->
258 return $ Artifacts (toInterfaces deps) objs
261toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
262toInterfaces deps =
263 Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
264 Map.elems (Map.mapMaybeWithKey getPublic deps)
267getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
268getPublic (ModuleName.Canonical _ name) dep =
269 case dep of
270 I.Public iface -> Just (name, OneOrMore.one iface)
271 I.Private _ _ _ -> Nothing
274toUnique :: OneOrMore.OneOrMore a -> Maybe a
275toUnique oneOrMore =
276 case oneOrMore of
277 OneOrMore.One value -> Just value
278 OneOrMore.More _ _ -> Nothing