Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Open
wants to merge 4 commits into from

1 participant

Greg Weber
Greg Weber

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
This page is out of date. Refresh to see the latest.
12  hinotify.cabal
@@ -36,3 +36,15 @@ library
36 36
     ghc-options: -Wall
37 37
 
38 38
     hs-source-dirs: src
  39
+
  40
+test-suite test
  41
+    type:           exitcode-stdio-1.0
  42
+    main-is:        main.hs
  43
+    hs-source-dirs: ., test
  44
+    ghc-options: -Wall
  45
+
  46
+    Build-depends: hinotify
  47
+
  48
+source-repository head
  49
+  type:     git
  50
+  location: https://github.com/kolmodin/hinotify
140  src/System/INotify.hsc
... ...
@@ -1,3 +1,4 @@
  1
+{-# Language ScopedTypeVariables #-}
1 2
 -----------------------------------------------------------------------------
2 3
 -- |
3 4
 -- Module      :  System.INotify
@@ -24,6 +25,7 @@ module System.INotify
24 25
     , killINotify
25 26
     , withINotify
26 27
     , addWatch
  28
+    , watch
27 29
     , removeWatch
28 30
     , INotify
29 31
     , WatchDescriptor
@@ -34,11 +36,11 @@ module System.INotify
34 36
 
35 37
 #include "sys/inotify.h"
36 38
 
37  
-import Prelude hiding (init)
  39
+import Prelude hiding (init, catch)
38 40
 import Control.Monad
39 41
 import Control.Concurrent
40  
-import Control.Concurrent.MVar
41  
-import Control.Exception (bracket)
  42
+import Control.Concurrent.MVar ()
  43
+import Control.Exception (bracket, catch, SomeException)
42 44
 import Data.Maybe
43 45
 import Data.Map (Map)
44 46
 import qualified Data.Map as Map
@@ -48,7 +50,7 @@ import Foreign.Ptr
48 50
 import Foreign.Storable
49 51
 import System.Directory
50 52
 import System.IO
51  
-import System.IO.Error
  53
+import System.IO.Error hiding (catch)
52 54
 #if __GLASGOW_HASKELL__ >= 612
53 55
 import GHC.IO.Handle.FD (fdToHandle')
54 56
 import GHC.IO.Device (IODeviceType(Stream))
@@ -63,14 +65,25 @@ type FD = CInt
63 65
 type WD = CInt
64 66
 type Masks = CUInt
65 67
 
66  
-type EventMap = Map WD (Event -> IO ())
  68
+type WatchMap = Map WD WatchDescriptor
67 69
 type WDEvent = (WD, Event)
68 70
 
69  
-data INotify = INotify Handle FD (MVar EventMap) ThreadId ThreadId
70  
-data WatchDescriptor = WatchDescriptor INotify WD deriving Eq
  71
+data INotify = INotify {
  72
+     inHandle   :: Handle
  73
+   , inFD       :: FD
  74
+   , inWatchMap :: (MVar WatchMap)
  75
+   , inTid      :: ThreadId
  76
+ }
  77
+
  78
+data WatchDescriptor = WatchDescriptor {
  79
+    wdInotify :: INotify
  80
+  , wdCInt    :: WD
  81
+  , wdChan    :: (Chan Event)
  82
+  , wdMasks   :: [EventVariety]
  83
+  } deriving Eq
71 84
 
72 85
 instance Eq INotify where
73  
-  (INotify _ fd1 _ _ _) == (INotify _ fd2 _ _ _) = fd1 == fd2
  86
+  in1 == in2 = inFD in1 == inFD in2
74 87
 
75 88
 newtype Cookie = Cookie CUInt deriving (Eq,Ord)
76 89
 
@@ -162,12 +175,12 @@ data EventVariety
162 175
     deriving Eq
163 176
 
164 177
 instance Show INotify where
165  
-    show (INotify _ fd _ _ _) =
  178
+    show inotify =
166 179
         showString "<inotify fd=" . 
167  
-        shows fd $ ">"
  180
+        shows (inFD inotify) $ ">"
168 181
 
169 182
 instance Show WatchDescriptor where
170  
-    show (WatchDescriptor _ wd) = showString "<wd=" . shows wd $ ">"
  183
+    show wd = showString "<wd=" . shows (wdCInt wd) $ ">"
171 184
 
172 185
 instance Show Cookie where
173 186
     show (Cookie c) = showString "<cookie " . shows c $ ">"
@@ -181,12 +194,21 @@ initINotify = do
181 194
 #else
182 195
     h <-  fdToHandle' (fromIntegral fd) (Just Stream) False{-is_socket-} desc ReadMode True{-binary-}
183 196
 #endif
184  
-    em <- newMVar Map.empty
185  
-    (tid1, tid2) <- inotify_start_thread h em
186  
-    return (INotify h fd em tid1 tid2)
  197
+    wm <- newMVar Map.empty
  198
+    tid1 <- inotify_start_thread h wm
  199
+    return (INotify h fd wm tid1)
187 200
 
188 201
 addWatch :: INotify -> [EventVariety] -> FilePath -> (Event -> IO ()) -> IO WatchDescriptor
189  
-addWatch inotify@(INotify _ fd em _ _) masks fp cb = do
  202
+addWatch inotify masks fp cb = do
  203
+  (wd,chan) <- watch inotify masks fp
  204
+  _<- forkIO $ do
  205
+        ev <- readChan chan
  206
+        cb ev `catch` \(_::SomeException) -> return ()
  207
+  return wd
  208
+
  209
+watch :: INotify -> [EventVariety] -> FilePath -> IO (WatchDescriptor, Chan Event)
  210
+watch inotify masks fp = do
  211
+    chan <- newChan
190 212
     is_dir <- doesDirectoryExist fp
191 213
     when (not is_dir) $ do
192 214
         file_exist <- doesFileExist fp
@@ -198,20 +220,12 @@ addWatch inotify@(INotify _ fd em _ _) masks fp cb = do
198 220
                                 Nothing 
199 221
                                 (Just fp)
200 222
     let mask = joinMasks (map eventVarietyToMask masks)
201  
-    wd <- withCString fp $ \fp_c ->
202  
-            throwErrnoIfMinus1 "addWatch" $
203  
-              c_inotify_add_watch (fromIntegral fd) fp_c mask
204  
-    let event = \e -> do
205  
-            when (OneShot `elem` masks) $
206  
-              rm_watch inotify wd
207  
-            case e of
208  
-              -- if the event is Ignored then we know for sure that
209  
-              -- this is the last event on that WatchDescriptor
210  
-              Ignored -> rm_watch inotify wd
211  
-              _       -> return ()
212  
-            cb e
213  
-    modifyMVar_ em $ \em' -> return (Map.insert wd event em')
214  
-    return (WatchDescriptor inotify wd)
  223
+    wdInt <- withCString fp $ \fp_c ->
  224
+              throwErrnoIfMinus1 "addWatch" $
  225
+                c_inotify_add_watch (fromIntegral $ inFD inotify) fp_c mask
  226
+    let wd = (WatchDescriptor inotify wdInt chan masks)
  227
+    modifyMVar_ (inWatchMap inotify) $ \wm -> return (Map.insert wdInt wd wm)
  228
+    return (wd, chan)
215 229
     where
216 230
     eventVarietyToMask ev =
217 231
         case ev of
@@ -236,14 +250,14 @@ addWatch inotify@(INotify _ fd em _ _) masks fp cb = do
236 250
             AllEvents -> inAllEvents
237 251
 
238 252
 removeWatch :: WatchDescriptor -> IO ()
239  
-removeWatch (WatchDescriptor (INotify _ fd _ _ _) wd) = do
  253
+removeWatch wd = do
240 254
     _ <- throwErrnoIfMinus1 "removeWatch" $
241  
-      c_inotify_rm_watch (fromIntegral fd) wd
  255
+      c_inotify_rm_watch (fromIntegral $ inFD $ wdInotify wd) (wdCInt wd)
242 256
     return ()
243 257
 
244  
-rm_watch :: INotify -> WD -> IO ()
245  
-rm_watch (INotify _ _ em _ _) wd =
246  
-    modifyMVar_ em (return . Map.delete wd)
  258
+rm_watch :: WatchDescriptor -> IO ()
  259
+rm_watch wd =
  260
+    modifyMVar_ (inWatchMap $ wdInotify wd) (return . Map.delete (wdCInt wd))
247 261
 
248 262
 read_events :: Handle -> IO [WDEvent]
249 263
 read_events h = 
@@ -292,40 +306,34 @@ read_events h =
292 306
         isSet bits = maskIsSet bits mask
293 307
         name = fromJust nameM
294 308
        
295  
-inotify_start_thread :: Handle -> MVar EventMap -> IO (ThreadId, ThreadId)
296  
-inotify_start_thread h em = do
297  
-    chan_events <- newChan
298  
-    tid1 <- forkIO (dispatcher chan_events)
299  
-    tid2 <- forkIO (start_thread chan_events)
300  
-    return (tid1,tid2)
301  
-    where
302  
-    start_thread :: Chan [WDEvent] -> IO ()
303  
-    start_thread chan_events = do
304  
-        events <- read_events h
305  
-        writeChan chan_events events
306  
-        start_thread chan_events
307  
-    dispatcher :: Chan [WDEvent] -> IO ()
308  
-    dispatcher chan_events = do
309  
-        events <- readChan chan_events
310  
-        mapM_ runHandler events
311  
-        dispatcher chan_events
312  
-    runHandler :: WDEvent -> IO ()
313  
-    runHandler (_,  e@QOverflow) = do -- send overflows to all handlers
314  
-        handlers <- readMVar em
315  
-        flip mapM_ (Map.elems handlers) $ \handler ->
316  
-            catch (handler e) (\_ -> return ()) -- supress errors
317  
-    runHandler (wd, event) = do 
318  
-        handlers <- readMVar em
319  
-        let handlerM = Map.lookup wd handlers
320  
-        case handlerM of
321  
-          Nothing -> putStrLn "runHandler: couldn't find handler" -- impossible?
322  
-          Just handler -> catch (handler event) (\_ -> return ())
  309
+inotify_start_thread :: Handle -> MVar WatchMap -> IO ThreadId
  310
+inotify_start_thread h watchMap = forkIO $
  311
+    read_events h >>= mapM_ chanDispatch
  312
+  where
  313
+    writeEvent wd = writeChan (wdChan wd)
  314
+
  315
+    chanDispatch :: WDEvent -> IO ()
  316
+    chanDispatch (_,  e@QOverflow) = do -- send overflows to all handlers
  317
+        wMap <- readMVar watchMap
  318
+        flip mapM_ (Map.elems wMap) $ \wd -> writeEvent wd e
  319
+    chanDispatch (wdInt, event) = do 
  320
+        wMap <- readMVar watchMap
  321
+        case Map.lookup wdInt wMap of
  322
+          Nothing -> putStrLn "chanDispatch: couldn't find watcher" -- impossible?
  323
+          Just wd -> handle wd event
  324
+      where
  325
+        handle wd e = do
  326
+            when (OneShot `elem` wdMasks wd) $
  327
+              rm_watch wd
  328
+            case e of
  329
+              -- if the event is Ignored then we know for sure that
  330
+              -- this is the last event on that WatchDescriptor
  331
+              Ignored -> rm_watch wd
  332
+              _       -> return ()
  333
+            writeEvent wd e
323 334
 
324 335
 killINotify :: INotify -> IO ()
325  
-killINotify (INotify h _ _ tid1 tid2) =
326  
-    do killThread tid1
327  
-       killThread tid2
328  
-       hClose h
  336
+killINotify inotify = killThread (inTid inotify) >> hClose (inHandle inotify)
329 337
 
330 338
 withINotify :: (INotify -> IO a) -> IO a
331 339
 withINotify = bracket initINotify killINotify
47  test/MoveSpec.hs
... ...
@@ -0,0 +1,47 @@
  1
+module MoveSpec where
  2
+
  3
+import Data.Maybe
  4
+
  5
+import Control.Monad
  6
+
  7
+import System.Directory
  8
+import System.IO
  9
+
  10
+import System.INotify as INotify
  11
+
  12
+import Utils
  13
+
  14
+file = "hello"
  15
+file2 = file ++ "2"
  16
+
  17
+write path = do
  18
+    writeFile (path ++ '/':file) ""
  19
+
  20
+move path = do
  21
+    renameFile (path ++ '/':file) (path ++ '/':file2)
  22
+
  23
+remove path = do
  24
+    removeFile (path ++ '/':file2)
  25
+
  26
+action path = do
  27
+    write path
  28
+    move path
  29
+    remove path
  30
+    
  31
+main =
  32
+    inTestEnviron [AllEvents] action $ \ events -> do
  33
+        let cookie = head [ c | MovedOut _ _ c <- events ]
  34
+        when (expected cookie ~= events)
  35
+            testSuccess
  36
+        explainFailure (expected cookie) events
  37
+
  38
+expected cookie =
  39
+    [ Created   False file
  40
+    , Opened    False (Just file)
  41
+    , Modified  False (Just file)
  42
+    , Closed    False (Just file) True
  43
+    , MovedOut  False file  cookie
  44
+    , MovedIn   False file2 cookie
  45
+    , Deleted   False file2
  46
+    ]
  47
+
71  test/Utils.hs
... ...
@@ -0,0 +1,71 @@
  1
+module Utils where
  2
+
  3
+import Control.Concurrent.Chan
  4
+import Control.Exception
  5
+
  6
+import System.Directory
  7
+import System.Environment
  8
+import System.Exit
  9
+
  10
+import System.INotify
  11
+
  12
+testName = do
  13
+    n <- getProgName
  14
+    return (n ++ "-playground")
  15
+
  16
+withTempDir f = do
  17
+    path <- testName
  18
+    bracket
  19
+        ( createDirectory path >> return path )
  20
+        ( removeDirectoryRecursive )
  21
+        ( f )
  22
+
  23
+withEventWatch inot events path f =
  24
+    bracket
  25
+        ( watch inot events path action )
  26
+        removeWatch
  27
+        ( f )
  28
+
  29
+withWatch inot events path action f =
  30
+    bracket
  31
+        ( addWatch inot events path action )
  32
+        removeWatch
  33
+        ( const f )
  34
+
  35
+inTestEnviron events action f = do
  36
+    withTempDir $ \testPath -> do
  37
+        inot <- initINotify
  38
+        chan <- newChan
  39
+        withWatch inot events testPath (writeChan chan) $ do
  40
+            action testPath
  41
+            events <- getChanContents chan
  42
+            f events
  43
+
  44
+inTestEnvironEvent events action f = do
  45
+    withTempDir $ \testPath -> do
  46
+        inot <- initINotify
  47
+        chan <- newChan
  48
+        withEventWatch inot events testPath $ \(wd,chan) -> do
  49
+            action testPath
  50
+            events <- getChanContents chan
  51
+            f events
  52
+
  53
+
  54
+(~=) :: Eq a => [a] -> [a] -> Bool
  55
+[] ~= _ = True
  56
+(x:xs) ~= (y:ys) = x == y && xs ~= ys
  57
+_ ~= _ = False
  58
+
  59
+asMany :: [a] -> [a] -> [a]
  60
+asMany xs ys = take (length xs) ys
  61
+
  62
+explainFailure expected reality = do
  63
+    putStrLn "Expected:"
  64
+    mapM_ (\x -> putStr "> " >> print x) expected
  65
+    putStrLn "But got:"
  66
+    mapM_ (\x -> putStr "< " >> print x) (asMany expected reality)
  67
+    testFailure
  68
+
  69
+testFailure = exitFailure 
  70
+
  71
+testSuccess = exitWith ExitSuccess
1  test/main.hs
... ...
@@ -0,0 +1 @@
  1
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-}
26  tests/Utils.hs
@@ -17,8 +17,14 @@ withTempDir f = do
17 17
     path <- testName
18 18
     bracket
19 19
         ( createDirectory path >> return path )
20  
-        ( removeDirectoryRecursive )
21  
-        ( f )
  20
+        removeDirectoryRecursive
  21
+        f
  22
+
  23
+withEventWatch inot events path f =
  24
+    bracket
  25
+        ( watch inot events path )
  26
+        (\(wd,e) -> removeWatch wd)
  27
+        f
22 28
 
23 29
 withWatch inot events path action f =
24 30
     bracket
@@ -26,7 +32,7 @@ withWatch inot events path action f =
26 32
         removeWatch
27 33
         ( const f )
28 34
 
29  
-inTestEnviron events action f = do
  35
+inTestEnviron events action f =
30 36
     withTempDir $ \testPath -> do
31 37
         inot <- initINotify
32 38
         chan <- newChan
@@ -35,13 +41,23 @@ inTestEnviron events action f = do
35 41
             events <- getChanContents chan
36 42
             f events
37 43
 
  44
+inTestEnvironEvent events action f =
  45
+    withTempDir $ \testPath -> do
  46
+        inot <- initINotify
  47
+        chan <- newChan
  48
+        withEventWatch inot events testPath $ \(wd,chan) -> do
  49
+            action testPath
  50
+            events <- getChanContents chan
  51
+            f events
  52
+
  53
+
38 54
 (~=) :: Eq a => [a] -> [a] -> Bool
39 55
 [] ~= _ = True
40 56
 (x:xs) ~= (y:ys) = x == y && xs ~= ys
41 57
 _ ~= _ = False
42 58
 
43 59
 asMany :: [a] -> [a] -> [a]
44  
-asMany xs ys = take (length xs) ys
  60
+asMany = take . length
45 61
 
46 62
 explainFailure expected reality = do
47 63
     putStrLn "Expected:"
@@ -52,4 +68,4 @@ explainFailure expected reality = do
52 68
 
53 69
 testFailure = exitFailure 
54 70
 
55  
-testSuccess = exitWith ExitSuccess
  71
+testSuccess = exitSuccess
Commit_comment_tip

Tip: You can add notes to lines in a file. Hover to the left of a line to make a note

Something went wrong with that request. Please try again.