--
-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
--
{-# 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
    -- 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])
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 ->
          -- Atomically add a watch and record its descriptor. Also, check
          -- if the listening task is cancelled, in which case do nothing.
          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
            -- When a new directory is created, add recursive inotify watches to it
            -- TODO: there's a race condition here; if there are files present in the directory before
            -- we add the watches, we'll miss them. The right thing to do would be to ls the directory
            -- and trigger Added events for everything we find there
            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

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

            -- Remove watch when this directory is removed
            case Event
event of
              (Event
INo.DeletedSelf) -> do
                -- putStrLn "Watched file/folder was deleted! TODO: remove watch."
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              (Event
INo.Ignored) -> do
                -- putStrLn "Watched file/folder was ignored, which possibly means it was deleted. TODO: remove watch."
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            -- Forward all events, including directory create
            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