@@ -1,30 +1,34 @@
1−{-# LANGUAGE CPP #-}
2−
31--------------------------------------------------------------------------------
2+{-# LANGUAGE CPP #-}
43module Hakyll.Preview.Poll
54 ( watchUpdates
65 ) where
76
87
98--------------------------------------------------------------------------------
10−import Control.Concurrent.MVar (newMVar, putMVar, takeMVar)
11−import Control.Monad (when, void)
9+import Control.Concurrent (forkIO)
10+import Control.Concurrent.MVar (newEmptyMVar, takeMVar,
11+ tryPutMVar)
12+import Control.Exception (AsyncException, fromException,
13+ handle, throw)
14+import Control.Monad (forever, void, when)
1215import Filesystem.Path.CurrentOS (decodeString, encodeString)
1316import System.Directory (canonicalizePath)
1417import System.FilePath (pathSeparators, (</>))
15−import System.FSNotify (Event (..), WatchConfig (..),
16− startManagerConf, watchTree)
18+import System.FSNotify (Event (..), startManager,
19+ watchTree)
1720
1821#ifdef mingw32_HOST_OS
19−import System.IO (IOMode(ReadMode), Handle, openFile,
20− hClose)
21−import System.IO.Error (isPermissionError)
2222import Control.Concurrent (threadDelay)
2323import Control.Exception (IOException, throw, try)
24−import System.Exit (exitFailure)
2524import System.Directory (doesFileExist)
25+import System.Exit (exitFailure)
26+import System.IO (Handle, IOMode (ReadMode),
27+ hClose, openFile)
28+import System.IO.Error (isPermissionError)
2629#endif
2730
31+
2832--------------------------------------------------------------------------------
2933import Hakyll.Core.Configuration
3034import Hakyll.Core.Identifier
@@ -37,10 +41,10 @@ import Hakyll.Core.Identifier.Pattern
3741watchUpdates :: Configuration -> IO Pattern -> IO ()
3842watchUpdates conf update = do
3943 let providerDir = decodeString $ providerDirectory conf
40− lock <- newMVar ()
44+ shouldBuild <- newEmptyMVar
4145 pattern <- update
4246 fullProviderDir <- canonicalizePath $ providerDirectory conf
43− manager <- startManagerConf (Debounce 0.1)
47+ manager <- startManager
4448
4549 let allowed event = do
4650 -- Absolute path of the changed file. This must be inside provider
@@ -53,42 +57,53 @@ watchUpdates conf update = do
5357 shouldIgnore <- shouldIgnoreFile conf path
5458 return $ not shouldIgnore && matches pattern identifier
5559
56− watchTree manager providerDir (not . isRemove) $ \event -> do
57− () <- takeMVar lock
60+ -- This thread continually watches the `shouldBuild` MVar and builds
61+ -- whenever a value is present.
62+ _ <- forkIO $ forever $ do
63+ event <- takeMVar shouldBuild
64+ handle
65+ (\e -> case fromException e of
66+ Nothing -> putStrLn (show e)
67+ Just async -> throw (async :: AsyncException))
68+ (update' event $ encodeString providerDir)
69+
70+ -- Send an event whenever something occurs so that the thread described
71+ -- above will do a build.
72+ void $ watchTree manager providerDir (not . isRemove) $ \event -> do
5873 allowed' <- allowed event
59− when allowed' $ update' event (encodeString providerDir)
60− putMVar lock ()
61− where
74+ when allowed' $ void $ tryPutMVar shouldBuild event
75+ where
6276#ifndef mingw32_HOST_OS
63− update' _ _ = void update
77+ update' _ _ = void update
6478#else
65− update' event provider = do
66− let path = provider </> eventPath event
67− -- on windows, a 'Modified' event is also sent on file deletion
68− fileExists <- doesFileExist path
69−
70− when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10
71−
72− -- continuously attempts to open the file in between sleep intervals
73− -- handler is run only once it is able to open the file
74− waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r
75− waitOpen _ _ _ 0 = do
76− putStrLn "[ERROR] Failed to retrieve modified file for regeneration"
77− exitFailure
78− waitOpen path mode handler retries = do
79− res <- try $ openFile path mode :: IO (Either IOException Handle)
80− case res of
81− Left ex -> if isPermissionError ex
82− then do
83− threadDelay 100000
84− waitOpen path mode handler (retries - 1)
85− else throw ex
86− Right h -> do
87− handled <- handler h
88− hClose h
89− return handled
79+ update' event provider = do
80+ let path = provider </> eventPath event
81+ -- on windows, a 'Modified' event is also sent on file deletion
82+ fileExists <- doesFileExist path
83+
84+ when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10
85+
86+ -- continuously attempts to open the file in between sleep intervals
87+ -- handler is run only once it is able to open the file
88+ waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r
89+ waitOpen _ _ _ 0 = do
90+ putStrLn "[ERROR] Failed to retrieve modified file for regeneration"
91+ exitFailure
92+ waitOpen path mode handler retries = do
93+ res <- try $ openFile path mode :: IO (Either IOException Handle)
94+ case res of
95+ Left ex -> if isPermissionError ex
96+ then do
97+ threadDelay 100000
98+ waitOpen path mode handler (retries - 1)
99+ else throw ex
100+ Right h -> do
101+ handled <- handler h
102+ hClose h
103+ return handled
90104#endif
91105
106+
92107--------------------------------------------------------------------------------
93108eventPath :: Event -> FilePath
94109eventPath evt = encodeString $ evtPath evt