cf98381 · hakyll · git.iko.soy

git.iko.soy/hakyll

Add event filtering based on pattern

commitcf9838150801dc71d68cd3a4ca0631946d749256 authorJasper Van der Jeugt <m@jaspervdj.be> dateThu 4 Apr 2013, 11:47 (14 years ago) parent030a5fe

5 files changed+64−29

compare with master

unifiedsplit

hakyll.cabal+5−5 src/Hakyll/Commands.hs+3−2 src/Hakyll/Core/Rules.hs+10−3 src/Hakyll/Core/Rules/Internal.hs+6−3 src/Hakyll/Preview/Poll.hs+40−16

hakyll.cabal+5−5

@@ -164,9 +164,9 @@ Library

164164

165165 If flag(previewServer)

166166 Build-depends:

167− snap-core >= 0.6 && < 0.10,

168− snap-server >= 0.6 && < 0.10,

169− fsnotify >= 0.0.6 && < 0.1,

167+ snap-core >= 0.6 && < 0.10,

168+ snap-server >= 0.6 && < 0.10,

169+ fsnotify >= 0.0.6 && < 0.1,

170170 system-filepath >= 0.4.6 && <= 0.5

171171 Cpp-options:

172172 -DPREVIEW_SERVER

@@ -240,8 +240,8 @@ Test-suite hakyll-tests

240240

241241 If flag(previewServer)

242242 Build-depends:

243− snap-core >= 0.6 && < 0.10,

244− snap-server >= 0.6 && < 0.10,

243+ snap-core >= 0.6 && < 0.10,

244+ snap-server >= 0.6 && < 0.10,

245245 fsnotify >= 0.0.6 && < 0.1,

246246 system-filepath >= 0.4.6 && <= 0.5

247247 Cpp-options:

src/Hakyll/Commands.hs+3−2

@@ -21,6 +21,7 @@ import qualified Hakyll.Check as Check

2121import Hakyll.Core.Configuration

2222import Hakyll.Core.Logger (Verbosity)

2323import Hakyll.Core.Rules

24+import Hakyll.Core.Rules.Internal

2425import Hakyll.Core.Runtime

2526import Hakyll.Core.Util.File

2627

@@ -68,8 +69,8 @@ preview conf verbosity rules port = do

6869 server conf port

6970 where

7071 update = do

71− _ <- run conf verbosity rules

72− return ()

72+ (_, ruleSet) <- run conf verbosity rules

73+ return $ rulesPattern ruleSet

7374#else

7475preview _ _ _ _ = previewServerDisabled

7576#endif

src/Hakyll/Core/Rules.hs+10−3

@@ -63,20 +63,26 @@ import Hakyll.Core.Writable

6363--------------------------------------------------------------------------------

6464-- | Add a route

6565tellRoute :: Routes -> Rules ()

66−tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty

66+tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty mempty

6767

6868

6969--------------------------------------------------------------------------------

7070-- | Add a number of compilers

7171tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()

72−tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty

72+tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty

7373

7474

7575--------------------------------------------------------------------------------

7676-- | Add resources

7777tellResources :: [Identifier] -> Rules ()

7878tellResources resources' = Rules $ tell $

79− RuleSet mempty mempty $ S.fromList resources'

79+ RuleSet mempty mempty (S.fromList resources') mempty

80+

81+

82+--------------------------------------------------------------------------------

83+-- | Add a pattern

84+tellPattern :: Pattern -> Rules ()

85+tellPattern pattern = Rules $ tell $ RuleSet mempty mempty mempty pattern

8086

8187

8288--------------------------------------------------------------------------------

@@ -116,6 +122,7 @@ flush = Rules $ do

116122--------------------------------------------------------------------------------

117123match :: Pattern -> Rules () -> Rules ()

118124match pattern rules = do

125+ tellPattern pattern

119126 flush

120127 ids <- getMatches pattern

121128 tellResources ids

src/Hakyll/Core/Rules/Internal.hs+6−3

@@ -47,14 +47,17 @@ data RuleSet = RuleSet

4747 rulesCompilers :: [(Identifier, Compiler SomeItem)]

4848 , -- | A set of the actually used files

4949 rulesResources :: Set Identifier

50+ , -- | A pattern we can use to check if a file *would* be used. This is

51+ -- needed for the preview server.

52+ rulesPattern :: Pattern

5053 }

5154

5255

5356--------------------------------------------------------------------------------

5457instance Monoid RuleSet where

55− mempty = RuleSet mempty mempty mempty

56− mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) =

57− RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)

58+ mempty = RuleSet mempty mempty mempty mempty

59+ mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =

60+ RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)

5861

5962

6063--------------------------------------------------------------------------------

src/Hakyll/Preview/Poll.hs+40−16

@@ -1,40 +1,64 @@

1+--------------------------------------------------------------------------------

12module Hakyll.Preview.Poll

23 ( watchUpdates

34 ) where

57--------------------------------------------------------------------------------

6−import Filesystem.Path.CurrentOS (decodeString, encodeString)

7−import System.FSNotify (startManagerConf, watchTree,

8− Event(..), WatchConfig(..))

8+import Control.Concurrent.MVar (newMVar, putMVar, takeMVar)

9+import Control.Monad (when)

10+import Filesystem.Path.CurrentOS (decodeString, encodeString)

11+import System.Directory (canonicalizePath)

12+import System.FilePath (pathSeparators)

13+import System.FSNotify (Event (..), WatchConfig (..),

14+ startManagerConf, watchTree)

15+

916

1017--------------------------------------------------------------------------------

1118import Hakyll.Core.Configuration

12−

19+import Hakyll.Core.Identifier

20+import Hakyll.Core.Identifier.Pattern

1321

1422

1523--------------------------------------------------------------------------------

1624-- | A thread that watches for updates in a 'providerDirectory' and recompiles

1725-- a site as soon as any changes occur

18−watchUpdates :: Configuration -> IO () -> IO ()

26+watchUpdates :: Configuration -> IO Pattern -> IO ()

1927watchUpdates conf update = do

20− _ <- update

21− manager <- startManagerConf (Debounce 0.1)

22− watchTree manager path (not . isRemove) update'

23− where

24− path = decodeString $ providerDirectory conf

25− update' evt = do

26− ignore <- shouldIgnoreFile conf $ eventPath evt

27− if ignore then return () else update

28+ let providerDir = decodeString $ providerDirectory conf

29+ lock <- newMVar ()

30+ pattern <- update

31+ fullProviderDir <- canonicalizePath $ providerDirectory conf

32+ manager <- startManagerConf (Debounce 0.1)

2833

34+ let allowed event = do

35+ -- Absolute path of the changed file. This must be inside provider

36+ -- dir, since that's the only dir we're watching.

37+ let path = eventPath event

38+ relative = dropWhile (`elem` pathSeparators) $

39+ drop (length fullProviderDir) path

40+ identifier = fromFilePath relative

2941

42+ shouldIgnore <- shouldIgnoreFile conf path

43+ return $ not shouldIgnore && matches pattern identifier

44+

45+ watchTree manager providerDir (not . isRemove) $ \event -> do

46+ () <- takeMVar lock

47+ allowed' <- allowed event

48+ when allowed' $ update >> return ()

49+ putMVar lock ()

50+

51+

52+--------------------------------------------------------------------------------

3053eventPath :: Event -> FilePath

3154eventPath evt = encodeString $ evtPath evt

3255 where

33− evtPath (Added p _) = p

56+ evtPath (Added p _) = p

3457 evtPath (Modified p _) = p

35− evtPath (Removed p _) = p

58+ evtPath (Removed p _) = p

3659

3760

61+--------------------------------------------------------------------------------

3862isRemove :: Event -> Bool

3963isRemove (Removed _ _) = True

40−isRemove _ = False

64+isRemove _ = False