{-# 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 Handle
_ FD
fd1 MVar EventMap
_ Async ()
_ Async ()
_) == :: INotify -> INotify -> Bool
== (INotify Handle
_ FD
fd2 MVar EventMap
_ Async ()
_ Async ()
_) = 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 Handle
_ FD
fd MVar EventMap
_ Async ()
_ Async ()
_) =
String -> ShowS
showString String
"<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
$ String
">"
instance Show WatchDescriptor where
show :: WatchDescriptor -> String
show (WatchDescriptor INotify
_ FD
wd) = String -> ShowS
showString String
"<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
$ String
">"
instance Show Cookie where
show :: Cookie -> String
show (Cookie CUInt
c) = String -> ShowS
showString String
"<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
$ String
">"
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 String
"initINotify" IO FD
c_inotify_init
(FD
fd,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,CDev
0,CIno
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 String
"<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
$ String
">")
IOMode
ReadMode
Bool
True
Maybe TextEncoding
forall a. Maybe a
Nothing
MVar EventMap
em <- EventMap -> IO (MVar EventMap)
forall a. a -> IO (MVar a)
newMVar EventMap
forall k a. Map k a
Map.empty
(Async ()
tid1, Async ()
tid2) <- Handle -> MVar EventMap -> IO (Async (), Async ())
inotify_start_thread Handle
h MVar EventMap
em
INotify -> IO INotify
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> FD -> MVar EventMap -> Async () -> Async () -> INotify
INotify Handle
h FD
fdint MVar EventMap
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 Handle
_ FD
fd MVar EventMap
em Async ()
_ Async ()
_) [EventVariety]
masks RawFilePath
fp 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
_ ->
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
String
"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
$ \CString
fp_c ->
String -> IO FD -> IO FD
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"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 = \Event
e -> IO () -> IO ()
ignore_failure (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
case Event
e of
Event
Ignored -> INotify -> FD -> IO ()
rm_watch INotify
inotify FD
wd
Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Event -> IO ()
cb Event
e
MVar EventMap -> (EventMap -> IO EventMap) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar EventMap
em ((EventMap -> IO EventMap) -> IO ())
-> (EventMap -> IO EventMap) -> IO ()
forall a b. (a -> b) -> a -> b
$ \EventMap
em' -> EventMap -> IO EventMap
forall (m :: * -> *) a. Monad m => a -> m a
return (((Event -> IO ()) -> (Event -> IO ()) -> Event -> IO ())
-> FD -> (Event -> IO ()) -> EventMap -> EventMap
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 EventMap
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 EventVariety
ev =
case EventVariety
ev of
EventVariety
Access -> Mask
inAccess
EventVariety
Modify -> Mask
inModify
EventVariety
Attrib -> Mask
inAttrib
EventVariety
Close -> Mask
inClose
EventVariety
CloseWrite -> Mask
inCloseWrite
EventVariety
CloseNoWrite -> Mask
inCloseNowrite
EventVariety
Open -> Mask
inOpen
EventVariety
Move -> Mask
inMove
EventVariety
MoveIn -> Mask
inMovedTo
EventVariety
MoveOut -> Mask
inMovedFrom
EventVariety
MoveSelf -> Mask
inMoveSelf
EventVariety
Create -> Mask
inCreate
EventVariety
Delete -> Mask
inDelete
EventVariety
DeleteSelf-> Mask
inDeleteSelf
EventVariety
OnlyDir -> Mask
inOnlydir
EventVariety
NoSymlink -> Mask
inDontFollow
EventVariety
MaskAdd -> Mask
inMaskAdd
EventVariety
OneShot -> Mask
inOneshot
EventVariety
AllEvents -> Mask
inAllEvents
ignore_failure :: IO () -> IO ()
ignore_failure :: IO () -> IO ()
ignore_failure 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 SomeException
e
#if MIN_VERSION_async(2,2,1)
| Just AsyncCancelled
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 Handle
_ FD
fd MVar EventMap
_ Async ()
_ Async ()
_) FD
wd) = do
FD
_ <- String -> IO FD -> IO FD
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"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 Handle
_ FD
_ MVar EventMap
em Async ()
_ Async ()
_) FD
wd =
MVar EventMap -> (EventMap -> IO EventMap) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar EventMap
em (EventMap -> IO EventMap
forall (m :: * -> *) a. Monad m => a -> m a
return (EventMap -> IO EventMap)
-> (EventMap -> EventMap) -> EventMap -> IO EventMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FD -> EventMap -> EventMap
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 Handle
h =
let maxRead :: Int
maxRead = Int
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
$ \Ptr Any
buffer -> do
Bool
_ <- Handle -> Int -> IO Bool
hWaitForInput Handle
h (-Int
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' Ptr a
_ Int
r | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [WDEvent] -> IO [WDEvent]
forall (m :: * -> *) a. Monad m => a -> m a
return []
read_events' Ptr a
ptr Int
r = do
FD
wd <- ((\Ptr a
hsc_ptr -> Ptr a -> Int -> IO FD
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr Int
0)) Ptr a
ptr :: IO CInt
{-# LINE 273 "src/System/INotify.hsc" #-}
CUInt
mask <- ((\Ptr a
hsc_ptr -> Ptr a -> Int -> IO CUInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr Int
4)) Ptr a
ptr :: IO CUInt
{-# LINE 274 "src/System/INotify.hsc" #-}
CUInt
cookie <- ((\Ptr a
hsc_ptr -> Ptr a -> Int -> IO CUInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr Int
8)) Ptr a
ptr :: IO CUInt
{-# LINE 275 "src/System/INotify.hsc" #-}
CUInt
len <- ((\Ptr a
hsc_ptr -> Ptr a -> Int -> IO CUInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
hsc_ptr Int
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
== CUInt
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 (((\Ptr a
hsc_ptr -> Ptr a
hsc_ptr Ptr a -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
16)) Ptr a
ptr)
{-# LINE 280 "src/System/INotify.hsc" #-}
let event_size :: Int
event_size = ((Int
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 FD
wd CUInt
mask CUInt
cookie 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 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 EventMap -> IO (Async (), Async ())
inotify_start_thread Handle
h MVar EventMap
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 String
"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 String
"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 [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 [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 (FD
_, e :: Event
e@Event
QOverflow) = do
EventMap
handlers <- MVar EventMap -> IO EventMap
forall a. MVar a -> IO a
readMVar MVar EventMap
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) (EventMap -> [Event -> IO ()]
forall k a. Map k a -> [a]
Map.elems EventMap
handlers)
runHandler (FD
wd, Event
event) = do
EventMap
handlers <- MVar EventMap -> IO EventMap
forall a. MVar a -> IO a
readMVar MVar EventMap
em
let handlerM :: Maybe (Event -> IO ())
handlerM = FD -> EventMap -> Maybe (Event -> IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FD
wd EventMap
handlers
case Maybe (Event -> IO ())
handlerM of
Maybe (Event -> IO ())
Nothing -> String -> IO ()
putStrLn String
"runHandler: couldn't find handler"
Just Event -> IO ()
handler -> Event -> IO ()
handler Event
event
logFailure :: String -> IO () -> IO ()
logFailure String
name IO ()
io = IO ()
io IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
e ->
case SomeException
e of
#if MIN_VERSION_async(2,2,1)
SomeException
_ | Just AsyncCancelled
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]
++ String
" 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 Handle
h FD
_ MVar EventMap
_ Async ()
tid1 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