@@ -0,0 +1,238 @@
1+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2+module Main
3+ ( main
4+ )
5+ where
6+
7+
8+import Control.Applicative ((<|>))
9+import Control.Concurrent (readMVar)
10+import Control.Monad (liftM2, msum)
11+import qualified Data.ByteString as B
12+import qualified Data.ByteString.Builder as B
13+import qualified Data.ByteString.Lazy as LBS
14+import qualified Data.HashSet as HashSet
15+import qualified Data.Map as Map
16+import qualified Data.OneOrMore as OneOrMore
17+import Network.URI (parseURI)
18+import Snap.Core
19+import Snap.Http.Server
20+import Snap.Util.CORS
21+import Snap.Util.FileServe (serveFile)
22+import Snap.Util.FileUploads
23+import qualified System.Directory as Dir
24+import qualified System.IO.Streams as Stream
25+import Text.RawString.QQ (r)
26+
27+import qualified AST.Source as Src
28+import qualified AST.Canonical as Can
29+import qualified AST.Optimized as Opt
30+import qualified Compile
31+import qualified Elm.Details as Details
32+import qualified Elm.Interface as I
33+import qualified Elm.ModuleName as ModuleName
34+import qualified Elm.Package as Pkg
35+import qualified Generate.Html as Html
36+import qualified Generate.JavaScript as Generate
37+import qualified Generate.Mode as Mode
38+import qualified Json.Encode as Encode
39+import qualified Parse.Module as Parse
40+import qualified Reporting
41+import qualified Reporting.Error as Error
42+import qualified Reporting.Render.Code as Code
43+
44+
45+
46+-- RUN THE DEV SERVER
47+
48+
49+main :: IO ()
50+main =
51+ do artifacts <- loadArtifacts
52+ httpServe config $ msum $
53+ [ path "compile" $ compile artifacts
54+ , path "compile/error.js" $ serveFile "error.js"
55+ , notFound
56+ ]
57+
58+
59+config :: Config Snap a
60+config =
61+ defaultConfig
62+ # setVerbose False
63+ # setPort 8000
64+ # setAccessLog ConfigNoLog
65+ # setErrorLog ConfigNoLog
66+
67+
68+(#) :: a -> (a -> b) -> b
69+(#) value func =
70+ func value
71+
72+
73+
74+-- NOT FOUND
75+
76+
77+notFound :: Snap ()
78+notFound =
79+ do modifyResponse $ setResponseStatus 404 "Not Found"
80+ modifyResponse $ setContentType "text/html; charset=utf-8"
81+ writeBS "Not Found"
82+
83+
84+
85+-- COMPILE
86+
87+
88+compile :: Artifacts -> Snap ()
89+compile (Artifacts ifaces objs) =
90+ applyCORS corsOptions $ method POST $
91+ do parts <- handleMultipart defaultUploadPolicy handlePart
92+ case parts of
93+ [Just source] ->
94+ case compileByteString ifaces source of
95+ Left err ->
96+ writeBuilder $ errorToHtmlBuilder source err
97+
98+ Right (home, locals, main) ->
99+ let
100+ mode = Mode.Dev Nothing
101+ name = ModuleName._module home
102+ mains = Map.singleton home main
103+ graph = Opt.addLocalGraph locals objs
104+ in
105+ writeBuilder $ Html.sandwich name $ Generate.generate mode graph mains
106+
107+ _ ->
108+ pass
109+
110+
111+handlePart :: PartInfo -> Stream.InputStream B.ByteString -> IO (Maybe B.ByteString)
112+handlePart info stream =
113+ if partFieldName info == "code" && partDisposition info == DispositionFormData
114+ then Just . LBS.toStrict <$> storeAsLazyByteString stream
115+ else return Nothing
116+
117+
118+compileByteString :: Map.Map ModuleName.Raw I.Interface -> B.ByteString -> Either Error.Error (ModuleName.Canonical, Opt.LocalGraph, Opt.Main)
119+compileByteString ifaces source =
120+ case Parse.fromByteString Pkg.dummyName source of
121+ Left err ->
122+ Left (Error.BadSyntax err)
123+
124+ Right modul ->
125+ case Compile.compile Pkg.dummyName ifaces modul of
126+ Left err ->
127+ Left err
128+
129+ Right artifacts@(Compile.Artifacts modul _ locals@(Opt.LocalGraph maybeMain _ _)) ->
130+ case maybeMain of
131+ Just main -> Right (Can._name modul, locals, main)
132+ Nothing -> Left (error "TODO no main")
133+
134+
135+errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
136+errorToHtmlBuilder source err =
137+ let
138+ json = Encode.encodeUgly (Error.errorToJson (Code.toSource source) err)
139+ in
140+ [r|<!DOCTYPE HTML>
141+<html>
142+<head>
143+ <meta charset="UTF-8">
144+ <style>body { padding: 0; margin: 0; }</style>
145+ <script src="https://worker.elm-lang.org/compile/error.js"></script>
146+ <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
147+</head>
148+<body></body>
149+</html>|]
150+
151+
152+
153+-- ARTIFACTS
154+
155+
156+data Artifacts =
157+ Artifacts
158+ { _ifaces :: Map.Map ModuleName.Raw I.Interface
159+ , _graph :: Opt.GlobalGraph
160+ }
161+
162+
163+loadArtifacts :: IO Artifacts
164+loadArtifacts =
165+ do style <- Reporting.terminal
166+ root <- Dir.getCurrentDirectory
167+ result <- Details.load style root
168+ case result of
169+ Left _ ->
170+ error "Ran into some problem loading elm.json details"
171+
172+ Right details ->
173+ do omvar <- Details.loadObjects root details
174+ imvar <- Details.loadInterfaces root details
175+ mdeps <- readMVar imvar
176+ mobjs <- readMVar omvar
177+ case liftM2 (,) mdeps mobjs of
178+ Nothing ->
179+ error "Ran into some weird problem loading elm.json details"
180+
181+ Just (deps, objs) ->
182+ return $ Artifacts (toInterfaces deps) objs
183+
184+
185+toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
186+toInterfaces deps =
187+ Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
188+ Map.elems (Map.mapMaybeWithKey getPublic deps)
189+
190+
191+getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
192+getPublic (ModuleName.Canonical _ name) dep =
193+ case dep of
194+ I.Public iface -> Just (name, OneOrMore.one iface)
195+ I.Private _ _ _ -> Nothing
196+
197+
198+toUnique :: OneOrMore.OneOrMore a -> Maybe a
199+toUnique oneOrMore =
200+ case oneOrMore of
201+ OneOrMore.One value -> Just value
202+ OneOrMore.More _ _ -> Nothing
203+
204+
205+
206+-- CORS
207+
208+
209+corsOptions :: (Monad m) => CORSOptions m
210+corsOptions =
211+ CORSOptions
212+ { corsAllowOrigin = return allowedOrigins
213+ , corsAllowCredentials = return True
214+ , corsExposeHeaders = return HashSet.empty
215+ , corsAllowedMethods = return allowedMethods
216+ , corsAllowedHeaders = return
217+ }
218+
219+
220+{-# NOINLINE allowedMethods #-}
221+allowedMethods :: HashSet.HashSet HashableMethod
222+allowedMethods =
223+ HashSet.singleton (HashableMethod POST)
224+
225+
226+{-# NOINLINE allowedOrigins #-}
227+allowedOrigins :: OriginList
228+allowedOrigins =
229+ let
230+ origins =
231+ [ "https://elm-lang.org"
232+ , "https://package.elm-lang.org"
233+ ]
234+ in
235+ Origins $ mkOriginSet $
236+ case traverse parseURI origins of
237+ Just uris -> uris
238+ Nothing -> error "Invalid entry in allowedOrigins list"