{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module System.FSNotify.Linux
( FileListener(..)
, NativeManager
) where
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Exception as E
import Control.Monad
import qualified Data.ByteString as BS
import Data.IORef (atomicModifyIORef, readIORef)
import Data.String
import qualified Data.Text as T
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX
import Data.Typeable
import qualified GHC.Foreign as F
import GHC.IO.Encoding (getFileSystemEncoding)
import Prelude hiding (FilePath)
import qualified Shelly as S
import System.FSNotify.Listener
import System.FSNotify.Path (findDirs, canonicalizeDirPath)
import System.FSNotify.Types
import System.FilePath
import qualified System.INotify as INo
import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes)
type NativeManager = INo.INotify
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
showList :: [EventVarietyMismatchException] -> ShowS
$cshowList :: [EventVarietyMismatchException] -> ShowS
show :: EventVarietyMismatchException -> String
$cshow :: EventVarietyMismatchException -> String
showsPrec :: Int -> EventVarietyMismatchException -> ShowS
$cshowsPrec :: Int -> EventVarietyMismatchException -> ShowS
Show, Typeable)
instance Exception EventVarietyMismatchException
#if MIN_VERSION_hinotify(0, 3, 10)
toRawFilePath :: FilePath -> IO BS.ByteString
toRawFilePath :: String -> IO ByteString
toRawFilePath String
fp = do
TextEncoding
enc <- IO TextEncoding
getFileSystemEncoding
TextEncoding
-> String -> (CString -> IO ByteString) -> IO ByteString
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
F.withCString TextEncoding
enc String
fp CString -> IO ByteString
BS.packCString
fromRawFilePath :: BS.ByteString -> IO FilePath
fromRawFilePath :: ByteString -> IO String
fromRawFilePath ByteString
bs = do
TextEncoding
enc <- IO TextEncoding
getFileSystemEncoding
ByteString -> (CString -> IO String) -> IO String
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString ByteString
bs (TextEncoding -> CString -> IO String
F.peekCString TextEncoding
enc)
#else
toRawFilePath = return . id
fromRawFilePath = return . id
#endif
fsnEvents :: FilePath -> UTCTime -> INo.Event -> IO [Event]
fsnEvents :: String -> UTCTime -> Event -> IO [Event]
fsnEvents String
basePath UTCTime
timestamp (INo.Attributes Bool
isDir (Just ByteString
raw)) = ByteString -> IO String
fromRawFilePath ByteString
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> Bool -> Event
Modified (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp Bool
isDir]
fsnEvents String
basePath UTCTime
timestamp (INo.Modified Bool
isDir (Just ByteString
raw)) = ByteString -> IO String
fromRawFilePath ByteString
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> Bool -> Event
Modified (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp Bool
isDir]
fsnEvents String
basePath UTCTime
timestamp (INo.Created Bool
isDir ByteString
raw) = ByteString -> IO String
fromRawFilePath ByteString
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> Bool -> Event
Added (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp Bool
isDir]
fsnEvents String
basePath UTCTime
timestamp (INo.MovedOut Bool
isDir ByteString
raw Cookie
_cookie) = ByteString -> IO String
fromRawFilePath ByteString
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> Bool -> Event
Removed (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp Bool
isDir]
fsnEvents String
basePath UTCTime
timestamp (INo.MovedIn Bool
isDir ByteString
raw Cookie
_cookie) = ByteString -> IO String
fromRawFilePath ByteString
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> Bool -> Event
Added (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp Bool
isDir]
fsnEvents String
basePath UTCTime
timestamp (INo.Deleted Bool
isDir ByteString
raw) = ByteString -> IO String
fromRawFilePath ByteString
raw IO String -> (String -> IO [Event]) -> IO [Event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> Bool -> Event
Removed (String
basePath String -> ShowS
</> String
name) UTCTime
timestamp Bool
isDir]
fsnEvents String
_ UTCTime
_ (Event
INo.Ignored) = [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return []
fsnEvents String
basePath UTCTime
timestamp Event
inoEvent = [Event] -> IO [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> String -> Event
Unknown String
basePath UTCTime
timestamp (Event -> String
forall a. Show a => a -> String
show Event
inoEvent)]
handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO ()
handleInoEvent :: ActionPredicate
-> EventChannel -> String -> DebouncePayload -> Event -> IO ()
handleInoEvent ActionPredicate
actPred EventChannel
chan String
basePath DebouncePayload
dbp Event
inoEvent = do
UTCTime
currentTime <- IO UTCTime
getCurrentTime
[Event]
events <- String -> UTCTime -> Event -> IO [Event]
fsnEvents String
basePath UTCTime
currentTime Event
inoEvent
(Event -> IO ()) -> [Event] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ActionPredicate
-> EventChannel -> DebouncePayload -> Event -> IO ()
handleEvent ActionPredicate
actPred EventChannel
chan DebouncePayload
dbp) [Event]
events
handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO ()
handleEvent :: ActionPredicate
-> EventChannel -> DebouncePayload -> Event -> IO ()
handleEvent ActionPredicate
actPred EventChannel
chan DebouncePayload
dbp 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
$ case DebouncePayload
dbp of
(Just (DebounceData NominalDiffTime
epsilon IOEvent
ior)) -> do
Event
lastEvent <- IOEvent -> IO Event
forall a. IORef a -> IO a
readIORef IOEvent
ior
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NominalDiffTime -> Event -> ActionPredicate
debounce NominalDiffTime
epsilon Event
lastEvent Event
event) IO ()
writeToChan
IOEvent -> (Event -> (Event, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IOEvent
ior ((Event, ()) -> Event -> (Event, ())
forall a b. a -> b -> a
const (Event
event, ()))
DebouncePayload
Nothing -> IO ()
writeToChan
where
writeToChan :: IO ()
writeToChan = EventChannel -> Event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan EventChannel
chan 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]
instance FileListener INo.INotify where
initSession :: IO (Maybe INotify)
initSession = IO (Maybe INotify)
-> (IOException -> IO (Maybe INotify)) -> IO (Maybe INotify)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch ((INotify -> Maybe INotify) -> IO INotify -> IO (Maybe INotify)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap INotify -> Maybe INotify
forall a. a -> Maybe a
Just IO INotify
INo.initINotify) (\(IOException
_ :: IOException) -> Maybe INotify -> IO (Maybe INotify)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe INotify
forall a. Maybe a
Nothing)
killSession :: INotify -> IO ()
killSession = INotify -> IO ()
INo.killINotify
listen :: WatchConfig
-> INotify
-> String
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listen WatchConfig
conf INotify
iNotify String
path ActionPredicate
actPred EventChannel
chan = do
String
path' <- String -> IO String
canonicalizeDirPath String
path
DebouncePayload
dbp <- Debounce -> IO DebouncePayload
newDebouncePayload (Debounce -> IO DebouncePayload) -> Debounce -> IO DebouncePayload
forall a b. (a -> b) -> a -> b
$ WatchConfig -> Debounce
confDebounce WatchConfig
conf
ByteString
rawPath <- String -> IO ByteString
toRawFilePath String
path'
WatchDescriptor
wd <- INotify
-> [EventVariety]
-> ByteString
-> (Event -> IO ())
-> IO WatchDescriptor
INo.addWatch INotify
iNotify [EventVariety]
varieties ByteString
rawPath (String -> DebouncePayload -> Event -> IO ()
handler String
path' DebouncePayload
dbp)
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ WatchDescriptor -> IO ()
INo.removeWatch WatchDescriptor
wd
where
handler :: FilePath -> DebouncePayload -> INo.Event -> IO ()
handler :: String -> DebouncePayload -> Event -> IO ()
handler = ActionPredicate
-> EventChannel -> String -> DebouncePayload -> Event -> IO ()
handleInoEvent ActionPredicate
actPred EventChannel
chan
listenRecursive :: WatchConfig
-> INotify
-> String
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listenRecursive WatchConfig
conf INotify
iNotify String
initialPath ActionPredicate
actPred EventChannel
chan = do
MVar (Maybe [WatchDescriptor])
wdVar <- Maybe [WatchDescriptor] -> IO (MVar (Maybe [WatchDescriptor]))
forall a. a -> IO (MVar a)
newMVar ([WatchDescriptor] -> Maybe [WatchDescriptor]
forall a. a -> Maybe a
Just [])
let
stopListening :: IO ()
stopListening = do
MVar (Maybe [WatchDescriptor])
-> (Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor]))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe [WatchDescriptor])
wdVar ((Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor]))
-> IO ())
-> (Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe [WatchDescriptor]
mbWds -> do
IO ()
-> ([WatchDescriptor] -> IO ()) -> Maybe [WatchDescriptor] -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((WatchDescriptor -> IO ()) -> [WatchDescriptor] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\WatchDescriptor
x -> IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (WatchDescriptor -> IO ()
INo.removeWatch WatchDescriptor
x) (\(SomeException
_ :: SomeException) -> String -> IO ()
putStrLn (String
"Error removing watch: " String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` WatchDescriptor -> String
forall a. Show a => a -> String
show WatchDescriptor
x)))) Maybe [WatchDescriptor]
mbWds
Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [WatchDescriptor]
forall a. Maybe a
Nothing
String -> MVar (Maybe [WatchDescriptor]) -> IO ()
listenRec String
initialPath MVar (Maybe [WatchDescriptor])
wdVar
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
stopListening
where
listenRec :: FilePath -> MVar (Maybe [INo.WatchDescriptor]) -> IO ()
listenRec :: String -> MVar (Maybe [WatchDescriptor]) -> IO ()
listenRec String
path MVar (Maybe [WatchDescriptor])
wdVar = do
String
path' <- String -> IO String
canonicalizeDirPath String
path
[String]
paths <- Bool -> String -> IO [String]
findDirs Bool
True String
path'
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MVar (Maybe [WatchDescriptor]) -> String -> IO ()
pathHandler MVar (Maybe [WatchDescriptor])
wdVar) (String
path'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
paths)
pathHandler :: MVar (Maybe [INo.WatchDescriptor]) -> FilePath -> IO ()
pathHandler :: MVar (Maybe [WatchDescriptor]) -> String -> IO ()
pathHandler MVar (Maybe [WatchDescriptor])
wdVar String
filePath = do
DebouncePayload
dbp <- Debounce -> IO DebouncePayload
newDebouncePayload (Debounce -> IO DebouncePayload) -> Debounce -> IO DebouncePayload
forall a b. (a -> b) -> a -> b
$ WatchConfig -> Debounce
confDebounce WatchConfig
conf
ByteString
rawFilePath <- String -> IO ByteString
toRawFilePath String
filePath
MVar (Maybe [WatchDescriptor])
-> (Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor]))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe [WatchDescriptor])
wdVar ((Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor]))
-> IO ())
-> (Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe [WatchDescriptor]
mbWds ->
case Maybe [WatchDescriptor]
mbWds of
Maybe [WatchDescriptor]
Nothing -> Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [WatchDescriptor]
mbWds
Just [WatchDescriptor]
wds -> do
WatchDescriptor
wd <- INotify
-> [EventVariety]
-> ByteString
-> (Event -> IO ())
-> IO WatchDescriptor
INo.addWatch INotify
iNotify [EventVariety]
varieties ByteString
rawFilePath (String -> DebouncePayload -> Event -> IO ()
handler String
filePath DebouncePayload
dbp)
Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor]))
-> Maybe [WatchDescriptor] -> IO (Maybe [WatchDescriptor])
forall a b. (a -> b) -> a -> b
$ [WatchDescriptor] -> Maybe [WatchDescriptor]
forall a. a -> Maybe a
Just (WatchDescriptor
wdWatchDescriptor -> [WatchDescriptor] -> [WatchDescriptor]
forall a. a -> [a] -> [a]
:[WatchDescriptor]
wds)
where
handler :: FilePath -> DebouncePayload -> INo.Event -> IO ()
handler :: String -> DebouncePayload -> Event -> IO ()
handler String
baseDir DebouncePayload
dbp Event
event = do
case Event
event of
(INo.Created Bool
True ByteString
rawDirPath) -> do
String
dirPath <- ByteString -> IO String
fromRawFilePath ByteString
rawDirPath
let newDir :: String
newDir = String
baseDir String -> ShowS
</> String
dirPath
NominalDiffTime
timestampBeforeAddingWatch <- IO NominalDiffTime
getPOSIXTime
String -> MVar (Maybe [WatchDescriptor]) -> IO ()
listenRec String
newDir MVar (Maybe [WatchDescriptor])
wdVar
[String]
files <- Sh [String] -> IO [String]
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
S.shelly (Sh [String] -> IO [String]) -> Sh [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> Sh [String]
S.find (ShowS
forall a. IsString a => String -> a
fromString String
newDir)
[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
file -> do
let newPath :: String
newPath = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ String -> Text
S.toTextIgnore String
file
FileStatus
fileStatus <- String -> IO FileStatus
getFileStatus String
newPath
let modTime :: NominalDiffTime
modTime = FileStatus -> NominalDiffTime
modificationTimeHiRes FileStatus
fileStatus
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
modTime NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
timestampBeforeAddingWatch) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ActionPredicate
-> EventChannel -> DebouncePayload -> Event -> IO ()
handleEvent ActionPredicate
actPred EventChannel
chan DebouncePayload
dbp (String -> UTCTime -> Bool -> Event
Added (String
newDir String -> ShowS
</> String
newPath) (NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
timestampBeforeAddingWatch) (FileStatus -> Bool
isDirectory FileStatus
fileStatus))
Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case Event
event of
(Event
INo.DeletedSelf) -> do
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Event
INo.Ignored) -> do
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ActionPredicate
-> EventChannel -> String -> DebouncePayload -> Event -> IO ()
handleInoEvent ActionPredicate
actPred EventChannel
chan String
baseDir DebouncePayload
dbp Event
event
usesPolling :: INotify -> Bool
usesPolling = Bool -> INotify -> Bool
forall a b. a -> b -> a
const Bool
False