--
-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module System.FSNotify.Linux (
  FileListener(..)
  , NativeManager
  ) where

import Control.Concurrent.MVar
import Control.Exception.Safe as E
import Control.Monad
import qualified Data.ByteString as BS
import Data.Function
import Data.Monoid
import Data.String
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX
import qualified GHC.Foreign as F
import GHC.IO.Encoding (getFileSystemEncoding)
import Prelude hiding (FilePath)
import System.Directory (canonicalizePath)
import System.FSNotify.Find
import System.FSNotify.Listener
import System.FSNotify.Types
import System.FilePath (FilePath, (</>))
import qualified System.INotify as INo
import System.Posix.ByteString (RawFilePath)
import System.Posix.Directory.ByteString (openDirStream, readDirStream, closeDirStream)
import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes)


data INotifyListener = INotifyListener { INotifyListener -> INotify
listenerINotify :: INo.INotify }

type NativeManager = INotifyListener

data EventVarietyMismatchException = EventVarietyMismatchException deriving (Int -> EventVarietyMismatchException -> ShowS
[EventVarietyMismatchException] -> ShowS
EventVarietyMismatchException -> String
(Int -> EventVarietyMismatchException -> ShowS)
-> (EventVarietyMismatchException -> String)
-> ([EventVarietyMismatchException] -> ShowS)
-> Show EventVarietyMismatchException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EventVarietyMismatchException -> ShowS
showsPrec :: Int -> EventVarietyMismatchException -> ShowS
$cshow :: EventVarietyMismatchException -> String
show :: EventVarietyMismatchException -> String
$cshowList :: [EventVarietyMismatchException] -> ShowS
showList :: [EventVarietyMismatchException] -> ShowS
Show, Typeable)
instance Exception EventVarietyMismatchException


fsnEvents :: RawFilePath -> UTCTime -> INo.Event -> IO [Event]
fsnEvents :: RawFilePath -> UTCTime -> Event -> IO [Event]
fsnEvents RawFilePath
basePath' UTCTime
timestamp (INo.Attributes (Bool -> EventIsDirectory
boolToIsDirectory -> EventIsDirectory
isDir) (Just RawFilePath
raw)) = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  RawFilePath -> IO String
fromHinotifyPath RawFilePath
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
ModifiedAttributes (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp EventIsDirectory
isDir]
fsnEvents RawFilePath
basePath' UTCTime
timestamp (INo.Modified (Bool -> EventIsDirectory
boolToIsDirectory -> EventIsDirectory
isDir) (Just RawFilePath
raw)) = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  RawFilePath -> IO String
fromHinotifyPath RawFilePath
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
Modified (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp EventIsDirectory
isDir]
fsnEvents RawFilePath
basePath' UTCTime
timestamp (INo.Closed (Bool -> EventIsDirectory
boolToIsDirectory -> EventIsDirectory
isDir) (Just RawFilePath
raw) Bool
True) = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  RawFilePath -> IO String
fromHinotifyPath RawFilePath
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
CloseWrite (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp EventIsDirectory
isDir]
fsnEvents RawFilePath
basePath' UTCTime
timestamp (INo.Created (Bool -> EventIsDirectory
boolToIsDirectory -> EventIsDirectory
isDir) RawFilePath
raw) = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  RawFilePath -> IO String
fromHinotifyPath RawFilePath
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
Added (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp EventIsDirectory
isDir]
fsnEvents RawFilePath
basePath' UTCTime
timestamp (INo.MovedOut (Bool -> EventIsDirectory
boolToIsDirectory -> EventIsDirectory
isDir) RawFilePath
raw Cookie
_cookie) = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  RawFilePath -> IO String
fromHinotifyPath RawFilePath
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
Removed (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp EventIsDirectory
isDir]
fsnEvents RawFilePath
basePath' UTCTime
timestamp (INo.MovedIn (Bool -> EventIsDirectory
boolToIsDirectory -> EventIsDirectory
isDir) RawFilePath
raw Cookie
_cookie) = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  RawFilePath -> IO String
fromHinotifyPath RawFilePath
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
Added (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp EventIsDirectory
isDir]
fsnEvents RawFilePath
basePath' UTCTime
timestamp (INo.Deleted (Bool -> EventIsDirectory
boolToIsDirectory -> EventIsDirectory
isDir) RawFilePath
raw) = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  RawFilePath -> IO String
fromHinotifyPath RawFilePath
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
Removed (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp EventIsDirectory
isDir]
fsnEvents RawFilePath
basePath' UTCTime
timestamp Event
INo.DeletedSelf = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> Event
WatchedDirectoryRemoved String
basePath UTCTime
timestamp EventIsDirectory
IsDirectory]
fsnEvents RawFilePath
_ UTCTime
_ Event
INo.Ignored = [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
fsnEvents RawFilePath
basePath' UTCTime
timestamp Event
inoEvent = do
  String
basePath <- RawFilePath -> IO String
fromRawFilePath RawFilePath
basePath'
  [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> EventIsDirectory -> String -> Event
Unknown String
basePath UTCTime
timestamp EventIsDirectory
IsFile (Event -> String
forall a. Show a => a -> String
show Event
inoEvent)]

handleInoEvent :: ActionPredicate -> EventCallback -> RawFilePath -> MVar Bool -> INo.Event -> IO ()
handleInoEvent :: ActionPredicate
-> EventCallback -> RawFilePath -> MVar Bool -> Event -> IO ()
handleInoEvent ActionPredicate
actPred EventCallback
callback RawFilePath
basePath MVar Bool
watchStillExistsVar Event
inoEvent = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event
INo.DeletedSelf Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
inoEvent) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
watchStillExistsVar ((Bool -> IO Bool) -> IO ()) -> (Bool -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> Bool -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> Bool -> IO Bool) -> IO Bool -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  UTCTime
currentTime <- IO UTCTime
getCurrentTime
  [Event]
events <- RawFilePath -> UTCTime -> Event -> IO [Event]
fsnEvents RawFilePath
basePath UTCTime
currentTime Event
inoEvent
  [Event] -> EventCallback -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
events (EventCallback -> IO ()) -> EventCallback -> IO ()
forall a b. (a -> b) -> a -> b
$ \Event
event -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ActionPredicate
actPred Event
event) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EventCallback
callback Event
event

varieties :: [INo.EventVariety]
varieties :: [EventVariety]
varieties = [EventVariety
INo.Create, EventVariety
INo.Delete, EventVariety
INo.MoveIn, EventVariety
INo.MoveOut, EventVariety
INo.Attrib, EventVariety
INo.Modify, EventVariety
INo.CloseWrite, EventVariety
INo.DeleteSelf]

instance FileListener INotifyListener () where
  initSession :: () -> IO (Either Text INotifyListener)
initSession ()
_ = (IOException -> IO (Either Text INotifyListener))
-> IO (Either Text INotifyListener)
-> IO (Either Text INotifyListener)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle (\(IOException
e :: IOException) -> Either Text INotifyListener -> IO (Either Text INotifyListener)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text INotifyListener -> IO (Either Text INotifyListener))
-> Either Text INotifyListener -> IO (Either Text INotifyListener)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text INotifyListener
forall a b. a -> Either a b
Left (Text -> Either Text INotifyListener)
-> Text -> Either Text INotifyListener
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e) (IO (Either Text INotifyListener)
 -> IO (Either Text INotifyListener))
-> IO (Either Text INotifyListener)
-> IO (Either Text INotifyListener)
forall a b. (a -> b) -> a -> b
$ do
    INotify
inotify <- IO INotify
INo.initINotify
    Either Text INotifyListener -> IO (Either Text INotifyListener)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text INotifyListener -> IO (Either Text INotifyListener))
-> Either Text INotifyListener -> IO (Either Text INotifyListener)
forall a b. (a -> b) -> a -> b
$ INotifyListener -> Either Text INotifyListener
forall a b. b -> Either a b
Right (INotifyListener -> Either Text INotifyListener)
-> INotifyListener -> Either Text INotifyListener
forall a b. (a -> b) -> a -> b
$ INotify -> INotifyListener
INotifyListener INotify
inotify

  killSession :: INotifyListener -> IO ()
killSession (INotifyListener {INotify
listenerINotify :: INotifyListener -> INotify
listenerINotify :: INotify
listenerINotify}) = INotify -> IO ()
INo.killINotify INotify
listenerINotify

  listen :: ListenFn INotifyListener ()
listen WatchConfig
_conf (INotifyListener {INotify
listenerINotify :: INotifyListener -> INotify
listenerINotify :: INotify
listenerINotify}) String
path ActionPredicate
actPred EventCallback
callback = do
    RawFilePath
rawPath <- String -> IO RawFilePath
toRawFilePath String
path
    RawFilePath
canonicalRawPath <- RawFilePath -> IO RawFilePath
canonicalizeRawDirPath RawFilePath
rawPath
    MVar Bool
watchStillExistsVar <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
True
    RawFilePath
hinotifyPath <- RawFilePath -> IO RawFilePath
rawToHinotifyPath RawFilePath
canonicalRawPath
    WatchDescriptor
wd <- INotify
-> [EventVariety]
-> RawFilePath
-> (Event -> IO ())
-> IO WatchDescriptor
INo.addWatch INotify
listenerINotify [EventVariety]
varieties RawFilePath
hinotifyPath (ActionPredicate
-> EventCallback -> RawFilePath -> MVar Bool -> Event -> IO ()
handleInoEvent ActionPredicate
actPred EventCallback
callback RawFilePath
canonicalRawPath MVar Bool
watchStillExistsVar)
    IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
      MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
watchStillExistsVar ((Bool -> IO Bool) -> IO ()) -> (Bool -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
wse -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wse (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WatchDescriptor -> IO ()
INo.removeWatch WatchDescriptor
wd
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  listenRecursive :: ListenFn INotifyListener ()
listenRecursive WatchConfig
_conf INotifyListener
listener String
initialPath ActionPredicate
actPred EventCallback
callback = do
    -- wdVar stores the list of created watch descriptors. We use it to
    -- cancel the whole recursive listening task.
    --
    -- To avoid a race condition (when a new watch is added right after
    -- we've stopped listening), we replace the MVar contents with Nothing
    -- to signify that the listening task is cancelled, and no new watches
    -- should be added.
    MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar <- Maybe [(WatchDescriptor, MVar Bool)]
-> IO (MVar (Maybe [(WatchDescriptor, MVar Bool)]))
forall a. a -> IO (MVar a)
newMVar ([(WatchDescriptor, MVar Bool)]
-> Maybe [(WatchDescriptor, MVar Bool)]
forall a. a -> Maybe a
Just [])

    let
      removeWatches :: t (WatchDescriptor, MVar Bool) -> IO ()
removeWatches t (WatchDescriptor, MVar Bool)
wds = t (WatchDescriptor, MVar Bool)
-> ((WatchDescriptor, MVar Bool) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (WatchDescriptor, MVar Bool)
wds (((WatchDescriptor, MVar Bool) -> IO ()) -> IO ())
-> ((WatchDescriptor, MVar Bool) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(WatchDescriptor
wd, MVar Bool
watchStillExistsVar) ->
        MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
watchStillExistsVar ((Bool -> IO Bool) -> IO ()) -> (Bool -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
wse -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wse (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(SomeException
e :: SomeException) -> String -> IO ()
putStrLn (String
"Error removing watch: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> WatchDescriptor -> String
forall a. Show a => a -> String
show WatchDescriptor
wd String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"))
                   (WatchDescriptor -> IO ()
INo.removeWatch WatchDescriptor
wd)
          Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

      stopListening :: IO ()
stopListening = MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> (Maybe [(WatchDescriptor, MVar Bool)]
    -> IO (Maybe [(WatchDescriptor, MVar Bool)]))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar ((Maybe [(WatchDescriptor, MVar Bool)]
  -> IO (Maybe [(WatchDescriptor, MVar Bool)]))
 -> IO ())
-> (Maybe [(WatchDescriptor, MVar Bool)]
    -> IO (Maybe [(WatchDescriptor, MVar Bool)]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe [(WatchDescriptor, MVar Bool)]
x -> IO ()
-> ([(WatchDescriptor, MVar Bool)] -> IO ())
-> Maybe [(WatchDescriptor, MVar Bool)]
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [(WatchDescriptor, MVar Bool)] -> IO ()
forall {t :: * -> *}.
Foldable t =>
t (WatchDescriptor, MVar Bool) -> IO ()
removeWatches Maybe [(WatchDescriptor, MVar Bool)]
x IO ()
-> IO (Maybe [(WatchDescriptor, MVar Bool)])
-> IO (Maybe [(WatchDescriptor, MVar Bool)])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [(WatchDescriptor, MVar Bool)]
-> IO (Maybe [(WatchDescriptor, MVar Bool)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(WatchDescriptor, MVar Bool)]
forall a. Maybe a
Nothing

    -- Add watches to this directory plus every sub-directory
    RawFilePath
rawInitialPath <- String -> IO RawFilePath
toRawFilePath String
initialPath
    RawFilePath
rawCanonicalInitialPath <- RawFilePath -> IO RawFilePath
canonicalizeRawDirPath RawFilePath
rawInitialPath
    INotifyListener
-> MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> ActionPredicate
-> EventCallback
-> Bool
-> RawFilePath
-> IO ()
watchDirectoryRecursively INotifyListener
listener MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar ActionPredicate
actPred EventCallback
callback Bool
True RawFilePath
rawCanonicalInitialPath
    RawFilePath -> (RawFilePath -> IO ()) -> IO ()
traverseAllDirs RawFilePath
rawCanonicalInitialPath ((RawFilePath -> IO ()) -> IO ())
-> (RawFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RawFilePath
subPath ->
      INotifyListener
-> MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> ActionPredicate
-> EventCallback
-> Bool
-> RawFilePath
-> IO ()
watchDirectoryRecursively INotifyListener
listener MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar ActionPredicate
actPred EventCallback
callback Bool
False RawFilePath
subPath

    IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
stopListening


type RecursiveWatches = MVar (Maybe [(INo.WatchDescriptor, MVar Bool)])

watchDirectoryRecursively :: INotifyListener -> RecursiveWatches -> ActionPredicate -> EventCallback -> Bool -> RawFilePath -> IO ()
watchDirectoryRecursively :: INotifyListener
-> MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> ActionPredicate
-> EventCallback
-> Bool
-> RawFilePath
-> IO ()
watchDirectoryRecursively listener :: INotifyListener
listener@(INotifyListener {INotify
listenerINotify :: INotifyListener -> INotify
listenerINotify :: INotify
listenerINotify}) MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar ActionPredicate
actPred EventCallback
callback Bool
isRootWatchedDir RawFilePath
rawFilePath = do
  MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> (Maybe [(WatchDescriptor, MVar Bool)]
    -> IO (Maybe [(WatchDescriptor, MVar Bool)]))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar ((Maybe [(WatchDescriptor, MVar Bool)]
  -> IO (Maybe [(WatchDescriptor, MVar Bool)]))
 -> IO ())
-> (Maybe [(WatchDescriptor, MVar Bool)]
    -> IO (Maybe [(WatchDescriptor, MVar Bool)]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \case
    Maybe [(WatchDescriptor, MVar Bool)]
Nothing -> Maybe [(WatchDescriptor, MVar Bool)]
-> IO (Maybe [(WatchDescriptor, MVar Bool)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(WatchDescriptor, MVar Bool)]
forall a. Maybe a
Nothing
    Just [(WatchDescriptor, MVar Bool)]
wds -> do
      MVar Bool
watchStillExistsVar <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
True
      RawFilePath
hinotifyPath <- RawFilePath -> IO RawFilePath
rawToHinotifyPath RawFilePath
rawFilePath
      WatchDescriptor
wd <- INotify
-> [EventVariety]
-> RawFilePath
-> (Event -> IO ())
-> IO WatchDescriptor
INo.addWatch INotify
listenerINotify [EventVariety]
varieties RawFilePath
hinotifyPath (RawFilePath
-> ActionPredicate
-> EventCallback
-> MVar Bool
-> Bool
-> INotifyListener
-> MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> Event
-> IO ()
handleRecursiveEvent RawFilePath
rawFilePath ActionPredicate
actPred EventCallback
callback MVar Bool
watchStillExistsVar Bool
isRootWatchedDir INotifyListener
listener MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar)
      Maybe [(WatchDescriptor, MVar Bool)]
-> IO (Maybe [(WatchDescriptor, MVar Bool)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(WatchDescriptor, MVar Bool)]
 -> IO (Maybe [(WatchDescriptor, MVar Bool)]))
-> Maybe [(WatchDescriptor, MVar Bool)]
-> IO (Maybe [(WatchDescriptor, MVar Bool)])
forall a b. (a -> b) -> a -> b
$ [(WatchDescriptor, MVar Bool)]
-> Maybe [(WatchDescriptor, MVar Bool)]
forall a. a -> Maybe a
Just ((WatchDescriptor
wd, MVar Bool
watchStillExistsVar)(WatchDescriptor, MVar Bool)
-> [(WatchDescriptor, MVar Bool)] -> [(WatchDescriptor, MVar Bool)]
forall a. a -> [a] -> [a]
:[(WatchDescriptor, MVar Bool)]
wds)


handleRecursiveEvent :: RawFilePath -> ActionPredicate -> EventCallback -> MVar Bool -> Bool -> INotifyListener -> RecursiveWatches -> INo.Event -> IO ()
handleRecursiveEvent :: RawFilePath
-> ActionPredicate
-> EventCallback
-> MVar Bool
-> Bool
-> INotifyListener
-> MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> Event
-> IO ()
handleRecursiveEvent RawFilePath
baseDir ActionPredicate
actPred EventCallback
callback MVar Bool
watchStillExistsVar Bool
isRootWatchedDir INotifyListener
listener MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar Event
event = do
  case Event
event of
    (INo.Created Bool
True RawFilePath
hiNotifyPath) -> do
      -- A new directory was created, so add recursive inotify watches to it
      RawFilePath
rawDirPath <- RawFilePath -> IO RawFilePath
rawFromHinotifyPath RawFilePath
hiNotifyPath
      let newRawDir :: RawFilePath
newRawDir = RawFilePath
baseDir RawFilePath -> RawFilePath -> RawFilePath
<//> RawFilePath
rawDirPath
      POSIXTime
timestampBeforeAddingWatch <- IO POSIXTime
getPOSIXTime
      INotifyListener
-> MVar (Maybe [(WatchDescriptor, MVar Bool)])
-> ActionPredicate
-> EventCallback
-> Bool
-> RawFilePath
-> IO ()
watchDirectoryRecursively INotifyListener
listener MVar (Maybe [(WatchDescriptor, MVar Bool)])
wdVar ActionPredicate
actPred EventCallback
callback Bool
False RawFilePath
newRawDir

      String
newDir <- RawFilePath -> IO String
fromRawFilePath RawFilePath
newRawDir

      -- Find all files/folders that might have been created *after* the timestamp, and hence might have been
      -- missed by the watch
      -- TODO: there's a chance of this generating double events, fix
      [String]
files <- Bool -> String -> IO [String]
find Bool
False String
newDir -- TODO: expose the ability to set followSymlinks to True?
      [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
files ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
newPath -> do
        FileStatus
fileStatus <- String -> IO FileStatus
getFileStatus String
newPath
        let modTime :: POSIXTime
modTime = FileStatus -> POSIXTime
modificationTimeHiRes FileStatus
fileStatus
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (POSIXTime
modTime POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> POSIXTime
timestampBeforeAddingWatch) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let isDir :: EventIsDirectory
isDir = if FileStatus -> Bool
isDirectory FileStatus
fileStatus then EventIsDirectory
IsDirectory else EventIsDirectory
IsFile
          let addedEvent :: Event
addedEvent = (String -> UTCTime -> EventIsDirectory -> Event
Added (String
newDir String -> ShowS
</> String
newPath) (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
timestampBeforeAddingWatch) EventIsDirectory
isDir)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ActionPredicate
actPred Event
addedEvent) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EventCallback
callback Event
addedEvent

    Event
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- If the watched directory was removed, mark the watch as already removed
  case Event
event of
    Event
INo.DeletedSelf -> MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
watchStillExistsVar ((Bool -> IO Bool) -> IO ()) -> (Bool -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> Bool -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> Bool -> IO Bool) -> IO Bool -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Event
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Forward the event. Ignore a DeletedSelf if we're not on the root directory,
  -- since the watch above us will pick up the delete of that directory.
  case Event
event of
    Event
INo.DeletedSelf | Bool -> Bool
not Bool
isRootWatchedDir -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Event
_ -> ActionPredicate
-> EventCallback -> RawFilePath -> MVar Bool -> Event -> IO ()
handleInoEvent ActionPredicate
actPred EventCallback
callback RawFilePath
baseDir MVar Bool
watchStillExistsVar Event
event



-- * Util

canonicalizeRawDirPath :: RawFilePath -> IO RawFilePath
canonicalizeRawDirPath :: RawFilePath -> IO RawFilePath
canonicalizeRawDirPath RawFilePath
p = RawFilePath -> IO String
fromRawFilePath RawFilePath
p IO String -> (String -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
canonicalizePath IO String -> (String -> IO RawFilePath) -> IO RawFilePath
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO RawFilePath
toRawFilePath

-- | Same as </> but for RawFilePath
-- TODO: make sure this is correct or find in a library
(<//>) :: RawFilePath -> RawFilePath -> RawFilePath
RawFilePath
x <//> :: RawFilePath -> RawFilePath -> RawFilePath
<//> RawFilePath
y = RawFilePath
x RawFilePath -> RawFilePath -> RawFilePath
forall a. Semigroup a => a -> a -> a
<> RawFilePath
"/" RawFilePath -> RawFilePath -> RawFilePath
forall a. Semigroup a => a -> a -> a
<> RawFilePath
y

traverseAllDirs :: RawFilePath -> (RawFilePath -> IO ()) -> IO ()
traverseAllDirs :: RawFilePath -> (RawFilePath -> IO ()) -> IO ()
traverseAllDirs RawFilePath
dir RawFilePath -> IO ()
cb = RawFilePath -> (RawFilePath -> IO Bool) -> IO ()
traverseAll RawFilePath
dir ((RawFilePath -> IO Bool) -> IO ())
-> (RawFilePath -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RawFilePath
subPath ->
  -- TODO: wish we didn't need fromRawFilePath here
  -- TODO: make sure this does the right thing with symlinks
  RawFilePath -> IO String
fromRawFilePath RawFilePath
subPath IO String -> (String -> IO FileStatus) -> IO FileStatus
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO FileStatus
getFileStatus IO FileStatus -> (FileStatus -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (FileStatus -> Bool
isDirectory -> Bool
True) -> RawFilePath -> IO ()
cb RawFilePath
subPath IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    FileStatus
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

traverseAll :: RawFilePath -> (RawFilePath -> IO Bool) -> IO ()
traverseAll :: RawFilePath -> (RawFilePath -> IO Bool) -> IO ()
traverseAll RawFilePath
dir RawFilePath -> IO Bool
cb = IO DirStream
-> (DirStream -> IO ()) -> (DirStream -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (RawFilePath -> IO DirStream
openDirStream RawFilePath
dir) DirStream -> IO ()
closeDirStream ((DirStream -> IO ()) -> IO ()) -> (DirStream -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DirStream
dirStream ->
  (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
    DirStream -> IO RawFilePath
readDirStream DirStream
dirStream IO RawFilePath -> (RawFilePath -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      RawFilePath
x | RawFilePath -> Bool
BS.null RawFilePath
x -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RawFilePath
"." -> IO ()
loop
      RawFilePath
".." -> IO ()
loop
      RawFilePath
subDir -> (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
finally IO ()
loop (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- TODO: canonicalize?
        let fullSubDir :: RawFilePath
fullSubDir = RawFilePath
dir RawFilePath -> RawFilePath -> RawFilePath
<//> RawFilePath
subDir
        Bool
shouldRecurse <- RawFilePath -> IO Bool
cb RawFilePath
fullSubDir
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldRecurse (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RawFilePath -> (RawFilePath -> IO Bool) -> IO ()
traverseAll RawFilePath
fullSubDir RawFilePath -> IO Bool
cb

boolToIsDirectory :: Bool -> EventIsDirectory
boolToIsDirectory :: Bool -> EventIsDirectory
boolToIsDirectory Bool
False = EventIsDirectory
IsFile
boolToIsDirectory Bool
True = EventIsDirectory
IsDirectory

toRawFilePath :: FilePath -> IO BS.ByteString
toRawFilePath :: String -> IO RawFilePath
toRawFilePath String
fp = do
  TextEncoding
enc <- IO TextEncoding
getFileSystemEncoding
  TextEncoding
-> String -> (CString -> IO RawFilePath) -> IO RawFilePath
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
F.withCString TextEncoding
enc String
fp CString -> IO RawFilePath
BS.packCString

fromRawFilePath :: BS.ByteString -> IO FilePath
fromRawFilePath :: RawFilePath -> IO String
fromRawFilePath RawFilePath
bs = do
  TextEncoding
enc <- IO TextEncoding
getFileSystemEncoding
  RawFilePath -> (CString -> IO String) -> IO String
forall a. RawFilePath -> (CString -> IO a) -> IO a
BS.useAsCString RawFilePath
bs (TextEncoding -> CString -> IO String
F.peekCString TextEncoding
enc)

#if MIN_VERSION_hinotify(0, 3, 10)
fromHinotifyPath :: BS.ByteString -> IO FilePath
fromHinotifyPath :: RawFilePath -> IO String
fromHinotifyPath = RawFilePath -> IO String
fromRawFilePath

rawToHinotifyPath :: BS.ByteString -> IO BS.ByteString
rawToHinotifyPath :: RawFilePath -> IO RawFilePath
rawToHinotifyPath = RawFilePath -> IO RawFilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

rawFromHinotifyPath :: BS.ByteString -> IO BS.ByteString
rawFromHinotifyPath :: RawFilePath -> IO RawFilePath
rawFromHinotifyPath = RawFilePath -> IO RawFilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
#else
fromHinotifyPath :: FilePath -> IO FilePath
fromHinotifyPath = return

rawToHinotifyPath :: BS.ByteString -> IO FilePath
rawToHinotifyPath = fromRawFilePath

rawFromHinotifyPath :: FilePath -> IO BS.ByteString
rawFromHinotifyPath = toRawFilePath
#endif