Commit 064cc7d3 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Standalone version of a live-reload HTTP server

parent d0ad66a5
......@@ -4,6 +4,7 @@
TAGS
public/
cache/
log/
*-deck.html
*-handout.html
*-page.html
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
import Context
import Control.Exception
import Control.Monad ()
......@@ -20,7 +21,7 @@ import Text.Pandoc ()
import Text.Printf ()
import Utilities
version = "0.1.0"
version = "0.3.0"
main :: IO ()
main = do
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Main
( main
) where
import Project
import Server
import Control.Concurrent
import Control.Monad
import System.Process
main :: IO ()
main = do
let port = 9999
dirs <- projectDirectories
server <- startHttpServer dirs port
callCommand $ "open http://localhost:" ++ show port
forever $ do
getLine
reloadClients server
putStrLn "reload initiated!"
......@@ -14,7 +14,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Watch, Embed, Context, Utilities, Filter, Project, Common
exposed-modules: Watch, Embed, Context, Utilities, Filter, Project, Common, Server
build-depends: base
, aeson
, random
......@@ -53,6 +53,10 @@ library
, scientific
, transformers
, unix
, snap-core
, snap-server
, websockets
, websockets-snap
default-language: Haskell2010
executable decker
......@@ -72,6 +76,17 @@ executable decker
, mustache
default-language: Haskell2010
executable liveserver
hs-source-dirs: app
main-is: liveserver.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, decker
, directory
, random
, process
default-language: Haskell2010
test-suite decker-test
type: exitcode-stdio-1.0
hs-source-dirs: test
......
......@@ -37,7 +37,7 @@ defaultActionContext :: IO ActionContext
defaultActionContext = do
files <- newIORef []
server <- newIORef Nothing
return $ ActionContext files server (ProjectDirs "" "" "" "")
return $ ActionContext files server (ProjectDirs "" "" "" "" "")
actionContextKey :: IO TypeRep
actionContextKey = do
......
......@@ -98,6 +98,7 @@ data ProjectDirs = ProjectDirs
, public :: FilePath
, cache :: FilePath
, support :: FilePath
, log :: FilePath
} deriving (Eq, Show)
-- Find the project directory.
......@@ -124,7 +125,8 @@ projectDirectories = do
let publicDir = projectDir </> "public"
let cacheDir = publicDir </> "cache"
let supportDir = publicDir </> "support"
return (ProjectDirs projectDir publicDir cacheDir supportDir)
let logDir = projectDir </> "log"
return (ProjectDirs projectDir publicDir cacheDir supportDir logDir)
-- Resolves a file path to a concrete verified file system path, or
-- returns Nothing if no file can be found.
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings #-}
module Server
( startHttpServer
, stopHttpServer
, reloadClients
) where
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List
import Data.Text
import Network.WebSockets
import Network.WebSockets.Snap
import Project
import Snap.Core
import Snap.Http.Server
import Snap.Util.FileServe
import System.Directory
import System.FilePath.Posix
import System.Random
serverConfig dirs port = do
let logDir = Project.log dirs
let accessLog = logDir </> "server-access.log"
let errorLog = logDir </> "server-error.log"
createDirectoryIfMissing True logDir
return
(setPort port $
setAccessLog (ConfigFileLog accessLog) $
setErrorLog (ConfigFileLog errorLog) defaultConfig :: Config Snap a)
-- | Clients are identified by integer ids
type Client = (Int, Connection)
type ServerState = [Client]
type Server = (ThreadId, MVar ServerState)
initState :: IO (MVar ServerState)
initState = newMVar []
addClient :: MVar ServerState -> Client -> IO ()
addClient state client = modifyMVar_ state add
where
add clients = return (client : clients)
removeClient :: MVar ServerState -> Int -> IO ()
removeClient state cid = modifyMVar_ state remove
where
remove clients = return [c | c <- clients, cid /= fst c]
reloadAll :: MVar ServerState -> IO ()
reloadAll state = withMVar state $ mapM_ send
where
send :: Client -> IO ()
send (cid, conn) = sendTextData conn ("reload!" :: Text)
runHttpServer :: MVar ServerState -> ProjectDirs -> Int -> IO ()
runHttpServer state dirs port = do
let documentRoot = public dirs
config <- serverConfig dirs port
simpleHttpServe config $
route
[ ("/reload", runWebSocketsSnap $ reloader state)
, ( "/reload.html"
, serveFile $ Project.project dirs </> "test" </> "reload.html")
, ( "/reload.js"
, serveFile $ Project.project dirs </> "test" </> "reload.js")
, ("/", serveDirectory documentRoot)
]
-- Starts a server in a new thread and returns the thread id.
startHttpServer :: ProjectDirs -> Int -> IO Server
startHttpServer dirs port = do
state <- initState
threadId <- forkIO $ runHttpServer state dirs port
return (threadId, state)
reloadClients :: Server -> IO ()
reloadClients = reloadAll . snd
stopHttpServer :: Server -> IO ()
stopHttpServer = killThread . fst
-- connect :: Connection -> IO ()
-- just keep it open
reloader :: MVar ServerState -> PendingConnection -> IO ()
reloader state pending = do
connection <- acceptRequest pending
cid <- randomIO
flip finally (removeClient state cid) $ do
addClient state (cid, connection)
-- putStrLn $ "reloader request from " ++ show cid
forever (receiveData connection :: IO Text)
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Utilities
( spawn
, terminate
, threadDelay'
, wantRepeat
, defaultContext
, runShakeInContext
, watchFiles
, dropSuffix
, stopServer
, startServer
, runHttpServer
, writeIndex
, readMetaDataForDir
......@@ -115,33 +112,6 @@ runHttpServer dir open = do
threadDelay' 200000
when open $ cmd ("open http://localhost:8888/" :: String) :: Action ()
startServer :: Control.Monad.IO.Class.MonadIO m => String -> String -> m ()
startServer id command =
liftIO $ do
processHandle <- spawnCommand command
withProcessHandle processHandle handleResult
where
handleResult ph =
case ph of
ClosedHandle e ->
print $ "Error starting server " ++ id ++ ": " ++ show e
OpenHandle p -> do
print $ "Server " ++ id ++ " running (" ++ show p ++ ")"
writeFile (id ++ ".pid") (show p)
stopServer id =
liftIO $ do
let pidFile = id ++ ".pid"
result <- try $ readFile pidFile
case result of
Left (SomeException e) -> print $ "Unable to read file " ++ pidFile
Right pid -> do
exitCode <- system ("kill -9 " ++ pid)
Dir.removeFile pidFile
terminate :: ProcessHandle -> Action ()
terminate = liftIO . terminateProcess
threadDelay' :: Int -> Action ()
threadDelay' = liftIO . threadDelay
......
<html>
<body>
<h1>Reload Test</h1>
<script>
var socket = new WebSocket("ws://" + location.host + "/reload");
socket.onmessage = function () {
window.location.reload(true);
};
</script>
</body>
</html>
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment