Merge branch 'dev'

server/Server.hs

@@ -1,114 +1,124 @@
+{-# 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 qualified Data.ByteString as BS
-import Data.Version (showVersion)
+import qualified Data.ByteString.Char8 as BSC
-import Happstack.Server
+import qualified Data.HashMap.Strict as Map
-import Happstack.Server.Compression
+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 System.IO (hGetContents, Handle)
-import qualified Elm.Internal.Paths as ElmPaths
-import Paths_elm_server
 
-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 ()
+data Flags = Flags
-serve portNumber libLoc = do
+  { port :: Int
-  putStrLn $ "Elm Server " ++ showVersion version ++
+  } deriving (Data,Typeable,Show,Eq)
-             ": running at <http://localhost:" ++ show portNumber ++ ">"
+
-  putStrLn "Just refresh a page to recompile it!"
+flags :: Flags
-  simpleHTTP httpConf $ do
+flags = Flags
-         _ <- compressedResponseFilter
+  { port = 8000 &= help "set the port of the server"
-         msum [ uriRest serveElm
+  } &= help "Quickly reload Elm projects in your browser. Just refresh to recompile.\n\
-              , uriRest (serveLib libLoc)
+            \It serves static files and freshly recompiled Elm files."
-              , serveDirectory EnableBrowsing [] "."
+    &= helpArg [explicit, name "help", name "h"]
+    &= versionArg [ explicit, name "version", name "v"
+                  , summary (Version.showVersion version)
                   ]
-  where httpConf = nullConf { port = portNumber }
+    &= summary ("Elm Server " ++ Version.showVersion version ++
+                ", (c) Evan Czaplicki 2011-2014")
 
-pageTitle :: String -> String
-pageTitle = dropExtension . takeBaseName
 
-serveElm :: FilePath -> ServerPartT IO Response
+config :: Config Snap a
-serveElm fp =
+config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
-  do fileExists <- liftIO $ doesFileExist file
+
-     guard (fileExists && takeExtension fp == ".elm")
+-- | Set up the server.
-     onSuccess compile serve
+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
+      <|> serveElm
+      <|> serveDirectoryWith directoryConfig "."
+
+directoryConfig :: MonadSnap m => DirectoryConfig m
+directoryConfig =
+    fancyDirectoryConfig
+    { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
+    , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
+    }
+
+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; }"
+
+runtime :: String
+runtime = "elm-runtime.js"
+
+serveRuntime :: Snap ()
+serveRuntime =
+  do file <- BSC.unpack . rqPathInfo <$> getRequest
+     guard (file == runtime)
+     serveFileAs "application/javascript" Elm.runtime
+
+serveElm :: Snap ()
+serveElm =
+  do file <- BSC.unpack . rqPathInfo <$> getRequest
+     exists <- liftIO $ doesFileExist file
+     guard (exists && takeExtension file == ".elm")
+     onSuccess (compile file) (serve file)
   where
-    file = tail fp
+    compile file =
+        let elmArgs = [ "--make", "--runtime=" ++ runtime, file ]
+        in  createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
 
-    compile = liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe }
+    serve file =
-        where args = [ "--make", "--runtime=" ++ runtime, file ]
+        serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
 
-    serve = serveFile (asContentType "text/html")
+failure :: String -> Snap ()
-                      ("build" </> replaceExtension file "html")
+failure msg =
+  do modifyResponse $ setResponseStatus 404 "Not found"
+     writeBS $ BSC.pack msg
 
-onSuccess action success = do
+onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
-  (_, stdout, _, handle) <- action
+onSuccess action success =
+  do (_, stdout, _, handle) <- liftIO action
      exitCode <- liftIO $ waitForProcess handle
      case (exitCode, stdout) of
        (ExitFailure 127, _) ->
-        badRequest $ toResponse "Error: elm binary not found in your path."
+           failure "Error: elm compiler not found in your path."
+
        (ExitFailure _, Just out) ->
-        do str <- liftIO $ hGetContents out
+           failure =<< liftIO (hGetContents out)
-           badRequest $ toResponse str
+
        (ExitFailure _, Nothing) ->
-        badRequest $ toResponse "See command line for error message."
+           failure "See command line for error message."
+
        (ExitSuccess, _) -> success
 
-
+{--
-serveLib :: FilePath -> String -> ServerPartT IO Response
+pageTitle :: String -> String
-serveLib libLoc fp = do
+pageTitle = dropExtension . takeBaseName
-  guard (fp == runtime)
+--}
-  serveFile (asContentType "application/javascript") libLoc
-
-main :: IO ()
-main = getArgs >>= parse
-
-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
-
-  where
-    runtimeArg = filter (isPrefixOf "--runtime-location=") args
-    portArg = filter (isPrefixOf "--port=") args
-    remainingArgs = (args \\ runtimeArg) \\ portArg
-
-    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
-
-usageMini :: String
-usageMini =
-  "Usage: elm-server [OPTIONS]\n\
-  \Try `elm-server --help' for more information."
-
-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: <http://elm-lang.org>"

server/elm-server.cabal

@@ -26,15 +26,14 @@ source-repository head
 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,
+                       Elm >= 0.11,
-                       process
+                       snap-core,
+                       snap-server,
+                       mtl,
+                       process,
+                       unordered-containers