summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Hakyll/Commands.hs5
-rw-r--r--src/Hakyll/Core/Rules.hs13
-rw-r--r--src/Hakyll/Core/Rules/Internal.hs9
-rw-r--r--src/Hakyll/Preview/Poll.hs56
4 files changed, 59 insertions, 24 deletions
diff --git a/src/Hakyll/Commands.hs b/src/Hakyll/Commands.hs
index 700dda5..6d6b0ae 100644
--- a/src/Hakyll/Commands.hs
+++ b/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
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index 66210b6..c248a9b 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/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
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index 6bb82df..a7c2059 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/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)
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs
index 36b057e..7dd266b 100644
--- a/src/Hakyll/Preview/Poll.hs
+++ b/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