Add event filtering based on pattern
This commit is contained in:
parent
030a5fe4bd
commit
cf98381508
5 changed files with 64 additions and 29 deletions
10
hakyll.cabal
10
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:
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue