diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 -------------- diff --git a/hinotify.cabal b/hinotify.cabal --- a/hinotify.cabal +++ b/hinotify.cabal @@ -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 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 diff --git a/src/System/INotify.hsc b/src/System/INotify.hsc --- a/src/System/INotify.hsc +++ b/src/System/INotify.hsc @@ -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 "" -#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 "") + 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 diff --git a/tests/test006-callbackHang.hs b/tests/test006-callbackHang.hs new file mode 100644 --- /dev/null +++ b/tests/test006-callbackHang.hs @@ -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