module System.FSNotify
(
Event(..)
, EventChannel
, eventTime
, eventPath
, Action
, ActionPredicate
, WatchManager
, withManager
, startManager
, stopManager
, defaultConfig
, WatchConfig(..)
, withManagerConf
, startManagerConf
, watchDir
, watchDirChan
, watchTree
, watchTreeChan
) where
import Prelude hiding (FilePath, catch)
import Control.Concurrent
import Control.Exception
import Data.Map (Map)
import Filesystem.Path.CurrentOS
import System.FSNotify.Polling
import System.FSNotify.Types
import qualified Data.Map as Map
#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
data WatchManager = WatchManager WatchConfig (Either PollManager NativeManager)
defaultConfig :: WatchConfig
defaultConfig = DebounceDefault
withManager :: (WatchManager -> IO a) -> IO a
withManager = withManagerConf defaultConfig
startManager :: IO WatchManager
startManager = startManagerConf defaultConfig
stopManager :: WatchManager -> IO ()
stopManager (WatchManager _ wm) =
case wm of
Right native -> killSession native
Left poll -> killSession poll
withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf debounce = bracket (startManagerConf debounce) stopManager
startManagerConf :: WatchConfig -> IO WatchManager
startManagerConf debounce = initSession >>= createManager
where
createManager :: Maybe NativeManager -> IO WatchManager
createManager (Just nativeManager) = return (WatchManager debounce (Right nativeManager))
createManager Nothing = return . (WatchManager debounce) . Left =<< createPollManager
watchDirChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO ()
watchDirChan (WatchManager db wm) = either (listen db) (listen db) wm
watchTreeChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO ()
watchTreeChan (WatchManager db wm) = either (listenRecursive db) (listenRecursive db) wm
watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO ()
watchDir (WatchManager db wm) = either runFallback runNative wm
where
runFallback = threadChanFallback $ listen db
runNative = threadChanNative $ listen db
threadChanNative :: (NativeManager -> FilePath -> ActionPredicate -> Chan Event -> IO b) -> NativeManager -> FilePath -> ActionPredicate -> Action -> IO b
threadChanNative listener iface path actPred action =
threadChan action $ listener iface path actPred
threadChanFallback :: (PollManager -> FilePath -> ActionPredicate -> Chan Event -> IO b) -> PollManager -> FilePath -> ActionPredicate -> Action -> IO b
threadChanFallback listener iface path actPred action =
threadChan action $ listener iface path actPred
threadChan :: Action -> (Chan Event -> IO b) -> IO b
threadChan action runListener = do
chan <- newChan
_ <- forkIO $ readEvents chan action Map.empty
runListener chan
watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO ()
watchTree (WatchManager db wm) = either runFallback runNative wm
where
runFallback = threadChanFallback $ listenRecursive db
runNative = threadChanNative $ listenRecursive db
type ThreadLock = MVar ()
type PathLockMap = Map FilePath ThreadLock
readEvents :: EventChannel -> Action -> PathLockMap -> IO ()
readEvents chan action pathMap = do
event <- readChan chan
let path = eventPath event
mVar <- getMVar $ Map.lookup path pathMap
_ <- takeMVar mVar >> (forkIO $ action event `finally` putMVar mVar ())
readEvents chan action $ Map.insert path mVar pathMap
where
getMVar :: Maybe ThreadLock -> IO ThreadLock
getMVar (Just tl) = return tl
getMVar Nothing = newMVar ()