@@ -1,127 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
3−module Main where
4−
5−import Control.Applicative ((<$>),(<|>))
6−import Control.Monad (guard)
7−import Control.Monad.Trans (MonadIO(liftIO))
8−import qualified Data.ByteString as BS
9−import qualified Data.ByteString.Char8 as BSC
10−import qualified Data.HashMap.Strict as Map
11−import qualified Data.Version as Version
12−import System.Console.CmdArgs
13−import System.Directory
14−import System.Exit
15−import System.FilePath
16−import System.Process
17−import System.IO (hGetContents, Handle)
18−
19−import Paths_elm_server (version)
20−import qualified Elm.Internal.Paths as Elm
21−import Snap.Core
22−import Snap.Http.Server
23−import Snap.Util.FileServe
24−
25−data Flags = Flags
26− { port :: Int
27− , runtime :: Maybe FilePath
28− } deriving (Data,Typeable,Show,Eq)
29−
30−flags :: Flags
31−flags = Flags
32− { port = 8000 &= help "set the port of the server"
33− , runtime = Nothing &= typFile
34− &= help "Specify a custom location for Elm's runtime system."
35− } &= help "Quickly reload Elm projects in your browser. Just refresh to recompile.\n\
36− \It serves static files and freshly recompiled Elm files."
37− &= helpArg [explicit, name "help", name "h"]
38− &= versionArg [ explicit, name "version", name "v"
39− , summary (Version.showVersion version)
40− ]
41− &= summary ("Elm Server " ++ Version.showVersion version ++
42− ", (c) Evan Czaplicki 2011-2014")
43−
44−
45−config :: Config Snap a
46−config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
47−
48−-- | Set up the server.
49−main :: IO ()
50−main = do
51− cargs <- cmdArgs flags
52− putStrLn $ "Elm Server " ++ Version.showVersion version ++
53− ": Just refresh a page to recompile it!"
54− httpServe (setPort (port cargs) config) $
55− serveRuntime (maybe Elm.runtime id (runtime cargs))
56− <|> serveElm
57− <|> serveDirectoryWith directoryConfig "."
58−
59−directoryConfig :: MonadSnap m => DirectoryConfig m
60−directoryConfig =
61− fancyDirectoryConfig
62− { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
63− , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
64− }
65−
66−indexStyle :: BS.ByteString
67−indexStyle =
68− "body { margin:0; font-family:sans-serif; background:rgb(245,245,245);\
69− \ font-family: calibri, verdana, helvetica, arial; }\
70− \div.header { padding: 40px 50px; font-size: 24px; }\
71− \div.content { padding: 0 40px }\
72− \div.footer { display:none; }\
73− \table { width:100%; border-collapse:collapse; }\
74− \td { padding: 6px 10px; }\
75− \tr:nth-child(odd) { background:rgb(216,221,225); }\
76− \td { font-family:monospace }\
77− \th { background:rgb(90,99,120); color:white; text-align:left;\
78− \ padding:10px; font-weight:normal; }"
79−
80−runtimeName :: String
81−runtimeName = "elm-runtime.js"
82−
83−serveRuntime :: FilePath -> Snap ()
84−serveRuntime runtimePath =
85− do file <- BSC.unpack . rqPathInfo <$> getRequest
86− guard (file == runtimeName)
87− serveFileAs "application/javascript" runtimePath
88−
89−serveElm :: Snap ()
90−serveElm =
91− do file <- BSC.unpack . rqPathInfo <$> getRequest
92− exists <- liftIO $ doesFileExist file
93− guard (exists && takeExtension file == ".elm")
94− onSuccess (compile file) (serve file)
95− where
96− compile file =
97− let elmArgs = [ "--make", "--runtime=" ++ runtimeName, file ]
98− in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
99−
100− serve file =
101− serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
102−
103−failure :: String -> Snap ()
104−failure msg =
105− do modifyResponse $ setResponseStatus 404 "Not found"
106− writeBS $ BSC.pack msg
107−
108−onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
109−onSuccess action success =
110− do (_, stdout, _, handle) <- liftIO action
111− exitCode <- liftIO $ waitForProcess handle
112− case (exitCode, stdout) of
113− (ExitFailure 127, _) ->
114− failure "Error: elm compiler not found in your path."
115−
116− (ExitFailure _, Just out) ->
117− failure =<< liftIO (hGetContents out)
118−
119− (ExitFailure _, Nothing) ->
120− failure "See command line for error message."
121−
122− (ExitSuccess, _) -> success
123−
124−{--
125−pageTitle :: String -> String
126−pageTitle = dropExtension . takeBaseName
127−--}