diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ Changes ======= +Version 0.2 +----------- + +Use filepath instead of deprecated system-filepath + Version 0.1.0.3 --------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,3 +2,18 @@ ========= Unified Haskell interface for basic file system notifications. + + +This is a library. There are executables built on top of it. + +* [spy](https://hackage.haskell.org/package/spy) +* [steeloverseer](https://github.com/schell/steeloverseer) + + +Requirements +============ + +Windows +------- + +compile with -fthreaded diff --git a/fsnotify.cabal b/fsnotify.cabal --- a/fsnotify.cabal +++ b/fsnotify.cabal @@ -1,5 +1,5 @@ Name: fsnotify -Version: 0.1.0.3 +Version: 0.2 Author: Mark Dittmer Maintainer: Greg Weber , Roman Cheplyaka License: BSD3 @@ -12,6 +12,7 @@ Category: Filesystem Cabal-Version: >= 1.8 Build-Type: Simple +Homepage: https://github.com/haskell-fswatch/hfsnotify Extra-Source-Files: README.md CHANGELOG.md @@ -22,11 +23,12 @@ Library Build-Depends: base >= 4.3.1 && < 5 , containers >= 0.4 - , system-fileio >= 0.3.8 - , system-filepath >= 0.4.6 + , directory >= 1.1.0.0 + , filepath >= 1.3.0.0 , text >= 0.11.0 , time >= 1.1 , async >= 2.0.1 + , unix-compat >= 0.2 Exposed-Modules: System.FSNotify , System.FSNotify.Devel Other-Modules: System.FSNotify.Listener @@ -59,9 +61,9 @@ Build-depends: base >= 4.3.1.0 , tasty >= 0.5 , tasty-hunit - , system-filepath >= 0.4.7 - , system-fileio >= 0.3.11 , directory + , filepath + , unix-compat , fsnotify , async >= 2 , temporary-rc diff --git a/src/System/FSNotify.hs b/src/System/FSNotify.hs --- a/src/System/FSNotify.hs +++ b/src/System/FSNotify.hs @@ -4,8 +4,11 @@ -- {-# LANGUAGE CPP, ScopedTypeVariables, ExistentialQuantification, RankNTypes #-} --- | Minimal example: +-- | NOTE: This library does not currently report changes made to directories, +-- only files within watched directories. -- +-- Minimal example: +-- -- >{-# LANGUAGE OverloadedStrings #-} -- for FilePath literals -- > -- >import System.FSNotify @@ -22,7 +25,7 @@ -- > print -- action -- > -- > -- sleep forever (until interrupted) --- > forever $ threadDelay maxBound +-- > forever $ threadDelay 1000000 module System.FSNotify ( @@ -63,7 +66,7 @@ import Control.Exception import Control.Applicative import Control.Monad -import Filesystem.Path.CurrentOS +import System.FilePath import System.FSNotify.Polling import System.FSNotify.Types @@ -92,6 +95,12 @@ (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped -- | Default configuration +-- +-- * Debouncing is enabled with a time interval of 1 millisecond +-- +-- * Polling is disabled +-- +-- * The polling interval defaults to 1 second defaultConfig :: WatchConfig defaultConfig = WatchConfig diff --git a/src/System/FSNotify/Devel.hs b/src/System/FSNotify/Devel.hs --- a/src/System/FSNotify/Devel.hs +++ b/src/System/FSNotify/Devel.hs @@ -22,8 +22,9 @@ import Prelude hiding (FilePath) import Data.Text -import Filesystem.Path.CurrentOS +import System.FilePath import System.FSNotify +import System.FSNotify.Path (hasThisExtension) -- | In the given directory tree, watch for any 'Added' and 'Modified' -- events (but ignore 'Removed' events) for files with the given file @@ -34,7 +35,7 @@ -> (FilePath -> IO ()) -- ^ action to run on file -> IO StopListening treeExtExists man dir ext action = - watchTree man dir (existsEvents $ flip hasExtension ext) (doAllEvents action) + watchTree man dir (existsEvents $ flip hasThisExtension ext) (doAllEvents action) -- | In the given directory tree, watch for any events for files with the -- given file extension @@ -44,7 +45,7 @@ -> (FilePath -> IO ()) -- ^ action to run on file -> IO StopListening treeExtAny man dir ext action = - watchTree man dir (allEvents $ flip hasExtension ext) (doAllEvents action) + watchTree man dir (allEvents $ flip hasThisExtension ext) (doAllEvents action) -- | Turn a 'FilePath' callback into an 'Event' callback that ignores the -- 'Event' type and timestamp diff --git a/src/System/FSNotify/Linux.hs b/src/System/FSNotify/Linux.hs --- a/src/System/FSNotify/Linux.hs +++ b/src/System/FSNotify/Linux.hs @@ -20,9 +20,9 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Typeable -- import Debug.Trace (trace) -import Filesystem.Path.CurrentOS +import System.FilePath import System.FSNotify.Listener -import System.FSNotify.Path (findDirs, fp, canonicalizeDirPath) +import System.FSNotify.Path (findDirs, canonicalizeDirPath) import System.FSNotify.Types import qualified System.INotify as INo @@ -34,11 +34,11 @@ -- 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 basePath timestamp (INo.Created False name ) = Just (Added (basePath name) timestamp) +fsnEvent basePath timestamp (INo.Closed False (Just name) _) = Just (Modified (basePath name) timestamp) +fsnEvent basePath timestamp (INo.MovedOut False name _) = Just (Removed (basePath name) timestamp) +fsnEvent basePath timestamp (INo.MovedIn False name _) = Just (Added (basePath name) timestamp) +fsnEvent basePath timestamp (INo.Deleted False name ) = Just (Removed (basePath name) timestamp) fsnEvent _ _ _ = Nothing handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO () @@ -73,7 +73,7 @@ listen conf iNotify path actPred chan = do path' <- canonicalizeDirPath path dbp <- newDebouncePayload $ confDebounce conf - wd <- INo.addWatch iNotify varieties (encodeString path') (handler path' dbp) + wd <- INo.addWatch iNotify varieties path' (handler path' dbp) return $ INo.removeWatch wd where handler :: FilePath -> DebouncePayload -> INo.Event -> IO () @@ -116,12 +116,12 @@ case mbWds of Nothing -> return mbWds Just wds -> do - wd <- INo.addWatch iNotify varieties (fp filePath) (handler filePath dbp) + wd <- INo.addWatch iNotify varieties filePath (handler filePath dbp) return $ Just (wd:wds) where handler :: FilePath -> DebouncePayload -> INo.Event -> IO () handler baseDir _ (INo.Created True dirPath) = do - listenRec (baseDir fp dirPath) wdVar + listenRec (baseDir dirPath) wdVar handler baseDir dbp event = handleInoEvent actPred chan baseDir dbp event diff --git a/src/System/FSNotify/Listener.hs b/src/System/FSNotify/Listener.hs --- a/src/System/FSNotify/Listener.hs +++ b/src/System/FSNotify/Listener.hs @@ -16,8 +16,7 @@ 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.FilePath import System.FSNotify.Types -- | An action that cancels a watching/listening job @@ -58,7 +57,7 @@ -- | The default event that provides a basis for comparison. eventDefault :: Event -eventDefault = Added (fp "") (posixSecondsToUTCTime 0) +eventDefault = Added "" (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 diff --git a/src/System/FSNotify/Path.hs b/src/System/FSNotify/Path.hs --- a/src/System/FSNotify/Path.hs +++ b/src/System/FSNotify/Path.hs @@ -5,41 +5,39 @@ {-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} module System.FSNotify.Path - ( fp - , findFiles + ( findFiles , findDirs , canonicalizeDirPath , canonicalizePath + , hasThisExtension ) where import Prelude hiding (FilePath) +import Control.Applicative 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 +import qualified Data.Text as T +import qualified System.Directory as D +import System.PosixCompat.Files as PF +import System.FilePath getDirectoryContentsPath :: FilePath -> IO [FilePath] -getDirectoryContentsPath path = fmap (map (path )) $ FS.listDirectory path +getDirectoryContentsPath path = (map (path )) . filter (not . dots) <$> D.getDirectoryContents path + where + dots "." = True + dots ".." = True + dots _ = False fileDirContents :: FilePath -> IO ([FilePath],[FilePath]) fileDirContents path = do contents <- getDirectoryContentsPath path - files <- filterM FS.isFile contents - dirs <- filterM FS.isDirectory contents + stats <- mapM getFileStatus contents + let pairs = zip stats contents + let files = [ f | (s, f) <- pairs, PF.isRegularFile s] + let dirs = [ d | (s, d) <- pairs, PF.isDirectory s] return (files, dirs) findAllFiles :: FilePath -> IO [FilePath] @@ -49,14 +47,8 @@ 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 +findImmediateFiles = fileDirContents >=> mapM D.canonicalizePath . fst +findImmediateDirs = fileDirContents >=> mapM D.canonicalizePath . snd findAllDirs :: FilePath -> IO [FilePath] findAllDirs path = do @@ -74,15 +66,16 @@ -- | 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 +addTrailingSlash = addTrailingPathSeparator canonicalizeDirPath :: FilePath -> IO FilePath -canonicalizeDirPath path = addTrailingSlash `fmap` FS.canonicalizePath path +canonicalizeDirPath path = addTrailingSlash `fmap` D.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 +canonicalizePath path = let was_dir = null (takeFileName path) in + if not was_dir then D.canonicalizePath path else canonicalizeDirPath path + +hasThisExtension :: FilePath -> T.Text -> Bool +hasThisExtension p ext = takeExtension p == T.unpack ext diff --git a/src/System/FSNotify/Polling.hs b/src/System/FSNotify/Polling.hs --- a/src/System/FSNotify/Polling.hs +++ b/src/System/FSNotify/Polling.hs @@ -11,16 +11,19 @@ import Prelude hiding (FilePath) +import Control.Applicative import Control.Concurrent import Data.Map (Map) import Data.Maybe import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock.POSIX -- import Debug.Trace (trace) -import Filesystem hiding (canonicalizePath) -import Filesystem.Path +import System.FilePath import System.FSNotify.Listener import System.FSNotify.Path (findFiles, canonicalizeDirPath) import System.FSNotify.Types +import System.PosixCompat.Files +import System.PosixCompat.Types import qualified Data.Map as Map import Control.Monad (forM_) @@ -56,7 +59,7 @@ where pathAndTime :: FilePath -> IO (FilePath, UTCTime) pathAndTime path = do - modTime <- getModified path + modTime <- getModificationTime path return (path, modTime) pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath UTCTime -> IO () @@ -125,3 +128,11 @@ return $ killAndUnregister mvarMap wk usesPolling = const True + + +getModificationTime :: FilePath -> IO UTCTime +getModificationTime p = fromEpoch . modificationTime <$> getFileStatus p + + +fromEpoch :: EpochTime -> UTCTime +fromEpoch = posixSecondsToUTCTime . realToFrac diff --git a/src/System/FSNotify/Types.hs b/src/System/FSNotify/Types.hs --- a/src/System/FSNotify/Types.hs +++ b/src/System/FSNotify/Types.hs @@ -24,7 +24,7 @@ import Data.IORef (IORef) import Data.Time (NominalDiffTime) import Data.Time.Clock (UTCTime) -import Filesystem.Path.CurrentOS +import System.FilePath -- | 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 @@ -61,11 +61,21 @@ -- available. This is mostly for testing purposes. } --- | This specifies whether events close to each other should be collapsed --- together, and how close is close enough. +-- | This specifies whether multiple events from the same file should be +-- collapsed together, and how close is close enough. +-- +-- This is performed by ignoring any event that occurs to the same file +-- until the specified time interval has elapsed. +-- +-- Note that the current debouncing logic may fail to report certain changes +-- to a file, potentially leaving your program in a state that is not +-- consistent with the filesystem. +-- +-- Make sure that if you are using this feature, all changes you make as a +-- result of an 'Event' notification are both non-essential and idempotent. data Debounce = DebounceDefault - -- ^ perform debouncing based on the default time interval + -- ^ perform debouncing based on the default time interval of 1 millisecond | Debounce NominalDiffTime -- ^ perform debouncing based on the specified time interval | NoDebounce diff --git a/test/EventUtils.hs b/test/EventUtils.hs --- a/test/EventUtils.hs +++ b/test/EventUtils.hs @@ -4,14 +4,13 @@ import Prelude hiding (FilePath) import Test.Tasty.HUnit import Control.Concurrent -import Control.Concurrent.Async +import Control.Concurrent.Async hiding (poll) import Control.Applicative import Control.Monad import Data.IORef import Data.List (sortBy) import Data.Ord (comparing) -import Filesystem.Path -import Filesystem.Path.CurrentOS +import System.FilePath import System.FSNotify import System.IO.Unsafe import System.Directory @@ -73,7 +72,7 @@ mgr <- startManagerConf defaultConfig { confDebounce = NoDebounce , confUsePolling = poll - , confPollInterval = 2 * 10^5 + , confPollInterval = 2 * 10^(5 :: Int) } eventsVar <- newIORef [] stop <- watch mgr path (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ()))) @@ -94,7 +93,10 @@ matchEvents pats $ sortBy (comparing eventTime) evs testDirPath :: FilePath -testDirPath = decodeString (unsafePerformIO getCurrentDirectory) "testdir" +testDirPath = (unsafePerformIO getCurrentDirectory) "testdir" +expectEventsHere :: (?timeInterval::Int) => Bool -> [EventPattern] -> IO () -> Assertion expectEventsHere poll = expectEvents poll watchDir testDirPath + +expectEventsHereRec :: (?timeInterval::Int) => Bool -> [EventPattern] -> IO () -> Assertion expectEventsHereRec poll = expectEvents poll watchTree testDirPath diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE OverloadedStrings, ImplicitParams, ViewPatterns #-} +{-# LANGUAGE OverloadedStrings, ImplicitParams #-} import Prelude hiding - ( FilePath, writeFile, writeFile ) + ( FilePath ) +import Control.Applicative import Test.Tasty import Test.Tasty.HUnit -import Filesystem -import Filesystem.Path -import Filesystem.Path.CurrentOS +import System.Directory +import System.FilePath import System.FSNotify +import System.IO.Error import System.IO.Temp -import Text.Printf +import System.PosixCompat.Files import Control.Monad import Control.Exception import Control.Concurrent @@ -21,16 +22,18 @@ stopManager mgr return $ not $ isPollingManager mgr +main :: IO () main = do hasNative <- nativeMgrSupported unless hasNative $ putStrLn "WARNING: native manager cannot be used or tested on this platform" defaultMain $ withResource - (createTree testDirPath) - (const $ removeTree testDirPath) $ + (createDirectoryIfMissing True testDirPath) + (const $ removeDirectoryRecursive testDirPath) $ const $ tests hasNative +tests :: Bool -> TestTree tests hasNative = testGroup "Tests" $ do poll <- if hasNative @@ -38,8 +41,8 @@ else [True] let ?timeInterval = if poll - then 2*10^6 - else 5*10^5 + then 2*10^(6 :: Int) + else 5*10^(5 :: Int) return $ testGroup (if poll then "Polling" else "Native") $ do recursive <- [False, True] return $ testGroup (if recursive then "Recursive" else "Non-recursive") $ do @@ -51,25 +54,35 @@ (const $ return ()) (\f -> writeFile f "foo") , mkTest "modify file" [evModified] (\f -> writeFile f "") - (\f -> when poll (threadDelay $ 10^6) >> writeFile f "foo") + (\f -> when poll (threadDelay $ 10^(6 :: Int)) >> writeFile f "foo") , mkTest "delete file" [evRemoved] (\f -> writeFile f "") (\f -> removeFile f) , mkTest "directories are ignored" [] (const $ return ()) - (\f -> createDirectory False f >> removeDirectory f) + (\f -> createDirectory f >> removeDirectory f) ] return $ t nested recursive poll where mkTest title evs prepare action nested recursive poll = testCase title $ - withTempDirectory (encodeString testDirPath) "test." $ \(decodeString -> watchedDir) -> do + withTempDirectory testDirPath "test." $ \watchedDir -> do let baseDir = if nested then watchedDir "subdir" else watchedDir - f = baseDir filename + f = baseDir fileName expect = expectEvents poll (if recursive then watchTree else watchDir) watchedDir - createDirectory True baseDir + createDirectoryIfMissing True baseDir (prepare f >> expect (if not nested || recursive then map ($ f) evs else []) (action f)) `finally` (isFile f >>= \b -> when b (removeFile f)) - filename = "testfile" + fileName = "testfile" + + +------------------------------------------------------------------------------- +isFile :: FilePath -> IO Bool +isFile p = handleJust h return checkFile + where + h e = if isDoesNotExistError e + then Just False + else Nothing + checkFile = isRegularFile <$> getFileStatus p