{-# 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 WatchDescriptor -> WatchDescriptor -> Bool
(WatchDescriptor -> WatchDescriptor -> Bool)
-> (WatchDescriptor -> WatchDescriptor -> Bool)
-> Eq WatchDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WatchDescriptor -> WatchDescriptor -> Bool
$c/= :: WatchDescriptor -> WatchDescriptor -> Bool
== :: WatchDescriptor -> WatchDescriptor -> Bool
$c== :: WatchDescriptor -> WatchDescriptor -> Bool
Eq
instance Eq INotify where
(INotify _ fd1 :: FD
fd1 _ _ _) == :: INotify -> INotify -> Bool
== (INotify _ fd2 :: FD
fd2 _ _ _) = FD
fd1 FD -> FD -> Bool
forall a. Eq a => a -> a -> Bool
== FD
fd2
newtype Cookie = Cookie CUInt deriving (Cookie -> Cookie -> Bool
(Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool) -> Eq Cookie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cookie -> Cookie -> Bool
$c/= :: Cookie -> Cookie -> Bool
== :: Cookie -> Cookie -> Bool
$c== :: Cookie -> Cookie -> Bool
Eq,Eq Cookie
Eq Cookie =>
(Cookie -> Cookie -> Ordering)
-> (Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Cookie)
-> (Cookie -> Cookie -> Cookie)
-> Ord Cookie
Cookie -> Cookie -> Bool
Cookie -> Cookie -> Ordering
Cookie -> Cookie -> Cookie
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cookie -> Cookie -> Cookie
$cmin :: Cookie -> Cookie -> Cookie
max :: Cookie -> Cookie -> Cookie
$cmax :: Cookie -> Cookie -> Cookie
>= :: Cookie -> Cookie -> Bool
$c>= :: Cookie -> Cookie -> Bool
> :: Cookie -> Cookie -> Bool
$c> :: Cookie -> Cookie -> Bool
<= :: Cookie -> Cookie -> Bool
$c<= :: Cookie -> Cookie -> Bool
< :: Cookie -> Cookie -> Bool
$c< :: Cookie -> Cookie -> Bool
compare :: Cookie -> Cookie -> Ordering
$ccompare :: Cookie -> Cookie -> Ordering
$cp1Ord :: Eq Cookie
Ord)
data FDEvent = FDEvent WD Masks CUInt (Maybe RawFilePath) deriving (FDEvent -> FDEvent -> Bool
(FDEvent -> FDEvent -> Bool)
-> (FDEvent -> FDEvent -> Bool) -> Eq FDEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FDEvent -> FDEvent -> Bool
$c/= :: FDEvent -> FDEvent -> Bool
== :: FDEvent -> FDEvent -> Bool
$c== :: FDEvent -> FDEvent -> Bool
Eq, Int -> FDEvent -> ShowS
[FDEvent] -> ShowS
FDEvent -> String
(Int -> FDEvent -> ShowS)
-> (FDEvent -> String) -> ([FDEvent] -> ShowS) -> Show FDEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FDEvent] -> ShowS
$cshowList :: [FDEvent] -> ShowS
show :: FDEvent -> String
$cshow :: FDEvent -> String
showsPrec :: Int -> FDEvent -> ShowS
$cshowsPrec :: Int -> FDEvent -> ShowS
Show)
data Event =
Accessed
{ Event -> Bool
isDirectory :: Bool
, Event -> Maybe RawFilePath
maybeFilePath :: Maybe RawFilePath
}
| Modified
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
}
| Attributes
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
}
| Closed
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
, Event -> Bool
wasWriteable :: Bool
}
| Opened
{ isDirectory :: Bool
, maybeFilePath :: Maybe RawFilePath
}
| MovedOut
{ isDirectory :: Bool
, Event -> RawFilePath
filePath :: RawFilePath
, Event -> Cookie
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 (Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)
data EventVariety
= Access
| Modify
| Attrib
| Close
| CloseWrite
| CloseNoWrite
| Open
| Move
| MoveIn
| MoveOut
| MoveSelf
| Create
| Delete
| DeleteSelf
| OnlyDir
| NoSymlink
| MaskAdd
| OneShot
| AllEvents
deriving EventVariety -> EventVariety -> Bool
(EventVariety -> EventVariety -> Bool)
-> (EventVariety -> EventVariety -> Bool) -> Eq EventVariety
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventVariety -> EventVariety -> Bool
$c/= :: EventVariety -> EventVariety -> Bool
== :: EventVariety -> EventVariety -> Bool
$c== :: EventVariety -> EventVariety -> Bool
Eq
instance Show INotify where
show :: INotify -> String
show (INotify _ fd :: FD
fd _ _ _) =
String -> ShowS
showString "<inotify fd=" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
FD -> ShowS
forall a. Show a => a -> ShowS
shows FD
fd ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ">"
instance Show WatchDescriptor where
show :: WatchDescriptor -> String
show (WatchDescriptor _ wd :: FD
wd) = String -> ShowS
showString "<wd=" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FD -> ShowS
forall a. Show a => a -> ShowS
shows FD
wd ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ">"
instance Show Cookie where
show :: Cookie -> String
show (Cookie c :: CUInt
c) = String -> ShowS
showString "<cookie " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CUInt -> ShowS
forall a. Show a => a -> ShowS
shows CUInt
c ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ">"
initINotify :: IO INotify
initINotify :: IO INotify
initINotify = do
FD
fdint <- String -> IO FD -> IO FD
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 "initINotify" IO FD
c_inotify_init
(fd :: FD
fd,fd_type :: IODeviceType
fd_type) <- FD
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD FD
fdint IOMode
ReadMode ((IODeviceType, CDev, CIno) -> Maybe (IODeviceType, CDev, CIno)
forall a. a -> Maybe a
Just (IODeviceType
Stream,0,0))
Bool
False
Bool
False
Handle
h <- FD
-> IODeviceType
-> String
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
mkHandleFromFD FD
fd IODeviceType
fd_type
(String -> ShowS
showString "<inotify handle, fd=" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FD -> ShowS
forall a. Show a => a -> ShowS
shows FD
fd ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ">")
IOMode
ReadMode
Bool
True
Maybe TextEncoding
forall a. Maybe a
Nothing
MVar (Map FD (Event -> IO ()))
em <- Map FD (Event -> IO ()) -> IO (MVar (Map FD (Event -> IO ())))
forall a. a -> IO (MVar a)
newMVar Map FD (Event -> IO ())
forall k a. Map k a
Map.empty
(tid1 :: Async ()
tid1, tid2 :: Async ()
tid2) <- Handle -> MVar (Map FD (Event -> IO ())) -> IO (Async (), Async ())
inotify_start_thread Handle
h MVar (Map FD (Event -> IO ()))
em
INotify -> IO INotify
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
-> FD
-> MVar (Map FD (Event -> IO ()))
-> Async ()
-> Async ()
-> INotify
INotify Handle
h FD
fdint MVar (Map FD (Event -> IO ()))
em Async ()
tid1 Async ()
tid2)
addWatch :: INotify -> [EventVariety] -> RawFilePath -> (Event -> IO ()) -> IO WatchDescriptor
addWatch :: INotify
-> [EventVariety]
-> RawFilePath
-> (Event -> IO ())
-> IO WatchDescriptor
addWatch inotify :: INotify
inotify@(INotify _ fd :: FD
fd em :: MVar (Map FD (Event -> IO ()))
em _ _) masks :: [EventVariety]
masks fp :: RawFilePath
fp cb :: Event -> IO ()
cb = do
IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
catch_IO (IO FileStatus -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FileStatus -> IO ()) -> IO FileStatus -> IO ()
forall a b. (a -> b) -> a -> b
$
(if (EventVariety
NoSymlink EventVariety -> [EventVariety] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventVariety]
masks) then RawFilePath -> IO FileStatus
getSymbolicLinkStatus else RawFilePath -> IO FileStatus
getFileStatus)
RawFilePath
fp) ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ ->
IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
doesNotExistErrorType
"can't watch what isn't there!"
Maybe Handle
forall a. Maybe a
Nothing
(String -> Maybe String
forall a. a -> Maybe a
Just (RawFilePath -> String
forall a. Show a => a -> String
show RawFilePath
fp))
let mask :: CUInt
mask = [Mask] -> CUInt
joinMasks ((EventVariety -> Mask) -> [EventVariety] -> [Mask]
forall a b. (a -> b) -> [a] -> [b]
map EventVariety -> Mask
eventVarietyToMask [EventVariety]
masks)
FD
wd <- RawFilePath -> (CString -> IO FD) -> IO FD
forall a. RawFilePath -> (CString -> IO a) -> IO a
withFilePath RawFilePath
fp ((CString -> IO FD) -> IO FD) -> (CString -> IO FD) -> IO FD
forall a b. (a -> b) -> a -> b
$ \fp_c :: CString
fp_c ->
String -> IO FD -> IO FD
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 "addWatch" (IO FD -> IO FD) -> IO FD -> IO FD
forall a b. (a -> b) -> a -> b
$
FD -> CString -> CUInt -> IO FD
c_inotify_add_watch (FD -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
fd) CString
fp_c CUInt
mask
let event :: Event -> IO ()
event = \e :: Event
e -> IO () -> IO ()
ignore_failure (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
case Event
e of
Ignored -> INotify -> FD -> IO ()
rm_watch INotify
inotify FD
wd
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Event -> IO ()
cb Event
e
MVar (Map FD (Event -> IO ()))
-> (Map FD (Event -> IO ()) -> IO (Map FD (Event -> IO ())))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map FD (Event -> IO ()))
em ((Map FD (Event -> IO ()) -> IO (Map FD (Event -> IO ())))
-> IO ())
-> (Map FD (Event -> IO ()) -> IO (Map FD (Event -> IO ())))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \em' :: Map FD (Event -> IO ())
em' -> Map FD (Event -> IO ()) -> IO (Map FD (Event -> IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Event -> IO ()) -> (Event -> IO ()) -> Event -> IO ())
-> FD
-> (Event -> IO ())
-> Map FD (Event -> IO ())
-> Map FD (Event -> IO ())
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((IO () -> IO () -> IO ())
-> (Event -> IO ()) -> (Event -> IO ()) -> Event -> IO ()
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)) FD
wd Event -> IO ()
event Map FD (Event -> IO ())
em')
WatchDescriptor -> IO WatchDescriptor
forall (m :: * -> *) a. Monad m => a -> m a
return (INotify -> FD -> WatchDescriptor
WatchDescriptor INotify
inotify FD
wd)
where
catch_IO :: IO a -> (IOError -> IO a) -> IO a
catch_IO :: IO a -> (IOError -> IO a) -> IO a
catch_IO = IO a -> (IOError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
eventVarietyToMask :: EventVariety -> Mask
eventVarietyToMask ev :: EventVariety
ev =
case EventVariety
ev of
Access -> Mask
inAccess
Modify -> Mask
inModify
Attrib -> Mask
inAttrib
Close -> Mask
inClose
CloseWrite -> Mask
inCloseWrite
CloseNoWrite -> Mask
inCloseNowrite
Open -> Mask
inOpen
Move -> Mask
inMove
MoveIn -> Mask
inMovedTo
MoveOut -> Mask
inMovedFrom
MoveSelf -> Mask
inMoveSelf
Create -> Mask
inCreate
Delete -> Mask
inDelete
DeleteSelf-> Mask
inDeleteSelf
OnlyDir -> Mask
inOnlydir
NoSymlink -> Mask
inDontFollow
MaskAdd -> Mask
inMaskAdd
OneShot -> Mask
inOneshot
AllEvents -> Mask
inAllEvents
ignore_failure :: IO () -> IO ()
ignore_failure :: IO () -> IO ()
ignore_failure action :: IO ()
action = IO ()
action IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
ignore
where
ignore :: SomeException -> IO ()
ignore :: SomeException -> IO ()
ignore e :: SomeException
e
#if MIN_VERSION_async(2,2,1)
| Just AsyncCancelled <- SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e
#else
| Just ThreadKilled{} <- fromException e = throwIO e
#endif
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
removeWatch :: WatchDescriptor -> IO ()
removeWatch :: WatchDescriptor -> IO ()
removeWatch (WatchDescriptor (INotify _ fd :: FD
fd _ _ _) wd :: FD
wd) = do
FD
_ <- String -> IO FD -> IO FD
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 "removeWatch" (IO FD -> IO FD) -> IO FD -> IO FD
forall a b. (a -> b) -> a -> b
$
FD -> FD -> IO FD
c_inotify_rm_watch (FD -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
fd) FD
wd
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
rm_watch :: INotify -> WD -> IO ()
rm_watch :: INotify -> FD -> IO ()
rm_watch (INotify _ _ em :: MVar (Map FD (Event -> IO ()))
em _ _) wd :: FD
wd =
MVar (Map FD (Event -> IO ()))
-> (Map FD (Event -> IO ()) -> IO (Map FD (Event -> IO ())))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map FD (Event -> IO ()))
em (Map FD (Event -> IO ()) -> IO (Map FD (Event -> IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FD (Event -> IO ()) -> IO (Map FD (Event -> IO ())))
-> (Map FD (Event -> IO ()) -> Map FD (Event -> IO ()))
-> Map FD (Event -> IO ())
-> IO (Map FD (Event -> IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FD -> Map FD (Event -> IO ()) -> Map FD (Event -> IO ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FD
wd)
read_events :: Handle -> IO [WDEvent]
read_events :: Handle -> IO [WDEvent]
read_events h :: Handle
h =
let maxRead :: Int
maxRead = 16385 in
Int -> (Ptr Any -> IO [WDEvent]) -> IO [WDEvent]
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
maxRead ((Ptr Any -> IO [WDEvent]) -> IO [WDEvent])
-> (Ptr Any -> IO [WDEvent]) -> IO [WDEvent]
forall a b. (a -> b) -> a -> b
$ \buffer :: Ptr Any
buffer -> do
Bool
_ <- Handle -> Int -> IO Bool
hWaitForInput Handle
h (-1)
Int
r <- Handle -> Ptr Any -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufNonBlocking Handle
h Ptr Any
buffer Int
maxRead
Ptr Any -> Int -> IO [WDEvent]
forall a. Ptr a -> Int -> IO [WDEvent]
read_events' Ptr Any
buffer Int
r
where
read_events' :: Ptr a -> Int -> IO [WDEvent]
read_events' :: Ptr a -> Int -> IO [WDEvent]
read_events' _ r :: Int
r | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = [WDEvent] -> IO [WDEvent]
forall (m :: * -> *) a. Monad m => a -> m a
return []
read_events' ptr :: Ptr a
ptr r :: Int
r = do
FD
wd <- ((\hsc_ptr :: Ptr a
hsc_ptr -> Ptr a -> Int -> IO FD
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr 0)) Ptr a
ptr :: IO CInt
{-# LINE 273 "src/System/INotify.hsc" #-}
CUInt
mask <- ((\hsc_ptr :: Ptr a
hsc_ptr -> Ptr a -> Int -> IO CUInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr 4)) Ptr a
ptr :: IO CUInt
{-# LINE 274 "src/System/INotify.hsc" #-}
CUInt
cookie <- ((\hsc_ptr :: Ptr a
hsc_ptr -> Ptr a -> Int -> IO CUInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr 8)) Ptr a
ptr :: IO CUInt
{-# LINE 275 "src/System/INotify.hsc" #-}
CUInt
len <- ((\hsc_ptr :: Ptr a
hsc_ptr -> Ptr a -> Int -> IO CUInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr 12)) Ptr a
ptr :: IO CUInt
{-# LINE 276 "src/System/INotify.hsc" #-}
Maybe RawFilePath
nameM <- if CUInt
len CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then Maybe RawFilePath -> IO (Maybe RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RawFilePath
forall a. Maybe a
Nothing
else do
(RawFilePath -> Maybe RawFilePath)
-> IO RawFilePath -> IO (Maybe RawFilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawFilePath -> Maybe RawFilePath
forall a. a -> Maybe a
Just (IO RawFilePath -> IO (Maybe RawFilePath))
-> IO RawFilePath -> IO (Maybe RawFilePath)
forall a b. (a -> b) -> a -> b
$ CString -> IO RawFilePath
peekFilePath (((\hsc_ptr :: Ptr a
hsc_ptr -> Ptr a
hsc_ptr Ptr a -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` 16)) Ptr a
ptr)
{-# LINE 280 "src/System/INotify.hsc" #-}
let event_size :: Int
event_size = ((16)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
len)
{-# LINE 281 "src/System/INotify.hsc" #-}
event :: WDEvent
event = FDEvent -> WDEvent
cEvent2Haskell (FD -> CUInt -> CUInt -> Maybe RawFilePath -> FDEvent
FDEvent FD
wd CUInt
mask CUInt
cookie Maybe RawFilePath
nameM)
[WDEvent]
rest <- Ptr Any -> Int -> IO [WDEvent]
forall a. Ptr a -> Int -> IO [WDEvent]
read_events' (Ptr a
ptr Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
event_size) (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
event_size)
[WDEvent] -> IO [WDEvent]
forall (m :: * -> *) a. Monad m => a -> m a
return (WDEvent
eventWDEvent -> [WDEvent] -> [WDEvent]
forall a. a -> [a] -> [a]
:[WDEvent]
rest)
cEvent2Haskell :: FDEvent
-> WDEvent
cEvent2Haskell :: FDEvent -> WDEvent
cEvent2Haskell fdevent :: FDEvent
fdevent@(FDEvent wd :: FD
wd mask :: CUInt
mask cookie :: CUInt
cookie nameM :: Maybe RawFilePath
nameM)
= (FD
wd, Event
event)
where
event :: Event
event
| Mask -> Bool
isSet Mask
inAccess = Bool -> Maybe RawFilePath -> Event
Accessed Bool
isDir Maybe RawFilePath
nameM
| Mask -> Bool
isSet Mask
inModify = Bool -> Maybe RawFilePath -> Event
Modified Bool
isDir Maybe RawFilePath
nameM
| Mask -> Bool
isSet Mask
inAttrib = Bool -> Maybe RawFilePath -> Event
Attributes Bool
isDir Maybe RawFilePath
nameM
| Mask -> Bool
isSet Mask
inClose = Bool -> Maybe RawFilePath -> Bool -> Event
Closed Bool
isDir Maybe RawFilePath
nameM (Mask -> Bool
isSet Mask
inCloseWrite)
| Mask -> Bool
isSet Mask
inOpen = Bool -> Maybe RawFilePath -> Event
Opened Bool
isDir Maybe RawFilePath
nameM
| Mask -> Bool
isSet Mask
inMovedFrom = Bool -> RawFilePath -> Cookie -> Event
MovedOut Bool
isDir RawFilePath
name (CUInt -> Cookie
Cookie CUInt
cookie)
| Mask -> Bool
isSet Mask
inMovedTo = Bool -> RawFilePath -> Cookie -> Event
MovedIn Bool
isDir RawFilePath
name (CUInt -> Cookie
Cookie CUInt
cookie)
| Mask -> Bool
isSet Mask
inMoveSelf = Bool -> Event
MovedSelf Bool
isDir
| Mask -> Bool
isSet Mask
inCreate = Bool -> RawFilePath -> Event
Created Bool
isDir RawFilePath
name
| Mask -> Bool
isSet Mask
inDelete = Bool -> RawFilePath -> Event
Deleted Bool
isDir RawFilePath
name
| Mask -> Bool
isSet Mask
inDeleteSelf = Event
DeletedSelf
| Mask -> Bool
isSet Mask
inUnmount = Event
Unmounted
| Mask -> Bool
isSet Mask
inQOverflow = Event
QOverflow
| Mask -> Bool
isSet Mask
inIgnored = Event
Ignored
| Bool
otherwise = FDEvent -> Event
Unknown FDEvent
fdevent
isDir :: Bool
isDir = Mask -> Bool
isSet Mask
inIsdir
isSet :: Mask -> Bool
isSet bits :: Mask
bits = Mask -> CUInt -> Bool
maskIsSet Mask
bits CUInt
mask
name :: RawFilePath
name = Maybe RawFilePath -> RawFilePath
forall a. HasCallStack => Maybe a -> a
fromJust Maybe RawFilePath
nameM
inotify_start_thread :: Handle -> MVar EventMap -> IO (Async (), Async ())
inotify_start_thread :: Handle -> MVar (Map FD (Event -> IO ())) -> IO (Async (), Async ())
inotify_start_thread h :: Handle
h em :: MVar (Map FD (Event -> IO ()))
em = do
Chan [WDEvent]
chan_events <- IO (Chan [WDEvent])
forall a. IO (Chan a)
newChan
Async ()
tid1 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (String -> IO () -> IO ()
logFailure "dispatcher" (Chan [WDEvent] -> IO ()
dispatcher Chan [WDEvent]
chan_events))
Async ()
tid2 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (String -> IO () -> IO ()
logFailure "start_thread" (Chan [WDEvent] -> IO ()
start_thread Chan [WDEvent]
chan_events))
(Async (), Async ()) -> IO (Async (), Async ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Async ()
tid1,Async ()
tid2)
where
start_thread :: Chan [WDEvent] -> IO ()
start_thread :: Chan [WDEvent] -> IO ()
start_thread chan_events :: Chan [WDEvent]
chan_events = do
[WDEvent]
events <- Handle -> IO [WDEvent]
read_events Handle
h
Chan [WDEvent] -> [WDEvent] -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan [WDEvent]
chan_events [WDEvent]
events
Chan [WDEvent] -> IO ()
start_thread Chan [WDEvent]
chan_events
dispatcher :: Chan [WDEvent] -> IO ()
dispatcher :: Chan [WDEvent] -> IO ()
dispatcher chan_events :: Chan [WDEvent]
chan_events = do
[WDEvent]
events <- Chan [WDEvent] -> IO [WDEvent]
forall a. Chan a -> IO a
readChan Chan [WDEvent]
chan_events
(WDEvent -> IO ()) -> [WDEvent] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WDEvent -> IO ()
runHandler [WDEvent]
events
Chan [WDEvent] -> IO ()
dispatcher Chan [WDEvent]
chan_events
runHandler :: WDEvent -> IO ()
runHandler :: WDEvent -> IO ()
runHandler (_, e :: Event
e@Event
QOverflow) = do
Map FD (Event -> IO ())
handlers <- MVar (Map FD (Event -> IO ())) -> IO (Map FD (Event -> IO ()))
forall a. MVar a -> IO a
readMVar MVar (Map FD (Event -> IO ()))
em
((Event -> IO ()) -> IO ()) -> [Event -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$ Event
e) (Map FD (Event -> IO ()) -> [Event -> IO ()]
forall k a. Map k a -> [a]
Map.elems Map FD (Event -> IO ())
handlers)
runHandler (wd :: FD
wd, event :: Event
event) = do
Map FD (Event -> IO ())
handlers <- MVar (Map FD (Event -> IO ())) -> IO (Map FD (Event -> IO ()))
forall a. MVar a -> IO a
readMVar MVar (Map FD (Event -> IO ()))
em
let handlerM :: Maybe (Event -> IO ())
handlerM = FD -> Map FD (Event -> IO ()) -> Maybe (Event -> IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FD
wd Map FD (Event -> IO ())
handlers
case Maybe (Event -> IO ())
handlerM of
Nothing -> String -> IO ()
putStrLn "runHandler: couldn't find handler"
Just handler :: Event -> IO ()
handler -> Event -> IO ()
handler Event
event
logFailure :: String -> IO () -> IO ()
logFailure name :: String
name io :: IO ()
io = IO ()
io IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: SomeException
e ->
case SomeException
e of
#if MIN_VERSION_async(2,2,1)
_ | Just AsyncCancelled <- SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
_ | Just ThreadKilled{} <- fromException e -> return ()
#endif
| Bool
otherwise -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ " dying: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
killINotify :: INotify -> IO ()
killINotify :: INotify -> IO ()
killINotify (INotify h :: Handle
h _ _ tid1 :: Async ()
tid1 tid2 :: Async ()
tid2) =
do Async () -> IO ()
forall a. Async a -> IO ()
cancelWait Async ()
tid1
Async () -> IO ()
forall a. Async a -> IO ()
cancelWait Async ()
tid2
Handle -> IO ()
hClose Handle
h
cancelWait :: Async a -> IO ()
#if MIN_VERSION_async(2,1,1)
cancelWait :: Async a -> IO ()
cancelWait = Async a -> IO ()
forall a. Async a -> IO ()
cancel
#else
cancelWait a = do cancel a; void $ waitCatch a
#endif
withINotify :: (INotify -> IO a) -> IO a
withINotify :: (INotify -> IO a) -> IO a
withINotify = IO INotify -> (INotify -> IO ()) -> (INotify -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO INotify
initINotify INotify -> IO ()
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