@@ -1,114 +1,127 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
1module Main where
3module Main where
3−import Control.Monad (msum,guard,when)
5+import Control.Applicative ((<$>),(<|>))
6+import Control.Monad (guard)
4import Control.Monad.Trans (MonadIO(liftIO))
7import Control.Monad.Trans (MonadIO(liftIO))
5−import Data.List (isPrefixOf, isSuffixOf, (\\))
8+import qualified Data.ByteString as BS
6−import Data.Version (showVersion)
9+import qualified Data.ByteString.Char8 as BSC
7−import Happstack.Server
10+import qualified Data.HashMap.Strict as Map
8−import Happstack.Server.Compression
11+import qualified Data.Version as Version
12+import System.Console.CmdArgs
9import System.Directory
13import System.Directory
10−import System.Environment
11import System.Exit
14import System.Exit
12import System.FilePath
15import System.FilePath
13import System.Process
16import System.Process
14−import GHC.IO.Handle
17+import System.IO (hGetContents, Handle)
19+import Paths_elm_server (version)
15−import qualified Elm.Internal.Paths as ElmPaths
20+import qualified Elm.Internal.Paths as Elm
16−import Paths_elm_server
21+import Snap.Core
17−
22+import Snap.Http.Server
18−runtime = "/elm-runtime.js"
23+import Snap.Util.FileServe
20−serve :: Int -> String -> IO ()
25+data Flags = Flags
21−serve portNumber libLoc = do
26+ { port :: Int
27+ , runtime :: Maybe FilePath
28+ } deriving (Data,Typeable,Show,Eq)
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)
41+ &= summary ("Elm Server " ++ Version.showVersion version ++
42+ ", (c) Evan Czaplicki 2011-2014")
45+config :: Config Snap a
46+config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
48+-- | Set up the server.
51+ cargs <- cmdArgs flags
22− putStrLn $ "Elm Server " ++ showVersion version ++
52+ putStrLn $ "Elm Server " ++ Version.showVersion version ++
23− ": running at <http://localhost:" ++ show portNumber ++ ">"
24− putStrLn "Just refresh a page to recompile it!"
53+ ": Just refresh a page to recompile it!"
25− simpleHTTP httpConf $ do
54+ httpServe (setPort (port cargs) config) $
26− _ <- compressedResponseFilter
55+ serveRuntime (maybe Elm.runtime id (runtime cargs))
27− msum [ uriRest serveElm
56+ <|> serveElm
28− , uriRest (serveLib libLoc)
57+ <|> serveDirectoryWith directoryConfig "."
29− , serveDirectory EnableBrowsing [] "."
58+
30− ]
59+directoryConfig :: MonadSnap m => DirectoryConfig m
31− where httpConf = nullConf { port = portNumber }
60+directoryConfig =
32−
61+ fancyDirectoryConfig
33−pageTitle :: String -> String
62+ { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
34−pageTitle = dropExtension . takeBaseName
63+ , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
36−serveElm :: FilePath -> ServerPartT IO Response
65+
66+indexStyle :: BS.ByteString
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; }"
81+runtimeName = "elm-runtime.js"
83+serveRuntime :: FilePath -> Snap ()
84+serveRuntime runtimePath =
85+ do file <- BSC.unpack . rqPathInfo <$> getRequest
86+ guard (file == runtimeName)
87+ serveFileAs "application/javascript" runtimePath
37−serveElm fp =
89+serveElm :: Snap ()
91+ do file <- BSC.unpack . rqPathInfo <$> getRequest
38− do fileExists <- liftIO $ doesFileExist file
92+ exists <- liftIO $ doesFileExist file
39− guard (fileExists && takeExtension fp == ".elm")
93+ guard (exists && takeExtension file == ".elm")
40− onSuccess compile serve
94+ onSuccess (compile file) (serve file)
42− file = tail fp
96+ compile file =
97+ let elmArgs = [ "--make", "--runtime=" ++ runtimeName, file ]
98+ in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
44− compile = liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe }
100+ serve file =
45− where args = [ "--make", "--runtime=" ++ runtime, file ]
101+ serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
47− serve = serveFile (asContentType "text/html")
103+failure :: String -> Snap ()
48− ("build" </> replaceExtension file "html")
104+failure msg =
105+ do modifyResponse $ setResponseStatus 404 "Not found"
106+ writeBS $ BSC.pack msg
108+onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
50−onSuccess action success = do
109+onSuccess action success =
51− (_, stdout, _, handle) <- action
110+ do (_, stdout, _, handle) <- liftIO action
52− exitCode <- liftIO $ waitForProcess handle
111+ exitCode <- liftIO $ waitForProcess handle
53− case (exitCode, stdout) of
112+ case (exitCode, stdout) of
54− (ExitFailure 127, _) ->
113+ (ExitFailure 127, _) ->
55− badRequest $ toResponse "Error: elm binary not found in your path."
114+ failure "Error: elm compiler not found in your path."
56− (ExitFailure _, Just out) ->
57− do str <- liftIO $ hGetContents out
58− badRequest $ toResponse str
59− (ExitFailure _, Nothing) ->
60− badRequest $ toResponse "See command line for error message."
61− (ExitSuccess, _) -> success
116+ (ExitFailure _, Just out) ->
117+ failure =<< liftIO (hGetContents out)
64−serveLib :: FilePath -> String -> ServerPartT IO Response
119+ (ExitFailure _, Nothing) ->
65−serveLib libLoc fp = do
120+ failure "See command line for error message."
66− guard (fp == runtime)
67− serveFile (asContentType "application/javascript") libLoc
69−main :: IO ()
122+ (ExitSuccess, _) -> success
70−main = getArgs >>= parse
72−parse :: [String] -> IO ()
73−parse ("--help":_) = putStrLn usage
74−parse ("--version":_) = putStrLn ("The Elm Server " ++ showVersion version)
76− if null remainingArgs then
77− serve portNumber elmRuntime
82− runtimeArg = filter (isPrefixOf "--runtime-location=") args
125+pageTitle :: String -> String
83− portArg = filter (isPrefixOf "--port=") args
126+pageTitle = dropExtension . takeBaseName
84− remainingArgs = (args \\ runtimeArg) \\ portArg
127+--}
86− argValue arg = tail $ dropWhile (/= '=') (head arg)
87− portNumber = if null portArg then 8000 else read (argValue portArg) :: Int
88− elmRuntime = if null runtimeArg then
95− "Usage: elm-server [OPTIONS]\n\
96− \Try `elm-server --help' for more information."
100− "Usage: elm-server [OPTIONS]\n\
101− \Compiles and serves .elm files from the current directory.\n\
102− \Example: elm-server\n\
104− \Server configuration:\n\
105− \ --port set the port to listen on (default: 8000)\n\
107− \Resource Locations:\n\
108− \ --runtime-location set the location of the Elm runtime\n\
110− \Compiler Information:\n\
111− \ --version print the version information and exit\n\
112− \ --help display this help and exit\n\
114− \Elm home page: <http://elm-lang.org>"