@@ -1,114 +1,124 @@
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+ } deriving (Data,Typeable,Show,Eq)
28+
29+flags :: Flags
30+flags = Flags
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)
37+ ]
38+ &= summary ("Elm Server " ++ Version.showVersion version ++
39+ ", (c) Evan Czaplicki 2011-2014")
40+
41+
42+config :: Config Snap a
43+config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
44+
45+-- | Set up the server.
46+main :: IO ()
47+main = do
48+ cargs <- cmdArgs flags
49+ putStrLn $ "Elm Server " ++ Version.showVersion version ++
50+ ": Just refresh a page to recompile it!"
51+ httpServe (setPort (port cargs) config) $
52+ serveRuntime
53+ <|> serveElm
54+ <|> serveDirectoryWith directoryConfig "."
55+
56+directoryConfig :: MonadSnap m => DirectoryConfig m
57+directoryConfig =
58+ fancyDirectoryConfig
59+ { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
60+ , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
61+ }
62+
63+indexStyle :: BS.ByteString
64+indexStyle =
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; }"
76+
77+runtime :: String
78+runtime = "elm-runtime.js"
79+
80+serveRuntime :: Snap ()
81+serveRuntime =
82+ do file <- BSC.unpack . rqPathInfo <$> getRequest
83+ guard (file == runtime)
84+ serveFileAs "application/javascript" Elm.runtime
85+
86+serveElm :: Snap ()
87+serveElm =
88+ do file <- BSC.unpack . rqPathInfo <$> getRequest
89+ exists <- liftIO $ doesFileExist file
90+ guard (exists && takeExtension file == ".elm")
91+ onSuccess (compile file) (serve file)
4192 where
42− file = tail fp
93+ compile file =
94+ let elmArgs = [ "--make", "--runtime=" ++ runtime, file ]
95+ in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
4396
44− compile = liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe }
45− where args = [ "--make", "--runtime=" ++ runtime, file ]
97+ serve file =
98+ serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
4699
47− serve = serveFile (asContentType "text/html")
48− ("build" </> replaceExtension file "html")
100+failure :: String -> Snap ()
101+failure msg =
102+ do modifyResponse $ setResponseStatus 404 "Not found"
103+ writeBS $ BSC.pack msg
49104
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
105+onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
106+onSuccess action success =
107+ do (_, stdout, _, handle) <- liftIO action
108+ exitCode <- liftIO $ waitForProcess handle
109+ case (exitCode, stdout) of
110+ (ExitFailure 127, _) ->
111+ failure "Error: elm compiler not found in your path."
62112
113+ (ExitFailure _, Just out) ->
114+ failure =<< liftIO (hGetContents out)
63115
64−serveLib :: FilePath -> String -> ServerPartT IO Response
65−serveLib libLoc fp = do
66− guard (fp == runtime)
67− serveFile (asContentType "application/javascript") libLoc
116+ (ExitFailure _, Nothing) ->
117+ failure "See command line for error message."
68118
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
119+ (ExitSuccess, _) -> success
80120
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>"
121+{--
122+pageTitle :: String -> String
123+pageTitle = dropExtension . takeBaseName
124+--}