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
library
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
, aeson
, random
......@@ -49,6 +49,7 @@ library
, http-types
, highlighting-kate
, multimap
, fsnotify
default-language: Haskell2010
executable decker
......
......@@ -11,6 +11,7 @@ import qualified Data.HashMap.Strict as H
import Data.List
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.MultiMap as MM
import Data.Digest.Pure.MD5
import qualified Data.Yaml as Y
......@@ -66,3 +67,5 @@ readMetaData metaFiles =
joinMeta :: Y.Value -> Y.Value -> Y.Value
joinMeta (Y.Object old) (Y.Object new) = Y.Object (H.union new old)
joinMeta _ _ = throw $ YamlException "Can only join YAML objects."
-- extractMetaDataFromMarkdown :: T.Text -> Y.Value
......@@ -4,11 +4,9 @@ module Utilities
, terminate
, threadDelay'
, wantRepeat
, waitForModificationIn
, defaultContext
, runShakeInContext
, watchFiles
, waitForTwitch
, dropSuffix
, stopServer
, startServer
......@@ -50,6 +48,7 @@ import Control.Exception
import Development.Shake
import Development.Shake.FilePath as SFP
import Data.Dynamic
import Data.List
import Data.List.Extra
import Data.Maybe
import Data.IORef
......@@ -87,6 +86,7 @@ import Network.URI
import Text.Highlighting.Kate.Styles
import Context
import Embed
import Watch
-- Find the project directory and change current directory to there.
-- The project directory is the first upwards directory that contains a .git directory entry.
......@@ -170,9 +170,6 @@ threadDelay' = liftIO . threadDelay
wantRepeat :: IORef Bool -> Action ()
wantRepeat justOnce = liftIO $ writeIORef justOnce False
waitForModificationIn :: [FilePath] -> Action ()
waitForModificationIn = liftIO . waitForTwitch
-- The context of program invocation consists of a list of
-- files to watch and a possibly running local http server.
data Context =
......@@ -201,27 +198,11 @@ runShakeInContext context options rules = do
if null files
then return True
else do
waitForTwitch files
waitForTwitchPassive files
return False
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.
(<++>)
:: 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