diff --git a/reserve.cabal b/reserve.cabal index e65809b..849efdc 100644 --- a/reserve.cabal +++ b/reserve.cabal @@ -37,6 +37,9 @@ executable reserve , http-types , http-kit >= 0.5 , bytestring + , filepath + , directory + , time test-suite spec type: @@ -57,6 +60,9 @@ test-suite spec , http-types , http-kit , bytestring + , filepath + , directory + , time , hspec >= 1.5 , QuickCheck diff --git a/src/Reserve.hs b/src/Reserve.hs index 488cd1d..6755c96 100644 --- a/src/Reserve.hs +++ b/src/Reserve.hs @@ -18,6 +18,7 @@ import Util import Options import Interpreter (Interpreter) import qualified Interpreter +import Data.IORef data Session = Session Socket Interpreter @@ -32,16 +33,23 @@ withSession :: Options -> (Session -> IO a) -> IO a withSession opts = bracket (openSession opts) closeSession run :: Options -> IO () -run opts = withSession opts $ \(Session s interpreter) -> forever $ do - (h, _, _) <- accept s - Interpreter.reload interpreter - Interpreter.start interpreter (optionsAppArgs opts) - c <- inputStreamFromHandle h - let send :: ByteString -> IO () - send = ignoreResourceVanished . B.hPutStr h - readRequest True c >>= httpRequest (optionsPort opts) send - Interpreter.stop interpreter - ignoreResourceVanished $ hClose h +run opts = withSession opts $ \(Session s int) -> do + Interpreter.start int (optionsAppArgs opts) + ref <- getModTime >>= newIORef + forever $ do + (h, _, _) <- accept s + t0 <- readIORef ref + t1 <- getModTime + when (t0 < t1) $ do + Interpreter.stop int + Interpreter.reload int + Interpreter.start int (optionsAppArgs opts) + writeIORef ref t1 + c <- inputStreamFromHandle h + let send :: ByteString -> IO () + send = ignoreResourceVanished . B.hPutStr h + readRequest True c >>= httpRequest (optionsPort opts) send + ignoreResourceVanished $ hClose h ignoreResourceVanished :: IO () -> IO () ignoreResourceVanished action = catchJust (guard . (== ResourceVanished) . ioe_type) action return diff --git a/src/Util.hs b/src/Util.hs index d54bbc0..674baf8 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,9 +1,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Util where +import Control.Applicative import Control.Concurrent +import Control.Monad import Control.Exception import System.IO +import System.FilePath +import System.Directory +import Data.Time.Clock +import Data.List import Network connectRetry :: Int -> HostName -> PortNumber -> (Maybe Handle -> IO a) -> IO a @@ -17,3 +23,21 @@ connectRetry delay host port action = go 0 tryConnect = try $ bracket connect hClose (action . Just) retry n = threadDelay delay >> go (succ n) connect = connectTo host $ PortNumber port + +getModTime :: IO UTCTime +getModTime = maximum <$> (listFiles >>= mapM getModificationTime) + where + listFiles :: IO [FilePath] + listFiles = filter ((||) <$> isSuffixOf ".hs" <*> isSuffixOf ".lhs") <$> go "." + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go (filter (`notElem` exclude) dirs) + + exclude :: [FilePath] + exclude = ["./.git"] + + getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) + getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c