hinotify 0.3.8.1 → 0.3.9

raw patch · 4 files changed

+110/−29 lines, 4 filesdep +asyncdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• hinotify.cabal +19/−4
• src/System/INotify.hsc +40/−25
• tests/test006-callbackHang.hs +34/−0

@@ -1,6 +1,23 @@ hinotify ====== +hinotify-0.3.9+--------------++Patches contributed by Simon Marlow marlowsd@gmail.com++- Don't run callbacks in `mask_`.++  It prevented the callback threads from receiving StackOverflow, amongst other things.++- Synchronous `killThread`.++  `killThread` will now wait for the callback dispatcher threads to finish.++- Bug fixes++  https://github.com/kolmodin/hinotify/pull/23+ hinotify-0.3.8 -------------- 

@@ -1,5 +1,5 @@ name:               hinotify-version:            0.3.8.1+version:            0.3.9 build-type:         Simple synopsis:           Haskell binding to inotify description:@@ -13,15 +13,16 @@ author:             Lennart Kolmodin maintainer:         Lennart Kolmodin <kolmodin@gmail.com> extra-source-files: README.md, CHANGELOG.md-cabal-version:      >= 1.8+cabal-version:      >= 1.10  source-repository head   type: git   location: git://github.com/kolmodin/hinotify.git  library-    build-depends:  base >= 4.5.0.0 && < 5, containers, directory, unix-    extensions:     ForeignFunctionInterface+    default-language: Haskell2010+    build-depends:  base >= 4.5.0.0 && < 5, containers, directory, unix,+                    async >= 1.0 && < 2.2      exposed-modules:         System.INotify@@ -34,6 +35,7 @@  test-suite test001     type: exitcode-stdio-1.0+    default-language: Haskell2010     build-depends: base, directory, hinotify     hs-source-dirs: src tests     main-is: test001-list-dir-contents.hs@@ -42,6 +44,7 @@  test-suite test002     type: exitcode-stdio-1.0+    default-language: Haskell2010     build-depends: base, directory, hinotify     hs-source-dirs: src tests     main-is: test002-writefile.hs@@ -50,6 +53,7 @@  test-suite test003     type: exitcode-stdio-1.0+    default-language: Haskell2010     build-depends: base, directory, hinotify     hs-source-dirs: src tests     main-is: test003-removefile.hs@@ -58,6 +62,7 @@  test-suite test004     type: exitcode-stdio-1.0+    default-language: Haskell2010     build-depends: base, directory, hinotify     hs-source-dirs: src tests     main-is: test004-modify-file.hs@@ -67,7 +72,17 @@ test-suite test005     type: exitcode-stdio-1.0     build-depends: base, directory, hinotify+    default-language: Haskell2010     hs-source-dirs: src tests     main-is: test005-move-file.hs+    other-modules: Utils+    ghc-options: -Wall++test-suite test006+    type: exitcode-stdio-1.0+    build-depends: base, directory, hinotify+    default-language: Haskell2010+    hs-source-dirs: src tests+    main-is: test006-callbackHang.hs     other-modules: Utils     ghc-options: -Wall

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  System.INotify@@ -37,7 +38,8 @@ import Prelude hiding (init) import Control.Monad import Control.Concurrent-import Control.Exception as E (bracket, catch, mask_, SomeException)+import Control.Concurrent.Async+import Control.Exception as E hiding (mask) import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map@@ -47,13 +49,9 @@ import Foreign.Storable import System.IO import System.IO.Error-#if __GLASGOW_HASKELL__ >= 612-import GHC.IO.Handle.FD (fdToHandle')+import GHC.IO.FD as FD (mkFD)+import GHC.IO.Handle.FD (mkHandleFromFD) import GHC.IO.Device (IODeviceType(Stream))-#else-import GHC.Handle-import System.Posix.Internals-#endif import System.Posix.Files import GHC.IO.Encoding (getFileSystemEncoding) import GHC.Foreign (withCString, peekCString)@@ -67,7 +65,7 @@ type EventMap = Map WD (Event -> IO ()) type WDEvent = (WD, Event) -data INotify = INotify Handle FD (MVar EventMap) ThreadId ThreadId+data INotify = INotify Handle FD (MVar EventMap) (Async ()) (Async ()) data WatchDescriptor = WatchDescriptor INotify WD deriving Eq  instance Eq INotify where@@ -175,16 +173,19 @@  initINotify :: IO INotify initINotify = do-    fd <- throwErrnoIfMinus1 "initINotify" c_inotify_init-    let desc = showString "<inotify handle, fd=" . shows fd $ ">"-#if __GLASGOW_HASKELL__ < 608-    h <-  openFd (fromIntegral fd) (Just Stream) False{-is_socket-} desc ReadMode True{-binary-}-#else-    h <-  fdToHandle' (fromIntegral fd) (Just Stream) False{-is_socket-} desc ReadMode True{-binary-}-#endif+    fdint <- throwErrnoIfMinus1 "initINotify" c_inotify_init+    (fd,fd_type) <- FD.mkFD fdint ReadMode (Just (Stream,0,0))+            False{-is_socket-}+            False{-is_nonblock-}+    h <- mkHandleFromFD fd fd_type+           (showString "<inotify handle, fd=" . shows fd $ ">")+           ReadMode+           True  -- make non-blocking.  Otherwise reading uses select(), which+                 -- can fail when there are >=1024 FDs+           Nothing -- no encoding, so binary     em <- newMVar Map.empty     (tid1, tid2) <- inotify_start_thread h em-    return (INotify h fd em tid1 tid2)+    return (INotify h fdint em tid1 tid2)  addWatch :: INotify -> [EventVariety] -> FilePath -> (Event -> IO ()) -> IO WatchDescriptor addWatch inotify@(INotify _ fd em _ _) masks fp cb = do@@ -236,10 +237,12 @@             AllEvents -> inAllEvents      ignore_failure :: IO () -> IO ()-    ignore_failure action = mask_ (action `E.catch` ignore)+    ignore_failure action = action `E.catch` ignore       where       ignore :: SomeException -> IO ()-      ignore _ = return ()+      ignore e+        | Just ThreadKilled{} <- fromException e = throwIO e+        | otherwise = return ()  removeWatch :: WatchDescriptor -> IO () removeWatch (WatchDescriptor (INotify _ fd _ _ _) wd) = do@@ -299,12 +302,12 @@         isDir = isSet inIsdir         isSet bits = maskIsSet bits mask         name = fromJust nameM-       -inotify_start_thread :: Handle -> MVar EventMap -> IO (ThreadId, ThreadId)++inotify_start_thread :: Handle -> MVar EventMap -> IO (Async (), Async ()) inotify_start_thread h em = do     chan_events <- newChan-    tid1 <- forkIO (dispatcher chan_events)-    tid2 <- forkIO (start_thread chan_events)+    tid1 <- async (logFailure "dispatcher" (dispatcher chan_events))+    tid2 <- async (logFailure "start_thread" (start_thread chan_events))     return (tid1,tid2)     where     start_thread :: Chan [WDEvent] -> IO ()@@ -328,15 +331,27 @@           Nothing -> putStrLn "runHandler: couldn't find handler" -- impossible?           Just handler -> handler event +    logFailure name io = io `E.catch` \e ->+       case e of+         _ | Just ThreadKilled{} <- fromException e -> return ()+           | otherwise -> hPutStrLn stderr (name ++ " dying: " ++ show e)+ killINotify :: INotify -> IO () killINotify (INotify h _ _ tid1 tid2) =-    do killThread tid1-       killThread tid2+    do cancelWait tid1+       cancelWait tid2        hClose h +cancelWait :: Async a -> IO ()+##if MIN_VERSION_async(2,1,1)+cancelWait = cancel+##else+cancelWait a = do cancel a; void $ waitCatch a+##endif+ withINotify :: (INotify -> IO a) -> IO a withINotify = bracket initINotify killINotify-        + foreign import ccall unsafe "sys/inotify.h inotify_init" c_inotify_init :: IO CInt foreign import ccall unsafe "sys/inotify.h inotify_add_watch" c_inotify_add_watch :: CInt -> CString -> CUInt -> IO CInt foreign import ccall unsafe "sys/inotify.h inotify_rm_watch" c_inotify_rm_watch :: CInt -> CInt -> IO CInt

@@ -0,0 +1,34 @@+module Main where++import Control.Concurrent+import Control.Exception++import System.INotify as INotify+import System.Timeout++import Utils++file :: String+file = "hello"++write :: String -> IO ()+write path = do+    writeFile (path ++ '/':file) ""++main :: IO ()+main = maybe testFailure (const testSuccess) =<< timeout 1000000 doTest++doTest :: IO ()+doTest =+    withTempDir $ \testPath ->+    bracket+        initINotify+        killINotify   -- should complete and kill all threads+        $ \inot -> do+            mvar1 <- newEmptyMVar+            mvar2 <- newEmptyMVar+            _ <- addWatch inot [AllEvents] testPath $ \_event -> do+                putMVar mvar1 ()+                takeMVar mvar2 -- hangs here+            write testPath+            takeMVar mvar1