packages feed

fsnotify 0.4.0.1 → 0.4.1.0

raw patch · 13 files changed

+180/−135 lines, 13 filesdep ~sandwichdep ~unliftio

Dependency ranges changed: sandwich, unliftio

Files

CHANGELOG.md view
@@ -1,6 +1,14 @@ Changes ======= +Version 0.4.1.0+---------------++* Add `unliftio` lower bound (#106)+* Change the tests back to a test-suite to avoid building for library users. (#107)+* Fix up Windows compatibility.+* Export `WatchConfig` type (#108)+ Version 0.4.0.1 ---------------
fsnotify.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           fsnotify-version:        0.4.0.1+version:        0.4.1.0 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 Windows, Mac, and Linux filesystem event notification. category:       Filesystem@@ -45,10 +45,11 @@     , text >=0.11.0     , time >=1.1     , unix-compat >=0.2+  default-language: Haskell2010   if os(linux)     cpp-options: -DOS_Linux   if os(windows)-    cpp-options: -DOS_Windows+    cpp-options: -DOS_Win32   if os(darwin)     cpp-options: -DOS_Mac   if os(freebsd) || os(netbsd) || os(openbsd)@@ -73,9 +74,9 @@         System.FSNotify.OSX     build-depends:         hfsevents >=0.1.3-  default-language: Haskell2010 -executable tests+test-suite tests+  type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:       FSNotify.Test.EventTests@@ -94,14 +95,14 @@     , random     , retry     , safe-exceptions-    , sandwich     , temporary     , unix-compat-    , unliftio+    , unliftio >=0.2.20+  default-language: Haskell2010   if os(linux)     cpp-options: -DOS_Linux   if os(windows)-    cpp-options: -DOS_Windows+    cpp-options: -DOS_Win32   if os(darwin)     cpp-options: -DOS_Mac   if os(freebsd) || os(netbsd) || os(openbsd)@@ -109,4 +110,7 @@   if os(windows)     build-depends:         Win32-  default-language: Haskell2010+      , sandwich >=0.1.1.1+  else+    build-depends:+        sandwich
src/System/FSNotify.hs view
@@ -2,9 +2,17 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org ---{-# LANGUAGE CPP, ScopedTypeVariables, ExistentialQuantification, RankNTypes, LambdaCase, OverloadedStrings, MultiWayIf, FlexibleContexts, RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-} --- | NOTE: This library does not currently report changes made to directories,+-- | This library does not currently report changes made to directories, -- only files within watched directories. -- -- Minimal example:@@ -27,42 +35,40 @@ -- >    -- sleep forever (until interrupted) -- >    forever $ threadDelay 1000000 -module System.FSNotify-       (--       -- * Events-         Event(..)-       , EventIsDirectory(..)-       , EventChannel-       , Action-       , ActionPredicate--       -- * Starting/Stopping-       , WatchManager-       , withManager-       , startManager-       , stopManager+module System.FSNotify (+  -- * Events+    Event(..)+  , EventIsDirectory(..)+  , EventChannel+  , Action+  , ActionPredicate -       -- * Configuration-       , defaultConfig-       , confWatchMode-       , confThreadingMode-       , confOnHandlerException-       , WatchMode(..)-       , ThreadingMode(..)+  -- * Starting/Stopping+  , WatchManager+  , withManager+  , startManager+  , stopManager -       -- * Lower level-       , withManagerConf-       , startManagerConf-       , StopListening+  -- * Configuration+  , defaultConfig+  , WatchConfig+  , confWatchMode+  , confThreadingMode+  , confOnHandlerException+  , WatchMode(..)+  , ThreadingMode(..) -       -- * Watching-       , watchDir-       , watchDirChan-       , watchTree-       , watchTreeChan+  -- * Lower level+  , withManagerConf+  , startManagerConf+  , StopListening -       ) where+  -- * Watching+  , watchDir+  , watchDirChan+  , watchTree+  , watchTreeChan+  ) where  import Prelude hiding (FilePath) @@ -146,11 +152,11 @@     Nothing -> return ()     Just (_, t) -> cancel t --- | Like 'withManager', but configurable+-- | Like 'withManager', but configurable. withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a withManagerConf conf = bracket (startManagerConf conf) stopManager --- | Like 'startManager', but configurable+-- | Like 'startManager', but configurable. startManagerConf :: WatchConfig -> IO WatchManager startManagerConf conf = do # ifdef OS_Win32
src/System/FSNotify/Devel.hs view
@@ -17,10 +17,12 @@  {-# LANGUAGE NamedFieldPuns #-} -module System.FSNotify.Devel-  ( treeExtAny, treeExtExists,-    doAllEvents,-    allEvents, existsEvents+module System.FSNotify.Devel (+  treeExtAny+  , treeExtExists+  , doAllEvents+  , allEvents+  , existsEvents   ) where  import Data.Text
src/System/FSNotify/Linux.hs view
@@ -14,10 +14,10 @@  {-# OPTIONS_GHC -fno-warn-orphans #-} -module System.FSNotify.Linux-       ( FileListener(..)-       , NativeManager-       ) where+module System.FSNotify.Linux (+  FileListener(..)+  , NativeManager+  ) where  import Control.Concurrent.MVar import Control.Exception.Safe as E
src/System/FSNotify/Listener.hs view
@@ -18,7 +18,7 @@ import System.FSNotify.Types import System.FilePath --- | An action that cancels a watching/listening job+-- | An action that cancels a watching/listening job. type StopListening = IO ()  type ListenFn sessionType argType = FileListener sessionType argType => WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventCallback -> IO StopListening
src/System/FSNotify/OSX.hs view
@@ -3,12 +3,14 @@ -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- -{-# LANGUAGE MultiWayIf, OverloadedStrings, MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-} -module System.FSNotify.OSX-       ( FileListener(..)-       , NativeManager-       ) where+module System.FSNotify.OSX (+  FileListener(..)+  , NativeManager+  ) where  import Control.Concurrent import Control.Monad
src/System/FSNotify/Path.hs view
@@ -7,13 +7,13 @@ {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE CPP #-}
 
-module System.FSNotify.Path
-       ( findFiles
-       , findFilesAndDirs
-       , canonicalizeDirPath
-       , canonicalizePath
-       , hasThisExtension
-       ) where
+module System.FSNotify.Path (
+  findFiles
+  , findFilesAndDirs
+  , canonicalizeDirPath
+  , canonicalizePath
+  , hasThisExtension
+  ) where
 
 import Control.Monad
 import qualified Data.Text as T
src/System/FSNotify/Polling.hs view
@@ -7,8 +7,8 @@ -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- -module System.FSNotify.Polling-  ( createPollManager+module System.FSNotify.Polling (+  createPollManager   , PollManager(..)   , FileListener(..)   ) where@@ -30,6 +30,7 @@ import System.PosixCompat.Files import System.PosixCompat.Types + data EventType = AddedEvent                | ModifiedEvent                | RemovedEvent@@ -37,8 +38,10 @@ newtype WatchKey = WatchKey ThreadId deriving (Eq, Ord) data WatchData = WatchData FilePath EventCallback type WatchMap = Map WatchKey WatchData-data PollManager = PollManager { pollManagerWatchMap :: MVar WatchMap-                               , pollManagerInterval :: Int }+data PollManager = PollManager {+  pollManagerWatchMap :: MVar WatchMap+  , pollManagerInterval :: Int+  }  generateEvent :: UTCTime -> EventIsDirectory -> EventType -> FilePath -> Maybe Event generateEvent timestamp isDir AddedEvent filePath = Just (Added filePath timestamp isDir)
src/System/FSNotify/Types.hs view
@@ -4,21 +4,21 @@ -- {-# LANGUAGE CPP #-} -module System.FSNotify.Types-       ( act-       , ActionPredicate-       , Action-       , DebounceFn-       , WatchConfig(..)-       , WatchMode(..)-       , ThreadingMode(..)-       , Event(..)-       , EventIsDirectory(..)-       , EventCallback-       , EventChannel-       , EventAndActionChannel-       , IOEvent-       ) where+module System.FSNotify.Types (+  act+  , ActionPredicate+  , Action+  , DebounceFn+  , WatchConfig(..)+  , WatchMode(..)+  , ThreadingMode(..)+  , Event(..)+  , EventIsDirectory(..)+  , EventCallback+  , EventChannel+  , EventAndActionChannel+  , IOEvent+  ) where  import Control.Concurrent.Chan import Control.Exception.Safe@@ -40,11 +40,11 @@   | ModifiedAttributes { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }   | Removed { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }   | WatchedDirectoryRemoved  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }-  -- ^ Note: currently only emitted on Linux+  -- ^ Note: Linux-only   | CloseWrite  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }-  -- ^ Note: currently only emitted on Linux+  -- ^ Note: Linux-only   | Unknown  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory, eventString :: String }-  -- ^ Note: currently only emitted on Linux+  -- ^ Note: Linux-only   deriving (Eq, Show)  type EventChannel = Chan Event@@ -73,14 +73,14 @@   | ThreadPerEvent   -- ^ Launch a separate thread for every event handler. --- | Watch configuration+-- | Watch configuration. data WatchConfig = WatchConfig   { confWatchMode :: WatchMode-    -- ^ Watch mode to use+    -- ^ Watch mode to use.   , confThreadingMode :: ThreadingMode-    -- ^ Threading mode to use+    -- ^ Threading mode to use.   , confOnHandlerException :: SomeException -> IO ()-    -- ^ Called when a handler throws an exception+    -- ^ Called when a handler throws an exception.   }  type IOEvent = IORef Event
src/System/FSNotify/Win32.hs view
@@ -5,10 +5,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module System.FSNotify.Win32-       ( FileListener(..)-       , NativeManager-       ) where+module System.FSNotify.Win32 (+  FileListener(..)+  , NativeManager+  ) where  import Control.Concurrent import Control.Monad (when)
test/FSNotify/Test/EventTests.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE MultiWayIf #-}@@ -25,13 +24,9 @@ import UnliftIO.Directory  -eventTests :: (MonadUnliftIO m, MonadThrow m, HasParallelSemaphore context) => ThreadingMode -> SpecFree context m ()+eventTests :: (MonadUnliftIO m, MonadThrow m, HasParallelSemaphore' context) => ThreadingMode -> SpecFree context m () eventTests threadingMode = describe "Tests" $ parallel $ do-#ifdef OS_BSD-  let pollOptions = [True]-#else-  let pollOptions = [False, True]-#endif+  let pollOptions = if isBSD then [True] else [False, True]    forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallel $ do     let ?timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int)@@ -41,7 +36,7 @@   -eventTests' :: (MonadUnliftIO m, MonadThrow m, HasParallelSemaphore context, ?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m ()+eventTests' :: (MonadUnliftIO m, MonadThrow m, HasParallelSemaphore' context, ?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m () eventTests' threadingMode poll recursive nested = do -- withParallelSemaphore $   let itWithFolder name action = introduceTestFolder threadingMode poll recursive nested $ it name action @@ -55,11 +50,16 @@    itWithFolder "works with a new file" $ do     TestFolderContext _watchedDir f getEvents _clearEvents <- getContext testFolderContext-    h <- openFile f AppendMode -    flip finally (hClose h) $+    let wrapper action = if | isWin -> liftIO (writeFile f "foo") >> action+                            | otherwise -> withFile f AppendMode $ \_ -> action++    wrapper $       pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->         if | nested && not recursive -> events `shouldBe` []+           | isWin && not poll -> case events of+               [Modified {}, Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+               _ -> expectationFailure $ "Got wrong events: " <> show events            | otherwise -> case events of                [Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()                _ -> expectationFailure $ "Got wrong events: " <> show events@@ -109,40 +109,29 @@     pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->       if | poll -> return ()          | nested && not recursive -> events `shouldBe` []-         | otherwise -> case events of-#ifdef mingw32_HOST_OS+         | isWin -> case events of              [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()-#else+             _ -> expectationFailure $ "Got wrong events: " <> show events+         | otherwise -> case events of              [ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()-#endif              _ -> expectationFailure $ "Got wrong events: " <> show events    itWithFolder "works with a modified file" $ do     TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext     liftIO (writeFile f "" >> clearEvents) -#ifdef mingw32_HOST_OS-    writeFile f "foo"-    do-#else-    withFile f WriteMode $ \h ->-      flip finally (hClose h) $ do-        liftIO $ hPutStr h "foo"-#endif--        pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->-          if | nested && not recursive -> events `shouldBe` []-             | otherwise -> case events of-#ifdef darwin_HOST_OS-                 [Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()-                 [ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()-#else-                 [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()-#endif-                 _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"+    (if isWin then withSingleWriteFile f "foo" else withOpenWritableAndWrite f "foo") $+      pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+        if | nested && not recursive -> events `shouldBe` []+           | isMac -> case events of+               [Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+               [ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+               _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"+           | otherwise -> case events of+               [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+               _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")" -#ifdef linux_HOST_OS-  unless poll $+  when isLinux $ unless poll $     itWithFolder "gets a close_write" $ do       TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext       liftIO (writeFile f "" >> clearEvents)@@ -157,4 +146,15 @@                  | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile                    && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()                _ -> expectationFailure $ "Got wrong events: " <> show events-#endif++withSingleWriteFile :: MonadIO m => FilePath -> String -> m b -> m b+withSingleWriteFile fp contents action = do+  liftIO $ writeFile fp contents+  action++withOpenWritableAndWrite :: MonadUnliftIO m => FilePath -> String -> m b -> m b+withOpenWritableAndWrite fp contents action = do+  withFile fp WriteMode $ \h ->+    flip finally (hClose h) $ do+      liftIO $ hPutStr h contents+      action
test/FSNotify/Test/Util.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}  module FSNotify.Test.Util where @@ -54,6 +55,20 @@ isWin = False #endif +isLinux :: Bool+#ifdef linux_HOST_OS+isLinux = True+#else+isLinux = False+#endif++isBSD :: Bool+#ifdef OS_BSD+isBSD = True+#else+isBSD = False+#endif+ pauseAndRetryOnExpectationFailure :: (MonadUnliftIO m, ?timeInterval :: Int) => Int -> m a -> m a pauseAndRetryOnExpectationFailure n action = threadDelay ?timeInterval >> retryOnExpectationFailure n action @@ -119,12 +134,17 @@ -- This is unfortunately necessary because of the madness of OS X FSEvents; see the comments in OSX.hs withRandomTempDirectory :: MonadUnliftIO m => (FilePath -> m ()) -> m () withRandomTempDirectory action = do-  randomID <- replicateM 10 $ R.randomRIO ('a', 'z')+  randomID <- liftIO $ replicateM 10 $ R.randomRIO ('a', 'z')   withSystemTempDirectory ("test." <> randomID) action  withParallelSemaphore :: forall context m. (-  MonadUnliftIO m, HasParallelSemaphore context+  MonadUnliftIO m, HasLabel context "parallelSemaphore" QSem   ) => SpecFree context m () -> SpecFree context m () withParallelSemaphore = around' (defaultNodeOptions { nodeOptionsRecordTime = False, nodeOptionsVisibilityThreshold = 125 }) "claim semaphore" $ \action -> do-  s <- getContext parallelSemaphore+  s <- getContext parallelSemaphore'   bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void action)++parallelSemaphore' :: Label "parallelSemaphore" QSem+parallelSemaphore' = Label++type HasParallelSemaphore' context = HasLabel context "parallelSemaphore" QSem