Add event filtering based on pattern

hakyll.cabal

@@ -164,9 +164,9 @@ Library
 
   If flag(previewServer)
     Build-depends:
-      snap-core   >= 0.6 && < 0.10,
-      snap-server >= 0.6 && < 0.10,
-      fsnotify    >= 0.0.6 && < 0.1,
+      snap-core       >= 0.6   && < 0.10,
+      snap-server     >= 0.6   && < 0.10,
+      fsnotify        >= 0.0.6 && < 0.1,
       system-filepath >= 0.4.6 && <= 0.5
     Cpp-options:
       -DPREVIEW_SERVER
@@ -240,8 +240,8 @@ Test-suite hakyll-tests
 
   If flag(previewServer)
     Build-depends:
-      snap-core       >= 0.6 && < 0.10,
-      snap-server     >= 0.6 && < 0.10,
+      snap-core       >= 0.6   && < 0.10,
+      snap-server     >= 0.6   && < 0.10,
       fsnotify        >= 0.0.6 && < 0.1,
       system-filepath >= 0.4.6 && <= 0.5
     Cpp-options:

src/Hakyll/Commands.hs

@@ -21,6 +21,7 @@ import qualified Hakyll.Check               as Check
 import           Hakyll.Core.Configuration
 import           Hakyll.Core.Logger         (Verbosity)
 import           Hakyll.Core.Rules
+import           Hakyll.Core.Rules.Internal
 import           Hakyll.Core.Runtime
 import           Hakyll.Core.Util.File
 
@@ -68,8 +69,8 @@ preview conf verbosity rules port = do
     server conf port
   where
     update = do
-        _ <- run conf verbosity rules
-        return ()
+        (_, ruleSet) <- run conf verbosity rules
+        return $ rulesPattern ruleSet
 #else
 preview _ _ _ _ = previewServerDisabled
 #endif

src/Hakyll/Core/Rules.hs

@@ -63,20 +63,26 @@ import           Hakyll.Core.Writable
 --------------------------------------------------------------------------------
 -- | Add a route
 tellRoute :: Routes -> Rules ()
-tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty
+tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty mempty
 
 
 --------------------------------------------------------------------------------
 -- | Add a number of compilers
 tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()
-tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty
+tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty
 
 
 --------------------------------------------------------------------------------
 -- | Add resources
 tellResources :: [Identifier] -> Rules ()
 tellResources resources' = Rules $ tell $
-    RuleSet mempty mempty $ S.fromList resources'
+    RuleSet mempty mempty (S.fromList resources') mempty
+
+
+--------------------------------------------------------------------------------
+-- | Add a pattern
+tellPattern :: Pattern -> Rules ()
+tellPattern pattern = Rules $ tell $ RuleSet mempty mempty mempty pattern
 
 
 --------------------------------------------------------------------------------
@@ -116,6 +122,7 @@ flush = Rules $ do
 --------------------------------------------------------------------------------
 match :: Pattern -> Rules () -> Rules ()
 match pattern rules = do
+    tellPattern pattern
     flush
     ids <- getMatches pattern
     tellResources ids

src/Hakyll/Core/Rules/Internal.hs

@@ -47,14 +47,17 @@ data RuleSet = RuleSet
       rulesCompilers :: [(Identifier, Compiler SomeItem)]
     , -- | A set of the actually used files
       rulesResources :: Set Identifier
+    , -- | A pattern we can use to check if a file *would* be used. This is
+      -- needed for the preview server.
+      rulesPattern   :: Pattern
     }
 
 
 --------------------------------------------------------------------------------
 instance Monoid RuleSet where
-    mempty = RuleSet mempty mempty mempty
-    mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) =
-        RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)
+    mempty = RuleSet mempty mempty mempty mempty
+    mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =
+        RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)
 
 
 --------------------------------------------------------------------------------

src/Hakyll/Preview/Poll.hs

@@ -1,40 +1,64 @@
+--------------------------------------------------------------------------------
 module Hakyll.Preview.Poll
     ( watchUpdates
     ) where
 
+
 --------------------------------------------------------------------------------
-import           Filesystem.Path.CurrentOS (decodeString, encodeString)
-import           System.FSNotify           (startManagerConf, watchTree,
-                                            Event(..), WatchConfig(..))
+import           Control.Concurrent.MVar        (newMVar, putMVar, takeMVar)
+import           Control.Monad                  (when)
+import           Filesystem.Path.CurrentOS      (decodeString, encodeString)
+import           System.Directory               (canonicalizePath)
+import           System.FilePath                (pathSeparators)
+import           System.FSNotify                (Event (..), WatchConfig (..),
+                                                 startManagerConf, watchTree)
+
 
 --------------------------------------------------------------------------------
 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 () -> IO ()
+watchUpdates :: Configuration -> IO Pattern -> IO ()
 watchUpdates conf update = do
-    _ <- update
-    manager <- startManagerConf (Debounce 0.1)
-    watchTree manager path (not . isRemove) update'
-  where
-    path = decodeString $ providerDirectory conf
-    update' evt = do
-        ignore <- shouldIgnoreFile conf $ eventPath evt
-        if ignore then return () else update
+    let providerDir = decodeString $ providerDirectory conf
+    lock            <- newMVar ()
+    pattern         <- update
+    fullProviderDir <- canonicalizePath $ providerDirectory conf
+    manager         <- startManagerConf (Debounce 0.1)
+
+    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
+
+    watchTree manager providerDir (not . isRemove) $ \event -> do
+        ()       <- takeMVar lock
+        allowed' <- allowed event
+        when allowed' $ update >> return ()
+        putMVar lock ()
 
 
+--------------------------------------------------------------------------------
 eventPath :: Event -> FilePath
 eventPath evt = encodeString $ evtPath evt
   where
-    evtPath (Added p _) = p
+    evtPath (Added p _)    = p
     evtPath (Modified p _) = p
-    evtPath (Removed p _) = p
+    evtPath (Removed p _)  = p
 
 
+--------------------------------------------------------------------------------
 isRemove :: Event -> Bool
 isRemove (Removed _ _) = True
-isRemove _ = False
+isRemove _             = False