From 61eec29a0c3af7922bf173320e7cf9ca2dbf3abe Mon Sep 17 00:00:00 2001 From: benitogf Date: Mon, 14 May 2018 17:56:56 +0800 Subject: [PATCH 1/3] add test and sample --- .gitignore | 2 ++ linux-inotify.cabal | 11 +++++++++++ src/System/Linux/Inotify.hsc | 12 +++++++----- test/test.hs | 26 ++++++++++++++++++++++++++ test/test.json | 1 + 5 files changed, 47 insertions(+), 5 deletions(-) create mode 100644 test/test.hs create mode 100644 test/test.json diff --git a/.gitignore b/.gitignore index 40c4550..3998b49 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ .hg/ _darcs/ +.cabal-sandbox/ +cabal.sandbox.config *~ dist/ *.prof diff --git a/linux-inotify.cabal b/linux-inotify.cabal index 7ee7d2b..c20b7a5 100644 --- a/linux-inotify.cabal +++ b/linux-inotify.cabal @@ -53,6 +53,17 @@ library ghc-options: -Wall +test-suite test + hs-source-dirs: + src, + test + type: + exitcode-stdio-1.0 + main-is: + test.hs + build-depends: base >= 4.7 && < 5, + linux-inotify + source-repository head type: git location: http://github.com/lpsmith/linux-inotify diff --git a/src/System/Linux/Inotify.hsc b/src/System/Linux/Inotify.hsc index 7f98cd9..d7c9d8d 100644 --- a/src/System/Linux/Inotify.hsc +++ b/src/System/Linux/Inotify.hsc @@ -79,8 +79,9 @@ import Prelude hiding (init) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 -import Control.Applicative -import Data.Monoid +-- import Control.Applicative +-- import Data.Monoid +-- https://ghc.haskell.org/trac/ghc/wiki/Migration/7.10#GHCsaysTheimportof...isredundant import Data.Typeable import Data.Function ( on ) import Data.Word @@ -325,7 +326,7 @@ data Event = Event -- to the watched directory. -- -- The proper Haskell interpretation of this seems to be to use - -- 'GHC.IO.Encoding.getFileSystemEncoding' and then unpack it to a + -- 'GHC.IO.Encoding.getFileSystemEncoding' and then unpack it to a -- 'String' or decode it using the text package. } deriving (Eq, Show, Typeable) @@ -538,8 +539,9 @@ fillBuffer funcName Inotify{..} closedHandler wouldBlock done = {-# INLINE fillBuffer #-} getMessage :: Inotify -> Int -> Bool -> IO Event -getMessage Inotify{..} start doConsume = withForeignPtr buffer $ \ptr0 -> do - let ptr = ptr0 `plusPtr` start +getMessage Inotify{..} start doConsume = withForeignPtr buffer $ \ptr -> do + -- let ptr = ptr0 `plusPtr` start + -- http://hackage.haskell.org/package/base-4.11.1.0/docs/Foreign-ForeignPtr.html#v:withForeignPtr wd <- Watch <$> ((#peek struct inotify_event, wd ) ptr :: IO CInt) mask <- Mask <$> ((#peek struct inotify_event, mask ) ptr :: IO Word32) cookie <- Cookie <$> ((#peek struct inotify_event, cookie) ptr :: IO Word32) diff --git a/test/test.hs b/test/test.hs new file mode 100644 index 0000000..ff5084c --- /dev/null +++ b/test/test.hs @@ -0,0 +1,26 @@ +import System.Environment +import Prelude hiding (reverse, log) +import qualified System.Linux.Inotify as IN +import Data.Monoid(mconcat) +import Control.Monad(forever) +import Control.Exception(bracket) +import GHC.Conc.Sync(ThreadId) + +log :: String -> IO() +log x = putStrLn $ "[linux-inotify]: " ++ x + +events :: IN.Mask a +events = mconcat [IN.in_DELETE, IN.in_MODIFY, IN.in_MOVE, IN.in_CREATE] + +initFileReload :: String -> IO ThreadId +initFileReload dir = do + bracket IN.init IN.close $ \ind -> do + _ <- IN.addWatch ind dir events + forever $ do + e <- IN.getEvent ind + print e + +main:: IO() +main = do + [x] <- getArgs + initFileReload x >> log "CLOSE" diff --git a/test/test.json b/test/test.json new file mode 100644 index 0000000..9daeafb --- /dev/null +++ b/test/test.json @@ -0,0 +1 @@ +test From 08337f1877d0b60b8c1fd4608db793d6b8f03b4c Mon Sep 17 00:00:00 2001 From: benitogf Date: Wed, 23 May 2018 14:17:11 +0800 Subject: [PATCH 2/3] rollback withForeignPtr changes, fix test/example --- .gitignore | 1 + linux-inotify.cabal | 6 +++-- src/System/Linux/Inotify.hsc | 5 ++-- test/test.hs | 51 +++++++++++++++++++++++++++++++----- test/test.json | 2 +- 5 files changed, 52 insertions(+), 13 deletions(-) diff --git a/.gitignore b/.gitignore index 3998b49..147f23c 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ _darcs/ .cabal-sandbox/ cabal.sandbox.config +test/.test.json.swp *~ dist/ *.prof diff --git a/linux-inotify.cabal b/linux-inotify.cabal index c20b7a5..8a96b21 100644 --- a/linux-inotify.cabal +++ b/linux-inotify.cabal @@ -61,8 +61,10 @@ test-suite test exitcode-stdio-1.0 main-is: test.hs - build-depends: base >= 4.7 && < 5, - linux-inotify + build-depends: + base >= 4.7 && < 5, + unix, + linux-inotify source-repository head type: git diff --git a/src/System/Linux/Inotify.hsc b/src/System/Linux/Inotify.hsc index d7c9d8d..57a0d42 100644 --- a/src/System/Linux/Inotify.hsc +++ b/src/System/Linux/Inotify.hsc @@ -539,9 +539,8 @@ fillBuffer funcName Inotify{..} closedHandler wouldBlock done = {-# INLINE fillBuffer #-} getMessage :: Inotify -> Int -> Bool -> IO Event -getMessage Inotify{..} start doConsume = withForeignPtr buffer $ \ptr -> do - -- let ptr = ptr0 `plusPtr` start - -- http://hackage.haskell.org/package/base-4.11.1.0/docs/Foreign-ForeignPtr.html#v:withForeignPtr +getMessage Inotify{..} start doConsume = withForeignPtr buffer $ \ptr0 -> do + let ptr = ptr0 `plusPtr` start wd <- Watch <$> ((#peek struct inotify_event, wd ) ptr :: IO CInt) mask <- Mask <$> ((#peek struct inotify_event, mask ) ptr :: IO Word32) cookie <- Cookie <$> ((#peek struct inotify_event, cookie) ptr :: IO Word32) diff --git a/test/test.hs b/test/test.hs index ff5084c..40076cc 100644 --- a/test/test.hs +++ b/test/test.hs @@ -1,26 +1,63 @@ +module Main where + import System.Environment +import System.Exit import Prelude hiding (reverse, log) import qualified System.Linux.Inotify as IN import Data.Monoid(mconcat) import Control.Monad(forever) import Control.Exception(bracket) import GHC.Conc.Sync(ThreadId) +import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef) +import System.Posix.Signals(installHandler, Handler(Catch), sigINT, sigTERM, raiseSignal) +import Control.Concurrent(forkIO, threadDelay) +import Control.Concurrent.MVar(newEmptyMVar, takeMVar, putMVar, MVar) log :: String -> IO() log x = putStrLn $ "[linux-inotify]: " ++ x events :: IN.Mask a -events = mconcat [IN.in_DELETE, IN.in_MODIFY, IN.in_MOVE, IN.in_CREATE] +events = mconcat [IN.in_MODIFY] -initFileReload :: String -> IO ThreadId -initFileReload dir = do - bracket IN.init IN.close $ \ind -> do +initFileReload :: IORef Int -> String -> IO ThreadId +initFileReload counter dir = do + forkIO.bracket IN.init IN.close $ \ind -> do _ <- IN.addWatch ind dir events forever $ do e <- IN.getEvent ind - print e + log $ show e + atomicModifyIORef' counter (\n -> (n + 1, ())) + +testFileWrite :: String -> IO () +testFileWrite path = do + writeFile path "test" + log "Test writing to file" + threadDelay $ 1 + raiseSignal sigINT + -- sigTERM will not be caught + +handler :: MVar () -> IO () +handler s_interrupted = + putMVar s_interrupted () + +recvFunction :: IORef Int -> MVar () -> IO () +recvFunction counter signal = do + output <- takeMVar signal + n <- readIORef counter + log $ "Interrupt Received. Stopping watcher" ++ show n + if n == 1 + then exitSuccess + else exitFailure + -- exitSuccess main:: IO() main = do - [x] <- getArgs - initFileReload x >> log "CLOSE" + let file = "test/test.json" + counter <- newIORef 0 + log $ "watching file: " ++ file + _ <- initFileReload counter file + testFileWrite file + s_interrupted <- newEmptyMVar + installHandler sigTERM (Catch $ handler s_interrupted) Nothing + installHandler sigINT (Catch $ handler s_interrupted) Nothing + recvFunction counter s_interrupted diff --git a/test/test.json b/test/test.json index 9daeafb..30d74d2 100644 --- a/test/test.json +++ b/test/test.json @@ -1 +1 @@ -test +test \ No newline at end of file From 3ac82fca842099d99bc061bb9f2b38c52825c0d6 Mon Sep 17 00:00:00 2001 From: benitogf Date: Wed, 23 May 2018 14:26:20 +0800 Subject: [PATCH 3/3] rollback withForeignPtr changes, fix test/example --- test/test.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/test.hs b/test/test.hs index 40076cc..5ae0a3a 100644 --- a/test/test.hs +++ b/test/test.hs @@ -34,7 +34,7 @@ testFileWrite path = do log "Test writing to file" threadDelay $ 1 raiseSignal sigINT - -- sigTERM will not be caught + -- sigTERM will not be caught :/ handler :: MVar () -> IO () handler s_interrupted = @@ -48,10 +48,11 @@ recvFunction counter signal = do if n == 1 then exitSuccess else exitFailure - -- exitSuccess main:: IO() main = do + -- [file] <- getArgs + -- https://github.com/haskell/cabal/issues/4643 let file = "test/test.json" counter <- newIORef 0 log $ "watching file: " ++ file