git.iko.soy/elk
on 35e07ef help sign in
elk/server/Server.hs
124 lines 4.0 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 } deriving (Data,Typeable,Show,Eq)
29flags :: Flags
30flags = 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")
42config :: Config Snap a
43config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
45-- | Set up the server.
46main :: IO ()
47main = 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 "."
56directoryConfig :: MonadSnap m => DirectoryConfig m
57directoryConfig =
58 fancyDirectoryConfig
59 { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
60 , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
61 }
63indexStyle :: BS.ByteString
64indexStyle =
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; }"
77runtime :: String
78runtime = "elm-runtime.js"
80serveRuntime :: Snap ()
81serveRuntime =
82 do file <- BSC.unpack . rqPathInfo <$> getRequest
83 guard (file == runtime)
84 serveFileAs "application/javascript" Elm.runtime
86serveElm :: Snap ()
87serveElm =
88 do file <- BSC.unpack . rqPathInfo <$> getRequest
89 exists <- liftIO $ doesFileExist file
90 guard (exists && takeExtension file == ".elm")
91 onSuccess (compile file) (serve file)
92 where
93 compile file =
94 let elmArgs = [ "--make", "--runtime=" ++ runtime, file ]
95 in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
97 serve file =
98 serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
100failure :: String -> Snap ()
101failure msg =
102 do modifyResponse $ setResponseStatus 404 "Not found"
103 writeBS $ BSC.pack msg
105onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
106onSuccess 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."
113 (ExitFailure _, Just out) ->
114 failure =<< liftIO (hGetContents out)
116 (ExitFailure _, Nothing) ->
117 failure "See command line for error message."
119 (ExitSuccess, _) -> success
121{--
122pageTitle :: String -> String
123pageTitle = dropExtension . takeBaseName
124--}