{-# 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
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
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
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> 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) = forall (m :: * -> *) a. Monad m => a -> m a
return []
fsnEvents String
basePath UTCTime
timestamp Event
inoEvent = forall (m :: * -> *) a. Monad m => a -> m a
return [String -> UTCTime -> String -> Event
Unknown String
basePath UTCTime
timestamp (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
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 =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ActionPredicate
actPred Event
event) forall a b. (a -> b) -> a -> b
$ case DebouncePayload
dbp of
(Just (DebounceData NominalDiffTime
epsilon IOEvent
ior)) -> do
Event
lastEvent <- forall a. IORef a -> IO a
readIORef IOEvent
ior
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NominalDiffTime -> Event -> ActionPredicate
debounce NominalDiffTime
epsilon Event
lastEvent Event
event) IO ()
writeToChan
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IOEvent
ior (forall a b. a -> b -> a
const (Event
event, ()))
DebouncePayload
Nothing -> IO ()
writeToChan
where
writeToChan :: IO ()
writeToChan = 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 = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just IO INotify
INo.initINotify) (\(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 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)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a. a -> IO (MVar a)
newMVar (forall a. a -> Maybe a
Just [])
let
stopListening :: IO ()
stopListening = do
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe [WatchDescriptor])
wdVar forall a b. (a -> b) -> a -> b
$ \Maybe [WatchDescriptor]
mbWds -> do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\WatchDescriptor
x -> 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: " forall a. Monoid a => a -> a -> a
`mappend` forall a. Show a => a -> String
show WatchDescriptor
x)))) Maybe [WatchDescriptor]
mbWds
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
String -> MVar (Maybe [WatchDescriptor]) -> IO ()
listenRec String
initialPath MVar (Maybe [WatchDescriptor])
wdVar
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'
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'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 forall a b. (a -> b) -> a -> b
$ WatchConfig -> Debounce
confDebounce WatchConfig
conf
ByteString
rawFilePath <- String -> IO ByteString
toRawFilePath String
filePath
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe [WatchDescriptor])
wdVar forall a b. (a -> b) -> a -> b
$ \Maybe [WatchDescriptor]
mbWds ->
case Maybe [WatchDescriptor]
mbWds of
Maybe [WatchDescriptor]
Nothing -> 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)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (WatchDescriptor
wdforall 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 <- forall (m :: * -> *) a. MonadIO m => Sh a -> m a
S.shelly forall a b. (a -> b) -> a -> b
$ String -> Sh [String]
S.find (forall a. IsString a => String -> a
fromString String
newDir)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
files forall a b. (a -> b) -> a -> b
$ \String
file -> do
let newPath :: String
newPath = Text -> String
T.unpack 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
modTime forall a. Ord a => a -> a -> Bool
> NominalDiffTime
timestampBeforeAddingWatch) 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
case Event
event of
(Event
INo.DeletedSelf) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Event
INo.Ignored) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Event
_ -> 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 = forall a b. a -> b -> a
const Bool
False