fsnotify-0.0.11/0000755000000000000000000000000012135554505011625 5ustar0000000000000000fsnotify-0.0.11/fsnotify.cabal0000644000000000000000000000714212135554505014456 0ustar0000000000000000Name: fsnotify Version: 0.0.11 Author: Mark Dittmer Maintainer: Mark Dittmer , Greg Weber License: BSD3 License-File: LICENSE Synopsis: Cross platform library for file change 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 Extra-Source-Files: test/FSNotify.hs test/Path.hs test/Util.hs test/watch-here.hs Library Build-Depends: base >= 4.3.1.0 && < 5 , containers >= 0.4 , system-fileio >= 0.3.8 && < 0.4 , system-filepath >= 0.4.6 && <= 0.5 , text >= 0.11.0 , time >= 1.1 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.5 && < 0.4 else if os(windows) CPP-Options: -DOS_Win32 Other-Modules: System.FSNotify.Win32 Build-Depends: Win32-notify >= 0.3 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 -- , 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.0 -- , time >= 1.1 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 , 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.10 , time >= 1.1 , QuickCheck >= 2.4.2 , uniqueid >= 0.1.1 if os(linux) CPP-Options: -DOS_Linux Build-Depends: hinotify >= 0.3.5 && < 0.4 else if os(windows) CPP-Options: -DOS_Win32 Build-Depends: Win32-notify >= 0.3, 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 fsnotify-0.0.11/LICENSE0000644000000000000000000000276212135554505012641 0ustar0000000000000000Copyright (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. fsnotify-0.0.11/Setup.hs0000644000000000000000000000031412135554505013257 0ustar0000000000000000-- -- 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-0.0.11/src/0000755000000000000000000000000012135554505012414 5ustar0000000000000000fsnotify-0.0.11/src/System/0000755000000000000000000000000012135554505013700 5ustar0000000000000000fsnotify-0.0.11/src/System/FSNotify.hs0000644000000000000000000001344212135554505015741 0ustar0000000000000000-- -- 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 ( -- * Events Event(..) , EventChannel , eventTime , eventPath , Action , ActionPredicate -- * 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 :: WatchConfig 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 () fsnotify-0.0.11/src/System/FSNotify/0000755000000000000000000000000012135554505015401 5ustar0000000000000000fsnotify-0.0.11/src/System/FSNotify/Path.hs0000644000000000000000000000644212135554505016637 0ustar0000000000000000-- -- 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 fsnotify-0.0.11/src/System/FSNotify/OSX.hs0000644000000000000000000001562612135554505016420 0ustar0000000000000000-- -- 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 fsnotify-0.0.11/src/System/FSNotify/Win32.hs0000644000000000000000000000630412135554505016642 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# OPTIONS_GHC -fno-warn-orphans #-} module System.FSNotify.Win32 ( FileListener(..) , NativeManager ) where import Prelude hiding (FilePath) import Control.Concurrent.Chan import Control.Monad (when) import Data.IORef (atomicModifyIORef, readIORef) import Data.Time (getCurrentTime, UTCTime) import System.FSNotify.Listener 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 () -- Win32-notify has (temporarily?) dropped support for Renamed events. fsnEvent :: UTCTime -> WNo.Event -> Maybe Event fsnEvent timestamp (WNo.Created False name) = Just $ Added (fp name) timestamp fsnEvent timestamp (WNo.Modified False name) = Just $ Modified (fp name) timestamp fsnEvent timestamp (WNo.Deleted False name) = Just $ Removed (fp name) timestamp fsnEvent _ _ = Nothing {- 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] -} handleWNoEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () handleWNoEvent actPred chan dbp inoEvent = do currentTime <- getCurrentTime let maybeEvent = fsnEvent currentTime inoEvent case maybeEvent of Just evt -> handleEvent actPred chan dbp evt Nothing -> void handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO () handleEvent actPred chan dbp 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 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 db watchManager path actPred chan = do path' <- canonicalizeDirPath path dbp <- newDebouncePayload db _ <- WNo.watchDirectory watchManager (fp path') False varieties (handler actPred chan dbp) void listenRecursive db watchManager path actPred chan = do path' <- canonicalizeDirPath path dbp <- newDebouncePayload db _ <- WNo.watchDirectory watchManager (fp path') True varieties (handler actPred chan dbp) void handler :: ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () handler = handleWNoEvent varieties :: [WNo.EventVariety] varieties = [WNo.Create, WNo.Delete, WNo.Move, WNo.Modify] fsnotify-0.0.11/src/System/FSNotify/Polling.hs0000644000000000000000000001042012135554505017336 0ustar0000000000000000-- -- 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) fsnotify-0.0.11/src/System/FSNotify/Listener.hs0000644000000000000000000000606012135554505017524 0ustar0000000000000000-- -- 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 fsnotify-0.0.11/src/System/FSNotify/Devel.hs0000644000000000000000000000406112135554505016775 0ustar0000000000000000module 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 fsnotify-0.0.11/src/System/FSNotify/Linux.hs0000644000000000000000000001021212135554505017030 0ustar0000000000000000-- -- 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 fsnotify-0.0.11/src/System/FSNotify/Types.hs0000644000000000000000000000467712135554505017057 0ustar0000000000000000-- -- 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 fsnotify-0.0.11/test/0000755000000000000000000000000012135554505012604 5ustar0000000000000000fsnotify-0.0.11/test/Util.hs0000644000000000000000000001511012135554505014053 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- module Util where import Prelude hiding (FilePath, catch, pred) import Control.Concurrent (threadDelay) import Control.Concurrent.Chan import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) import Control.Exception import Control.Monad (when) import Data.Unique.Id import Filesystem.Path.CurrentOS hiding (concat) import Filesystem (createTree, removeTree) import System.IO.Error (isPermissionError) import System.FSNotify import System.FSNotify.Path import System.Random import System.Timeout (timeout) data ChanActionEnv = ChanEnv | ActionEnv data DirTreeEnv = DirEnv | TreeEnv data TestContext = TestContext ChanActionEnv DirTreeEnv ActionPredicate data TestReport = TestReport FilePath [Event] deriving (Show) data TestResult = TestResult Bool String TestReport deriving (Show) type TestAction = FilePath -> IO () type MTestResult = MVar TestResult type TestCase = MTestResult -> IO () type CurriedEventProcessor = TestReport -> IO (TestResult) type EventProcessor = MTestResult -> CurriedEventProcessor data EventPredicate = EventPredicate String (Event -> Bool) void :: IO () void = return () predicateName :: EventPredicate -> String predicateName (EventPredicate name _) = name matchEvents :: [EventPredicate] -> EventProcessor matchEvents preds mVar report@(TestReport _ events) = swapMVar mVar result >> return result where matchMatrix :: [[Bool]] matchMatrix = map (\(EventPredicate _ pred) -> map (\event -> pred event) events) preds matchList :: [Bool] matchList = map (\lst -> any id lst) matchMatrix errorList :: [(Bool, String)] errorList = zip matchList (map (\(EventPredicate errStr _) -> errStr) preds) errorString :: String errorString = foldl foldError "" errorList foldError :: String -> (Bool, String) -> String foldError accStr (success, errStr) = if not success then accStr ++ " " ++ errStr else accStr status :: Bool status = all id matchList result = if status then TestResult status "" report else TestResult status ("Failed to match events: " ++ errorString) report newId :: IO String newId = randomIO >>= initIdSupply >>= return . show . hashedId . idFromSupply testFileName :: String -> IO FilePath testFileName ext = do uId <- newId return $ fp ("test-" ++ uId ++ "." ++ ext) testName :: IO FilePath testName = do uId <- newId return $ fp ("sandbox-" ++ uId) empty dirPreAction :: Int dirPreAction = 500000 -- Delay to keep temporary directories around long enough for events to be -- picked up by OS (in microseconds) dirPostAction :: Int dirPostAction = 500000 withTempDir :: (FilePath -> IO ()) -> IO () withTempDir fn = withNestedTempDir empty fn withNestedTempDir :: FilePath -> (FilePath -> IO ()) -> IO () withNestedTempDir firstPath fn = do secondPath <- testName let path = if firstPath /= empty then firstPath secondPath else secondPath bracket (createTree path >> threadDelay dirPreAction >> return path) attemptDirectoryRemoval fn attemptDirectoryRemoval :: FilePath -> IO () attemptDirectoryRemoval path = do threadDelay dirPostAction catch (removeTree path) (\e -> when (not $ isPermissionError e) (throw e)) performAction :: TestAction -> FilePath -> IO () performAction action path = action path reportOnAction :: FilePath -> EventChannel -> CurriedEventProcessor -> IO TestResult reportOnAction = reportOnAction' [] reportOnAction' :: [Event] -> FilePath -> EventChannel -> CurriedEventProcessor -> IO TestResult reportOnAction' events path chan processor = do result@(TestResult status _ _) <- processor (TestReport path events) if not status then do event <- readChan chan reportOnAction' (event:events) path chan processor else return result actAndReport :: TestAction -> FilePath -> EventChannel -> CurriedEventProcessor -> IO TestResult actAndReport action path chan processor = do performAction action path reportOnAction path chan processor testTimeout :: Int testTimeout = 3000000 timeoutTest :: MTestResult -> Maybe () -> IO () timeoutTest mResult Nothing = do result <- readMVar mResult error $ "TIMEOUT: Last test result: " ++ show result timeoutTest mResult (Just _) = do result <- readMVar mResult case result of (TestResult False _ _) -> error $ show result (TestResult True _ _) -> void runTest :: TestCase -> IO () runTest test = do mVar <- newMVar $ TestResult False "Timeout with no test result" (TestReport empty []) timeout testTimeout (test mVar) >>= timeoutTest mVar inEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor -> IO () inEnv caEnv dtEnv reportPred action eventProcessor = withTempDir $ inTempDirEnv caEnv dtEnv reportPred action eventProcessor inTempDirEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor-> FilePath -> IO () inTempDirEnv caEnv dtEnv reportPred action eventProcessor path = withManagerConf NoDebounce $ \manager -> do chan <- newChan inTempDirChanEnv caEnv dtEnv reportPred action eventProcessor path manager chan inChanEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor -> EventChannel -> IO () inChanEnv caEnv dtEnv reportPred action eventProcessor chan = withTempDir $ \path -> do withManagerConf NoDebounce $ \manager -> do inTempDirChanEnv caEnv dtEnv reportPred action eventProcessor path manager chan inTempDirChanEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor-> FilePath -> WatchManager -> EventChannel -> IO () inTempDirChanEnv caEnv dtEnv reportPred action eventProcessor path manager chan = do watchInEnv caEnv dtEnv manager path reportPred chan runTest $ \mVar -> do _ <- actAndReport action path chan $ eventProcessor mVar void void actionAsChan :: (WatchManager -> FilePath -> ActionPredicate -> Action -> IO ()) -> WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO () actionAsChan actionFunction wm path ap ec = actionFunction wm path ap (writeChan ec) watchInEnv :: ChanActionEnv -> DirTreeEnv -> WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO () watchInEnv ChanEnv DirEnv = watchDirChan watchInEnv ChanEnv TreeEnv = watchTreeChan watchInEnv ActionEnv DirEnv = actionAsChan watchDir watchInEnv ActionEnv TreeEnv = actionAsChan watchTree fsnotify-0.0.11/test/Path.hs0000644000000000000000000001117712135554505014043 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE CPP #-} module Path (spec) where import Prelude hiding (FilePath, writeFile) import Control.Applicative ((<*>)) import Filesystem (writeFile) import Filesystem.Path.CurrentOS (FilePath) import Filesystem.Path ((), empty) import System.FilePath.Glob (compile, match) import System.FSNotify.Path (canonicalizeDirPath, canonicalizePath, findDirs, findFiles, fp) import Test.Hspec (describe, it, Spec, shouldBe) import Util import qualified Data.ByteString as BS type Assertion = IO () -- Boolean XOR (.^.) :: Bool -> Bool -> Bool (.^.) True True = False (.^.) True False = True (.^.) False True = True (.^.) False False = False hasTrailingSlash :: FilePath -> (FilePath -> IO FilePath) -> Assertion hasTrailingSlash path canonicalizeFn = do let expectedTail = last $ fp (fp "dir" empty) -- Get OS/filesystem's idea of a separator actualPath <- canonicalizeFn path let actualTail = last (fp actualPath) :: Char actualTail `shouldBe` expectedTail relPath :: FilePath relPathSlash :: FilePath absPath :: FilePath absPathSlash :: FilePath relPath = fp "." #ifdef OS_Linux absPath = fp "/home" absPathSlash = fp "/home/" relPathSlash = fp "./" empty #else # ifdef OS_Win32 absPath = fp "C:" fp "Windows" absPathSlash = fp "C:" fp "Windows" empty relPathSlash = fp ".\\" empty # else # ifdef OS_Mac absPath = fp "/Users" absPathSlash = fp "/Users/" relPathSlash = fp "./" # else -- Assume UNIX-like for anything non-Linux/Windows/Mac absPath = fp "/home" absPathSlash = fp "/home/" relPathSlash = fp "./" empty # endif # endif #endif spec :: Spec spec = do describe "canonicalizeDirPath" $ do it "Absolute path keeps trailing slash" $ do hasTrailingSlash absPathSlash canonicalizeDirPath it "Absolute path gains trailing slash" $ do hasTrailingSlash absPath canonicalizeDirPath it "Relative path keeps trailing slash" $ do hasTrailingSlash relPathSlash canonicalizeDirPath it "Relative path gains trailing slash" $ do hasTrailingSlash relPath canonicalizeDirPath describe "canonicalizePath" $ do it "Absolute path keeps trailing slash" $ do hasTrailingSlash absPathSlash canonicalizePath it "Relative path keeps trailing slash" $ do hasTrailingSlash relPathSlash canonicalizePath describe "findFiles" $ do it "Non-recursive" $ do withTempDir $ \tmpDir -> do fileName <- testFileName "txt" writeFile (tmpDir fileName) BS.empty files <- findFiles False tmpDir 1 `shouldBe` length files let (resultFP:_) = files pattern = "**/*" ++ fp fileName result = fp resultFP if match (compile pattern) result then True `shouldBe` True else result `shouldBe` pattern it "Recursive" $ do withTempDir $ \tmpDir -> do withNestedTempDir tmpDir $ \tmpPath -> do fileName <- testFileName "txt" writeFile (tmpPath fileName) BS.empty files <- findFiles True tmpDir 1 `shouldBe` length files let (resultFP:_) = files pattern = "**/*" ++ fp fileName result = fp resultFP if match (compile pattern) result then True `shouldBe` True else result `shouldBe` pattern describe "findDirs" $ do it "Non-recursive" $ withTempDir $ \tmpDir -> do withNestedTempDir tmpDir $ \dirName -> do dirs <- findDirs False tmpDir 1 `shouldBe` length dirs let (resultFP:_) = dirs pattern = "**/*" ++ fp dirName result = fp resultFP if match (compile pattern) result then True `shouldBe` True else result `shouldBe` pattern it "Recursive" $ withTempDir $ \tmpDir -> do withNestedTempDir tmpDir $ \dirName1 -> do withNestedTempDir tmpDir $ \dirName2 -> do dirs <- findDirs False tmpDir 2 `shouldBe` length dirs let pats = ["**/*" ++ fp dirName1, "**/*" ++ fp dirName2] patFns = map (match . compile) pats dirStrings = map fp dirs (r1:r2:r3:r4:_) = patFns <*> dirStrings -- The two patterns should succeed once and fail once on -- opposite tests. if (r1 .^. r2) && (r3 .^. r4) && (r1 .^. r3) && (r2 .^. r4) then True `shouldBe` True else dirStrings `shouldBe` pats return () fsnotify-0.0.11/test/FSNotify.hs0000644000000000000000000002020012135554505014633 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- module FSNotify (spec) where import Prelude hiding (appendFile, FilePath, writeFile) import Control.Concurrent.Chan (newChan, writeChan) import Data.ByteString (empty) import Data.Text (pack) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Filesystem (removeFile, rename, writeFile, writeTextFile) import Filesystem.Path.CurrentOS ((), FilePath) import System.FilePath.Glob (compile, match, Pattern) import System.FSNotify.Path (fp) import System.FSNotify.Types import Test.Hspec (describe, it, Spec) import Util type Assertion = IO () spec :: Spec spec = do describe "watchDir" $ do it "Create file" $ testFileName "txt" >>= createFileSpec ActionEnv it "Modify file" $ testFileName "txt" >>= modifyFileSpec ActionEnv it "Remove file" $ testFileName "txt" >>= removeFileSpec ActionEnv it "Rename file" $ renameInput >>= renameFileSpec ActionEnv it "Debounce" $ testFileName "txt" >>= dbFileSpec ActionEnv describe "watchDirChan" $ do it "Create file" $ testFileName "txt" >>= createFileSpec ChanEnv it "Modify file" $ testFileName "txt" >>= modifyFileSpec ChanEnv it "Remove file" $ testFileName "txt" >>= removeFileSpec ChanEnv it "Rename file" $ renameInput >>= renameFileSpec ChanEnv describe "watchTree" $ do it "Create file (pre-existing directory)" $ testFileName "txt" >>= createFileSpecR1 ActionEnv it "Create file (create directory)" $ testFileName "txt" >>= createFileSpecR2 ActionEnv it "Modify file" $ testFileName "txt" >>= modifyFileSpecR ActionEnv it "Remove file" $ testFileName "txt" >>= removeFileSpecR ActionEnv it "Rename file" $ renameInput >>= renameFileSpecR ActionEnv describe "watchTreeChan" $ do it "Create file (pre-existing directory)" $ testFileName "txt" >>= createFileSpecR1 ChanEnv it "Create file (create directory)" $ testFileName "txt" >>= createFileSpecR2 ChanEnv it "Modify file" $ testFileName "txt" >>= modifyFileSpecR ChanEnv it "Remove file" $ testFileName "txt" >>= removeFileSpecR ChanEnv it "Rename file" $ renameInput >>= renameFileSpecR ChanEnv createFileSpec :: ChanActionEnv -> FilePath -> Assertion createFileSpec envType fileName = do inEnv envType DirEnv act action $ matchEvents matchers where action :: FilePath -> IO () action envDir = writeFile (envDir fileName) empty matchers :: [EventPredicate] matchers = [EventPredicate "File creation" (matchCreate fileName)] modifyFileSpec :: ChanActionEnv -> FilePath -> Assertion modifyFileSpec envType fileName = do withTempDir $ \envDir -> do writeFile (envDir fileName) empty inTempDirEnv envType DirEnv act action (matchEvents matchers) envDir where action :: FilePath -> IO () action envDir = do writeTextFile (envDir fileName) $ pack "Hello world" matchers :: [EventPredicate] matchers = [EventPredicate "File modification" (matchModify fileName)] removeFileSpec :: ChanActionEnv -> FilePath -> Assertion removeFileSpec envType fileName = do withTempDir $ \envDir -> do writeFile (envDir fileName) empty inTempDirEnv envType DirEnv act action (matchEvents matchers) envDir where action :: FilePath -> IO () action envDir = removeFile (envDir fileName) matchers :: [EventPredicate] matchers = [EventPredicate "File deletion" (matchRemove fileName)] renameFileSpec :: ChanActionEnv -> (FilePath, FilePath) -> Assertion renameFileSpec envType (oldFileName, newFileName) = do withTempDir $ \envDir -> do writeFile (envDir oldFileName) empty inTempDirEnv envType DirEnv act action (matchEvents matchers) envDir where action :: FilePath -> IO () action envDir = rename (envDir oldFileName) (envDir newFileName) matchers :: [EventPredicate] matchers = [ EventPredicate "Rename: File deletion" (matchRemove oldFileName) , EventPredicate "Rename: File creation" (matchCreate newFileName) ] -- TODO: This is a weak test. What we actually need is an interface for -- "anti-matchers" to ensure that certain events do NOT get reported. dbFileSpec :: ChanActionEnv -> FilePath -> Assertion dbFileSpec envType _ = do chan <- newChan inChanEnv envType DirEnv act (action chan) (matchEvents matchers) chan where action :: EventChannel -> FilePath -> IO () action chan _ = do writeChan chan e1 writeChan chan e2 matchers :: [EventPredicate] matchers = [EventPredicate "First debounced event" (\e -> e == e1)] e1 :: Event e1 = Added (fp "") (posixSecondsToUTCTime 0) e2 :: Event e2 = Modified (fp "") (posixSecondsToUTCTime 0) createFileSpecR1 :: ChanActionEnv -> FilePath -> Assertion createFileSpecR1 envType fileName = do withTempDir $ \envDir -> do withNestedTempDir envDir $ \envPath -> do inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir where action :: FilePath -> FilePath -> IO () action envPath _ = do writeFile (envPath fileName) empty matchers :: [EventPredicate] matchers = [EventPredicate "File creation" (matchCreate fileName)] createFileSpecR2 :: ChanActionEnv -> FilePath -> Assertion createFileSpecR2 envType fileName = do withTempDir $ \envDir -> do inTempDirEnv envType TreeEnv act (action envDir) (matchEvents matchers) envDir where action :: FilePath -> FilePath -> IO () action envDir _ = do withNestedTempDir envDir $ \envPath -> writeFile (envPath fileName) empty matchers :: [EventPredicate] matchers = [EventPredicate "File creation" (matchCreate fileName)] modifyFileSpecR :: ChanActionEnv -> FilePath -> Assertion modifyFileSpecR envType fileName = do withTempDir $ \envDir -> do withNestedTempDir envDir $ \envPath -> do writeFile (envPath fileName) empty inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir where action :: FilePath -> FilePath -> IO () action envPath _ = do writeTextFile (envPath fileName) $ pack "Hello world" matchers :: [EventPredicate] matchers = [EventPredicate "File deletion" (matchModify fileName)] removeFileSpecR :: ChanActionEnv -> FilePath -> Assertion removeFileSpecR envType fileName = do withTempDir $ \envDir -> do withNestedTempDir envDir $ \envPath -> do writeFile (envPath fileName) empty inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir where action :: FilePath -> FilePath -> IO () action envPath _ = do removeFile (envPath fileName) matchers :: [EventPredicate] matchers = [EventPredicate "File deletion" (matchRemove fileName)] renameFileSpecR :: ChanActionEnv -> (FilePath, FilePath) -> Assertion renameFileSpecR envType (oldFileName, newFileName) = do withTempDir $ \envDir -> do withNestedTempDir envDir $ \envPath -> do writeFile (envPath oldFileName) empty inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir where action :: FilePath -> FilePath -> IO () action envPath _ = rename (envPath oldFileName) (envPath newFileName) matchers :: [EventPredicate] matchers = [ EventPredicate "Rename: File deletion" (matchRemove oldFileName) , EventPredicate "Rename: File creation" (matchCreate newFileName) ] renameInput :: IO (FilePath, FilePath) renameInput = do oldName <- testFileName "txt" newName <- testFileName "txt" return (oldName, newName) matchCreate :: FilePath -> Event -> Bool matchCreate fileName (Added path _) = matchFP pattern path where pattern = compile $ "**/*" ++ fp fileName matchCreate _ _ = False matchModify :: FilePath -> Event -> Bool matchModify fileName (Modified path _) = matchFP pattern path where pattern = compile $ "**/*" ++ fp fileName matchModify _ _ = False matchRemove :: FilePath -> Event -> Bool matchRemove fileName (Removed path _) = matchFP pattern path where pattern = compile $ "**/*" ++ fp fileName matchRemove _ _ = False matchFP :: Pattern -> FilePath -> Bool matchFP pattern path = match pattern $ fp path fsnotify-0.0.11/test/main.hs0000644000000000000000000000027012135554505014063 0ustar0000000000000000module 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 fsnotify-0.0.11/test/watch-here.hs0000644000000000000000000000060312135554505015166 0ustar0000000000000000{- {-# LANGUAGE OverloadedStrings #-} import Filesystem.Path.CurrentOS -} import System.FSNotify import Filesystem main :: IO () main = do -- let wd = "." wd <- getWorkingDirectory print wd man <- startManager watchTree man wd (const True) print print "press retrun to stop" getLine print "watching stopped, press retrun to exit" stopManager man getLine return ()