fsnotify (empty) → 0.0.1
raw patch · 13 files changed
+1040/−0 lines, 13 filesdep +Win32-notifydep +basedep +containerssetup-changed
Dependencies added: Win32-notify, base, containers, directory, hfsevents, hinotify, system-fileio, system-filepath, text, time
Files
- LICENSE +30/−0
- Setup.hs +11/−0
- fsnotify.cabal +98/−0
- src/System/FSNotify.hs +151/−0
- src/System/FSNotify/Devel.hs +68/−0
- src/System/FSNotify/Linux.hs +99/−0
- src/System/FSNotify/Listener.hs +71/−0
- src/System/FSNotify/OSX.hs +146/−0
- src/System/FSNotify/Path.hs +88/−0
- src/System/FSNotify/Polling.hs +114/−0
- src/System/FSNotify/Types.hs +76/−0
- src/System/FSNotify/Win32.hs +77/−0
- test/main.hs +11/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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
+ fsnotify.cabal view
@@ -0,0 +1,98 @@+Name: fsnotify+Version: 0.0.1+Author: Mark Dittmer <mark.s.dittmer@gmail.com>+Maintainer: Mark Dittmer <mark.s.dittmer@gmail.com>, Greg Weber <greg@gregweber.info>+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
+ src/System/FSNotify.hs view
@@ -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 ()
+ src/System/FSNotify/Devel.hs view
@@ -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
+ src/System/FSNotify/Linux.hs view
@@ -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
+ src/System/FSNotify/Listener.hs view
@@ -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
+ src/System/FSNotify/OSX.hs view
@@ -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
+ src/System/FSNotify/Path.hs view
@@ -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
+ src/System/FSNotify/Polling.hs view
@@ -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)
+ src/System/FSNotify/Types.hs view
@@ -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
+ src/System/FSNotify/Win32.hs view
@@ -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]
+ test/main.hs view
@@ -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