diff options
| -rw-r--r-- | hakyll.cabal | 12 | ||||
| -rw-r--r-- | src/Hakyll/Preview/Poll.hs | 101 |
2 files changed, 64 insertions, 49 deletions
diff --git a/hakyll.cabal b/hakyll.cabal index dacb0ae..7e84d16 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -160,7 +160,7 @@ Library old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, pandoc >= 1.12.4 && < 1.14, - pandoc-citeproc >= 0.4 && < 0.5, + pandoc-citeproc >= 0.4 && < 0.7, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.3, random >= 1.0 && < 1.2, @@ -174,7 +174,7 @@ Library Build-depends: snap-core >= 0.6 && < 0.10, snap-server >= 0.6 && < 0.10, - fsnotify >= 0.0.6 && < 0.1, + fsnotify >= 0.1 && < 0.2, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DPREVIEW_SERVER @@ -184,7 +184,7 @@ Library If flag(watchServer) Build-depends: - fsnotify >= 0.0.6 && < 0.1, + fsnotify >= 0.1 && < 0.2, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DWATCH_SERVER @@ -247,7 +247,7 @@ Test-suite hakyll-tests old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, pandoc >= 1.12.4 && < 1.14, - pandoc-citeproc >= 0.4 && < 0.5, + pandoc-citeproc >= 0.4 && < 0.7, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.3, random >= 1.0 && < 1.2, @@ -261,7 +261,7 @@ Test-suite hakyll-tests Build-depends: snap-core >= 0.6 && < 0.10, snap-server >= 0.6 && < 0.10, - fsnotify >= 0.0.6 && < 0.1, + fsnotify >= 0.1 && < 0.2, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DPREVIEW_SERVER @@ -271,7 +271,7 @@ Test-suite hakyll-tests If flag(watchServer) Build-depends: - fsnotify >= 0.0.6 && < 0.1, + fsnotify >= 0.1 && < 0.2, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DWATCH_SERVER diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index ab183f7..34eb971 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -1,30 +1,34 @@ -{-# LANGUAGE CPP #-} - -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} module Hakyll.Preview.Poll ( watchUpdates ) where -------------------------------------------------------------------------------- -import Control.Concurrent.MVar (newMVar, putMVar, takeMVar) -import Control.Monad (when, void) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, + tryPutMVar) +import Control.Exception (AsyncException, fromException, + handle, throw) +import Control.Monad (forever, void, when) import Filesystem.Path.CurrentOS (decodeString, encodeString) import System.Directory (canonicalizePath) import System.FilePath (pathSeparators, (</>)) -import System.FSNotify (Event (..), WatchConfig (..), - startManagerConf, watchTree) +import System.FSNotify (Event (..), startManager, + watchTree) #ifdef mingw32_HOST_OS -import System.IO (IOMode(ReadMode), Handle, openFile, - hClose) -import System.IO.Error (isPermissionError) import Control.Concurrent (threadDelay) import Control.Exception (IOException, throw, try) -import System.Exit (exitFailure) import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (Handle, IOMode (ReadMode), + hClose, openFile) +import System.IO.Error (isPermissionError) #endif + -------------------------------------------------------------------------------- import Hakyll.Core.Configuration import Hakyll.Core.Identifier @@ -37,10 +41,10 @@ import Hakyll.Core.Identifier.Pattern watchUpdates :: Configuration -> IO Pattern -> IO () watchUpdates conf update = do let providerDir = decodeString $ providerDirectory conf - lock <- newMVar () + shouldBuild <- newEmptyMVar pattern <- update fullProviderDir <- canonicalizePath $ providerDirectory conf - manager <- startManagerConf (Debounce 0.1) + manager <- startManager let allowed event = do -- Absolute path of the changed file. This must be inside provider @@ -53,42 +57,53 @@ watchUpdates conf update = do shouldIgnore <- shouldIgnoreFile conf path return $ not shouldIgnore && matches pattern identifier - watchTree manager providerDir (not . isRemove) $ \event -> do - () <- takeMVar lock + -- This thread continually watches the `shouldBuild` MVar and builds + -- whenever a value is present. + _ <- forkIO $ forever $ do + event <- takeMVar shouldBuild + handle + (\e -> case fromException e of + Nothing -> putStrLn (show e) + Just async -> throw (async :: AsyncException)) + (update' event $ encodeString providerDir) + + -- Send an event whenever something occurs so that the thread described + -- above will do a build. + void $ watchTree manager providerDir (not . isRemove) $ \event -> do allowed' <- allowed event - when allowed' $ update' event (encodeString providerDir) - putMVar lock () - where + when allowed' $ void $ tryPutMVar shouldBuild event + where #ifndef mingw32_HOST_OS - update' _ _ = void update + update' _ _ = void update #else - update' event provider = do - let path = provider </> eventPath event - -- on windows, a 'Modified' event is also sent on file deletion - fileExists <- doesFileExist path - - when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10 - - -- continuously attempts to open the file in between sleep intervals - -- handler is run only once it is able to open the file - waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r - waitOpen _ _ _ 0 = do - putStrLn "[ERROR] Failed to retrieve modified file for regeneration" - exitFailure - waitOpen path mode handler retries = do - res <- try $ openFile path mode :: IO (Either IOException Handle) - case res of - Left ex -> if isPermissionError ex - then do - threadDelay 100000 - waitOpen path mode handler (retries - 1) - else throw ex - Right h -> do - handled <- handler h - hClose h - return handled + update' event provider = do + let path = provider </> eventPath event + -- on windows, a 'Modified' event is also sent on file deletion + fileExists <- doesFileExist path + + when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10 + + -- continuously attempts to open the file in between sleep intervals + -- handler is run only once it is able to open the file + waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r + waitOpen _ _ _ 0 = do + putStrLn "[ERROR] Failed to retrieve modified file for regeneration" + exitFailure + waitOpen path mode handler retries = do + res <- try $ openFile path mode :: IO (Either IOException Handle) + case res of + Left ex -> if isPermissionError ex + then do + threadDelay 100000 + waitOpen path mode handler (retries - 1) + else throw ex + Right h -> do + handled <- handler h + hClose h + return handled #endif + -------------------------------------------------------------------------------- eventPath :: Event -> FilePath eventPath evt = encodeString $ evtPath evt |