{-|
Module      : Z.IO.FileSystem.Watch
Description : cross-platform recursive fs watcher
Copyright   : (c) Dong Han, 2017-2020
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides fs watcher based on libuv's fs_event, we also maintain watch list if target OS doesn't
support recursive watch(Linux's inotify).

@
-- start watching threads, cleanup watching threads automatically when finished.
withResource (initWatchDirs ["fold_to_be_watch"] True) $ \ srcf -> do
    -- dup a file event source
    src <- srcf
    -- print event to stdout
    runBIO_ $ src . sinkToIO printStd
@
-}

module Z.IO.FileSystem.Watch
    ( FileEvent(..)
    , watchDirs
    , initWatchDirs
    ) where

import           Control.Concurrent
import           Control.Monad
import           Data.Bits
import qualified Data.HashMap.Strict      as HM
import           Data.IORef
#if defined(linux_HOST_OS)
import qualified Data.List                as List
#endif
import           Data.Primitive.PrimArray
import           Data.Word
import           GHC.Generics
import           Z.Data.Array
import           Z.Data.Array.Unaligned
import           Z.Data.CBytes            (CBytes)
import qualified Z.Data.CBytes            as CBytes
import           Z.Data.JSON              (JSON)
import           Z.Data.Text.Print        (Print)
import           Z.Data.Vector            (defaultChunkSize)
import           Z.Foreign
import           Z.IO.BIO
import           Z.IO.BIO.Concurrent
import           Z.IO.Exception
import           Z.IO.FileSystem.Base
import qualified Z.IO.FileSystem.FilePath as P
import           Z.IO.LowResTimer
import           Z.IO.Resource
import           Z.IO.UV.FFI
import           Z.IO.UV.Manager

-- | File event with path info.
data FileEvent = FileAdd CBytes | FileRemove CBytes | FileModify CBytes
    deriving (Int -> FileEvent -> ShowS
[FileEvent] -> ShowS
FileEvent -> String
(Int -> FileEvent -> ShowS)
-> (FileEvent -> String)
-> ([FileEvent] -> ShowS)
-> Show FileEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileEvent] -> ShowS
$cshowList :: [FileEvent] -> ShowS
show :: FileEvent -> String
$cshow :: FileEvent -> String
showsPrec :: Int -> FileEvent -> ShowS
$cshowsPrec :: Int -> FileEvent -> ShowS
Show, ReadPrec [FileEvent]
ReadPrec FileEvent
Int -> ReadS FileEvent
ReadS [FileEvent]
(Int -> ReadS FileEvent)
-> ReadS [FileEvent]
-> ReadPrec FileEvent
-> ReadPrec [FileEvent]
-> Read FileEvent
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FileEvent]
$creadListPrec :: ReadPrec [FileEvent]
readPrec :: ReadPrec FileEvent
$creadPrec :: ReadPrec FileEvent
readList :: ReadS [FileEvent]
$creadList :: ReadS [FileEvent]
readsPrec :: Int -> ReadS FileEvent
$creadsPrec :: Int -> ReadS FileEvent
Read, Eq FileEvent
Eq FileEvent
-> (FileEvent -> FileEvent -> Ordering)
-> (FileEvent -> FileEvent -> Bool)
-> (FileEvent -> FileEvent -> Bool)
-> (FileEvent -> FileEvent -> Bool)
-> (FileEvent -> FileEvent -> Bool)
-> (FileEvent -> FileEvent -> FileEvent)
-> (FileEvent -> FileEvent -> FileEvent)
-> Ord FileEvent
FileEvent -> FileEvent -> Bool
FileEvent -> FileEvent -> Ordering
FileEvent -> FileEvent -> FileEvent
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 :: FileEvent -> FileEvent -> FileEvent
$cmin :: FileEvent -> FileEvent -> FileEvent
max :: FileEvent -> FileEvent -> FileEvent
$cmax :: FileEvent -> FileEvent -> FileEvent
>= :: FileEvent -> FileEvent -> Bool
$c>= :: FileEvent -> FileEvent -> Bool
> :: FileEvent -> FileEvent -> Bool
$c> :: FileEvent -> FileEvent -> Bool
<= :: FileEvent -> FileEvent -> Bool
$c<= :: FileEvent -> FileEvent -> Bool
< :: FileEvent -> FileEvent -> Bool
$c< :: FileEvent -> FileEvent -> Bool
compare :: FileEvent -> FileEvent -> Ordering
$ccompare :: FileEvent -> FileEvent -> Ordering
$cp1Ord :: Eq FileEvent
Ord, FileEvent -> FileEvent -> Bool
(FileEvent -> FileEvent -> Bool)
-> (FileEvent -> FileEvent -> Bool) -> Eq FileEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileEvent -> FileEvent -> Bool
$c/= :: FileEvent -> FileEvent -> Bool
== :: FileEvent -> FileEvent -> Bool
$c== :: FileEvent -> FileEvent -> Bool
Eq, (forall x. FileEvent -> Rep FileEvent x)
-> (forall x. Rep FileEvent x -> FileEvent) -> Generic FileEvent
forall x. Rep FileEvent x -> FileEvent
forall x. FileEvent -> Rep FileEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileEvent x -> FileEvent
$cfrom :: forall x. FileEvent -> Rep FileEvent x
Generic)
    deriving anyclass (Int -> FileEvent -> Builder ()
(Int -> FileEvent -> Builder ()) -> Print FileEvent
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> FileEvent -> Builder ()
$ctoUTF8BuilderP :: Int -> FileEvent -> Builder ()
Print, Value -> Converter FileEvent
FileEvent -> Value
FileEvent -> Builder ()
(Value -> Converter FileEvent)
-> (FileEvent -> Value)
-> (FileEvent -> Builder ())
-> JSON FileEvent
forall a.
(Value -> Converter a)
-> (a -> Value) -> (a -> Builder ()) -> JSON a
encodeJSON :: FileEvent -> Builder ()
$cencodeJSON :: FileEvent -> Builder ()
toValue :: FileEvent -> Value
$ctoValue :: FileEvent -> Value
fromValue :: Value -> Converter FileEvent
$cfromValue :: Value -> Converter FileEvent
JSON)

-- | Watching a list of given directories.
watchDirs :: [CBytes]     -- ^ Directories to be watched
          -> Bool         -- ^ recursively watch?
          -> (FileEvent -> IO ())  -- ^ Callback function to handle 'FileEvent'
          -> IO ()
watchDirs :: [CBytes] -> Bool -> (FileEvent -> IO ()) -> IO ()
watchDirs [CBytes]
dirs Bool
rec FileEvent -> IO ()
callback = do
    Resource (IO (Source FileEvent))
-> (IO (Source FileEvent) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource ([CBytes] -> Bool -> Resource (IO (Source FileEvent))
initWatchDirs [CBytes]
dirs Bool
rec) ((IO (Source FileEvent) -> IO ()) -> IO ())
-> (IO (Source FileEvent) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ IO (Source FileEvent)
srcf -> do
        Source FileEvent
src <- IO (Source FileEvent)
srcf
        BIO Void Void -> IO ()
forall inp out. HasCallStack => BIO inp out -> IO ()
runBIO_ (BIO Void Void -> IO ()) -> BIO Void Void -> IO ()
forall a b. (a -> b) -> a -> b
$ Source FileEvent
src Source FileEvent
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> BIO Void Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileEvent -> IO ())
-> (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
forall a. HasCallStack => (a -> IO ()) -> Sink a
sinkToIO FileEvent -> IO ()
callback

-- | Start watching a list of given directories, stream version.
initWatchDirs :: [CBytes]       -- ^ watching list
              -> Bool           -- ^ recursively watch?
              -> Resource (IO (Source FileEvent))
initWatchDirs :: [CBytes] -> Bool -> Resource (IO (Source FileEvent))
initWatchDirs [CBytes]
dirs Bool
False = do
    IO () -> Resource ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Resource ())
-> ((CBytes -> IO ()) -> IO ()) -> (CBytes -> IO ()) -> Resource ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CBytes] -> (CBytes -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CBytes]
dirs ((CBytes -> IO ()) -> Resource ())
-> (CBytes -> IO ()) -> Resource ()
forall a b. (a -> b) -> a -> b
$ \ CBytes
dir -> do
        Bool
b <- HasCallStack => CBytes -> IO Bool
CBytes -> IO Bool
isDir CBytes
dir
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
UV_ENOTDIR))
    CUInt -> [CBytes] -> Resource (IO (Source FileEvent))
watch_ CUInt
0 [CBytes]
dirs
initWatchDirs [CBytes]
dirs Bool
_ = do
#if defined(linux_HOST_OS)
    -- inotify doesn't support recursive watch, so we manually maintain watch list
    [[CBytes]]
subDirs <- IO [[CBytes]] -> Resource [[CBytes]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[CBytes]] -> Resource [[CBytes]])
-> ((CBytes -> IO [CBytes]) -> IO [[CBytes]])
-> (CBytes -> IO [CBytes])
-> Resource [[CBytes]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CBytes] -> (CBytes -> IO [CBytes]) -> IO [[CBytes]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CBytes]
dirs ((CBytes -> IO [CBytes]) -> Resource [[CBytes]])
-> (CBytes -> IO [CBytes]) -> Resource [[CBytes]]
forall a b. (a -> b) -> a -> b
$ \ CBytes
dir ->
        HasCallStack =>
CBytes -> (CBytes -> DirEntType -> IO Bool) -> IO [CBytes]
CBytes -> (CBytes -> DirEntType -> IO Bool) -> IO [CBytes]
scandirRecursively CBytes
dir (\ CBytes
_ DirEntType
t -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (DirEntType
t DirEntType -> DirEntType -> Bool
forall a. Eq a => a -> a -> Bool
== DirEntType
DirEntDir))
    CUInt -> [CBytes] -> Resource (IO (Source FileEvent))
watch_ CUInt
UV_FS_EVENT_RECURSIVE ([[CBytes]] -> [CBytes]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat ([CBytes]
dirs[CBytes] -> [[CBytes]] -> [[CBytes]]
forall a. a -> [a] -> [a]
:[[CBytes]]
subDirs))
#else
    watch_ UV_FS_EVENT_RECURSIVE dirs
#endif

-- Internal function to start watching
watch_ :: CUInt -> [CBytes] -> Resource (IO (Source FileEvent))
watch_ :: CUInt -> [CBytes] -> Resource (IO (Source FileEvent))
watch_ CUInt
flag [CBytes]
dirs = (IO (Source FileEvent),
 ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
  MVar (HashMap CBytes ThreadId)))
-> IO (Source FileEvent)
forall a b. (a, b) -> a
fst ((IO (Source FileEvent),
  ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
   MVar (HashMap CBytes ThreadId)))
 -> IO (Source FileEvent))
-> Resource
     (IO (Source FileEvent),
      ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
       MVar (HashMap CBytes ThreadId)))
-> Resource (IO (Source FileEvent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO
  (IO (Source FileEvent),
   ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
    MVar (HashMap CBytes ThreadId)))
-> ((IO (Source FileEvent),
     ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
      MVar (HashMap CBytes ThreadId)))
    -> IO ())
-> Resource
     (IO (Source FileEvent),
      ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
       MVar (HashMap CBytes ThreadId)))
forall a. IO a -> (a -> IO ()) -> Resource a
initResource (do
    -- HashMap to store all watchers
    MVar (HashMap CBytes ThreadId)
mRef <- HashMap CBytes ThreadId -> IO (MVar (HashMap CBytes ThreadId))
forall a. a -> IO (MVar a)
newMVar HashMap CBytes ThreadId
forall k v. HashMap k v
HM.empty
    -- there's only one place to pull the sink, that is cleanUpWatcher
    ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink, IO (Source FileEvent)
srcf) <- Int
-> IO
     ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
      IO (Source FileEvent))
forall a. Int -> IO (Sink a, IO (Source a))
newBroadcastTChanNode Int
1
    -- lock UVManager first
    ([CBytes] -> (CBytes -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CBytes]
dirs ((CBytes -> IO ()) -> IO ()) -> (CBytes -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ CBytes
dir -> do
        CBytes
dir' <- CBytes -> IO CBytes
P.normalize CBytes
dir
        ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar (HashMap CBytes ThreadId)
-> CBytes
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> IO ()
watchThread MVar (HashMap CBytes ThreadId)
mRef CBytes
dir' (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink
        MVar (HashMap CBytes ThreadId)
-> (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (HashMap CBytes ThreadId)
mRef ((HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
 -> IO ())
-> (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \ HashMap CBytes ThreadId
m ->
            HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId)
forall a b. (a -> b) -> a -> b
$! CBytes
-> ThreadId -> HashMap CBytes ThreadId -> HashMap CBytes ThreadId
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert CBytes
dir' ThreadId
tid HashMap CBytes ThreadId
m) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` MVar (HashMap CBytes ThreadId)
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()) -> IO ()
forall (t :: * -> *) a a a.
Foldable t =>
MVar (t ThreadId) -> ((a -> IO ()) -> Maybe a -> IO a) -> IO ()
cleanUpWatcher MVar (HashMap CBytes ThreadId)
mRef (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink
    (IO (Source FileEvent),
 ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
  MVar (HashMap CBytes ThreadId)))
-> IO
     (IO (Source FileEvent),
      ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO (),
       MVar (HashMap CBytes ThreadId)))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Source FileEvent)
srcf, ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink, MVar (HashMap CBytes ThreadId)
mRef)))
    (\ (IO (Source FileEvent)
_, ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink, MVar (HashMap CBytes ThreadId)
mRef)) -> MVar (HashMap CBytes ThreadId)
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()) -> IO ()
forall (t :: * -> *) a a a.
Foldable t =>
MVar (t ThreadId) -> ((a -> IO ()) -> Maybe a -> IO a) -> IO ()
cleanUpWatcher MVar (HashMap CBytes ThreadId)
mRef (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink)
  where
    eventBufSiz :: Int
eventBufSiz = Int
defaultChunkSize

    cleanUpWatcher :: MVar (t ThreadId) -> ((a -> IO ()) -> Maybe a -> IO a) -> IO ()
cleanUpWatcher MVar (t ThreadId)
mRef (a -> IO ()) -> Maybe a -> IO a
sink = do
        t ThreadId
m <- MVar (t ThreadId) -> IO (t ThreadId)
forall a. MVar a -> IO a
takeMVar MVar (t ThreadId)
mRef
        t ThreadId -> (ThreadId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t ThreadId
m ThreadId -> IO ()
killThread
        IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((a -> IO ()) -> Maybe a -> IO a
sink a -> IO ()
forall a. a -> IO ()
discard Maybe a
forall a. Maybe a
EOF)

    watchThread :: MVar (HashMap CBytes ThreadId)
-> CBytes
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> IO ()
watchThread MVar (HashMap CBytes ThreadId)
mRef CBytes
dir (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink = do
        -- IORef store temp events to de-duplicated
        IORef (Maybe FileEvent)
eRef <- Maybe FileEvent -> IO (IORef (Maybe FileEvent))
forall a. a -> IO (IORef a)
newIORef Maybe FileEvent
forall a. Maybe a
Nothing
        UVManager
uvm <- IO UVManager
getUVManager
        (IO
  (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8, Ptr UVHandle)
-> ((Ptr UVHandle, Int, MutablePrimArray RealWorld Word8,
     Ptr UVHandle)
    -> IO ())
-> ((Ptr UVHandle, Int, MutablePrimArray RealWorld Word8,
     Ptr UVHandle)
    -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
            (do UVManager
-> (Ptr UVLoop
    -> IO
         (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8,
          Ptr UVHandle))
-> IO
     (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8, Ptr UVHandle)
forall a. HasCallStack => UVManager -> (Ptr UVLoop -> IO a) -> IO a
withUVManager UVManager
uvm ((Ptr UVLoop
  -> IO
       (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8,
        Ptr UVHandle))
 -> IO
      (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8,
       Ptr UVHandle))
-> (Ptr UVLoop
    -> IO
         (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8,
          Ptr UVHandle))
-> IO
     (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8, Ptr UVHandle)
forall a b. (a -> b) -> a -> b
$ \ Ptr UVLoop
loop -> do
                    Ptr UVHandle
hdl <- Ptr UVLoop -> IO (Ptr UVHandle)
hs_uv_handle_alloc Ptr UVLoop
loop
                    Int
slot <- HasCallStack => UVManager -> IO UVSlotUnsafe -> IO Int
UVManager -> IO UVSlotUnsafe -> IO Int
getUVSlot UVManager
uvm (Ptr UVHandle -> IO UVSlotUnsafe
peekUVHandleData Ptr UVHandle
hdl)
                    -- init uv struct
                    IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> IO CInt
uv_fs_event_init Ptr UVLoop
loop Ptr UVHandle
hdl)

                    MutablePrimArray RealWorld Word8
buf <- Int -> IO (MutablePrimArray (PrimState IO) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
eventBufSiz :: IO (MutablePrimArray RealWorld Word8)

                    Ptr UVHandle
check <- IO (Ptr UVHandle) -> IO (Ptr UVHandle)
forall a. HasCallStack => IO (Ptr a) -> IO (Ptr a)
throwOOMIfNull (IO (Ptr UVHandle) -> IO (Ptr UVHandle))
-> IO (Ptr UVHandle) -> IO (Ptr UVHandle)
forall a b. (a -> b) -> a -> b
$ IO (Ptr UVHandle)
hs_uv_check_alloc
                    IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> Ptr UVHandle -> IO CInt
hs_uv_check_init Ptr UVHandle
check Ptr UVHandle
hdl)

                    MutablePrimArray RealWorld Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld Word8
buf ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
p -> do
                        UVManager -> Int -> Ptr Word8 -> Int -> IO ()
pokeBufferTable UVManager
uvm Int
slot (Ptr Word8 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
p) Int
eventBufSiz
                        -- init uv_check_t must come after poking buffer
                        IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> IO CInt
hs_uv_fs_event_check_start Ptr UVHandle
check

                    (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8, Ptr UVHandle)
-> IO
     (Ptr UVHandle, Int, MutablePrimArray RealWorld Word8, Ptr UVHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr UVHandle
hdl, Int
slot, MutablePrimArray RealWorld Word8
buf, Ptr UVHandle
check))

            (\ (Ptr UVHandle
hdl,Int
_,MutablePrimArray RealWorld Word8
_,Ptr UVHandle
check) -> Ptr UVHandle -> IO ()
hs_uv_handle_close Ptr UVHandle
hdl IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr UVHandle -> IO ()
hs_uv_check_close Ptr UVHandle
check)

            (\ (Ptr UVHandle
hdl, Int
slot, MutablePrimArray RealWorld Word8
buf, Ptr UVHandle
_) -> do
                MVar Int
m <- UVManager -> Int -> IO (MVar Int)
getBlockMVar UVManager
uvm Int
slot
                UVManager -> IO () -> IO ()
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Maybe Int
_ <- MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m
                    UVManager -> Int -> Int -> IO ()
pokeBufferSizeTable UVManager
uvm Int
slot Int
eventBufSiz
                    CBytes -> (BA# Word8 -> IO ()) -> IO ()
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
CBytes.withCBytesUnsafe CBytes
dir ((BA# Word8 -> IO ()) -> IO ()) -> (BA# Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
p ->
                        IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> BA# Word8 -> CUInt -> IO CInt
hs_uv_fs_event_start Ptr UVHandle
hdl BA# Word8
p CUInt
flag)

                IO ThreadId -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ do

                    Int
_ <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
m IO Int -> IO () -> IO Int
forall a b. IO a -> IO b -> IO a
`onException` (do
                            CInt
_ <- UVManager -> IO CInt -> IO CInt
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> IO CInt
uv_fs_event_stop Ptr UVHandle
hdl
                            IO (Maybe Int) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m))

                    (PrimArray BA# Word8
buf#) <- UVManager -> IO (PrimArray Word8) -> IO (PrimArray Word8)
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO (PrimArray Word8) -> IO (PrimArray Word8))
-> IO (PrimArray Word8) -> IO (PrimArray Word8)
forall a b. (a -> b) -> a -> b
$ do
                        Maybe Int
_ <- MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m
                        Int
r <- UVManager -> Int -> IO Int
peekBufferSizeTable UVManager
uvm Int
slot
                        UVManager -> Int -> Int -> IO ()
pokeBufferSizeTable UVManager
uvm Int
slot Int
eventBufSiz

                        let eventSiz :: Int
eventSiz = Int
eventBufSiz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r
                        MutablePrimArray RealWorld Word8
buf' <- Int -> IO (MutablePrimArray (PrimState IO) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
eventSiz
                        MutablePrimArray (PrimState IO) Word8
-> Int
-> MutablePrimArray (PrimState IO) Word8
-> Int
-> Int
-> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> MutablePrimArray (PrimState m) a -> Int -> Int -> m ()
copyMutablePrimArray MutablePrimArray RealWorld Word8
MutablePrimArray (PrimState IO) Word8
buf' Int
0 MutablePrimArray RealWorld Word8
MutablePrimArray (PrimState IO) Word8
buf Int
r Int
eventSiz
                        MutablePrimArray (PrimState IO) Word8 -> IO (PrimArray Word8)
forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Word8
MutablePrimArray (PrimState IO) Word8
buf'

                    IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ CBytes
-> MVar (HashMap CBytes ThreadId)
-> IORef (Maybe FileEvent)
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> [(Word8, CBytes)]
-> IO ()
processEvent CBytes
dir MVar (HashMap CBytes ThreadId)
mRef IORef (Maybe FileEvent)
eRef (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink ([(Word8, CBytes)] -> IO ()) -> IO [(Word8, CBytes)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BA# Word8 -> Int -> [(Word8, CBytes)] -> IO [(Word8, CBytes)]
forall (m :: * -> *) a.
(Monad m, Unaligned a) =>
BA# Word8 -> Int -> [(a, CBytes)] -> m [(a, CBytes)]
loopReadFileEvent BA# Word8
buf# Int
0 [])
            ) IO () -> (NoSuchThing -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
                -- when a directory is removed, either watcher is killed
                -- or hs_uv_fs_event_start return ENOENT
                (\ (NoSuchThing
_ :: NoSuchThing) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

    loopReadFileEvent :: BA# Word8 -> Int -> [(a, CBytes)] -> m [(a, CBytes)]
loopReadFileEvent BA# Word8
buf# Int
i [(a, CBytes)]
acc
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
siz = [(a, CBytes)] -> m [(a, CBytes)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(a, CBytes)]
acc
        | Bool
otherwise =
            let !event :: a
event  = BA# Word8 -> Int -> a
forall a. Unaligned a => BA# Word8 -> Int -> a
indexBA BA# Word8
buf# Int
i
                !path :: CBytes
path   = BA# Word8 -> Int -> CBytes
CBytes.indexBACBytes BA# Word8
buf# (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            in BA# Word8 -> Int -> [(a, CBytes)] -> m [(a, CBytes)]
loopReadFileEvent BA# Word8
buf# (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CBytes -> Int
CBytes.length CBytes
path Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) ((a
event,CBytes
path)(a, CBytes) -> [(a, CBytes)] -> [(a, CBytes)]
forall a. a -> [a] -> [a]
:[(a, CBytes)]
acc)
      where siz :: Int
siz = PrimArray Word8 -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray (BA# Word8 -> PrimArray Word8
forall a. BA# Word8 -> PrimArray a
PrimArray BA# Word8
buf# :: PrimArray Word8)

    processEvent :: CBytes
-> MVar (HashMap CBytes ThreadId)
-> IORef (Maybe FileEvent)
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> [(Word8, CBytes)]
-> IO ()
processEvent CBytes
pdir MVar (HashMap CBytes ThreadId)
mRef IORef (Maybe FileEvent)
eRef (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink = ((Word8, CBytes) -> IO ()) -> [(Word8, CBytes)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((Word8, CBytes) -> IO ()) -> [(Word8, CBytes)] -> IO ())
-> ((Word8, CBytes) -> IO ()) -> [(Word8, CBytes)] -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (Word8
e, CBytes
path) ->
        -- don't report event about directory itself, it will reported by its parent
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CBytes -> Bool
CBytes.null CBytes
path) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            CBytes
f <- CBytes
pdir CBytes -> CBytes -> IO CBytes
`P.join` CBytes
path
            if (Word8
e Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
UV_RENAME) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0
            then IO () -> (NoSuchThing -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                (do FStat
_s <- HasCallStack => CBytes -> IO FStat
CBytes -> IO FStat
lstat CBytes
f
#if defined(linux_HOST_OS)
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((FStat -> CInt
stMode FStat
_s CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.&. CInt
S_IFMT CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
S_IFDIR) Bool -> Bool -> Bool
&& (CUInt
flag CUInt -> CUInt -> CUInt
forall a. Bits a => a -> a -> a
.&. CUInt
UV_FS_EVENT_RECURSIVE CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CUInt
0)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        MVar (HashMap CBytes ThreadId)
-> (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (HashMap CBytes ThreadId)
mRef ((HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
 -> IO ())
-> (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \ HashMap CBytes ThreadId
m -> do
                            case CBytes -> HashMap CBytes ThreadId -> Maybe ThreadId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup CBytes
f HashMap CBytes ThreadId
m of
                                Just ThreadId
_ -> HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return HashMap CBytes ThreadId
m
                                Maybe ThreadId
_ -> do
                                    [CBytes]
ds <- HasCallStack =>
CBytes -> (CBytes -> DirEntType -> IO Bool) -> IO [CBytes]
CBytes -> (CBytes -> DirEntType -> IO Bool) -> IO [CBytes]
scandirRecursively CBytes
f (\ CBytes
_ DirEntType
t -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (DirEntType
t DirEntType -> DirEntType -> Bool
forall a. Eq a => a -> a -> Bool
== DirEntType
DirEntDir))
                                    (HashMap CBytes ThreadId -> CBytes -> IO (HashMap CBytes ThreadId))
-> HashMap CBytes ThreadId
-> [CBytes]
-> IO (HashMap CBytes ThreadId)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ HashMap CBytes ThreadId
m' CBytes
d -> do
                                        ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar (HashMap CBytes ThreadId)
-> CBytes
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> IO ()
watchThread MVar (HashMap CBytes ThreadId)
mRef CBytes
d (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink
                                        HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId)
forall a b. (a -> b) -> a -> b
$! CBytes
-> ThreadId -> HashMap CBytes ThreadId -> HashMap CBytes ThreadId
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert CBytes
d ThreadId
tid HashMap CBytes ThreadId
m') HashMap CBytes ThreadId
m (CBytes
fCBytes -> [CBytes] -> [CBytes]
forall a. a -> [a] -> [a]
:[CBytes]
ds)
#endif
                    IORef (Maybe FileEvent)
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> FileEvent
-> IO ()
forall a out. Eq a => IORef (Maybe a) -> BIO a out -> a -> IO ()
pushDedup IORef (Maybe FileEvent)
eRef (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink (CBytes -> FileEvent
FileAdd CBytes
f))
                (\ (NoSuchThing
_ :: NoSuchThing) -> do
                    MVar (HashMap CBytes ThreadId)
-> (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (HashMap CBytes ThreadId)
mRef ((HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
 -> IO ())
-> (HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \ HashMap CBytes ThreadId
m -> do
                        Maybe ThreadId -> (ThreadId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (CBytes -> HashMap CBytes ThreadId -> Maybe ThreadId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup CBytes
f HashMap CBytes ThreadId
m) ThreadId -> IO ()
killThread
                        HashMap CBytes ThreadId -> IO (HashMap CBytes ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (CBytes -> HashMap CBytes ThreadId -> HashMap CBytes ThreadId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete CBytes
f HashMap CBytes ThreadId
m)
                    IORef (Maybe FileEvent)
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> FileEvent
-> IO ()
forall a out. Eq a => IORef (Maybe a) -> BIO a out -> a -> IO ()
pushDedup IORef (Maybe FileEvent)
eRef (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink (CBytes -> FileEvent
FileRemove CBytes
f))
            else IORef (Maybe FileEvent)
-> ((Maybe Void -> IO ()) -> Maybe FileEvent -> IO ())
-> FileEvent
-> IO ()
forall a out. Eq a => IORef (Maybe a) -> BIO a out -> a -> IO ()
pushDedup IORef (Maybe FileEvent)
eRef (Maybe Void -> IO ()) -> Maybe FileEvent -> IO ()
sink (CBytes -> FileEvent
FileModify CBytes
f)

    pushDedup :: IORef (Maybe a) -> BIO a out -> a -> IO ()
pushDedup IORef (Maybe a)
eRef BIO a out
sink a
event = do
        Int -> IO () -> IO ()
registerLowResTimer_ Int
1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe a
me' <- IORef (Maybe a) -> (Maybe a -> (Maybe a, Maybe a)) -> IO (Maybe a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe a)
eRef ((Maybe a -> (Maybe a, Maybe a)) -> IO (Maybe a))
-> (Maybe a -> (Maybe a, Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \ Maybe a
me ->
                case Maybe a
me of
                    Just a
e -> (Maybe a
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just a
e)
                    Maybe a
_      -> (Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
            Maybe a -> (a -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe a
me' (BIO a out -> a -> IO ()
forall inp out. HasCallStack => BIO inp out -> inp -> IO ()
stepBIO_ BIO a out
sink)

        Maybe a
me' <- IORef (Maybe a) -> (Maybe a -> (Maybe a, Maybe a)) -> IO (Maybe a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe a)
eRef ((Maybe a -> (Maybe a, Maybe a)) -> IO (Maybe a))
-> (Maybe a -> (Maybe a, Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \ Maybe a
me ->
            case Maybe a
me of
                Just a
e -> if (a
e a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
event)
                    then (Maybe a
me, Maybe a
forall a. Maybe a
Nothing)
                    else (a -> Maybe a
forall a. a -> Maybe a
Just a
event, a -> Maybe a
forall a. a -> Maybe a
Just a
e)
                Maybe a
_ -> (a -> Maybe a
forall a. a -> Maybe a
Just a
event, Maybe a
forall a. Maybe a
Nothing)
        Maybe a -> (a -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe a
me' (BIO a out -> a -> IO ()
forall inp out. HasCallStack => BIO inp out -> inp -> IO ()
stepBIO_ BIO a out
sink)