Commit 17ec90c3 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Replace active file eatching with event based FSNotify

parent 2a211c0c
...@@ -15,7 +15,7 @@ cabal-version: >=1.10 ...@@ -15,7 +15,7 @@ cabal-version: >=1.10
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: Pandoc, Test, Embed, Context, Utilities, Filter, Student, Shuffle exposed-modules: Watch, Pandoc, Test, Embed, Context, Utilities, Filter, Student, Shuffle
build-depends: base build-depends: base
, aeson , aeson
, random , random
...@@ -49,6 +49,7 @@ library ...@@ -49,6 +49,7 @@ library
, http-types , http-types
, highlighting-kate , highlighting-kate
, multimap , multimap
, fsnotify
default-language: Haskell2010 default-language: Haskell2010
executable decker executable decker
......
...@@ -11,6 +11,7 @@ import qualified Data.HashMap.Strict as H ...@@ -11,6 +11,7 @@ import qualified Data.HashMap.Strict as H
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.MultiMap as MM import qualified Data.MultiMap as MM
import Data.Digest.Pure.MD5 import Data.Digest.Pure.MD5
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
...@@ -66,3 +67,5 @@ readMetaData metaFiles = ...@@ -66,3 +67,5 @@ readMetaData metaFiles =
joinMeta :: Y.Value -> Y.Value -> Y.Value joinMeta :: Y.Value -> Y.Value -> Y.Value
joinMeta (Y.Object old) (Y.Object new) = Y.Object (H.union new old) joinMeta (Y.Object old) (Y.Object new) = Y.Object (H.union new old)
joinMeta _ _ = throw $ YamlException "Can only join YAML objects." joinMeta _ _ = throw $ YamlException "Can only join YAML objects."
-- extractMetaDataFromMarkdown :: T.Text -> Y.Value
...@@ -4,11 +4,9 @@ module Utilities ...@@ -4,11 +4,9 @@ module Utilities
, terminate , terminate
, threadDelay' , threadDelay'
, wantRepeat , wantRepeat
, waitForModificationIn
, defaultContext , defaultContext
, runShakeInContext , runShakeInContext
, watchFiles , watchFiles
, waitForTwitch
, dropSuffix , dropSuffix
, stopServer , stopServer
, startServer , startServer
...@@ -50,6 +48,7 @@ import Control.Exception ...@@ -50,6 +48,7 @@ import Control.Exception
import Development.Shake import Development.Shake
import Development.Shake.FilePath as SFP import Development.Shake.FilePath as SFP
import Data.Dynamic import Data.Dynamic
import Data.List
import Data.List.Extra import Data.List.Extra
import Data.Maybe import Data.Maybe
import Data.IORef import Data.IORef
...@@ -87,6 +86,7 @@ import Network.URI ...@@ -87,6 +86,7 @@ import Network.URI
import Text.Highlighting.Kate.Styles import Text.Highlighting.Kate.Styles
import Context import Context
import Embed import Embed
import Watch
-- Find the project directory and change current directory to there. -- Find the project directory and change current directory to there.
-- The project directory is the first upwards directory that contains a .git directory entry. -- The project directory is the first upwards directory that contains a .git directory entry.
...@@ -170,9 +170,6 @@ threadDelay' = liftIO . threadDelay ...@@ -170,9 +170,6 @@ threadDelay' = liftIO . threadDelay
wantRepeat :: IORef Bool -> Action () wantRepeat :: IORef Bool -> Action ()
wantRepeat justOnce = liftIO $ writeIORef justOnce False wantRepeat justOnce = liftIO $ writeIORef justOnce False
waitForModificationIn :: [FilePath] -> Action ()
waitForModificationIn = liftIO . waitForTwitch
-- The context of program invocation consists of a list of -- The context of program invocation consists of a list of
-- files to watch and a possibly running local http server. -- files to watch and a possibly running local http server.
data Context = data Context =
...@@ -201,27 +198,11 @@ runShakeInContext context options rules = do ...@@ -201,27 +198,11 @@ runShakeInContext context options rules = do
if null files if null files
then return True then return True
else do else do
waitForTwitch files waitForTwitchPassive files
return False return False
watchFiles = setFilesToWatch watchFiles = setFilesToWatch
-- | Actively waits for the first change to any member in the set of specified
-- | files and their parent directories, then returns.
waitForTwitch files = do
startTime <- getCurrentTime
let dirs = map takeDirectory files
let filesAndDirs = Set.toList . Set.fromList $ files ++ dirs
whileM_ (noModificationSince startTime filesAndDirs) (threadDelay 300000)
where
noModificationSince startTime pathes = do
modified <- mapM (modifiedSince startTime) pathes
return $ not (or modified)
modifiedSince time path =
handle (\(SomeException _) -> return False) $
do modTime <- getModificationTime path
return $ diffUTCTime modTime time > 0
-- | Monadic version of list concatenation. -- | Monadic version of list concatenation.
(<++>) (<++>)
:: Monad m :: Monad m
......
module Watch (waitForTwitchPassive) where
-- | A non-polling file watcher based on fsnotify
import Data.List
import System.FilePath
import System.FilePath.Glob
import Control.Concurrent.MVar
import System.FSNotify
-- | Wait for something to happen on one of the matching files
-- in one of the supplied directories.
waitForTwitch :: [FilePath] -> [Pattern] -> IO FilePath
waitForTwitch directories patterns = do
done <- newEmptyMVar
mgr <- startManager
stops <- watchIt mgr done
filepath <- takeMVar done
sequence_ stops
stopManager mgr
return filepath
where
-- Match a filepath against the supplied patterns
isWatchedFile event =
any ((flip match) (eventPath event)) patterns
-- Stop the watch manager and notify the main thread
stopWatching mgr done event = do
putMVar done (eventPath event)
-- Watch everything within the supplied dirs
watchInDir mgr done dir = watchTree mgr dir isWatchedFile (stopWatching mgr done)
watchIt mgr done = do
mapM (watchInDir mgr done) directories
twitchPatterns = map compile ["**/*.md", "**/*.yaml", "**/*.png", "**/*.jpg"]
waitForTwitchPassive files = do
let dirs = nub (map takeDirectory files)
waitForTwitch dirs twitchPatterns
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment