{-# LINE 1 "src/System/INotify.hsc" #-}
{-# LANGUAGE CPP #-}
module System.INotify
( initINotify
, killINotify
, withINotify
, addWatch
, removeWatch
, INotify
, WatchDescriptor
, Event(..)
, EventVariety(..)
, Cookie
) where
import Prelude hiding (init)
import Control.Monad
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception as E hiding (mask)
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Foreign.C
import Foreign.Marshal hiding (void)
import Foreign.Ptr
import Foreign.Storable
import System.IO
import System.IO.Error
import System.Posix.ByteString.FilePath
import System.Posix.Files.ByteString
import GHC.IO.FD as FD (mkFD)
import GHC.IO.Handle.FD (mkHandleFromFD)
import GHC.IO.Device (IODeviceType(Stream))
import System.INotify.Masks
type FD = CInt
type WD = CInt
type Masks = CUInt
type EventMap = Map WD (Event -> IO ())
type WDEvent = (WD, Event)
data INotify = INotify Handle FD (MVar EventMap) (Async ()) (Async ())
data WatchDescriptor = WatchDescriptor INotify WD deriving Eq
instance Eq INotify where
(INotify _ fd1 _ _ _) == (INotify _ fd2 _ _ _) = fd1 == fd2
newtype Cookie = Cookie CUInt deriving (Eq,Ord)
data FDEvent = FDEvent WD Masks CUInt (Maybe RawFilePath) deriving (Eq, Show)
data Event =
Accessed
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
}
| Modified
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
}
| Attributes
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
}
| Closed
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
, wasWriteable :: Bool
}
| Opened
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
}
| MovedOut
{ isDirectory :: Bool
, filePath :: RawFilePath
, moveCookie :: Cookie
}
| MovedIn
{ isDirectory :: Bool
, filePath :: RawFilePath
, moveCookie :: Cookie
}
| MovedSelf
{ isDirectory :: Bool
}
| Created
{ isDirectory :: Bool
, filePath :: RawFilePath
}
| Deleted
{ isDirectory :: Bool
, filePath :: RawFilePath
}
| DeletedSelf
| Unmounted
| QOverflow
| Ignored
| Unknown FDEvent
deriving (Eq, Show)
data EventVariety
= Access
| Modify
| Attrib
| Close
| CloseWrite
| CloseNoWrite
| Open
| Move
| MoveIn
| MoveOut
| MoveSelf
| Create
| Delete
| DeleteSelf
| OnlyDir
| NoSymlink
| MaskAdd
| OneShot
| AllEvents
deriving Eq
instance Show INotify where
show (INotify _ fd _ _ _) =
showString "<inotify fd=" .
shows fd $ ">"
instance Show WatchDescriptor where
show (WatchDescriptor _ wd) = showString "<wd=" . shows wd $ ">"
instance Show Cookie where
show (Cookie c) = showString "<cookie " . shows c $ ">"
initINotify :: IO INotify
initINotify = do
fdint <- throwErrnoIfMinus1 "initINotify" c_inotify_init
(fd,fd_type) <- FD.mkFD fdint ReadMode (Just (Stream,0,0))
False
False
h <- mkHandleFromFD fd fd_type
(showString "<inotify handle, fd=" . shows fd $ ">")
ReadMode
True
Nothing
em <- newMVar Map.empty
(tid1, tid2) <- inotify_start_thread h em
return (INotify h fdint em tid1 tid2)
addWatch :: INotify -> [EventVariety] -> RawFilePath -> (Event -> IO ()) -> IO WatchDescriptor
addWatch inotify@(INotify _ fd em _ _) masks fp cb = do
catch_IO (void $
(if (NoSymlink `elem` masks) then getSymbolicLinkStatus else getFileStatus)
fp) $ \_ ->
ioError $ mkIOError doesNotExistErrorType
"can't watch what isn't there!"
Nothing
(Just (show fp))
let mask = joinMasks (map eventVarietyToMask masks)
wd <- withFilePath fp $ \fp_c ->
throwErrnoIfMinus1 "addWatch" $
c_inotify_add_watch (fromIntegral fd) fp_c mask
let event = \e -> ignore_failure $ do
case e of
Ignored -> rm_watch inotify wd
_ -> return ()
cb e
modifyMVar_ em $ \em' -> return (Map.insertWith (liftM2 (>>)) wd event em')
return (WatchDescriptor inotify wd)
where
catch_IO :: IO a -> (IOError -> IO a) -> IO a
catch_IO = E.catch
eventVarietyToMask ev =
case ev of
Access -> inAccess
Modify -> inModify
Attrib -> inAttrib
Close -> inClose
CloseWrite -> inCloseWrite
CloseNoWrite -> inCloseNowrite
Open -> inOpen
Move -> inMove
MoveIn -> inMovedTo
MoveOut -> inMovedFrom
MoveSelf -> inMoveSelf
Create -> inCreate
Delete -> inDelete
DeleteSelf-> inDeleteSelf
OnlyDir -> inOnlydir
NoSymlink -> inDontFollow
MaskAdd -> inMaskAdd
OneShot -> inOneshot
AllEvents -> inAllEvents
ignore_failure :: IO () -> IO ()
ignore_failure action = action `E.catch` ignore
where
ignore :: SomeException -> IO ()
ignore e
#if MIN_VERSION_async(2,2,1)
| Just AsyncCancelled <- fromException e = throwIO e
#else
| Just ThreadKilled{} <- fromException e = throwIO e
#endif
| otherwise = return ()
removeWatch :: WatchDescriptor -> IO ()
removeWatch (WatchDescriptor (INotify _ fd _ _ _) wd) = do
_ <- throwErrnoIfMinus1 "removeWatch" $
c_inotify_rm_watch (fromIntegral fd) wd
return ()
rm_watch :: INotify -> WD -> IO ()
rm_watch (INotify _ _ em _ _) wd =
modifyMVar_ em (return . Map.delete wd)
read_events :: Handle -> IO [WDEvent]
read_events h =
let maxRead = 16385 in
allocaBytes maxRead $ \buffer -> do
_ <- hWaitForInput h (-1)
r <- hGetBufNonBlocking h buffer maxRead
read_events' buffer r
where
read_events' :: Ptr a -> Int -> IO [WDEvent]
read_events' _ r | r <= 0 = return []
read_events' ptr r = do
wd <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr :: IO CInt
{-# LINE 273 "src/System/INotify.hsc" #-}
mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr :: IO CUInt
{-# LINE 274 "src/System/INotify.hsc" #-}
cookie <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr :: IO CUInt
{-# LINE 275 "src/System/INotify.hsc" #-}
len <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr :: IO CUInt
{-# LINE 276 "src/System/INotify.hsc" #-}
nameM <- if len == 0
then return Nothing
else do
fmap Just $ peekFilePath (((\hsc_ptr -> hsc_ptr `plusPtr` 16)) ptr)
{-# LINE 280 "src/System/INotify.hsc" #-}
let event_size = ((16)) + (fromIntegral len)
{-# LINE 281 "src/System/INotify.hsc" #-}
event = cEvent2Haskell (FDEvent wd mask cookie nameM)
rest <- read_events' (ptr `plusPtr` event_size) (r - event_size)
return (event:rest)
cEvent2Haskell :: FDEvent
-> WDEvent
cEvent2Haskell fdevent@(FDEvent wd mask cookie nameM)
= (wd, event)
where
event
| isSet inAccess = Accessed isDir nameM
| isSet inModify = Modified isDir nameM
| isSet inAttrib = Attributes isDir nameM
| isSet inClose = Closed isDir nameM (isSet inCloseWrite)
| isSet inOpen = Opened isDir nameM
| isSet inMovedFrom = MovedOut isDir name (Cookie cookie)
| isSet inMovedTo = MovedIn isDir name (Cookie cookie)
| isSet inMoveSelf = MovedSelf isDir
| isSet inCreate = Created isDir name
| isSet inDelete = Deleted isDir name
| isSet inDeleteSelf = DeletedSelf
| isSet inUnmount = Unmounted
| isSet inQOverflow = QOverflow
| isSet inIgnored = Ignored
| otherwise = Unknown fdevent
isDir = isSet inIsdir
isSet bits = maskIsSet bits mask
name = fromJust nameM
inotify_start_thread :: Handle -> MVar EventMap -> IO (Async (), Async ())
inotify_start_thread h em = do
chan_events <- newChan
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 ()
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
handlers <- readMVar em
mapM_ ($ e) (Map.elems handlers)
runHandler (wd, event) = do
handlers <- readMVar em
let handlerM = Map.lookup wd handlers
case handlerM of
Nothing -> putStrLn "runHandler: couldn't find handler"
Just handler -> handler event
logFailure name io = io `E.catch` \e ->
case e of
#if MIN_VERSION_async(2,2,1)
_ | Just AsyncCancelled <- fromException e -> return ()
#else
_ | Just ThreadKilled{} <- fromException e -> return ()
#endif
| otherwise -> hPutStrLn stderr (name ++ " dying: " ++ show e)
killINotify :: INotify -> IO ()
killINotify (INotify h _ _ tid1 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