diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2012-2013, Evan Czaplicki +Copyright (c)2012-2014, Evan Czaplicki All rights reserved. diff --git a/Server.hs b/Server.hs --- a/Server.hs +++ b/Server.hs @@ -1,114 +1,127 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Main where -import Control.Monad (msum,guard,when) +import Control.Applicative ((<$>),(<|>)) +import Control.Monad (guard) import Control.Monad.Trans (MonadIO(liftIO)) -import Data.List (isPrefixOf, isSuffixOf, (\\)) -import Data.Version (showVersion) -import Happstack.Server -import Happstack.Server.Compression +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.HashMap.Strict as Map +import qualified Data.Version as Version +import System.Console.CmdArgs import System.Directory -import System.Environment import System.Exit import System.FilePath import System.Process -import GHC.IO.Handle -import qualified Elm.Internal.Paths as ElmPaths -import Paths_elm_server +import System.IO (hGetContents, Handle) -runtime = "/elm-runtime.js" +import Paths_elm_server (version) +import qualified Elm.Internal.Paths as Elm +import Snap.Core +import Snap.Http.Server +import Snap.Util.FileServe -serve :: Int -> String -> IO () -serve portNumber libLoc = do - putStrLn $ "Elm Server " ++ showVersion version ++ - ": running at " - putStrLn "Just refresh a page to recompile it!" - simpleHTTP httpConf $ do - _ <- compressedResponseFilter - msum [ uriRest serveElm - , uriRest (serveLib libLoc) - , serveDirectory EnableBrowsing [] "." - ] - where httpConf = nullConf { port = portNumber } +data Flags = Flags + { port :: Int + , runtime :: Maybe FilePath + } deriving (Data,Typeable,Show,Eq) -pageTitle :: String -> String -pageTitle = dropExtension . takeBaseName +flags :: Flags +flags = Flags + { port = 8000 &= help "set the port of the server" + , runtime = Nothing &= typFile + &= help "Specify a custom location for Elm's runtime system." + } &= help "Quickly reload Elm projects in your browser. Just refresh to recompile.\n\ + \It serves static files and freshly recompiled Elm files." + &= helpArg [explicit, name "help", name "h"] + &= versionArg [ explicit, name "version", name "v" + , summary (Version.showVersion version) + ] + &= summary ("Elm Server " ++ Version.showVersion version ++ + ", (c) Evan Czaplicki 2011-2014") -serveElm :: FilePath -> ServerPartT IO Response -serveElm fp = - do fileExists <- liftIO $ doesFileExist file - guard (fileExists && takeExtension fp == ".elm") - onSuccess compile serve - where - file = tail fp - compile = liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe } - where args = [ "--make", "--runtime=" ++ runtime, file ] - - serve = serveFile (asContentType "text/html") - ("build" replaceExtension file "html") +config :: Config Snap a +config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig) -onSuccess action success = do - (_, stdout, _, handle) <- action - exitCode <- liftIO $ waitForProcess handle - case (exitCode, stdout) of - (ExitFailure 127, _) -> - badRequest $ toResponse "Error: elm binary not found in your path." - (ExitFailure _, Just out) -> - do str <- liftIO $ hGetContents out - badRequest $ toResponse str - (ExitFailure _, Nothing) -> - badRequest $ toResponse "See command line for error message." - (ExitSuccess, _) -> success +-- | Set up the server. +main :: IO () +main = do + cargs <- cmdArgs flags + putStrLn $ "Elm Server " ++ Version.showVersion version ++ + ": Just refresh a page to recompile it!" + httpServe (setPort (port cargs) config) $ + serveRuntime (maybe Elm.runtime id (runtime cargs)) + <|> serveElm + <|> serveDirectoryWith directoryConfig "." +directoryConfig :: MonadSnap m => DirectoryConfig m +directoryConfig = + fancyDirectoryConfig + { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle + , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes + } -serveLib :: FilePath -> String -> ServerPartT IO Response -serveLib libLoc fp = do - guard (fp == runtime) - serveFile (asContentType "application/javascript") libLoc +indexStyle :: BS.ByteString +indexStyle = + "body { margin:0; font-family:sans-serif; background:rgb(245,245,245);\ + \ font-family: calibri, verdana, helvetica, arial; }\ + \div.header { padding: 40px 50px; font-size: 24px; }\ + \div.content { padding: 0 40px }\ + \div.footer { display:none; }\ + \table { width:100%; border-collapse:collapse; }\ + \td { padding: 6px 10px; }\ + \tr:nth-child(odd) { background:rgb(216,221,225); }\ + \td { font-family:monospace }\ + \th { background:rgb(90,99,120); color:white; text-align:left;\ + \ padding:10px; font-weight:normal; }" -main :: IO () -main = getArgs >>= parse +runtimeName :: String +runtimeName = "elm-runtime.js" -parse :: [String] -> IO () -parse ("--help":_) = putStrLn usage -parse ("--version":_) = putStrLn ("The Elm Server " ++ showVersion version) -parse args = - if null remainingArgs then - serve portNumber elmRuntime - else - putStrLn usageMini +serveRuntime :: FilePath -> Snap () +serveRuntime runtimePath = + do file <- BSC.unpack . rqPathInfo <$> getRequest + guard (file == runtimeName) + serveFileAs "application/javascript" runtimePath +serveElm :: Snap () +serveElm = + do file <- BSC.unpack . rqPathInfo <$> getRequest + exists <- liftIO $ doesFileExist file + guard (exists && takeExtension file == ".elm") + onSuccess (compile file) (serve file) where - runtimeArg = filter (isPrefixOf "--runtime-location=") args - portArg = filter (isPrefixOf "--port=") args - remainingArgs = (args \\ runtimeArg) \\ portArg + compile file = + let elmArgs = [ "--make", "--runtime=" ++ runtimeName, file ] + in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe } - argValue arg = tail $ dropWhile (/= '=') (head arg) - portNumber = if null portArg then 8000 else read (argValue portArg) :: Int - elmRuntime = if null runtimeArg then - ElmPaths.runtime - else - argValue runtimeArg + serve file = + serveFileAs "text/html; charset=UTF-8" ("build" replaceExtension file "html") -usageMini :: String -usageMini = - "Usage: elm-server [OPTIONS]\n\ - \Try `elm-server --help' for more information." +failure :: String -> Snap () +failure msg = + do modifyResponse $ setResponseStatus 404 "Not found" + writeBS $ BSC.pack msg -usage :: String -usage = - "Usage: elm-server [OPTIONS]\n\ - \Compiles and serves .elm files from the current directory.\n\ - \Example: elm-server\n\ - \\n\ - \Server configuration:\n\ - \ --port set the port to listen on (default: 8000)\n\ - \\n\ - \Resource Locations:\n\ - \ --runtime-location set the location of the Elm runtime\n\ - \\n\ - \Compiler Information:\n\ - \ --version print the version information and exit\n\ - \ --help display this help and exit\n\ - \\n\ - \Elm home page: " +onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap () +onSuccess action success = + do (_, stdout, _, handle) <- liftIO action + exitCode <- liftIO $ waitForProcess handle + case (exitCode, stdout) of + (ExitFailure 127, _) -> + failure "Error: elm compiler not found in your path." + + (ExitFailure _, Just out) -> + failure =<< liftIO (hGetContents out) + + (ExitFailure _, Nothing) -> + failure "See command line for error message." + + (ExitSuccess, _) -> success + +{-- +pageTitle :: String -> String +pageTitle = dropExtension . takeBaseName +--} diff --git a/elm-server.cabal b/elm-server.cabal --- a/elm-server.cabal +++ b/elm-server.cabal @@ -1,7 +1,9 @@ Name: elm-server -Version: 0.10.1 -Synopsis: The Elm language server. -Description: This package provides a standalone, Happstack-based Elm server. +Version: 0.11 +Synopsis: Server for developing Elm projects +Description: Provides a standalone Snap server that serves static files. + For Elm files, it recompiles them and serves them as HTML, + so you can just refresh to see the new version. Homepage: http://elm-lang.org @@ -10,7 +12,7 @@ Author: Evan Czaplicki Maintainer: info@elm-lang.org -Copyright: Copyright: (c) 2011-2013 Evan Czaplicki +Copyright: Copyright: (c) 2011-2014 Evan Czaplicki Category: Compiler, Language @@ -26,15 +28,14 @@ Executable elm-server Main-is: Server.hs Build-depends: base >=4.2 && <5, + bytestring, + cmdargs, containers >= 0.3, directory, - transformers >= 0.2, - mtl >= 2, - parsec >= 3.1.1, - blaze-html >= 0.5.1, - HTTP >= 4000, - happstack-server, - deepseq, filepath, - Elm >= 0.10.1, - process + Elm >= 0.11, + snap-core, + snap-server, + mtl, + process, + unordered-containers