or error:
+js :: FilePath -> IO String
+js filePath =
+ do output <- compile filePath
+ return (either (wrap "error") (wrap "success") output)
+ where
+ wrap :: String -> String -> String
+ wrap typ msg = "{ " ++ show typ ++ " : " ++ show msg ++ " }"
+
+addSpaces :: String -> String
+addSpaces str =
+ case str of
+ ' ' : ' ' : rest -> " " ++ addSpaces rest
+ c : rest -> c : addSpaces rest
+ [] -> []
+
+compile :: FilePath -> IO (Either String String)
+compile filePath =
+ do (_, Just hout, Just herr, p) <- createProcess (proc "elm" $ args fileName)
+ { cwd = Just directory
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ exitCode <- waitForProcess p
+ stdout <- exitCode `seq` hGetContents hout
+ stderr <- exitCode `seq` hGetContents herr
+ case exitCode of
+ ExitFailure _ ->
+ do return (Left (stdout ++ stderr))
+ ExitSuccess ->
+ do result <- readFile (directory "build" fileName `replaceExtension` "js")
+ return (Right result)
+ where
+ (directory, fileName) = splitFileName filePath
+ args file =
+ [ "--make"
+ , "--only-js"
+ , file
+ ]
diff --git a/server/Index.hs b/server/Index.hs
new file mode 100644
--- /dev/null
+++ b/server/Index.hs
@@ -0,0 +1,201 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Index (elmIndexGenerator) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import qualified Data.ByteString.Char8 as S
+import Data.List (sort, partition, intercalate)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime)
+import System.FilePath ((), takeExtension, splitDirectories)
+import Snap.Core (MonadSnap, modifyResponse, setContentType, writeBS)
+
+indexStyle :: S.ByteString
+indexStyle =
+ S.intercalate "\n"
+ [ "body {"
+ , " margin: 0;"
+ , " background: rgb(253,253,253);"
+ , " font-family: 'Lucida Grande','Trebuchet MS','Bitstream Vera Sans',Verdana,Helvetica,sans-serif;"
+ , "}"
+ , "div.topbar {"
+ , " height: 6px;"
+ , " background-color: rgb(96,181,204);"
+ , "}"
+ , "div.header {"
+ , " padding: 20px 50px;"
+ , " font-size: 30px;"
+ , "}"
+ , "div.content { padding: 0 40px }"
+ , "table {"
+ , " width:100%;"
+ , " border-collapse: collapse;"
+ , " margin-bottom: 40px;"
+ , " float: left"
+ , "}"
+ , "a { text-decoration: none; color:rgb(96,181,204) }"
+ , "td { padding: 8px 10px; color:rgb(136,136,136) }"
+ , "tr { border-bottom: solid rgb(245,245,245) 1px }"
+ , "th {"
+ , " text-align: left;"
+ , " padding: 6px 10px;"
+ , " font-weight: normal;"
+ , " font-size: 24px;"
+ , "}"
+ ]
+
+writeS :: MonadSnap m => FilePath -> m ()
+writeS = writeBS . S.pack
+
+
+replaceChar :: Char -> Char -> String -> String
+replaceChar old new string =
+ map (\c -> if c == old then new else c) string
+
+
+makeSafe :: String -> String
+makeSafe filePath =
+ replaceChar ' ' '+' filePath
+
+
+writeLink :: MonadSnap m => String -> String -> m ()
+writeLink href name =
+ do writeBS ""
+ writeS name
+ writeBS ""
+
+
+timeSince :: MonadSnap m => FilePath -> m String
+timeSince filePath =
+ do modificationTime <- liftIO $ getModificationTime filePath
+ currentTime <- liftIO getCurrentTime
+ return (showDiff currentTime modificationTime)
+ where
+ showDiff currentTime modificationTime =
+ case diffUTCTime currentTime modificationTime of
+ diff
+ | diff < minute -> format diff second "second"
+ | diff < hour -> format diff minute "minute"
+ | diff < day -> format diff hour "hour"
+ | diff < year -> format diff day "day"
+ | otherwise -> format diff year "year"
+
+ format diff scale name =
+ let t :: Integer
+ t = round (diff / scale)
+ in
+ show t ++ " " ++ name ++ (if t == 1 then "" else "s") ++ " ago"
+
+ second = 1
+ minute = 60 * second
+ hour = 60 * minute
+ day = 24 * hour
+ year = 365 * day
+
+
+elmIndexGenerator :: MonadSnap m => FilePath -> m ()
+elmIndexGenerator directory =
+ do modifyResponse $ setContentType "text/html; charset=utf-8"
+
+ let title =
+ intercalate "/" $
+ case splitDirectories directory of
+ "." : rest -> "~" : rest
+ path -> path
+
+ writeBS "\n\n"
+ writeBS ""
+ writeS title
+ writeBS " "
+ writeBS ""
+
+ writeBS ""
+
+ writeBS ""
+ writeLink "/" "~"
+ writeBS " / "
+ case splitDirectories directory of
+ _ : pathParts@(_:_) -> do
+ let fullPaths = scanl1 (\a b -> a ++ "/" ++ b) pathParts
+ forM_ (zip pathParts fullPaths) $ \(part, fullPath) -> do
+ writeLink ("/" ++ fullPath) part
+ writeBS " / "
+ _ -> return ()
+
+ writeBS ""
+
+ writeBS ""
+
+ entries <- liftIO $ getDirectoryContents directory
+ allDirs <- liftIO $ filterM (doesDirectoryExist . (directory )) entries
+ files <- liftIO $ filterM (doesFileExist . (directory )) entries
+
+ let (elmFiles, otherFiles) =
+ partition (\file -> takeExtension file == ".elm") files
+
+ let dotFile filePath =
+ null filePath || head filePath == '.'
+
+ let keepDir dir =
+ dir /= "cache" &&
+ dir /= "build" &&
+ not (dotFile dir)
+
+ let dirs = sort (filter keepDir allDirs)
+
+ let nonElmFiles = sort $ filter (not . dotFile) otherFiles
+
+ unless (null dirs) $ do
+ writeBS "Directories "
+ writeLink (dir ++ "/") dir
+ writeBS "
"
+
+ unless (null elmFiles) $ do
+ writeBS "Elm Files "
+
+ writeBS ""
+ writeLink
+ ("/" ++ intercalate "/" (splitDirectories directory) ++ "/" ++ filePath ++ "?debug")
+ "![](/_reactor/wrench.png "\\"Debug")
"
+ writeBS " "
+ writeLink filePath filePath
+ writeBS " "
+
+ writeBS ""
+ writeS =<< timeSince (directory filePath)
+ writeBS " "
+
+ writeBS " "
+ writeBS "
"
+
+ unless (null nonElmFiles) $ do
+ writeBS ""
+ writeBS "Other Files "
+
+ writeBS ""
+ writeLink filePath filePath
+ writeBS " "
+
+ writeBS ""
+ writeS =<< timeSince (directory filePath)
+ writeBS " "
+
+ writeBS " "
+ writeBS "
"
+
+ writeBS ""
+ writeBS ""
+ writeBS ""
+
diff --git a/server/Server.hs b/server/Server.hs
new file mode 100644
--- /dev/null
+++ b/server/Server.hs
@@ -0,0 +1,152 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
+module Main where
+
+import Control.Applicative ((<$>),(<|>))
+import Control.Monad (guard)
+import Control.Monad.Trans (MonadIO(liftIO))
+import qualified Data.ByteString.Char8 as BSC
+import qualified Data.Version as Version
+import qualified Network.WebSockets.Snap as WSS
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html.Renderer.Utf8 as BlazeBS
+import System.Console.CmdArgs
+import System.Directory
+import System.FilePath
+import System.Process
+import System.IO (hGetContents)
+import Paths_elm_reactor (version)
+import qualified Elm.Internal.Paths as Elm
+import Snap.Core
+import Snap.Http.Server
+import Snap.Util.FileServe
+
+import Index
+import qualified Generate
+import qualified Socket
+import qualified Utils
+
+data Flags = Flags
+ { port :: Int
+ , runtime :: Maybe FilePath
+ } deriving (Data,Typeable,Show,Eq)
+
+flags :: Flags
+flags = Flags
+ { port = 8000 &= help "set the port of the reactor"
+ , runtime = Nothing &= typFile
+ &= help "Specify a custom location for Elm's runtime system."
+ } &= help "Interactive development tool that makes it easy to develop and debug Elm programs.\n\
+ \ Read more about it at ."
+ &= helpArg [explicit, name "help", name "h"]
+ &= versionArg [ explicit, name "version", name "v"
+ , summary (Version.showVersion version)
+ ]
+ &= summary ("Elm Reactor " ++ Version.showVersion version ++
+ ", (c) Evan Czaplicki 2011-2014")
+
+
+config :: Int -> Config Snap a
+config portNumber =
+ setBind "localhost" $
+ setPort portNumber $
+ setAccessLog ConfigNoLog $
+ setErrorLog ConfigNoLog $
+ defaultConfig
+
+-- | Set up the reactor.
+main :: IO ()
+main = do
+ cargs <- cmdArgs flags
+ (_,Just h,_,_) <- createProcess $ (shell "elm --version") { std_out = CreatePipe }
+ elmVer <- hGetContents h
+ putStrLn (startupMessage elmVer)
+ httpServe (config (port cargs)) $
+ serveRuntime (maybe Elm.runtime id (runtime cargs))
+ <|> serveElm
+ <|> route [ ("socket", socket) ]
+ <|> serveDirectoryWith directoryConfig "."
+ <|> serveAssets
+ <|> error404
+
+startupMessage :: String -> String
+startupMessage elmVer =
+ "Elm Reactor " ++ Version.showVersion version ++ ", backed by version " ++
+ filter (/= '\n') elmVer ++ " of the compiler."
+
+directoryConfig :: MonadSnap m => DirectoryConfig m
+directoryConfig =
+ fancyDirectoryConfig
+ { indexFiles = []
+ , indexGenerator = elmIndexGenerator
+ }
+
+runtimeName :: String
+runtimeName = "elm-runtime.js"
+
+serveRuntime :: FilePath -> Snap ()
+serveRuntime runtimePath =
+ do file <- BSC.unpack . rqPathInfo <$> getRequest
+ guard (file == runtimeName)
+ serveFileAs "application/javascript" runtimePath
+
+socket :: Snap ()
+socket = maybe error400 socketSnap =<< getParam "file"
+ where
+ socketSnap fileParam =
+ WSS.runWebSocketsSnap $ Socket.fileChangeApp $ BSC.unpack fileParam
+
+withFile :: (FilePath -> H.Html) -> Snap ()
+withFile handler =
+ do filePath <- BSC.unpack . rqPathInfo <$> getRequest
+ exists <- liftIO (doesFileExist filePath)
+ if not exists then error404 else
+ serveHtml $ handler filePath
+
+error400 :: Snap ()
+error400 = modifyResponse $ setResponseStatus 400 "Bad Request"
+
+error404 :: Snap ()
+error404 = modifyResponse $ setResponseStatus 404 "Not Found"
+
+serveHtml :: MonadSnap m => H.Html -> m ()
+serveHtml html =
+ do _ <- setContentType "text/html" <$> getResponse
+ writeLBS (BlazeBS.renderHtml html)
+
+serveElm :: Snap ()
+serveElm =
+ let despace = map (\c -> if c == '+' then ' ' else c) in
+ do file <- despace . BSC.unpack . rqPathInfo <$> getRequest
+ debugParam <- getParam "debug"
+ let doDebug = maybe False (const True) debugParam
+ exists <- liftIO $ doesFileExist file
+ guard (exists && takeExtension file == ".elm")
+ result <- liftIO $ Generate.html file doDebug
+ serveHtml result
+
+serveAsset :: FilePath -> Snap ()
+serveAsset assetPath =
+ do dataPath <- liftIO $ Utils.getDataFile assetPath
+ serveFile dataPath
+
+staticAssets :: [FilePath]
+staticAssets = [ "favicon.ico"
+ , "debugger.js"
+ , "_reactor/wrench.png"
+ , "_reactor/debugger/pause-button-up.png"
+ , "_reactor/debugger/pause-button-down.png"
+ , "_reactor/debugger/pause-button-hover.png"
+ , "_reactor/debugger/play-button-up.png"
+ , "_reactor/debugger/play-button-down.png"
+ , "_reactor/debugger/play-button-hover.png"
+ , "_reactor/debugger/restart-button-up.png"
+ , "_reactor/debugger/restart-button-down.png"
+ , "_reactor/debugger/restart-button-hover.png"
+ ]
+
+serveAssets :: Snap ()
+serveAssets =
+ do file <- BSC.unpack . rqPathInfo <$> getRequest
+ guard (file `elem` staticAssets)
+ serveAsset file
diff --git a/server/Socket.hs b/server/Socket.hs
new file mode 100644
--- /dev/null
+++ b/server/Socket.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Socket where
+
+import Control.Monad.Trans (MonadIO(liftIO))
+import Control.Concurrent (threadDelay, forkIO, killThread, ThreadId)
+import qualified Control.Exception as E
+import qualified Data.ByteString.Char8 as BSC
+import qualified Filesystem.Path.CurrentOS as FP
+import qualified Network.WebSockets as WS
+import qualified System.FSNotify.Devel as NDevel
+import qualified System.FSNotify as Notify
+
+import qualified Generate
+
+fileChangeApp :: FilePath -> WS.ServerApp
+fileChangeApp watchedFile pendingConnection =
+ do connection <- WS.acceptRequest pendingConnection
+ Notify.withManager $ \notifyManager -> do
+ _ <- NDevel.treeExtExists notifyManager "." "elm" (sendHotSwap watchedFile connection)
+ keepAlive connection
+
+
+sendHotSwap :: FilePath -> WS.Connection -> FP.FilePath -> IO ()
+sendHotSwap watchedFile connection _ =
+ do result <- liftIO (Generate.js watchedFile)
+ WS.sendTextData connection (BSC.pack result)
+
+
+keepAlive :: WS.Connection -> IO ()
+keepAlive connection =
+ loop
+ where
+ loop :: IO ()
+ loop = do
+ pingThread <- forkIO ping
+ listen pingThread
+
+ ping :: IO ()
+ ping = do
+ threadDelay (10 * 1000000) -- 10 seconds
+ WS.sendPing connection ("ping" :: BSC.ByteString) `E.catch` connectionClosed
+
+ connectionClosed :: E.SomeException -> IO ()
+ connectionClosed _ = return ()
+
+ listen :: ThreadId -> IO ()
+ listen pingThread = do
+ pong <- WS.receive connection
+ case pong of
+ WS.DataMessage _ -> listen pingThread
+ WS.ControlMessage controlMessage ->
+ case controlMessage of
+ WS.Ping _ -> listen pingThread
+ WS.Pong _ -> loop
+ WS.Close _ _ ->
+ killThread pingThread >> return ()
diff --git a/server/Utils.hs b/server/Utils.hs
new file mode 100644
--- /dev/null
+++ b/server/Utils.hs
@@ -0,0 +1,38 @@
+{-# OPTIONS_GHC -Wall #-}
+module Utils where
+
+import System.Directory (doesFileExist)
+import System.Environment (getEnv)
+import System.FilePath (())
+import System.IO.Error (tryIOError)
+import qualified Paths_elm_reactor as This
+
+-- |The absolute path to a data file
+getDataFile :: FilePath -> IO FilePath
+getDataFile name = do
+ path <- This.getDataFileName name
+ exists <- doesFileExist path
+ if exists
+ then return path
+ else do
+ environment <- tryIOError (getEnv "ELM_HOME")
+ case environment of
+ Right env -> return (env "reactor" name)
+ Left _ ->
+ fail $ unlines
+ [ "Unable to find the ELM_HOME environment variable when searching"
+ , "for the " ++ name ++ " file."
+ , ""
+ , "If you installed Elm Platform with the Mac or Windows installer, it looks like"
+ , "ELM_HOME was not set automatically. Look up how to set environment variables"
+ , "on your platform and set ELM_HOME to the directory that contains Elm's static"
+ , "files:"
+ , ""
+ , " * On Mac it is /usr/local/share/elm"
+ , " * On Windows it is one of the following:"
+ , " C:/Program Files/Elm Platform/0.13/share"
+ , " C:/Program Files (x86)/Elm Platform/0.13/share"
+ , ""
+ , "If it seems like a more complex issue, please report it here:"
+ , " "
+ ]