Permalink
Fetching contributors…
Cannot retrieve contributors at this time
229 lines (202 sloc) 7.69 KB
--
-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
--
{-# LANGUAGE CPP, ScopedTypeVariables, ExistentialQuantification, RankNTypes #-}
-- | NOTE: This library does not currently report changes made to directories,
-- only files within watched directories.
--
-- Minimal example:
--
-- >{-# LANGUAGE OverloadedStrings #-} -- for FilePath literals
-- >
-- >import System.FSNotify
-- >import Control.Concurrent (threadDelay)
-- >import Control.Monad (forever)
-- >
-- >main =
-- > withManager $ \mgr -> do
-- > -- start a watching job (in the background)
-- > watchDir
-- > mgr -- manager
-- > "." -- directory to watch
-- > (const True) -- predicate
-- > print -- action
-- >
-- > -- sleep forever (until interrupted)
-- > forever $ threadDelay 1000000
module System.FSNotify
(
-- * Events
Event(..)
, EventChannel
, eventIsDirectory
, eventTime
, eventPath
, Action
, ActionPredicate
-- * Starting/Stopping
, WatchManager
, withManager
, startManager
, stopManager
, defaultConfig
, WatchConfig(..)
, Debounce(..)
, withManagerConf
, startManagerConf
, StopListening
, isPollingManager
-- * Watching
, watchDir
, watchDirChan
, watchTree
, watchTreeChan
) where
import Prelude hiding (FilePath)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Data.Maybe
import System.FSNotify.Polling
import System.FSNotify.Types
import System.FilePath
import System.FSNotify.Listener (StopListening)
#ifdef OS_Linux
import System.FSNotify.Linux
#else
# ifdef OS_Win32
import System.FSNotify.Win32
# else
# ifdef OS_Mac
import System.FSNotify.OSX
# else
type NativeManager = PollManager
# endif
# endif
#endif
-- | Watch manager. You need one in order to create watching jobs.
data WatchManager
= forall manager . FileListener manager
=> WatchManager
WatchConfig
manager
(MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped
-- | Default configuration
--
-- * Debouncing is enabled with a time interval of 1 millisecond
--
-- * Polling is disabled
--
-- * The polling interval defaults to 1 second
defaultConfig :: WatchConfig
defaultConfig =
WatchConfig
{ confDebounce = DebounceDefault
, confPollInterval = 10^(6 :: Int) -- 1 second
, confUsePolling = False
}
-- | Perform an IO action with a WatchManager in place.
-- Tear down the WatchManager after the action is complete.
withManager :: (WatchManager -> IO a) -> IO a
withManager = withManagerConf defaultConfig
-- | Start a file watch manager.
-- Directories can only be watched when they are managed by a started watch
-- watch manager.
-- When finished watching. you must release resources via 'stopManager'.
-- It is preferrable if possible to use 'withManager' to handle this
-- automatically.
startManager :: IO WatchManager
startManager = startManagerConf defaultConfig
-- | Stop a file watch manager.
-- Stopping a watch manager will immediately stop
-- watching for files and free resources.
stopManager :: WatchManager -> IO ()
stopManager (WatchManager _ wm cleanupVar) = do
mbCleanup <- swapMVar cleanupVar Nothing
fromMaybe (return ()) mbCleanup
killSession wm
-- | Like 'withManager', but configurable
withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf conf = bracket (startManagerConf conf) stopManager
-- | Like 'startManager', but configurable
startManagerConf :: WatchConfig -> IO WatchManager
startManagerConf conf
| confUsePolling conf = pollingManager
| otherwise = initSession >>= createManager
where
createManager :: Maybe NativeManager -> IO WatchManager
createManager (Just nativeManager) =
WatchManager conf nativeManager <$> cleanupVar
createManager Nothing = pollingManager
pollingManager =
WatchManager conf <$> createPollManager <*> cleanupVar
cleanupVar = newMVar (Just (return ()))
-- | Does this manager use polling?
isPollingManager :: WatchManager -> Bool
isPollingManager (WatchManager _ wm _) = usesPolling wm
-- | Watch the immediate contents of a directory by streaming events to a Chan.
-- Watching the immediate contents of a directory will only report events
-- associated with files within the specified directory, and not files
-- within its subdirectories.
watchDirChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening
watchDirChan (WatchManager db wm _) = listen db wm
-- | Watch all the contents of a directory by streaming events to a Chan.
-- Watching all the contents of a directory will report events associated with
-- files within the specified directory and its subdirectories.
watchTreeChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening
watchTreeChan (WatchManager db wm _) = listenRecursive db wm
-- | Watch the immediate contents of a directory by committing an Action for each event.
-- Watching the immediate contents of a directory will only report events
-- associated with files within the specified directory, and not files
-- within its subdirectories.
watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
watchDir wm = threadChan listen wm
-- | Watch all the contents of a directory by committing an Action for each event.
-- Watching all the contents of a directory will report events associated with
-- files within the specified directory and its subdirectories.
watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
watchTree wm = threadChan listenRecursive wm
threadChan
:: (forall sessionType . FileListener sessionType =>
WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening)
-- (^ this is the type of listen and listenRecursive)
-> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
threadChan listenFn (WatchManager db listener cleanupVar) path actPred action =
modifyMVar cleanupVar $ \mbCleanup -> case mbCleanup of
-- check if we've been stopped
Nothing -> return (Nothing, return ()) -- or throw an exception?
Just cleanup -> do
chan <- newChan
asy <- async $ readEvents chan action
-- Ideally, the the asy thread should be linked to the current one
-- (@link asy@), so that it doesn't die quietly.
-- However, if we do that, then cancelling asy will also kill
-- ourselves. I haven't figured out how to do this (probably we
-- should just abandon async and use lower-level primitives). For now
-- we don't link the thread.
stopListener <- listenFn db listener path actPred chan
let cleanThisUp = cancel asy
return
( Just $ cleanup >> cleanThisUp
, stopListener >> cleanThisUp
)
readEvents :: EventChannel -> Action -> IO ()
readEvents chan action = forever $ do
event <- readChan chan
us <- myThreadId
-- Execute the event handler in a separate thread, but throw any
-- exceptions back to us.
--
-- Note that there's a possibility that we may miss some exceptions, if
-- an event handler finishes after the listen is cancelled (and so this
-- thread is dead). How bad is that? The alternative is to kill the
-- handler anyway when we're cancelling.
forkFinally (action event) $ either (throwTo us) (const $ return ())
#if !MIN_VERSION_base(4,6,0)
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally action and_then =
mask $ \restore ->
forkIO $ try (restore action) >>= and_then
#endif