@@ -1,114 +1,124 @@
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+ } deriving (Data,Typeable,Show,Eq)
31+ { port = 8000 &= help "set the port of the server"
32+ } &= help "Quickly reload Elm projects in your browser. Just refresh to recompile.\n\
33+ \It serves static files and freshly recompiled Elm files."
34+ &= helpArg [explicit, name "help", name "h"]
35+ &= versionArg [ explicit, name "version", name "v"
36+ , summary (Version.showVersion version)
38+ &= summary ("Elm Server " ++ Version.showVersion version ++
39+ ", (c) Evan Czaplicki 2011-2014")
42+config :: Config Snap a
43+config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
45+-- | Set up the server.
48+ cargs <- cmdArgs flags
22− putStrLn $ "Elm Server " ++ showVersion version ++
49+ putStrLn $ "Elm Server " ++ Version.showVersion version ++
23− ": running at <http://localhost:" ++ show portNumber ++ ">"
24− putStrLn "Just refresh a page to recompile it!"
50+ ": Just refresh a page to recompile it!"
25− simpleHTTP httpConf $ do
51+ httpServe (setPort (port cargs) config) $
26− _ <- compressedResponseFilter
52+ serveRuntime
27− msum [ uriRest serveElm
53+ <|> serveElm
28− , uriRest (serveLib libLoc)
54+ <|> serveDirectoryWith directoryConfig "."
29− , serveDirectory EnableBrowsing [] "."
55+
30− ]
56+directoryConfig :: MonadSnap m => DirectoryConfig m
31− where httpConf = nullConf { port = portNumber }
57+directoryConfig =
32−
58+ fancyDirectoryConfig
33−pageTitle :: String -> String
59+ { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
34−pageTitle = dropExtension . takeBaseName
60+ , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
36−serveElm :: FilePath -> ServerPartT IO Response
62+
63+indexStyle :: BS.ByteString
65+ "body { margin:0; font-family:sans-serif; background:rgb(245,245,245);\
66+ \ font-family: calibri, verdana, helvetica, arial; }\
67+ \div.header { padding: 40px 50px; font-size: 24px; }\
68+ \div.content { padding: 0 40px }\
69+ \div.footer { display:none; }\
70+ \table { width:100%; border-collapse:collapse; }\
71+ \td { padding: 6px 10px; }\
72+ \tr:nth-child(odd) { background:rgb(216,221,225); }\
73+ \td { font-family:monospace }\
74+ \th { background:rgb(90,99,120); color:white; text-align:left;\
75+ \ padding:10px; font-weight:normal; }"
78+runtime = "elm-runtime.js"
80+serveRuntime :: Snap ()
82+ do file <- BSC.unpack . rqPathInfo <$> getRequest
83+ guard (file == runtime)
84+ serveFileAs "application/javascript" Elm.runtime
37−serveElm fp =
87+serveElm =
88+ do file <- BSC.unpack . rqPathInfo <$> getRequest
38− do fileExists <- liftIO $ doesFileExist file
89+ exists <- liftIO $ doesFileExist file
39− guard (fileExists && takeExtension fp == ".elm")
90+ guard (exists && takeExtension file == ".elm")
40− onSuccess compile serve
91+ onSuccess (compile file) (serve file)
42− file = tail fp
93+ compile file =
94+ let elmArgs = [ "--make", "--runtime=" ++ runtime, file ]
95+ in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
44− compile = liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe }
97+ serve file =
45− where args = [ "--make", "--runtime=" ++ runtime, file ]
98+ serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
47− serve = serveFile (asContentType "text/html")
100+failure :: String -> Snap ()
48− ("build" </> replaceExtension file "html")
101+failure msg =
102+ do modifyResponse $ setResponseStatus 404 "Not found"
103+ writeBS $ BSC.pack msg
105+onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
50−onSuccess action success = do
106+onSuccess action success =
51− (_, stdout, _, handle) <- action
107+ do (_, stdout, _, handle) <- liftIO action
52− exitCode <- liftIO $ waitForProcess handle
108+ exitCode <- liftIO $ waitForProcess handle
53− case (exitCode, stdout) of
109+ case (exitCode, stdout) of
54− (ExitFailure 127, _) ->
110+ (ExitFailure 127, _) ->
55− badRequest $ toResponse "Error: elm binary not found in your path."
111+ 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
113+ (ExitFailure _, Just out) ->
114+ failure =<< liftIO (hGetContents out)
64−serveLib :: FilePath -> String -> ServerPartT IO Response
116+ (ExitFailure _, Nothing) ->
65−serveLib libLoc fp = do
117+ failure "See command line for error message."
66− guard (fp == runtime)
67− serveFile (asContentType "application/javascript") libLoc
69−main :: IO ()
119+ (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
122+pageTitle :: String -> String
83− portArg = filter (isPrefixOf "--port=") args
123+pageTitle = dropExtension . takeBaseName
84− remainingArgs = (args \\ runtimeArg) \\ portArg
124+--}
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>"