From 42cdd649db36d6be52d297be36bedfc1f3ba8ee7 Mon Sep 17 00:00:00 2001 From: Simonas Kazlauskas Date: Sat, 30 Mar 2013 16:28:23 +0200 Subject: Migrating from polling to notification: First shot Using system file notification APIs it is much more efficient than polling files every second. --- src/Hakyll/Preview/Poll.hs | 69 +++++++++++++++++++++++++--------------------- 1 file changed, 37 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index 55118b3..c6c9b9a 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -1,48 +1,53 @@ --------------------------------------------------------------------------------- --- | Interval-based implementation of preview polling -{-# LANGUAGE CPP #-} module Hakyll.Preview.Poll ( previewPoll ) where - -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) import Control.Concurrent (threadDelay) -import Control.Monad (filterM) -#if MIN_VERSION_directory(1,2,0) -import Data.Time (getCurrentTime) -#else -import System.Time (getClockTime) -#endif -import System.Directory (doesFileExist, getModificationTime) - +import Control.Monad (void) +import Data.List (isPrefixOf) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import System.Directory (canonicalizePath) +import System.FSNotify (withManagerConf, watchTree, Event(..), WatchConfig(..)) +import System.IO.Error (catchIOError) -------------------------------------------------------------------------------- import Hakyll.Core.Configuration + -------------------------------------------------------------------------------- --- | A preview thread that periodically recompiles the site. +-- | A preview thread that recompiles the site when files change. previewPoll :: Configuration -- ^ Configuration -> IO [FilePath] -- ^ Updating action -> IO () -- ^ Can block forever -previewPoll _ update = do -#if MIN_VERSION_directory(1,2,0) - time <- getCurrentTime -#else - time <- getClockTime -#endif - loop time =<< update +previewPoll conf update = withManagerConf (Debounce 0.1) monitor where - delay = 1000000 - loop time files = do - threadDelay delay - files' <- filterM doesFileExist files - filesTime <- case files' of - [] -> return time - _ -> maximum <$> mapM getModificationTime files' - - if filesTime > time || files' /= files - then loop filesTime =<< update - else loop time files' + path = decodeString $ providerDirectory conf + monitor manager = do + _ <- update + ignore <- mapM getPath + [destinationDirectory, storeDirectory, tmpDirectory] + watchTree manager path (predicate ignore) (\_ -> void update) + infiniteLoop + getPath fn = catchIOError (canonicalizePath $ fn conf) + (const $ return $ fn conf) + predicate ignore evt + | isRemove evt = False + | any (flip isPrefixOf $ eventPath evt) ignore == True = False + | (ignoreFile conf) (eventPath evt) == True = False + | otherwise = True + +infiniteLoop :: IO () +infiniteLoop = do + threadDelay maxBound + infiniteLoop + +eventPath :: Event -> FilePath +eventPath (Added p _) = encodeString p +eventPath (Modified p _) = encodeString p +eventPath (Removed p _) = encodeString p + +isRemove :: Event -> Bool +isRemove (Removed _ _) = True +isRemove _ = False -- cgit v1.2.3 From fdfbf3dd344318dbb4f104644c6b952e48df294c Mon Sep 17 00:00:00 2001 From: Simonas Kazlauskas Date: Sat, 30 Mar 2013 17:24:20 +0200 Subject: Run server in main thread --- src/Hakyll/Commands.hs | 4 +--- src/Hakyll/Preview/Poll.hs | 12 +++--------- 2 files changed, 4 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Commands.hs b/src/Hakyll/Commands.hs index 6e0b9f2..140e0d9 100644 --- a/src/Hakyll/Commands.hs +++ b/src/Hakyll/Commands.hs @@ -27,7 +27,6 @@ import Hakyll.Core.Util.File -------------------------------------------------------------------------------- #ifdef PREVIEW_SERVER -import Control.Concurrent (forkIO) import qualified Data.Set as S import Hakyll.Core.Identifier import Hakyll.Core.Rules.Internal @@ -68,9 +67,8 @@ clean conf = do preview :: Configuration -> Verbosity -> Rules a -> Int -> IO () #ifdef PREVIEW_SERVER preview conf verbosity rules port = do - -- Run the server in a separate thread - _ <- forkIO $ server conf port previewPoll conf update + server conf port where update = do (exitCode, ruleSet) <- run conf verbosity rules diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index c6c9b9a..e9920ad 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -3,12 +3,12 @@ module Hakyll.Preview.Poll ) where -------------------------------------------------------------------------------- -import Control.Concurrent (threadDelay) import Control.Monad (void) import Data.List (isPrefixOf) import Filesystem.Path.CurrentOS (decodeString, encodeString) import System.Directory (canonicalizePath) -import System.FSNotify (withManagerConf, watchTree, Event(..), WatchConfig(..)) +import System.FSNotify (startManagerConf, watchTree, + Event(..), WatchConfig(..)) import System.IO.Error (catchIOError) -------------------------------------------------------------------------------- @@ -21,7 +21,7 @@ import Hakyll.Core.Configuration previewPoll :: Configuration -- ^ Configuration -> IO [FilePath] -- ^ Updating action -> IO () -- ^ Can block forever -previewPoll conf update = withManagerConf (Debounce 0.1) monitor +previewPoll conf update = monitor =<< startManagerConf (Debounce 0.1) where path = decodeString $ providerDirectory conf monitor manager = do @@ -29,7 +29,6 @@ previewPoll conf update = withManagerConf (Debounce 0.1) monitor ignore <- mapM getPath [destinationDirectory, storeDirectory, tmpDirectory] watchTree manager path (predicate ignore) (\_ -> void update) - infiniteLoop getPath fn = catchIOError (canonicalizePath $ fn conf) (const $ return $ fn conf) predicate ignore evt @@ -38,11 +37,6 @@ previewPoll conf update = withManagerConf (Debounce 0.1) monitor | (ignoreFile conf) (eventPath evt) == True = False | otherwise = True -infiniteLoop :: IO () -infiniteLoop = do - threadDelay maxBound - infiniteLoop - eventPath :: Event -> FilePath eventPath (Added p _) = encodeString p eventPath (Modified p _) = encodeString p -- cgit v1.2.3 From 7677bb4a775f7e0f6d1d88a5c0d37d5eb30d0213 Mon Sep 17 00:00:00 2001 From: Simonas Kazlauskas Date: Sat, 30 Mar 2013 18:07:16 +0200 Subject: Use shouldIgnoreFile --- src/Hakyll/Preview/Poll.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index e9920ad..ec53e85 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -21,21 +21,19 @@ import Hakyll.Core.Configuration previewPoll :: Configuration -- ^ Configuration -> IO [FilePath] -- ^ Updating action -> IO () -- ^ Can block forever -previewPoll conf update = monitor =<< startManagerConf (Debounce 0.1) +previewPoll conf update = do + _ <- update + manager <- startManagerConf (Debounce 0.1) + ignore <- mapM getPath [destinationDirectory, storeDirectory, tmpDirectory] + watchTree manager path (predicate ignore) (\_ -> void update) where path = decodeString $ providerDirectory conf - monitor manager = do - _ <- update - ignore <- mapM getPath - [destinationDirectory, storeDirectory, tmpDirectory] - watchTree manager path (predicate ignore) (\_ -> void update) getPath fn = catchIOError (canonicalizePath $ fn conf) (const $ return $ fn conf) predicate ignore evt | isRemove evt = False | any (flip isPrefixOf $ eventPath evt) ignore == True = False - | (ignoreFile conf) (eventPath evt) == True = False - | otherwise = True + | otherwise = not $ shouldIgnoreFile conf (eventPath evt) eventPath :: Event -> FilePath eventPath (Added p _) = encodeString p -- cgit v1.2.3 From bcc0ef828ec6f0abd8f397e6c04335e2c37256c9 Mon Sep 17 00:00:00 2001 From: Simonas Kazlauskas Date: Sat, 30 Mar 2013 18:38:31 +0200 Subject: Prefer relative directories instead of absolute This allows us to fully utilise shouldIgnoreFile --- src/Hakyll/Preview/Poll.hs | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index ec53e85..9f7a505 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -4,12 +4,11 @@ module Hakyll.Preview.Poll -------------------------------------------------------------------------------- import Control.Monad (void) -import Data.List (isPrefixOf) import Filesystem.Path.CurrentOS (decodeString, encodeString) -import System.Directory (canonicalizePath) +import System.Directory (getCurrentDirectory) +import System.FilePath (makeRelative) import System.FSNotify (startManagerConf, watchTree, Event(..), WatchConfig(..)) -import System.IO.Error (catchIOError) -------------------------------------------------------------------------------- import Hakyll.Core.Configuration @@ -24,21 +23,20 @@ previewPoll :: Configuration -- ^ Configuration previewPoll conf update = do _ <- update manager <- startManagerConf (Debounce 0.1) - ignore <- mapM getPath [destinationDirectory, storeDirectory, tmpDirectory] - watchTree manager path (predicate ignore) (\_ -> void update) + wDir <- getCurrentDirectory + watchTree manager path (predicate wDir) (\_ -> void update) where path = decodeString $ providerDirectory conf - getPath fn = catchIOError (canonicalizePath $ fn conf) - (const $ return $ fn conf) - predicate ignore evt + predicate wDir evt | isRemove evt = False - | any (flip isPrefixOf $ eventPath evt) ignore == True = False - | otherwise = not $ shouldIgnoreFile conf (eventPath evt) + | otherwise = not $ shouldIgnoreFile conf (relativeEventPath wDir evt) -eventPath :: Event -> FilePath -eventPath (Added p _) = encodeString p -eventPath (Modified p _) = encodeString p -eventPath (Removed p _) = encodeString p +relativeEventPath :: FilePath -> Event -> FilePath +relativeEventPath b evt = makeRelative b $ encodeString $ evtPath evt + where + evtPath (Added p _) = p + evtPath (Modified p _) = p + evtPath (Removed p _) = p isRemove :: Event -> Bool isRemove (Removed _ _) = True -- cgit v1.2.3 From 259190e30bb9136aef5b06546d47306edc2ad3ee Mon Sep 17 00:00:00 2001 From: Simonas Kazlauskas Date: Sun, 31 Mar 2013 14:47:47 +0300 Subject: Refine code This patch includes several smaller changes, namely: 1. We don't use result of `update` function and likely never will, so don't bother generating it. 2. Rename watch function to better reflect what it does. 3. Never exit preview server in case of failed update. --- src/Hakyll/Commands.hs | 14 ++++---------- src/Hakyll/Preview/Poll.hs | 18 +++++++++--------- 2 files changed, 13 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Commands.hs b/src/Hakyll/Commands.hs index 140e0d9..700dda5 100644 --- a/src/Hakyll/Commands.hs +++ b/src/Hakyll/Commands.hs @@ -13,7 +13,7 @@ module Hakyll.Commands -------------------------------------------------------------------------------- -import System.Exit (ExitCode (ExitSuccess), exitWith) +import System.Exit (exitWith) -------------------------------------------------------------------------------- @@ -27,9 +27,6 @@ import Hakyll.Core.Util.File -------------------------------------------------------------------------------- #ifdef PREVIEW_SERVER -import qualified Data.Set as S -import Hakyll.Core.Identifier -import Hakyll.Core.Rules.Internal import Hakyll.Preview.Poll import Hakyll.Preview.Server #endif @@ -67,15 +64,12 @@ clean conf = do preview :: Configuration -> Verbosity -> Rules a -> Int -> IO () #ifdef PREVIEW_SERVER preview conf verbosity rules port = do - previewPoll conf update + watchUpdates conf update server conf port where update = do - (exitCode, ruleSet) <- run conf verbosity rules - case exitCode of - ExitSuccess -> return $ map toFilePath $ S.toList $ - rulesResources ruleSet - _ -> exitWith exitCode + _ <- run conf verbosity rules + return () #else preview _ _ _ _ = previewServerDisabled #endif diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index 9f7a505..65021db 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -1,9 +1,8 @@ module Hakyll.Preview.Poll - ( previewPoll + ( watchUpdates ) where -------------------------------------------------------------------------------- -import Control.Monad (void) import Filesystem.Path.CurrentOS (decodeString, encodeString) import System.Directory (getCurrentDirectory) import System.FilePath (makeRelative) @@ -16,21 +15,21 @@ import Hakyll.Core.Configuration -------------------------------------------------------------------------------- --- | A preview thread that recompiles the site when files change. -previewPoll :: Configuration -- ^ Configuration - -> IO [FilePath] -- ^ Updating action - -> IO () -- ^ Can block forever -previewPoll conf update = do +-- | A thread that watches for updates in a 'providerDirectory' and recompiles +-- a site as soon as any changes occur +watchUpdates :: Configuration -> IO () -> IO () +watchUpdates conf update = do _ <- update manager <- startManagerConf (Debounce 0.1) - wDir <- getCurrentDirectory - watchTree manager path (predicate wDir) (\_ -> void update) + workingDirectory <- getCurrentDirectory + watchTree manager path (predicate workingDirectory) $ const update where path = decodeString $ providerDirectory conf predicate wDir evt | isRemove evt = False | otherwise = not $ shouldIgnoreFile conf (relativeEventPath wDir evt) + relativeEventPath :: FilePath -> Event -> FilePath relativeEventPath b evt = makeRelative b $ encodeString $ evtPath evt where @@ -38,6 +37,7 @@ relativeEventPath b evt = makeRelative b $ encodeString $ evtPath evt evtPath (Modified p _) = p evtPath (Removed p _) = p + isRemove :: Event -> Bool isRemove (Removed _ _) = True isRemove _ = False -- cgit v1.2.3 From 5a9a869e5878f82df486859bcb36bd50b309c290 Mon Sep 17 00:00:00 2001 From: Simonas Kazlauskas Date: Wed, 3 Apr 2013 13:31:27 +0300 Subject: Update patch for 5e4adaecb --- src/Hakyll/Preview/Poll.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index 65021db..36b057e 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -4,8 +4,6 @@ module Hakyll.Preview.Poll -------------------------------------------------------------------------------- import Filesystem.Path.CurrentOS (decodeString, encodeString) -import System.Directory (getCurrentDirectory) -import System.FilePath (makeRelative) import System.FSNotify (startManagerConf, watchTree, Event(..), WatchConfig(..)) @@ -21,17 +19,16 @@ watchUpdates :: Configuration -> IO () -> IO () watchUpdates conf update = do _ <- update manager <- startManagerConf (Debounce 0.1) - workingDirectory <- getCurrentDirectory - watchTree manager path (predicate workingDirectory) $ const update + watchTree manager path (not . isRemove) update' where path = decodeString $ providerDirectory conf - predicate wDir evt - | isRemove evt = False - | otherwise = not $ shouldIgnoreFile conf (relativeEventPath wDir evt) + update' evt = do + ignore <- shouldIgnoreFile conf $ eventPath evt + if ignore then return () else update -relativeEventPath :: FilePath -> Event -> FilePath -relativeEventPath b evt = makeRelative b $ encodeString $ evtPath evt +eventPath :: Event -> FilePath +eventPath evt = encodeString $ evtPath evt where evtPath (Added p _) = p evtPath (Modified p _) = p -- cgit v1.2.3