Upgrade to use Snap instead of Happstack
This commit is contained in:
Evan Czaplicki
parent
92af8a4f0d
commit
85d493ce59
2 changed files with 120 additions and 111 deletions
214
server/Server.hs
214
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 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 <http://localhost:" ++ show portNumber ++ ">"
|
||||
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
|
||||
} deriving (Data,Typeable,Show,Eq)
|
||||
|
||||
flags :: Flags
|
||||
flags = Flags
|
||||
{ port = 8000 &= help "set the port of the server"
|
||||
} &= 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")
|
||||
|
||||
|
||||
config :: Config Snap a
|
||||
config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
|
||||
|
||||
-- | 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
|
||||
<|> 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
|
||||
compile file =
|
||||
let elmArgs = [ "--make", "--runtime=" ++ runtime, file ]
|
||||
in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
|
||||
|
||||
serve file =
|
||||
serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
|
||||
|
||||
failure :: String -> Snap ()
|
||||
failure msg =
|
||||
do modifyResponse $ setResponseStatus 404 "Not found"
|
||||
writeBS $ BSC.pack msg
|
||||
|
||||
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
|
||||
|
||||
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")
|
||||
|
||||
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
|
||||
|
||||
|
||||
serveLib :: FilePath -> String -> ServerPartT IO Response
|
||||
serveLib libLoc fp = do
|
||||
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>"
|
||||
--}
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
process
|
||||
Elm >= 0.11,
|
||||
snap-core,
|
||||
snap-server,
|
||||
mtl,
|
||||
process,
|
||||
unordered-containers
|
||||
|
|
|
|||
Loading…
Reference in a new issue