diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Mark Dittmer + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mark Dittmer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,11 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org + + + +-- + +import Distribution.Simple + +main = defaultMain diff --git a/fsnotify.cabal b/fsnotify.cabal new file mode 100644 --- /dev/null +++ b/fsnotify.cabal @@ -0,0 +1,98 @@ +Name: fsnotify +Version: 0.0.1 +Author: Mark Dittmer +Maintainer: Mark Dittmer , Greg Weber +License: BSD3 +License-File: LICENSE +Synopsis: Cross platform library for file creation, modification, + and deletion notification. +Description: Cross platform library for file creation, modification, + and deletion notification. This library builds upon + existing libraries for platform-specific Window, Mac, + and Linux filesystem event notification. +Category: Filesystem +Cabal-Version: >= 1.8 +Build-Type: Simple + + +Library + Build-Depends: base >= 4.3.1.0 && < 5 + , containers >= 0.4.2.1 + , directory >= 1.1.0.2 + , system-fileio >= 0.3.8 && < 0.4 + , system-filepath >= 0.4.6 && <= 0.5 + , text >= 0.11.2.0 + , time >= 1.4 + Exposed-Modules: System.FSNotify + , System.FSNotify.Devel + Other-Modules: System.FSNotify.Listener + , System.FSNotify.Path + , System.FSNotify.Polling + , System.FSNotify.Types + Hs-Source-Dirs: src + GHC-Options: -Wall + if os(linux) + CPP-Options: -DOS_Linux + Other-Modules: System.FSNotify.Linux + Build-Depends: hinotify == 0.3.2 + else + if os(windows) + CPP-Options: -DOS_Win32 + Other-Modules: System.FSNotify.Win32 + Build-Depends: Win32-notify == 0.2 + else + if os(darwin) + CPP-Options: -DOS_Mac + Other-Modules: System.FSNotify.OSX + Build-Depends: hfsevents >= 0.1.3 + +-- executable watch-here +-- hs-source-dirs: src, test +-- main-is: watch-here.hs +-- build-depends: base +-- , containers >= 0.4.2.1 +-- , directory >= 1.1.0.2 +-- , filepath >= 1.3.0.0 +-- , Glob >= 0.7.1 +-- , system-fileio >= 0.3.8 +-- , system-filepath >= 0.4.6 +-- , text >= 0.11.2.0 +-- , time >= 1.4 + +Test-Suite test + Type: exitcode-stdio-1.0 + Main-Is: main.hs + -- Type: detailed-0.9 + -- Test-Module: Tests + Hs-Source-Dirs: test, src + GHC-Options: -Wall -threaded + Build-depends: base >= 4.3.1.0 + , bytestring >= 0.9.2.1 + , Cabal >= 1.14.0 + , containers >= 0.4.2.1 + , directory >= 1.1.0.2 + , Glob >= 0.7.1 + , hspec >= 1.3.0 + , random >= 1.0.1.1 + , system-filepath >= 0.4.6 + , system-fileio >= 0.3.7 + , text >= 0.11.2.0 + , time >= 1.4 + , QuickCheck >= 2.4.2 + , uniqueid >= 0.1.1 + if os(linux) + CPP-Options: -DOS_Linux + Build-Depends: hinotify == 0.3.2 + else + if os(windows) + CPP-Options: -DOS_Win32 + Build-Depends: Win32-notify == 0.2, ghc >= 7.4.2 + else + if os(darwin) + CPP-Options: -DOS_Mac + Build-Depends: hfsevents >= 0.1.3 + + +Source-Repository head + Type: git + Location: git://github.com/mdittmer/hfsnotify diff --git a/src/System/FSNotify.hs b/src/System/FSNotify.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify.hs @@ -0,0 +1,151 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +-- | cross-platform file watching. + +module System.FSNotify + ( Event(..) + + -- * Starting/Stopping + , WatchManager + , withManager + , startManager + , stopManager + , defaultConfig + , WatchConfig(..) + , withManagerConf + , startManagerConf + + -- * Watching + , 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 = DebounceDefault + +-- | 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) = + 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 + +-- | 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 () +watchDirChan (WatchManager db wm) = either (listen db) (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 () +watchTreeChan (WatchManager db wm) = either (listenRecursive db) (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. No two events pertaining to the same FilePath will +-- be executed concurrently. +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 + + +-- | 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. No two events +-- pertaining to the same FilePath will be executed concurrently. +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 () diff --git a/src/System/FSNotify/Devel.hs b/src/System/FSNotify/Devel.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Devel.hs @@ -0,0 +1,68 @@ +module System.FSNotify.Devel + ( treeExtAny, treeExtExists, + doAllEvents, + allEvents, existsEvents + ) where + +import Prelude hiding (FilePath, catch) + +import Data.Text +import Filesystem.Path.CurrentOS +import System.FSNotify +-- import System.FSNotify.Path (fp) + +-- | Example of compiling scss files with compass +-- @ +-- compass :: WatchManager -> FilePath -> IO () +-- compass man dir = do +-- putStrLn $ "compass " ++ encodeString dir +-- treeExtExists man dir "scss" $ \fp -> +-- when ("deploy" `notElem` splitDirectories fp) $ do +-- let d = encodeString $ head (splitDirectories rel) +-- system "cd " ++ d ++ "&& bundle exec compass compile" +-- return () +-- @ + +-- | In the given directory tree, +-- watch for any Added and Modified events (but ignore Removed events) +-- for files with the given file extension +-- perform the given action +treeExtExists :: WatchManager + -> FilePath -- ^ Directory to watch + -> Text -- ^ extension + -> (FilePath -> IO ()) -- ^ action to run on file + -> IO () +treeExtExists man dir ext action = + watchTree man dir (existsEvents $ flip hasExtension ext) (doAllEvents action) + +-- | In the given directory tree, +-- for files with the given file extension +-- perform the given action +treeExtAny :: WatchManager + -> FilePath -- ^ Directory to watch + -> Text -- ^ extension + -> (FilePath -> IO ()) -- ^ action to run on file + -> IO () +treeExtAny man dir ext action = + watchTree man dir (existsEvents $ flip hasExtension ext) (doAllEvents action) + +doAllEvents :: Monad m => (FilePath -> m ()) -> Event -> m () +doAllEvents action event = + case event of + Added f _ -> action f + Modified f _ -> action f + Removed f _ -> action f + +existsEvents :: (FilePath -> Bool) -> (Event -> Bool) +existsEvents filt event = + case event of + Added f _ -> filt f + Modified f _ -> filt f + Removed _ _ -> False + +allEvents :: (FilePath -> Bool) -> (Event -> Bool) +allEvents filt event = + case event of + Added f _ -> filt f + Modified f _ -> filt f + Removed f _ -> filt f diff --git a/src/System/FSNotify/Linux.hs b/src/System/FSNotify/Linux.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Linux.hs @@ -0,0 +1,99 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module System.FSNotify.Linux + ( FileListener(..) + , NativeManager + ) where + +import Prelude hiding (FilePath) + +import Control.Concurrent.Chan +import Control.Exception +import Control.Monad (when) +import Data.IORef (atomicModifyIORef, readIORef) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Typeable +-- import Debug.Trace (trace) +import Filesystem.Path.CurrentOS +import System.FSNotify.Listener +import System.FSNotify.Path (findDirs, fp, canonicalizeDirPath) +import System.FSNotify.Types +import qualified System.INotify as INo + +type NativeManager = INo.INotify + +data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable) +instance Exception EventVarietyMismatchException + +void :: IO () +void = return () + +-- Note that INo.Closed in this context is "modified" because we listen to +-- CloseWrite events. +fsnEvent :: FilePath -> UTCTime -> INo.Event -> Maybe Event +fsnEvent basePath timestamp (INo.Created False name ) = Just (Added (basePath (fp name)) timestamp) +fsnEvent basePath timestamp (INo.Closed False (Just name) _) = Just (Modified (basePath (fp name)) timestamp) +fsnEvent basePath timestamp (INo.MovedOut False name _) = Just (Removed (basePath (fp name)) timestamp) +fsnEvent basePath timestamp (INo.MovedIn False name _) = Just (Added (basePath (fp name)) timestamp) +fsnEvent basePath timestamp (INo.Deleted False name ) = Just (Removed (basePath (fp name)) timestamp) +fsnEvent _ _ _ = Nothing + +handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO () +-- handleInoEvent _ _ basePath _ inoEvent | trace ("Linux: handleInoEvent " ++ show basePath ++ " " ++ show inoEvent) False = undefined +handleInoEvent actPred chan basePath dbp inoEvent = do + currentTime <- getCurrentTime + let maybeFsnEvent = fsnEvent basePath currentTime inoEvent + handleEvent actPred chan dbp maybeFsnEvent + +handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Maybe Event -> IO () +-- handleEvent actPred _ _ (Just event) | trace ("Linux: handleEvent " ++ show (actPred event) ++ " " ++ show event) False = undefined +handleEvent actPred chan dbp (Just event) = + when (actPred event) $ case dbp of + (Just (DebounceData epsilon ior)) -> do + lastEvent <- readIORef ior + when (not $ debounce epsilon lastEvent event) writeToChan + atomicModifyIORef ior (\_ -> (event, ())) + Nothing -> writeToChan + where + writeToChan = writeChan chan event +-- handleEvent _ _ _ Nothing | trace ("Linux handleEvent Nothing") False = undefined +handleEvent _ _ _ Nothing = void + +varieties :: [INo.EventVariety] +varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.CloseWrite] + +instance FileListener INo.INotify where + initSession = fmap Just INo.initINotify + + killSession = INo.killINotify + + listen db iNotify path actPred chan = do + path' <- canonicalizeDirPath path + dbp <- newDebouncePayload db + _ <- INo.addWatch iNotify varieties (encodeString path') (handler path' dbp) + void + where + handler :: FilePath -> DebouncePayload -> INo.Event -> IO () + handler = handleInoEvent actPred chan + + listenRecursive db iNotify path actPred chan = do + path' <- canonicalizeDirPath path + paths <- findDirs True path' + mapM_ pathHandler (path':paths) + where + pathHandler :: FilePath -> IO () + pathHandler filePath = do + dbp <- newDebouncePayload db + _ <- INo.addWatch iNotify varieties (fp filePath) (handler filePath dbp) + void + where + handler :: FilePath -> DebouncePayload -> INo.Event -> IO () + handler baseDir _ (INo.Created True dirPath) = + listenRecursive db iNotify (baseDir (fp dirPath)) actPred chan + handler baseDir dbp event = + handleInoEvent actPred chan baseDir dbp event diff --git a/src/System/FSNotify/Listener.hs b/src/System/FSNotify/Listener.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Listener.hs @@ -0,0 +1,71 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- + +module System.FSNotify.Listener + ( debounce + , epsilonDefault + , FileListener(..) + , newDebouncePayload + ) where + +import Prelude hiding (FilePath) + +import Data.IORef (newIORef) +import Data.Time (diffUTCTime, NominalDiffTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Filesystem.Path.CurrentOS +import System.FSNotify.Path (fp) +import System.FSNotify.Types + +-- | A typeclass that imposes structure on watch managers capable of listening +-- for events, or simulated listening for events. +class FileListener sessionType where + -- | Initialize a file listener instance. + initSession :: IO (Maybe sessionType) -- ^ Just an initialized file listener, + -- or Nothing if this file listener + -- cannot be supported. + + -- | Kill a file listener instance. + -- This will immediately stop acting on events for all directories being + -- watched. + killSession :: sessionType -> IO () + + -- | Listen for file events associated with the immediate contents of a directory. + -- Listening for events associated with immediate contents of a directory will + -- only report events associated with files within the specified directory, and + -- not files within its subdirectories. + listen :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO () + + -- | Listen for file events associated with all the contents of a directory. + -- Listening for events associated with all the contents of a directory will + -- report events associated with files within the specified directory and its + -- subdirectories. + listenRecursive :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO () + +-- | The default maximum difference (exclusive, in seconds) for two +-- events to be considered as occuring "at the same time". +epsilonDefault :: NominalDiffTime +epsilonDefault = 0.001 + +-- | The default event that provides a basis for comparison. +eventDefault :: Event +eventDefault = Added (fp "") (posixSecondsToUTCTime 0) + +-- | A predicate indicating whether two events may be considered "the same +-- event". This predicate is applied to the most recent dispatched event and +-- the current event after the client-specified ActionPredicate is applied, +-- before the event is dispatched. +debounce :: NominalDiffTime -> Event -> Event -> Bool +debounce epsilon e1 e2 = + eventPath e1 == eventPath e2 && timeDiff > -epsilon && timeDiff < epsilon + where + timeDiff = diffUTCTime (eventTime e2) (eventTime e1) + +-- | Produces a fresh data payload used for debouncing events in a +-- handler. +newDebouncePayload :: WatchConfig -> IO DebouncePayload +newDebouncePayload DebounceDefault = newIORef eventDefault >>= return . Just . DebounceData epsilonDefault +newDebouncePayload (Debounce epsilon) = newIORef eventDefault >>= return . Just . DebounceData epsilon +newDebouncePayload NoDebounce = return Nothing diff --git a/src/System/FSNotify/OSX.hs b/src/System/FSNotify/OSX.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/OSX.hs @@ -0,0 +1,146 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- + +module System.FSNotify.OSX + ( FileListener(..) + , NativeManager + ) where + +import Prelude hiding (FilePath, catch) + +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Monad hiding (void) +import Data.Bits +import Data.IORef (atomicModifyIORef, readIORef) +import Data.Map (Map) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Word +-- import Debug.Trace (trace) +import Filesystem (isFile) +import Filesystem.Path hiding (concat) +import System.FSNotify.Listener +import System.FSNotify.Path (fp, canonicalizeDirPath) +import System.FSNotify.Types +import qualified Data.Map as Map +import qualified System.OSX.FSEvents as FSE + +data ListenType = NonRecursive | Recursive +data WatchData = WatchData FSE.EventStream ListenType EventChannel + +-- TODO: We really should use something other than FilePath as a key to allow +-- for more than one listener per FilePath. +type WatchMap = Map FilePath WatchData +data OSXManager = OSXManager (MVar WatchMap) +type NativeManager = OSXManager + +void :: IO () +void = return () + +nil :: Word64 +nil = 0x00 + +-- OS X reports the absolute (canonical) path without a trailing slash. Add +-- the trailing slash when the path refers to a directory +canonicalEventPath :: FSE.Event -> FilePath +canonicalEventPath event = + if flags .&. dirFlag /= nil then path empty else path + where + flags = FSE.eventFlags event + dirFlag = FSE.eventFlagItemIsDir + path = fp $ FSE.eventPath event + +fsnEvents :: UTCTime -> FSE.Event -> IO [Event] +fsnEvents timestamp fseEvent = liftM concat . sequence $ map (\f -> f fseEvent) (eventFunctions timestamp) + where + eventFunctions :: UTCTime -> [FSE.Event -> IO [Event]] + eventFunctions t = [addedFn t, modifFn t, removFn t, renamFn t] + addedFn t e = if hasFlag e FSE.eventFlagItemCreated then return [Added (path e) t] else return [] + modifFn t e = if (hasFlag e FSE.eventFlagItemModified + || hasFlag e FSE.eventFlagItemInodeMetaMod) then return [Modified (path e) t] else return [] + removFn t e = if hasFlag e FSE.eventFlagItemRemoved then return [Removed (path e) t] else return [] + renamFn t e = if hasFlag e FSE.eventFlagItemRenamed then + isFile (path e) >>= \exists -> if exists then return [Added (path e) t] else return [Removed (path e) t] + else + return [] + path = canonicalEventPath + hasFlag event flag = FSE.eventFlags event .&. flag /= 0 + +-- Separate logic is needed for non-recursive events in OSX because the +-- hfsevents package doesn't support non-recursive event reporting. + +handleNonRecursiveFSEEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO () +-- handleNonRecursiveFSEEvent _ _ dirPath _ fseEvent | trace ("OSX: handleNonRecursiveFSEEvent " ++ show dirPath ++ " " ++ show fseEvent) False = undefined +handleNonRecursiveFSEEvent actPred chan dirPath dbp fseEvent = do + currentTime <- getCurrentTime + events <- fsnEvents currentTime fseEvent + handleNonRecursiveEvents actPred chan dirPath dbp events +handleNonRecursiveEvents :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO () +-- handleNonRecursiveEvents actPred _ dirPath _ (event:_ ) | trace ( "OSX: handleNonRecursiveEvents " +-- ++ show dirPath ++ " " ++ show event +-- ++ "\n " ++ fp (directory dirPath) +-- ++ "\n " ++ fp (directory (eventPath event)) +-- ++ "\n " ++ show (actPred event)) False = undefined +handleNonRecursiveEvents actPred chan dirPath dbp (event:events) + | directory dirPath == directory (eventPath event) && actPred event = do + case dbp of + (Just (DebounceData epsilon ior)) -> do + lastEvent <- readIORef ior + when (not $ debounce epsilon lastEvent event) (writeChan chan event) + atomicModifyIORef ior (\_ -> (event, ())) + Nothing -> writeChan chan event + handleNonRecursiveEvents actPred chan dirPath dbp events + | otherwise = handleNonRecursiveEvents actPred chan dirPath dbp events +handleNonRecursiveEvents _ _ _ _ [] = void + +handleFSEEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> FSE.Event -> IO () +-- handleFSEEvent _ _ _ fseEvent | trace ("OSX: handleFSEEvent " ++ show fseEvent) False = undefined +handleFSEEvent actPred chan dbp fseEvent = do + currentTime <- getCurrentTime + events <- fsnEvents currentTime fseEvent + handleEvents actPred chan dbp events + +handleEvents :: ActionPredicate -> EventChannel -> DebouncePayload -> [Event] -> IO () +-- handleEvents actPred _ _ (event:_ ) | trace ("OSX: handleEvents " ++ show event ++ " " ++ show (actPred event)) False = undefined +handleEvents actPred chan dbp (event:events) = do + when (actPred event) $ case dbp of + (Just (DebounceData epsilon ior)) -> do + lastEvent <- readIORef ior + when (not $ debounce epsilon lastEvent event) (writeChan chan event) + atomicModifyIORef ior (\_ -> (event, ())) + Nothing -> writeChan chan event + handleEvents actPred chan dbp events +handleEvents _ _ _ [] = void + +instance FileListener OSXManager where + initSession = do + (v1, v2, _) <- FSE.osVersion + if not $ v1 > 10 || (v1 == 10 && v2 > 6) then return Nothing else + fmap (Just . OSXManager) $ newMVar Map.empty + + killSession (OSXManager mvarMap) = do + watchMap <- readMVar mvarMap + forM_ (Map.elems watchMap) eventStreamDestroy' + where + eventStreamDestroy' :: WatchData -> IO () + eventStreamDestroy' (WatchData eventStream _ _) = FSE.eventStreamDestroy eventStream + + listen db (OSXManager mvarMap) path actPred chan = do + path' <- canonicalizeDirPath path + dbp <- newDebouncePayload db + eventStream <- FSE.eventStreamCreate [fp path'] 0.0 True False True (handler path' dbp) + modifyMVar_ mvarMap $ \watchMap -> return (Map.insert path' (WatchData eventStream NonRecursive chan) watchMap) + where + handler :: FilePath -> DebouncePayload -> FSE.Event -> IO () + handler = handleNonRecursiveFSEEvent actPred chan + + listenRecursive db (OSXManager mvarMap) path actPred chan = do + path' <- canonicalizeDirPath path + dbp <- newDebouncePayload db + eventStream <- FSE.eventStreamCreate [fp path'] 0.0 True False True $ handler dbp + modifyMVar_ mvarMap $ \watchMap -> return (Map.insert path' (WatchData eventStream Recursive chan) watchMap) + where + handler :: DebouncePayload -> FSE.Event -> IO () + handler = handleFSEEvent actPred chan diff --git a/src/System/FSNotify/Path.hs b/src/System/FSNotify/Path.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Path.hs @@ -0,0 +1,88 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} + +module System.FSNotify.Path + ( fp + , findFiles + , findDirs + , canonicalizeDirPath + , canonicalizePath + ) where + +import Prelude hiding (FilePath) + +import Control.Monad +-- import Filesystem +-- import Filesystem.Path hiding (concat) +import Filesystem.Path.CurrentOS hiding (concat) + +import qualified Filesystem as FS +import qualified Filesystem.Path as FP + +-- This will ensure than any calls to fp for type coercion in FSNotify will not +-- break when/if the dependent package moves from using String to the more +-- efficient Filesystem.Path.FilePath +class ConvertFilePath a b where + fp :: a -> b +instance ConvertFilePath FilePath String where fp = encodeString +instance ConvertFilePath String FilePath where fp = decodeString +instance ConvertFilePath String String where fp = id +instance ConvertFilePath FilePath FilePath where fp = id + +getDirectoryContentsPath :: FilePath -> IO [FilePath] +getDirectoryContentsPath path = fmap (map (path )) $ FS.listDirectory path + +fileDirContents :: FilePath -> IO ([FilePath],[FilePath]) +fileDirContents path = do + contents <- getDirectoryContentsPath path + files <- filterM FS.isFile contents + dirs <- filterM FS.isDirectory contents + return (files, dirs) + +findAllFiles :: FilePath -> IO [FilePath] +findAllFiles path = do + (files, dirs) <- fileDirContents path + nestedFiles <- mapM findAllFiles dirs + return (files ++ concat nestedFiles) + +findImmediateFiles, findImmediateDirs :: FilePath -> IO [FilePath] +findImmediateFiles = getDirectoryContentsPath >=> filterM FS.isFile >=> canonicalize + where + canonicalize :: [FilePath] -> IO [FilePath] + canonicalize files = mapM FS.canonicalizePath files +findImmediateDirs = getDirectoryContentsPath >=> filterM FS.isDirectory >=> canonicalize + where + canonicalize :: [FilePath] -> IO [FilePath] + canonicalize dirs = mapM canonicalizeDirPath dirs + +findAllDirs :: FilePath -> IO [FilePath] +findAllDirs path = do + dirs <- findImmediateDirs path + nestedDirs <- mapM findAllDirs dirs + return (dirs ++ concat nestedDirs) + +findFiles :: Bool -> FilePath -> IO [FilePath] +findFiles True path = findAllFiles =<< canonicalizeDirPath path +findFiles False path = findImmediateFiles =<< canonicalizeDirPath path + +findDirs :: Bool -> FilePath -> IO [FilePath] +findDirs True path = findAllDirs =<< canonicalizeDirPath path +findDirs False path = findImmediateDirs =<< canonicalizeDirPath path + +-- | add a trailing slash to ensure the path indicates a directory +addTrailingSlash :: FilePath -> FilePath +addTrailingSlash p = + if FP.null (FP.filename p) then p else + p FP. FP.empty + +canonicalizeDirPath :: FilePath -> IO FilePath +canonicalizeDirPath path = addTrailingSlash `fmap` FS.canonicalizePath path + +-- | bugfix older version of canonicalizePath (system-fileio <= 0.3.7) loses trailing slash +canonicalizePath :: FilePath -> IO FilePath +canonicalizePath path = let was_dir = FP.null (FP.filename path) in + if not was_dir then FS.canonicalizePath path + else canonicalizeDirPath path diff --git a/src/System/FSNotify/Polling.hs b/src/System/FSNotify/Polling.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Polling.hs @@ -0,0 +1,114 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- + +module System.FSNotify.Polling + ( createPollManager + , PollManager(..) + , FileListener(..) + ) where + +import Prelude hiding (FilePath) + +import Control.Concurrent +import Data.Map (Map) +import Data.Maybe +import Data.Time.Clock (UTCTime, getCurrentTime) +-- import Debug.Trace (trace) +import Filesystem hiding (canonicalizePath) +import Filesystem.Path +import System.FSNotify.Listener +import System.FSNotify.Path (findFiles, canonicalizeDirPath) +import System.FSNotify.Types +import qualified Data.Map as Map +import Control.Monad (forM_) + +data EventType = + AddedEvent + | ModifiedEvent + | RemovedEvent + +data WatchKey = WatchKey ThreadId deriving (Eq, Ord) +data WatchData = WatchData FilePath EventChannel +type WatchMap = Map WatchKey WatchData +data PollManager = PollManager (MVar WatchMap) + +generateEvent :: UTCTime -> EventType -> FilePath -> Maybe Event +generateEvent timestamp AddedEvent filePath = Just (Added filePath timestamp) +generateEvent timestamp ModifiedEvent filePath = Just (Modified filePath timestamp) +generateEvent timestamp RemovedEvent filePath = Just (Removed filePath timestamp) + +generateEvents :: UTCTime -> EventType -> [FilePath] -> [Event] +generateEvents timestamp eventType = mapMaybe (generateEvent timestamp eventType) + +handleEvent :: EventChannel -> ActionPredicate -> Event -> IO () +handleEvent chan actPred event + | actPred event = writeChan chan event + | otherwise = return () + +pathModMap :: Bool -> FilePath -> IO (Map FilePath UTCTime) +pathModMap True path = findFiles True path >>= pathModMap' +pathModMap False path = findFiles False path >>= pathModMap' + +pathModMap' :: [FilePath] -> IO (Map FilePath UTCTime) +pathModMap' files = fmap Map.fromList $ mapM pathAndTime files + where + pathAndTime :: FilePath -> IO (FilePath, UTCTime) + pathAndTime path = do + modTime <- getModified path + return (path, modTime) + +pollPath :: Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath UTCTime -> IO () +pollPath recursive chan filePath actPred oldPathMap = do + threadDelay 1000000 + newPathMap <- pathModMap recursive filePath + currentTime <- getCurrentTime + let deletedMap = Map.difference oldPathMap newPathMap + createdMap = Map.difference newPathMap oldPathMap + modifiedAndCreatedMap = Map.differenceWith modifiedDifference newPathMap oldPathMap + modifiedMap = Map.difference modifiedAndCreatedMap createdMap + generateEvents' = generateEvents currentTime + handleEvents $ generateEvents' AddedEvent $ Map.keys createdMap + handleEvents $ generateEvents' ModifiedEvent $ Map.keys modifiedMap + handleEvents $ generateEvents' RemovedEvent $ Map.keys deletedMap + pollPath' newPathMap + where + modifiedDifference :: UTCTime -> UTCTime -> Maybe UTCTime + modifiedDifference newTime oldTime + | oldTime /= newTime = Just newTime + | otherwise = Nothing + + handleEvents :: [Event] -> IO () + handleEvents = mapM_ (handleEvent chan actPred) + + pollPath' :: Map FilePath UTCTime -> IO () + pollPath' = pollPath recursive chan filePath actPred + + +-- Additional init funciton exported to allow startManager to unconditionally +-- create a poll manager as a fallback when other managers will not instantiate. +createPollManager :: IO PollManager +createPollManager = fmap PollManager $ newMVar Map.empty + +instance FileListener PollManager where + initSession = fmap Just createPollManager + + killSession (PollManager mvarMap) = do + watchMap <- readMVar mvarMap + forM_ (Map.keys watchMap) killThread' + where + killThread' :: WatchKey -> IO () + killThread' (WatchKey threadId) = killThread threadId + + listen _ (PollManager mvarMap) path actPred chan = do + path' <- canonicalizeDirPath path + pmMap <- pathModMap False path' + threadId <- forkIO $ pollPath False chan path' actPred pmMap + modifyMVar_ mvarMap $ return . Map.insert (WatchKey threadId) (WatchData path' chan) + + listenRecursive _ (PollManager mvarMap) path actPred chan = do + path' <- canonicalizeDirPath path + pmMap <- pathModMap True path' + threadId <- forkIO $ pollPath True chan path' actPred pmMap + modifyMVar_ mvarMap $ return . Map.insert (WatchKey threadId) (WatchData path' chan) diff --git a/src/System/FSNotify/Types.hs b/src/System/FSNotify/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Types.hs @@ -0,0 +1,76 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- + +module System.FSNotify.Types + ( act + , ActionPredicate + , Action + , WatchConfig(..) + , DebounceData(..) + , DebouncePayload + , Event(..) + , EventChannel + , eventPath + , eventTime + , IOEvent + ) where + +import Prelude hiding (FilePath) + +import Control.Concurrent.Chan +import Data.IORef (IORef) +import Data.Time (NominalDiffTime) +import Data.Time.Clock (UTCTime) +import Filesystem.Path.CurrentOS + +-- | A file event reported by a file watcher. Each event contains the +-- canonical path for the file and a timestamp guaranteed to be after the +-- event occurred (timestamps represent current time when FSEvents receives +-- it from the OS and/or platform-specific Haskell modules). +data Event = + Added FilePath UTCTime + | Modified FilePath UTCTime + | Removed FilePath UTCTime + deriving (Eq, Show) + +-- | Helper for extracting the path associated with an event. +eventPath :: Event -> FilePath +eventPath (Added path _) = path +eventPath (Modified path _) = path +eventPath (Removed path _) = path + +-- | Helper for extracting the time associated with an event. +eventTime :: Event -> UTCTime +eventTime (Added _ timestamp) = timestamp +eventTime (Modified _ timestamp) = timestamp +eventTime (Removed _ timestamp) = timestamp + +type EventChannel = Chan Event + +-- | Config object, currently used just for debouncing events. +data WatchConfig = DebounceDefault | Debounce NominalDiffTime | NoDebounce + +type IOEvent = IORef Event + +-- | DebouncePayload contents. Contains epsilon value for debouncing +-- near-simultaneous events and an IORef of the latest Event. Difference in +-- arrival time is measured according to Event value timestamps. +data DebounceData = DebounceData NominalDiffTime IOEvent + +-- | Data "payload" passed to event handlers to enable debouncing. This value +-- is automatically derived from a 'WatchConfig' value. A value of Just +-- DebounceData results in debouncing according to the given epsilon and +-- IOEvent. A value of Nothing results in no debouncing. +type DebouncePayload = Maybe DebounceData + +-- | A predicate used to determine whether to act on an event. +type ActionPredicate = Event -> Bool + +-- | An action to be performed in response to an event. +type Action = Event -> IO () + +-- | Predicate to always act. +act :: ActionPredicate +act _ = True diff --git a/src/System/FSNotify/Win32.hs b/src/System/FSNotify/Win32.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Win32.hs @@ -0,0 +1,77 @@ +-- +-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org +-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org +-- + +module System.FSNotify.Win32 + ( FileListener(..) + , NativeManager + ) where + +import Prelude hiding (FilePath) +import System.IO hiding (FilePath) + +import Control.Concurrent.Chan +import Control.Monad (when) +import Data.IORef (atomicModifyIORef, newIORef, readIORef) +import Data.Time (getCurrentTime, UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Filesystem.Path.CurrentOS (FilePath) +import System.FSNotify.Listener (debounce, FileListener(..)) +import System.FSNotify.Path (fp, canonicalizeDirPath) +import System.FSNotify.Types +import qualified System.Win32.Notify as WNo + +type NativeManager = WNo.WatchManager + +-- NEXT TODO: Need to ensure we use properly canonalized paths as +-- event paths. In Linux this required passing the base dir to +-- handle[native]Event. + +void :: IO () +void = return () + +fsnEvents :: UTCTime -> WNo.Event -> [Event] +fsnEvents timestamp (WNo.Created False name) = [Added (fp name) timestamp] +fsnEvents timestamp (WNo.Renamed False (Just oldName) newName) = [Removed (fp oldName) timestamp, Added (fp newName) timestamp] +fsnEvents timestamp (WNo.Renamed False Nothing newName) = [Added (fp newName) timestamp] +fsnEvents timestamp (WNo.Modified False (Just name)) = [Modified (fp name) timestamp] +fsnEvents timestamp (WNo.Deleted False name) = [Removed (fp name) timestamp] +fsnEvents _ _ = [] + +handleWNoEvent :: IOEvent -> ActionPredicate -> EventChannel -> WNo.Event -> IO () +handleWNoEvent ior actPred chan inoEvent = do + currentTime <- getCurrentTime + mapM_ (handleEvent ior actPred chan) (fsnEvents currentTime inoEvent) +handleEvent :: IOEvent -> ActionPredicate -> EventChannel -> Event -> IO () +handleEvent ior actPred chan event = + when (actPred event) $ do + lastEvent <- readIORef ior + when (not $ debounce lastEvent event) (writeChan chan event) + atomicModifyIORef ior \_ -> (event, ()) + +instance FileListener WNo.WatchManager where + -- TODO: This should actually lookup a Windows API version and possibly return + -- Nothing the calls we need are not available. This will require that API + -- version information be exposed by Win32-notify. + initSession = fmap Just WNo.initWatchManager + + killSession = WNo.killWatchManager + + listen watchManager path actPred chan = do + path' <- canonicalizeDirPath path + ior <- newIORef (Added (fp "") (posixSecondsToUTCTime 0)) + _ <- WNo.watchDirectory watchManager (fp path') False varieties (handler ior actPred chan) + void + + listenRecursive watchManager path actPred chan = do + path' <- canonicalizeDirPath path + ior <- newIORef (Added (fp "") (posixSecondsToUTCTime 0)) + _ <- WNo.watchDirectory watchManager (fp path') True varieties (handler ior actPred chan) + void + +handler :: IOEvent -> ActionPredicate -> EventChannel -> WNo.Event -> IO () +handler = handleWNoEvent + +varieties :: [WNo.EventVariety] +varieties = [WNo.Create, WNo.Delete, WNo.Move, WNo.Modify] diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,11 @@ +module Main where + +import Test.Hspec (hspec, Spec) +import qualified Path as P +import qualified FSNotify as FSN + +main :: IO () +main = hspec spec + +spec :: Spec +spec = P.spec >> FSN.spec