summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--hakyll.cabal12
-rw-r--r--src/Hakyll/Preview/Poll.hs101
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