git.iko.soy/elk
on 4e88d39 help sign in
elk/server/Server.hs
127 lines 4.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
3module Main where
5import Control.Applicative ((<$>),(<|>))
6import Control.Monad (guard)
7import Control.Monad.Trans (MonadIO(liftIO))
8import qualified Data.ByteString as BS
9import qualified Data.ByteString.Char8 as BSC
10import qualified Data.HashMap.Strict as Map
11import qualified Data.Version as Version
12import System.Console.CmdArgs
13import System.Directory
14import System.Exit
15import System.FilePath
16import System.Process
17import System.IO (hGetContents, Handle)
19import Paths_elm_server (version)
20import qualified Elm.Internal.Paths as Elm
21import Snap.Core
22import Snap.Http.Server
23import Snap.Util.FileServe
25data Flags = Flags
26 { port :: Int
27 , runtime :: Maybe FilePath
28 } deriving (Data,Typeable,Show,Eq)
30flags :: Flags
31flags = 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")
45config :: Config Snap a
46config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
48-- | Set up the server.
49main :: IO ()
50main = 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 "."
59directoryConfig :: MonadSnap m => DirectoryConfig m
60directoryConfig =
61 fancyDirectoryConfig
62 { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
63 , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
64 }
66indexStyle :: BS.ByteString
67indexStyle =
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; }"
80runtimeName :: String
81runtimeName = "elm-runtime.js"
83serveRuntime :: FilePath -> Snap ()
84serveRuntime runtimePath =
85 do file <- BSC.unpack . rqPathInfo <$> getRequest
86 guard (file == runtimeName)
87 serveFileAs "application/javascript" runtimePath
89serveElm :: Snap ()
90serveElm =
91 do file <- BSC.unpack . rqPathInfo <$> getRequest
92 exists <- liftIO $ doesFileExist file
93 guard (exists && takeExtension file == ".elm")
94 onSuccess (compile file) (serve file)
95 where
96 compile file =
97 let elmArgs = [ "--make", "--runtime=" ++ runtimeName, file ]
98 in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
100 serve file =
101 serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
103failure :: String -> Snap ()
104failure msg =
105 do modifyResponse $ setResponseStatus 404 "Not found"
106 writeBS $ BSC.pack msg
108onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
109onSuccess 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."
116 (ExitFailure _, Just out) ->
117 failure =<< liftIO (hGetContents out)
119 (ExitFailure _, Nothing) ->
120 failure "See command line for error message."
122 (ExitSuccess, _) -> success
124{--
125pageTitle :: String -> String
126pageTitle = dropExtension . takeBaseName
127--}