{-# LINE 1 "src/System/INotify.hsc" #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  System.INotify
-- Copyright   :  (c) Lennart Kolmodin 2006-2012
-- License     :  BSD3
-- Maintainer  :  kolmodin@gmail.com
-- Stability   :  experimental
-- Portability :  hc portable, linux only
--
-- A Haskell binding to INotify.
-- See <http://www.kernel.org/pub/linux/kernel/people/rml/inotify/> and @man
-- inotify@.
--
-- Use 'initINotify' to get a 'INotify', then use 'addWatch' to
-- add a watch on a file or directory. Select which events you're interested
-- in with 'EventVariety', which corresponds to the 'Event' events.
--
-- Use 'removeWatch' once you don't want to watch a file any more.
--
-----------------------------------------------------------------------------

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{-Cookie-} (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 =
    -- | A file was accessed. @Accessed isDirectory file@
      Accessed
        { Event -> Bool
isDirectory :: Bool
        , Event -> Maybe RawFilePath
maybeFilePath :: Maybe RawFilePath
        }
    -- | A file was modified. @Modified isDirectory file@
    | Modified
        { isDirectory :: Bool
        , maybeFilePath :: Maybe RawFilePath
        }
    -- | A files attributes where changed. @Attributes isDirectory file@
    | Attributes
        { isDirectory :: Bool
        , maybeFilePath :: Maybe RawFilePath
        }
    -- | A file was closed. @Closed isDirectory file wasWriteable@
    | Closed
        { isDirectory :: Bool
        , maybeFilePath :: Maybe RawFilePath
        , Event -> Bool
wasWriteable :: Bool
        }
    -- | A file was opened. @Opened isDirectory maybeFilePath@
    | Opened
        { isDirectory :: Bool
        , maybeFilePath :: Maybe RawFilePath
        }
    -- | A file was moved away from the watched dir. @MovedFrom isDirectory from cookie@
    | MovedOut
        { isDirectory :: Bool
        , Event -> RawFilePath
filePath :: RawFilePath
        , Event -> Cookie
moveCookie :: Cookie
        }
    -- | A file was moved into the watched dir. @MovedTo isDirectory to cookie@
    | MovedIn
        { isDirectory :: Bool
        , filePath :: RawFilePath
        , moveCookie :: Cookie
        }
    -- | The watched file was moved. @MovedSelf isDirectory@
    | MovedSelf
        { isDirectory :: Bool
        }
    -- | A file was created. @Created isDirectory file@
    | Created
        { isDirectory :: Bool
        , filePath :: RawFilePath
        }
    -- | A file was deleted. @Deleted isDirectory file@
    | Deleted
        { isDirectory :: Bool
        , filePath :: RawFilePath
        }
    -- | The file watched was deleted.
    | DeletedSelf
    -- | The file watched was unmounted.
    | Unmounted
    -- | The queue overflowed.
    | 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{-is_socket-}
            Bool
False{-is_nonblock-}
    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  -- make non-blocking.  Otherwise reading uses select(), which
                 -- can fail when there are >=1024 FDs
           Maybe TextEncoding
forall a. Maybe a
Nothing -- no encoding, so binary
    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
              -- if the event is Ignored then we know for sure that
              -- this is the last event on that WatchDescriptor
              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 is same as catchIOError from base >= 4.5.0.0
    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)  -- wait forever
        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 -- send overflows to all handlers
        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" -- impossible?
          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