{-|
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, use returned close function to cleanup watching threads.
(close, srcf) <- watchDirs ["fold_to_be_watch"]
-- dup a file event source
src <- srcf
-- print event to stdout
runBIO $ src >|> sinkToIO printLineStd
@
-}

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

import           Control.Concurrent
import           Control.Monad
import           Data.Bits
import           Data.IORef
import qualified Data.HashMap.Strict      as HM
import qualified Data.List                as List
import           Data.Word
import           GHC.Generics
import           Data.Primitive.PrimArray
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.UV.FFI
import           Z.IO.UV.Manager
import           Z.IO.LowResTimer

-- | 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)


-- | Start watching a list of given directories.
--
watchDirs :: [CBytes] -> IO (IO (), IO (Source FileEvent))
watchDirs :: [CBytes] -> IO (IO (), IO (Source FileEvent))
watchDirs [CBytes]
dirs =  do
    [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
        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] -> IO (IO (), IO (Source FileEvent))
watch_ CUInt
0 [CBytes]
dirs

-- | Start watching a list of given directories recursively.
--
watchDirsRecursively :: [CBytes] -> IO (IO (), IO (Source FileEvent))
watchDirsRecursively :: [CBytes] -> IO (IO (), IO (Source FileEvent))
watchDirsRecursively [CBytes]
dirs = do
#if defined(linux_HOST_OS)
    -- inotify doesn't support recursive watch, so we manually maintain watch list
    [[CBytes]]
subDirs <- [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
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] -> IO (IO (), 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] -> IO (IO (), IO (Source FileEvent))
watch_ :: CUInt -> [CBytes] -> IO (IO (), IO (Source FileEvent))
watch_ CUInt
flag [CBytes]
dirs = 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
    (Sink FileEvent
sink, IO (Source FileEvent)
srcf) <- Int -> IO (Sink FileEvent, 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 -> Sink FileEvent -> IO ()
watchThread MVar (HashMap CBytes ThreadId)
mRef CBytes
dir' Sink FileEvent
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) -> Sink FileEvent -> IO ()
forall (t :: * -> *) inp out.
Foldable t =>
MVar (t ThreadId) -> BIO inp out -> IO ()
cleanUpWatcher MVar (HashMap CBytes ThreadId)
mRef Sink FileEvent
sink
    (IO (), IO (Source FileEvent)) -> IO (IO (), IO (Source FileEvent))
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (HashMap CBytes ThreadId) -> Sink FileEvent -> IO ()
forall (t :: * -> *) inp out.
Foldable t =>
MVar (t ThreadId) -> BIO inp out -> IO ()
cleanUpWatcher MVar (HashMap CBytes ThreadId)
mRef Sink FileEvent
sink, IO (Source FileEvent)
srcf)
  where
    eventBufSiz :: Int
eventBufSiz = Int
defaultChunkSize

    cleanUpWatcher :: MVar (t ThreadId) -> BIO inp out -> IO ()
cleanUpWatcher MVar (t ThreadId)
mRef BIO inp out
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 (Maybe out) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (BIO inp out -> IO (Maybe out)
forall inp out. BIO inp out -> IO (Maybe out)
pull BIO inp out
sink)

    watchThread :: MVar (HashMap CBytes ThreadId) -> CBytes -> Sink FileEvent -> IO ()
watchThread MVar (HashMap CBytes ThreadId)
mRef CBytes
dir Sink FileEvent
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)
-> Sink FileEvent
-> [(Word8, CBytes)]
-> IO ()
processEvent CBytes
dir MVar (HashMap CBytes ThreadId)
mRef IORef (Maybe FileEvent)
eRef Sink FileEvent
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)
-> Sink FileEvent
-> [(Word8, CBytes)]
-> IO ()
processEvent CBytes
pdir MVar (HashMap CBytes ThreadId)
mRef IORef (Maybe FileEvent)
eRef Sink FileEvent
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 -> Sink FileEvent -> IO ()
watchThread MVar (HashMap CBytes ThreadId)
mRef CBytes
d Sink FileEvent
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) -> Sink FileEvent -> FileEvent -> IO ()
forall inp out.
Eq inp =>
IORef (Maybe inp) -> BIO inp out -> inp -> IO ()
pushDedup IORef (Maybe FileEvent)
eRef Sink FileEvent
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) -> Sink FileEvent -> FileEvent -> IO ()
forall inp out.
Eq inp =>
IORef (Maybe inp) -> BIO inp out -> inp -> IO ()
pushDedup IORef (Maybe FileEvent)
eRef Sink FileEvent
sink (CBytes -> FileEvent
FileRemove CBytes
f))
            else IORef (Maybe FileEvent) -> Sink FileEvent -> FileEvent -> IO ()
forall inp out.
Eq inp =>
IORef (Maybe inp) -> BIO inp out -> inp -> IO ()
pushDedup IORef (Maybe FileEvent)
eRef Sink FileEvent
sink (CBytes -> FileEvent
FileModify CBytes
f)

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

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