Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Chan #1

Open
wants to merge 4 commits into from

1 participant

@gregwebs

So the previous code I sent is now all here patched against your repo. @mdittmer and I will work with you to address the points you brought up.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Jun 30, 2012
  1. @gregwebs

    chan-based API

    gregwebs authored
  2. @gregwebs

    tests for new watch interface

    gregwebs authored
Commits on Jul 2, 2012
  1. @gregwebs
  2. @gregwebs

    fix test/Utils.hs

    gregwebs authored
This page is out of date. Refresh to see the latest.
View
12 hinotify.cabal
@@ -36,3 +36,15 @@ library
ghc-options: -Wall
hs-source-dirs: src
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: main.hs
+ hs-source-dirs: ., test
+ ghc-options: -Wall
+
+ Build-depends: hinotify
+
+source-repository head
+ type: git
+ location: https://github.com/kolmodin/hinotify
View
140 src/System/INotify.hsc
@@ -1,3 +1,4 @@
+{-# Language ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.INotify
@@ -24,6 +25,7 @@ module System.INotify
, killINotify
, withINotify
, addWatch
+ , watch
, removeWatch
, INotify
, WatchDescriptor
@@ -34,11 +36,11 @@ module System.INotify
#include "sys/inotify.h"
-import Prelude hiding (init)
+import Prelude hiding (init, catch)
import Control.Monad
import Control.Concurrent
-import Control.Concurrent.MVar
-import Control.Exception (bracket)
+import Control.Concurrent.MVar ()
+import Control.Exception (bracket, catch, SomeException)
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
@@ -48,7 +50,7 @@ import Foreign.Ptr
import Foreign.Storable
import System.Directory
import System.IO
-import System.IO.Error
+import System.IO.Error hiding (catch)
#if __GLASGOW_HASKELL__ >= 612
import GHC.IO.Handle.FD (fdToHandle')
import GHC.IO.Device (IODeviceType(Stream))
@@ -63,14 +65,25 @@ type FD = CInt
type WD = CInt
type Masks = CUInt
-type EventMap = Map WD (Event -> IO ())
+type WatchMap = Map WD WatchDescriptor
type WDEvent = (WD, Event)
-data INotify = INotify Handle FD (MVar EventMap) ThreadId ThreadId
-data WatchDescriptor = WatchDescriptor INotify WD deriving Eq
+data INotify = INotify {
+ inHandle :: Handle
+ , inFD :: FD
+ , inWatchMap :: (MVar WatchMap)
+ , inTid :: ThreadId
+ }
+
+data WatchDescriptor = WatchDescriptor {
+ wdInotify :: INotify
+ , wdCInt :: WD
+ , wdChan :: (Chan Event)
+ , wdMasks :: [EventVariety]
+ } deriving Eq
instance Eq INotify where
- (INotify _ fd1 _ _ _) == (INotify _ fd2 _ _ _) = fd1 == fd2
+ in1 == in2 = inFD in1 == inFD in2
newtype Cookie = Cookie CUInt deriving (Eq,Ord)
@@ -162,12 +175,12 @@ data EventVariety
deriving Eq
instance Show INotify where
- show (INotify _ fd _ _ _) =
+ show inotify =
showString "<inotify fd=" .
- shows fd $ ">"
+ shows (inFD inotify) $ ">"
instance Show WatchDescriptor where
- show (WatchDescriptor _ wd) = showString "<wd=" . shows wd $ ">"
+ show wd = showString "<wd=" . shows (wdCInt wd) $ ">"
instance Show Cookie where
show (Cookie c) = showString "<cookie " . shows c $ ">"
@@ -181,12 +194,21 @@ initINotify = do
#else
h <- fdToHandle' (fromIntegral fd) (Just Stream) False{-is_socket-} desc ReadMode True{-binary-}
#endif
- em <- newMVar Map.empty
- (tid1, tid2) <- inotify_start_thread h em
- return (INotify h fd em tid1 tid2)
+ wm <- newMVar Map.empty
+ tid1 <- inotify_start_thread h wm
+ return (INotify h fd wm tid1)
addWatch :: INotify -> [EventVariety] -> FilePath -> (Event -> IO ()) -> IO WatchDescriptor
-addWatch inotify@(INotify _ fd em _ _) masks fp cb = do
+addWatch inotify masks fp cb = do
+ (wd,chan) <- watch inotify masks fp
+ _<- forkIO $ do
+ ev <- readChan chan
+ cb ev `catch` \(_::SomeException) -> return ()
+ return wd
+
+watch :: INotify -> [EventVariety] -> FilePath -> IO (WatchDescriptor, Chan Event)
+watch inotify masks fp = do
+ chan <- newChan
is_dir <- doesDirectoryExist fp
when (not is_dir) $ do
file_exist <- doesFileExist fp
@@ -198,20 +220,12 @@ addWatch inotify@(INotify _ fd em _ _) masks fp cb = do
Nothing
(Just fp)
let mask = joinMasks (map eventVarietyToMask masks)
- wd <- withCString fp $ \fp_c ->
- throwErrnoIfMinus1 "addWatch" $
- c_inotify_add_watch (fromIntegral fd) fp_c mask
- let event = \e -> do
- when (OneShot `elem` masks) $
- rm_watch inotify wd
- case e of
- -- if the event is Ignored then we know for sure that
- -- this is the last event on that WatchDescriptor
- Ignored -> rm_watch inotify wd
- _ -> return ()
- cb e
- modifyMVar_ em $ \em' -> return (Map.insert wd event em')
- return (WatchDescriptor inotify wd)
+ wdInt <- withCString fp $ \fp_c ->
+ throwErrnoIfMinus1 "addWatch" $
+ c_inotify_add_watch (fromIntegral $ inFD inotify) fp_c mask
+ let wd = (WatchDescriptor inotify wdInt chan masks)
+ modifyMVar_ (inWatchMap inotify) $ \wm -> return (Map.insert wdInt wd wm)
+ return (wd, chan)
where
eventVarietyToMask ev =
case ev of
@@ -236,14 +250,14 @@ addWatch inotify@(INotify _ fd em _ _) masks fp cb = do
AllEvents -> inAllEvents
removeWatch :: WatchDescriptor -> IO ()
-removeWatch (WatchDescriptor (INotify _ fd _ _ _) wd) = do
+removeWatch wd = do
_ <- throwErrnoIfMinus1 "removeWatch" $
- c_inotify_rm_watch (fromIntegral fd) wd
+ c_inotify_rm_watch (fromIntegral $ inFD $ wdInotify wd) (wdCInt wd)
return ()
-rm_watch :: INotify -> WD -> IO ()
-rm_watch (INotify _ _ em _ _) wd =
- modifyMVar_ em (return . Map.delete wd)
+rm_watch :: WatchDescriptor -> IO ()
+rm_watch wd =
+ modifyMVar_ (inWatchMap $ wdInotify wd) (return . Map.delete (wdCInt wd))
read_events :: Handle -> IO [WDEvent]
read_events h =
@@ -292,40 +306,34 @@ read_events h =
isSet bits = maskIsSet bits mask
name = fromJust nameM
-inotify_start_thread :: Handle -> MVar EventMap -> IO (ThreadId, ThreadId)
-inotify_start_thread h em = do
- chan_events <- newChan
- tid1 <- forkIO (dispatcher chan_events)
- tid2 <- forkIO (start_thread chan_events)
- return (tid1,tid2)
- where
- start_thread :: Chan [WDEvent] -> IO ()
- start_thread chan_events = do
- events <- read_events h
- writeChan chan_events events
- start_thread chan_events
- dispatcher :: Chan [WDEvent] -> IO ()
- dispatcher chan_events = do
- events <- readChan chan_events
- mapM_ runHandler events
- dispatcher chan_events
- runHandler :: WDEvent -> IO ()
- runHandler (_, e@QOverflow) = do -- send overflows to all handlers
- handlers <- readMVar em
- flip mapM_ (Map.elems handlers) $ \handler ->
- catch (handler e) (\_ -> return ()) -- supress errors
- runHandler (wd, event) = do
- handlers <- readMVar em
- let handlerM = Map.lookup wd handlers
- case handlerM of
- Nothing -> putStrLn "runHandler: couldn't find handler" -- impossible?
- Just handler -> catch (handler event) (\_ -> return ())
+inotify_start_thread :: Handle -> MVar WatchMap -> IO ThreadId
+inotify_start_thread h watchMap = forkIO $
+ read_events h >>= mapM_ chanDispatch
+ where
+ writeEvent wd = writeChan (wdChan wd)
+
+ chanDispatch :: WDEvent -> IO ()
+ chanDispatch (_, e@QOverflow) = do -- send overflows to all handlers
+ wMap <- readMVar watchMap
+ flip mapM_ (Map.elems wMap) $ \wd -> writeEvent wd e
+ chanDispatch (wdInt, event) = do
+ wMap <- readMVar watchMap
+ case Map.lookup wdInt wMap of
+ Nothing -> putStrLn "chanDispatch: couldn't find watcher" -- impossible?
+ Just wd -> handle wd event
+ where
+ handle wd e = do
+ when (OneShot `elem` wdMasks wd) $
+ rm_watch wd
+ case e of
+ -- if the event is Ignored then we know for sure that
+ -- this is the last event on that WatchDescriptor
+ Ignored -> rm_watch wd
+ _ -> return ()
+ writeEvent wd e
killINotify :: INotify -> IO ()
-killINotify (INotify h _ _ tid1 tid2) =
- do killThread tid1
- killThread tid2
- hClose h
+killINotify inotify = killThread (inTid inotify) >> hClose (inHandle inotify)
withINotify :: (INotify -> IO a) -> IO a
withINotify = bracket initINotify killINotify
View
47 test/MoveSpec.hs
@@ -0,0 +1,47 @@
+module MoveSpec where
+
+import Data.Maybe
+
+import Control.Monad
+
+import System.Directory
+import System.IO
+
+import System.INotify as INotify
+
+import Utils
+
+file = "hello"
+file2 = file ++ "2"
+
+write path = do
+ writeFile (path ++ '/':file) ""
+
+move path = do
+ renameFile (path ++ '/':file) (path ++ '/':file2)
+
+remove path = do
+ removeFile (path ++ '/':file2)
+
+action path = do
+ write path
+ move path
+ remove path
+
+main =
+ inTestEnviron [AllEvents] action $ \ events -> do
+ let cookie = head [ c | MovedOut _ _ c <- events ]
+ when (expected cookie ~= events)
+ testSuccess
+ explainFailure (expected cookie) events
+
+expected cookie =
+ [ Created False file
+ , Opened False (Just file)
+ , Modified False (Just file)
+ , Closed False (Just file) True
+ , MovedOut False file cookie
+ , MovedIn False file2 cookie
+ , Deleted False file2
+ ]
+
View
71 test/Utils.hs
@@ -0,0 +1,71 @@
+module Utils where
+
+import Control.Concurrent.Chan
+import Control.Exception
+
+import System.Directory
+import System.Environment
+import System.Exit
+
+import System.INotify
+
+testName = do
+ n <- getProgName
+ return (n ++ "-playground")
+
+withTempDir f = do
+ path <- testName
+ bracket
+ ( createDirectory path >> return path )
+ ( removeDirectoryRecursive )
+ ( f )
+
+withEventWatch inot events path f =
+ bracket
+ ( watch inot events path action )
+ removeWatch
+ ( f )
+
+withWatch inot events path action f =
+ bracket
+ ( addWatch inot events path action )
+ removeWatch
+ ( const f )
+
+inTestEnviron events action f = do
+ withTempDir $ \testPath -> do
+ inot <- initINotify
+ chan <- newChan
+ withWatch inot events testPath (writeChan chan) $ do
+ action testPath
+ events <- getChanContents chan
+ f events
+
+inTestEnvironEvent events action f = do
+ withTempDir $ \testPath -> do
+ inot <- initINotify
+ chan <- newChan
+ withEventWatch inot events testPath $ \(wd,chan) -> do
+ action testPath
+ events <- getChanContents chan
+ f events
+
+
+(~=) :: Eq a => [a] -> [a] -> Bool
+[] ~= _ = True
+(x:xs) ~= (y:ys) = x == y && xs ~= ys
+_ ~= _ = False
+
+asMany :: [a] -> [a] -> [a]
+asMany xs ys = take (length xs) ys
+
+explainFailure expected reality = do
+ putStrLn "Expected:"
+ mapM_ (\x -> putStr "> " >> print x) expected
+ putStrLn "But got:"
+ mapM_ (\x -> putStr "< " >> print x) (asMany expected reality)
+ testFailure
+
+testFailure = exitFailure
+
+testSuccess = exitWith ExitSuccess
View
1  test/main.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-}
View
26 tests/Utils.hs
@@ -17,8 +17,14 @@ withTempDir f = do
path <- testName
bracket
( createDirectory path >> return path )
- ( removeDirectoryRecursive )
- ( f )
+ removeDirectoryRecursive
+ f
+
+withEventWatch inot events path f =
+ bracket
+ ( watch inot events path )
+ (\(wd,e) -> removeWatch wd)
+ f
withWatch inot events path action f =
bracket
@@ -26,7 +32,7 @@ withWatch inot events path action f =
removeWatch
( const f )
-inTestEnviron events action f = do
+inTestEnviron events action f =
withTempDir $ \testPath -> do
inot <- initINotify
chan <- newChan
@@ -35,13 +41,23 @@ inTestEnviron events action f = do
events <- getChanContents chan
f events
+inTestEnvironEvent events action f =
+ withTempDir $ \testPath -> do
+ inot <- initINotify
+ chan <- newChan
+ withEventWatch inot events testPath $ \(wd,chan) -> do
+ action testPath
+ events <- getChanContents chan
+ f events
+
+
(~=) :: Eq a => [a] -> [a] -> Bool
[] ~= _ = True
(x:xs) ~= (y:ys) = x == y && xs ~= ys
_ ~= _ = False
asMany :: [a] -> [a] -> [a]
-asMany xs ys = take (length xs) ys
+asMany = take . length
explainFailure expected reality = do
putStrLn "Expected:"
@@ -52,4 +68,4 @@ explainFailure expected reality = do
testFailure = exitFailure
-testSuccess = exitWith ExitSuccess
+testSuccess = exitSuccess
Something went wrong with that request. Please try again.