Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
238 lines (205 sloc) 9.14 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, LambdaCase, OverloadedStrings, MultiWayIf, FlexibleContexts, RecordWildCards, NamedFieldPuns #-}
-- | 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(..)
, EventIsDirectory(..)
, EventChannel
, Action
, ActionPredicate
-- * Starting/Stopping
, WatchManager
, withManager
, startManager
, stopManager
-- * Configuration
, defaultConfig
, confWatchMode
, confThreadingMode
, confOnHandlerException
, WatchMode(..)
, ThreadingMode(..)
-- * Lower level
, withManagerConf
, startManagerConf
, StopListening
-- * Watching
, watchDir
, watchDirChan
, watchTree
, watchTreeChan
-- * Debouncing
, makeDebouncedAction
) where
import Prelude hiding (FilePath)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception.Safe as E
import Control.Monad
import Control.Monad.IO.Class
import Data.Text as T
import System.FSNotify.Debounce
import System.FSNotify.Polling
import System.FSNotify.Types
import System.FilePath
import System.FSNotify.Listener (ListenFn, StopListening)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
#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 argType. FileListener manager argType =>
WatchManager { watchManagerConfig :: WatchConfig
, watchManagerManager :: manager
, watchManagerCleanupVar :: (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped
, watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
}
-- | Default configuration
--
-- * Uses OS watch mode and single thread.
defaultConfig :: WatchConfig
defaultConfig =
WatchConfig
{ confWatchMode = WatchModeOS
, confThreadingMode = SingleThread
, confOnHandlerException = defaultOnHandlerException
}
defaultOnHandlerException :: SomeException -> IO ()
defaultOnHandlerException e = putStrLn ("fsnotify: handler threw exception: " <> show e)
-- | 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 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 {..}) = do
mbCleanup <- swapMVar watchManagerCleanupVar Nothing
maybe (return ()) liftIO mbCleanup
liftIO $ killSession watchManagerManager
case watchManagerGlobalChan of
Nothing -> return ()
Just (_, t) -> cancel t
-- | 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 = do
# ifdef OS_Win32
-- See https://github.com/haskell-fswatch/hfsnotify/issues/50
unless rtsSupportsBoundThreads $ throwIO $ userError "startManagerConf must be called with -threaded on Windows"
# endif
case confWatchMode conf of
WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> cleanupVar <*> globalWatchChan
WatchModeOS -> liftIO (initSession ()) >>= createManager
where
createManager :: Either Text NativeManager -> IO (WatchManager)
createManager (Right nativeManager) = WatchManager conf nativeManager <$> cleanupVar <*> globalWatchChan
createManager (Left err) = throwIO $ userError $ T.unpack $ "Error: couldn't start native file manager: " <> err
globalWatchChan = case confThreadingMode conf of
SingleThread -> do
globalChan <- newChan
globalReaderThread <- async $ forever $ do
(event, action) <- readChan globalChan
tryAny (action event) >>= \case
Left _ -> return () -- TODO: surface the exception somehow?
Right () -> return ()
return $ Just (globalChan, globalReaderThread)
_ -> return Nothing
cleanupVar = newMVar (Just (return ()))
-- | 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 {..}) path actionPredicate chan = listen watchManagerConfig watchManagerManager path actionPredicate (writeChan chan)
-- | 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 {..}) path actionPredicate chan = listenRecursive watchManagerConfig watchManagerManager path actionPredicate (writeChan chan)
-- | 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@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listen wm fp actionPredicate wrappedAction
where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x)
-- | 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@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listenRecursive wm fp actionPredicate wrappedAction
where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x)
-- * Main threading logic
threadChan :: (forall a b. ListenFn a b) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
threadChan listenFn (WatchManager {watchManagerGlobalChan=(Just (globalChan, _)), ..}) path actPred action =
modifyMVar watchManagerCleanupVar $ \case
Nothing -> return (Nothing, return ()) -- we've been stopped. Throw an exception?
Just cleanup -> do
stopListener <- liftIO $ listenFn watchManagerConfig watchManagerManager path actPred (\event -> writeChan globalChan (event, action))
return (Just cleanup, stopListener)
threadChan listenFn (WatchManager {watchManagerGlobalChan=Nothing, ..}) path actPred action =
modifyMVar watchManagerCleanupVar $ \case
Nothing -> return (Nothing, return ()) -- we've been stopped. Throw an exception?
Just cleanup -> do
chan <- newChan
let forkThreadPerEvent = case confThreadingMode watchManagerConfig of
SingleThread -> error "Should never happen"
ThreadPerWatch -> False
ThreadPerEvent -> True
readerThread <- async $ readEvents forkThreadPerEvent chan
stopListener <- liftIO $ listenFn watchManagerConfig watchManagerManager path actPred (writeChan chan)
return (Just (cleanup >> cancel readerThread), stopListener >> cancel readerThread)
where
readEvents :: Bool -> EventChannel -> IO ()
readEvents True chan = forever $ readChan chan >>= (async . action)
readEvents False chan = forever $ readChan chan >>= action