@@ -1,114 +1,127 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
13module Main where
24
3−import Control.Monad (msum,guard,when)
5+import Control.Applicative ((<$>),(<|>))
6+import Control.Monad (guard)
47import Control.Monad.Trans (MonadIO(liftIO))
5−import Data.List (isPrefixOf, isSuffixOf, (\\))
6−import Data.Version (showVersion)
7−import Happstack.Server
8−import Happstack.Server.Compression
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
913import System.Directory
10−import System.Environment
1114import System.Exit
1215import System.FilePath
1316import System.Process
14−import GHC.IO.Handle
15−import qualified Elm.Internal.Paths as ElmPaths
16−import Paths_elm_server
17−
18−runtime = "/elm-runtime.js"
19−
20−serve :: Int -> String -> IO ()
21−serve portNumber libLoc = do
22− putStrLn $ "Elm Server " ++ showVersion version ++
23− ": running at <http://localhost:" ++ show portNumber ++ ">"
24− putStrLn "Just refresh a page to recompile it!"
25− simpleHTTP httpConf $ do
26− _ <- compressedResponseFilter
27− msum [ uriRest serveElm
28− , uriRest (serveLib libLoc)
29− , serveDirectory EnableBrowsing [] "."
30− ]
31− where httpConf = nullConf { port = portNumber }
32−
33−pageTitle :: String -> String
34−pageTitle = dropExtension . takeBaseName
35−
36−serveElm :: FilePath -> ServerPartT IO Response
37−serveElm fp =
38− do fileExists <- liftIO $ doesFileExist file
39− guard (fileExists && takeExtension fp == ".elm")
40− onSuccess compile serve
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)
4195 where
42− file = tail fp
96+ compile file =
97+ let elmArgs = [ "--make", "--runtime=" ++ runtimeName, file ]
98+ in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
4399
44− compile = liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe }
45− where args = [ "--make", "--runtime=" ++ runtime, file ]
100+ serve file =
101+ serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
46102
47− serve = serveFile (asContentType "text/html")
48− ("build" </> replaceExtension file "html")
103+failure :: String -> Snap ()
104+failure msg =
105+ do modifyResponse $ setResponseStatus 404 "Not found"
106+ writeBS $ BSC.pack msg
49107
50−onSuccess action success = do
51− (_, stdout, _, handle) <- action
52− exitCode <- liftIO $ waitForProcess handle
53− case (exitCode, stdout) of
54− (ExitFailure 127, _) ->
55− badRequest $ toResponse "Error: elm binary 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
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."
62115
116+ (ExitFailure _, Just out) ->
117+ failure =<< liftIO (hGetContents out)
63118
64−serveLib :: FilePath -> String -> ServerPartT IO Response
65−serveLib libLoc fp = do
66− guard (fp == runtime)
67− serveFile (asContentType "application/javascript") libLoc
119+ (ExitFailure _, Nothing) ->
120+ failure "See command line for error message."
68121
69−main :: IO ()
70−main = getArgs >>= parse
71−
72−parse :: [String] -> IO ()
73−parse ("--help":_) = putStrLn usage
74−parse ("--version":_) = putStrLn ("The Elm Server " ++ showVersion version)
75−parse args =
76− if null remainingArgs then
77− serve portNumber elmRuntime
78− else
79− putStrLn usageMini
122+ (ExitSuccess, _) -> success
80123
81− where
82− runtimeArg = filter (isPrefixOf "--runtime-location=") args
83− portArg = filter (isPrefixOf "--port=") args
84− remainingArgs = (args \\ runtimeArg) \\ portArg
85−
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
89− ElmPaths.runtime
90− else
91− argValue runtimeArg
92−
93−usageMini :: String
94−usageMini =
95− "Usage: elm-server [OPTIONS]\n\
96− \Try `elm-server --help' for more information."
97−
98−usage :: String
99−usage =
100− "Usage: elm-server [OPTIONS]\n\
101− \Compiles and serves .elm files from the current directory.\n\
102− \Example: elm-server\n\
103− \\n\
104− \Server configuration:\n\
105− \ --port set the port to listen on (default: 8000)\n\
106− \\n\
107− \Resource Locations:\n\
108− \ --runtime-location set the location of the Elm runtime\n\
109− \\n\
110− \Compiler Information:\n\
111− \ --version print the version information and exit\n\
112− \ --help display this help and exit\n\
113− \\n\
114− \Elm home page: <http://elm-lang.org>"
124+{--
125+pageTitle :: String -> String
126+pageTitle = dropExtension . takeBaseName
127+--}