1-- 2-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org 3-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org 4-- 5{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} 6{-# OPTIONS_GHC -fno-warn-orphans #-} 7 8module System.FSNotify.Linux 9 ( FileListener(..) 10 , NativeManager 11 ) where 12 13import Control.Concurrent.Chan 14import Control.Concurrent.MVar 15import Control.Exception as E 16import Control.Monad 17import qualified Data.ByteString as BS 18import Data.IORef (atomicModifyIORef, readIORef) 19import Data.String 20import qualified Data.Text as T 21import Data.Time.Clock (UTCTime, getCurrentTime) 22import Data.Time.Clock.POSIX 23import Data.Typeable 24import qualified GHC.Foreign as F 25import GHC.IO.Encoding (getFileSystemEncoding) 26import Prelude hiding (FilePath) 27import qualified Shelly as S 28import System.FSNotify.Listener 29import System.FSNotify.Path (findDirs, canonicalizeDirPath) 30import System.FSNotify.Types 31import System.FilePath 32import qualified System.INotify as INo 33import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes) 34 35type NativeManager = INo.INotify 36 37data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable) 38instance Exception EventVarietyMismatchException 39 40#if MIN_VERSION_hinotify(0, 3, 10) 41toRawFilePath :: FilePath -> IO BS.ByteString 42toRawFilePath fp = do 43 enc <- getFileSystemEncoding 44 F.withCString enc fp BS.packCString 45 46fromRawFilePath :: BS.ByteString -> IO FilePath 47fromRawFilePath bs = do 48 enc <- getFileSystemEncoding 49 BS.useAsCString bs (F.peekCString enc) 50#else 51toRawFilePath = return . id 52fromRawFilePath = return . id 53#endif 54 55fsnEvents :: FilePath -> UTCTime -> INo.Event -> IO [Event] 56fsnEvents basePath timestamp (INo.Attributes isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir] 57fsnEvents basePath timestamp (INo.Modified isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir] 58fsnEvents basePath timestamp (INo.Created isDir raw) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir] 59fsnEvents basePath timestamp (INo.MovedOut isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir] 60fsnEvents basePath timestamp (INo.MovedIn isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir] 61fsnEvents basePath timestamp (INo.Deleted isDir raw) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir] 62fsnEvents _ _ (INo.Ignored) = return [] 63fsnEvents basePath timestamp inoEvent = return [Unknown basePath timestamp (show inoEvent)] 64 65handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO () 66handleInoEvent actPred chan basePath dbp inoEvent = do 67 currentTime <- getCurrentTime 68 events <- fsnEvents basePath currentTime inoEvent 69 mapM_ (handleEvent actPred chan dbp) events 70 71handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO () 72handleEvent actPred chan dbp event = 73 when (actPred event) $ case dbp of 74 (Just (DebounceData epsilon ior)) -> do 75 lastEvent <- readIORef ior 76 unless (debounce epsilon lastEvent event) writeToChan 77 atomicModifyIORef ior (const (event, ())) 78 Nothing -> writeToChan 79 where 80 writeToChan = writeChan chan event 81 82varieties :: [INo.EventVariety] 83varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify] 84 85instance FileListener INo.INotify where 86 initSession = E.catch (fmap Just INo.initINotify) (\(_ :: IOException) -> return Nothing) 87 88 killSession = INo.killINotify 89 90 listen conf iNotify path actPred chan = do 91 path' <- canonicalizeDirPath path 92 dbp <- newDebouncePayload $ confDebounce conf 93 rawPath <- toRawFilePath path' 94 wd <- INo.addWatch iNotify varieties rawPath (handler path' dbp) 95 return $ INo.removeWatch wd 96 where 97 handler :: FilePath -> DebouncePayload -> INo.Event -> IO () 98 handler = handleInoEvent actPred chan 99 100 listenRecursive conf iNotify initialPath actPred chan = do 101 -- wdVar stores the list of created watch descriptors. We use it to 102 -- cancel the whole recursive listening task. 103 -- 104 -- To avoid a race condition (when a new watch is added right after 105 -- we've stopped listening), we replace the MVar contents with Nothing 106 -- to signify that the listening task is cancelled, and no new watches 107 -- should be added. 108 wdVar <- newMVar (Just []) 109 110 let 111 stopListening = do 112 modifyMVar_ wdVar $ \mbWds -> do 113 maybe (return ()) (mapM_ (\x -> catch (INo.removeWatch x) (\(_ :: SomeException) -> putStrLn ("Error removing watch: " `mappend` show x)))) mbWds 114 return Nothing 115 116 listenRec initialPath wdVar 117 118 return stopListening 119 120 where 121 listenRec :: FilePath -> MVar (Maybe [INo.WatchDescriptor]) -> IO () 122 listenRec path wdVar = do 123 path' <- canonicalizeDirPath path 124 paths <- findDirs True path' 125 126 mapM_ (pathHandler wdVar) (path':paths) 127 128 pathHandler :: MVar (Maybe [INo.WatchDescriptor]) -> FilePath -> IO () 129 pathHandler wdVar filePath = do 130 dbp <- newDebouncePayload $ confDebounce conf 131 rawFilePath <- toRawFilePath filePath 132 modifyMVar_ wdVar $ \mbWds -> 133 -- Atomically add a watch and record its descriptor. Also, check 134 -- if the listening task is cancelled, in which case do nothing. 135 case mbWds of 136 Nothing -> return mbWds 137 Just wds -> do 138 wd <- INo.addWatch iNotify varieties rawFilePath (handler filePath dbp) 139 return $ Just (wd:wds) 140 where 141 handler :: FilePath -> DebouncePayload -> INo.Event -> IO () 142 handler baseDir dbp event = do 143 -- When a new directory is created, add recursive inotify watches to it 144 -- TODO: there's a race condition here; if there are files present in the directory before 145 -- we add the watches, we'll miss them. The right thing to do would be to ls the directory 146 -- and trigger Added events for everything we find there 147 case event of 148 (INo.Created True rawDirPath) -> do 149 dirPath <- fromRawFilePath rawDirPath 150 let newDir = baseDir </> dirPath 151 timestampBeforeAddingWatch <- getPOSIXTime 152 listenRec newDir wdVar 153 154 -- Find all files/folders that might have been created *after* the timestamp, and hence might have been 155 -- missed by the watch 156 -- TODO: there's a chance of this generating double events, fix 157 files <- S.shelly $ S.find (fromString newDir) 158 forM_ files $ \file -> do 159 let newPath = T.unpack $ S.toTextIgnore file 160 fileStatus <- getFileStatus newPath 161 let modTime = modificationTimeHiRes fileStatus 162 when (modTime > timestampBeforeAddingWatch) $ do 163 handleEvent actPred chan dbp (Added (newDir </> newPath) (posixSecondsToUTCTime timestampBeforeAddingWatch) (isDirectory fileStatus)) 164 165 _ -> return () 166 167 -- Remove watch when this directory is removed 168 case event of 169 (INo.DeletedSelf) -> do 170 -- putStrLn "Watched file/folder was deleted! TODO: remove watch." 171 return () 172 (INo.Ignored) -> do 173 -- putStrLn "Watched file/folder was ignored, which possibly means it was deleted. TODO: remove watch." 174 return () 175 _ -> return () 176 177 -- Forward all events, including directory create 178 handleInoEvent actPred chan baseDir dbp event 179 180 usesPolling = const False 181