diff options
Diffstat (limited to 'lib/Hakyll/Preview/Poll.hs')
-rw-r--r-- | lib/Hakyll/Preview/Poll.hs | 119 |
1 files changed, 119 insertions, 0 deletions
diff --git a/lib/Hakyll/Preview/Poll.hs b/lib/Hakyll/Preview/Poll.hs new file mode 100644 index 0000000..e197d3f --- /dev/null +++ b/lib/Hakyll/Preview/Poll.hs @@ -0,0 +1,119 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +module Hakyll.Preview.Poll + ( watchUpdates + ) where + + +-------------------------------------------------------------------------------- +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 System.Directory (canonicalizePath) +import System.FilePath (pathSeparators) +import System.FSNotify (Event (..), startManager, + watchTree) + +#ifdef mingw32_HOST_OS +import Control.Concurrent (threadDelay) +import Control.Exception (IOException, throw, try) +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.FilePath ((</>)) +import System.IO (Handle, IOMode (ReadMode), + hClose, openFile) +import System.IO.Error (isPermissionError) +#endif + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Configuration +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern + + +-------------------------------------------------------------------------------- +-- | A thread that watches for updates in a 'providerDirectory' and recompiles +-- a site as soon as any changes occur +watchUpdates :: Configuration -> IO Pattern -> IO () +watchUpdates conf update = do + let providerDir = providerDirectory conf + shouldBuild <- newEmptyMVar + pattern <- update + fullProviderDir <- canonicalizePath $ providerDirectory conf + manager <- startManager + + let allowed event = do + -- Absolute path of the changed file. This must be inside provider + -- dir, since that's the only dir we're watching. + let path = eventPath event + relative = dropWhile (`elem` pathSeparators) $ + drop (length fullProviderDir) path + identifier = fromFilePath relative + + shouldIgnore <- shouldIgnoreFile conf path + return $ not shouldIgnore && matches pattern identifier + + -- 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 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' $ void $ tryPutMVar shouldBuild event + where +#ifndef mingw32_HOST_OS + 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 +#endif + + +-------------------------------------------------------------------------------- +eventPath :: Event -> FilePath +eventPath evt = evtPath evt + where + evtPath (Added p _) = p + evtPath (Modified p _) = p + evtPath (Removed p _) = p + + +-------------------------------------------------------------------------------- +isRemove :: Event -> Bool +isRemove (Removed _ _) = True +isRemove _ = False |