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)
|
If flag(previewServer)
|
||||||
Build-depends:
|
Build-depends:
|
||||||
snap-core >= 0.6 && < 0.10,
|
snap-core >= 0.6 && < 0.10,
|
||||||
snap-server >= 0.6 && < 0.10,
|
snap-server >= 0.6 && < 0.10,
|
||||||
fsnotify >= 0.0.6 && < 0.1,
|
fsnotify >= 0.0.6 && < 0.1,
|
||||||
system-filepath >= 0.4.6 && <= 0.5
|
system-filepath >= 0.4.6 && <= 0.5
|
||||||
Cpp-options:
|
Cpp-options:
|
||||||
-DPREVIEW_SERVER
|
-DPREVIEW_SERVER
|
||||||
|
@ -240,8 +240,8 @@ Test-suite hakyll-tests
|
||||||
|
|
||||||
If flag(previewServer)
|
If flag(previewServer)
|
||||||
Build-depends:
|
Build-depends:
|
||||||
snap-core >= 0.6 && < 0.10,
|
snap-core >= 0.6 && < 0.10,
|
||||||
snap-server >= 0.6 && < 0.10,
|
snap-server >= 0.6 && < 0.10,
|
||||||
fsnotify >= 0.0.6 && < 0.1,
|
fsnotify >= 0.0.6 && < 0.1,
|
||||||
system-filepath >= 0.4.6 && <= 0.5
|
system-filepath >= 0.4.6 && <= 0.5
|
||||||
Cpp-options:
|
Cpp-options:
|
||||||
|
|
|
@ -21,6 +21,7 @@ import qualified Hakyll.Check as Check
|
||||||
import Hakyll.Core.Configuration
|
import Hakyll.Core.Configuration
|
||||||
import Hakyll.Core.Logger (Verbosity)
|
import Hakyll.Core.Logger (Verbosity)
|
||||||
import Hakyll.Core.Rules
|
import Hakyll.Core.Rules
|
||||||
|
import Hakyll.Core.Rules.Internal
|
||||||
import Hakyll.Core.Runtime
|
import Hakyll.Core.Runtime
|
||||||
import Hakyll.Core.Util.File
|
import Hakyll.Core.Util.File
|
||||||
|
|
||||||
|
@ -68,8 +69,8 @@ preview conf verbosity rules port = do
|
||||||
server conf port
|
server conf port
|
||||||
where
|
where
|
||||||
update = do
|
update = do
|
||||||
_ <- run conf verbosity rules
|
(_, ruleSet) <- run conf verbosity rules
|
||||||
return ()
|
return $ rulesPattern ruleSet
|
||||||
#else
|
#else
|
||||||
preview _ _ _ _ = previewServerDisabled
|
preview _ _ _ _ = previewServerDisabled
|
||||||
#endif
|
#endif
|
||||||
|
|
|
@ -63,20 +63,26 @@ import Hakyll.Core.Writable
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Add a route
|
-- | Add a route
|
||||||
tellRoute :: Routes -> Rules ()
|
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
|
-- | Add a number of compilers
|
||||||
tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()
|
tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()
|
||||||
tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty
|
tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Add resources
|
-- | Add resources
|
||||||
tellResources :: [Identifier] -> Rules ()
|
tellResources :: [Identifier] -> Rules ()
|
||||||
tellResources resources' = Rules $ tell $
|
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 () -> Rules ()
|
||||||
match pattern rules = do
|
match pattern rules = do
|
||||||
|
tellPattern pattern
|
||||||
flush
|
flush
|
||||||
ids <- getMatches pattern
|
ids <- getMatches pattern
|
||||||
tellResources ids
|
tellResources ids
|
||||||
|
|
|
@ -47,14 +47,17 @@ data RuleSet = RuleSet
|
||||||
rulesCompilers :: [(Identifier, Compiler SomeItem)]
|
rulesCompilers :: [(Identifier, Compiler SomeItem)]
|
||||||
, -- | A set of the actually used files
|
, -- | A set of the actually used files
|
||||||
rulesResources :: Set Identifier
|
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
|
instance Monoid RuleSet where
|
||||||
mempty = RuleSet mempty mempty mempty
|
mempty = RuleSet mempty mempty mempty mempty
|
||||||
mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) =
|
mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =
|
||||||
RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)
|
RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -1,40 +1,64 @@
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
module Hakyll.Preview.Poll
|
module Hakyll.Preview.Poll
|
||||||
( watchUpdates
|
( watchUpdates
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Filesystem.Path.CurrentOS (decodeString, encodeString)
|
import Control.Concurrent.MVar (newMVar, putMVar, takeMVar)
|
||||||
import System.FSNotify (startManagerConf, watchTree,
|
import Control.Monad (when)
|
||||||
Event(..), WatchConfig(..))
|
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.Configuration
|
||||||
|
import Hakyll.Core.Identifier
|
||||||
|
import Hakyll.Core.Identifier.Pattern
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | A thread that watches for updates in a 'providerDirectory' and recompiles
|
-- | A thread that watches for updates in a 'providerDirectory' and recompiles
|
||||||
-- a site as soon as any changes occur
|
-- a site as soon as any changes occur
|
||||||
watchUpdates :: Configuration -> IO () -> IO ()
|
watchUpdates :: Configuration -> IO Pattern -> IO ()
|
||||||
watchUpdates conf update = do
|
watchUpdates conf update = do
|
||||||
_ <- update
|
let providerDir = decodeString $ providerDirectory conf
|
||||||
manager <- startManagerConf (Debounce 0.1)
|
lock <- newMVar ()
|
||||||
watchTree manager path (not . isRemove) update'
|
pattern <- update
|
||||||
where
|
fullProviderDir <- canonicalizePath $ providerDirectory conf
|
||||||
path = decodeString $ providerDirectory conf
|
manager <- startManagerConf (Debounce 0.1)
|
||||||
update' evt = do
|
|
||||||
ignore <- shouldIgnoreFile conf $ eventPath evt
|
let allowed event = do
|
||||||
if ignore then return () else update
|
-- 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 :: Event -> FilePath
|
||||||
eventPath evt = encodeString $ evtPath evt
|
eventPath evt = encodeString $ evtPath evt
|
||||||
where
|
where
|
||||||
evtPath (Added p _) = p
|
evtPath (Added p _) = p
|
||||||
evtPath (Modified p _) = p
|
evtPath (Modified p _) = p
|
||||||
evtPath (Removed p _) = p
|
evtPath (Removed p _) = p
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
isRemove :: Event -> Bool
|
isRemove :: Event -> Bool
|
||||||
isRemove (Removed _ _) = True
|
isRemove (Removed _ _) = True
|
||||||
isRemove _ = False
|
isRemove _ = False
|
||||||
|
|
Loading…
Reference in a new issue