Permalink
Fetching contributors…
Cannot retrieve contributors at this time
149 lines (126 sloc) 6.72 KB
--
-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
--
{-# LANGUAGE MultiWayIf #-}
module System.FSNotify.OSX
( FileListener(..)
, NativeManager
) where
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Monad
import Data.Bits
import Data.IORef (atomicModifyIORef, readIORef)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Unique
import Data.Word
import Prelude hiding (FilePath)
import System.Directory
import System.FSNotify.Listener
import System.FSNotify.Path (canonicalizeDirPath)
import System.FSNotify.Types
import System.FilePath
import qualified System.OSX.FSEvents as FSE
data WatchData = WatchData FSE.EventStream EventChannel
type WatchMap = Map Unique WatchData
data OSXManager = OSXManager (MVar WatchMap)
type NativeManager = OSXManager
nil :: Word64
nil = 0x00
-- OS X reports the absolute (canonical) path without a trailing slash. Add
-- the trailing slash when the path refers to a directory
canonicalEventPath :: FSE.Event -> FilePath
canonicalEventPath event =
if flags .&. dirFlag /= nil then addTrailingPathSeparator path else path
where
flags = FSE.eventFlags event
dirFlag = FSE.eventFlagItemIsDir
path = FSE.eventPath event
-- We have to be careful about interpreting the flags in a given event, because
-- "really it's an OR of all the changes made since the FSEventsListener is created"
-- See https://stackoverflow.com/questions/18415285/osx-fseventstreameventflags-not-working-correctly
-- Thus, we try to look at whether the path exists or not to determine whether it was created, modified, etc.
-- Note that there's still some bugs possible due to event coalescing, which the docs say is a possibility:
-- for example, a file could be created and modified within a short time interval, and then we'd only emit one
-- event (the "modified" one, given the logic below)
-- See https://developer.apple.com/library/content/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html
fsnEvents :: UTCTime -> FSE.Event -> IO [Event]
fsnEvents timestamp e = do
-- Note: we *don't* want to use the canonical event path in the existence check, because of the aforementioned crazy event coalescing.
-- For example, suppose a directory is created and deleted, and then a file is created with the same name. This means the isDirectory flag might
-- still be turned on, which could lead us to construct a canonical event path with a trailing slash, which would then cause the existence
-- check to fail and make us think the file was removed.
-- The upshot of this is that the canonical event paths in the events we emit can't really be trusted, but hey, that's what the extra flag
-- on the event is for :(
exists <- doesPathExist $ FSE.eventPath e
-- Uncomment for an easy way to see flag activity when testing manually
-- putStrLn $ show ["Event", show e, "isDirectory", show isDirectory, "isFile", show isFile, "isModified", show isModified, "isCreated", show isCreated, "path", path e, "exists", show exists]
return $ if | exists && isModified -> [Modified (path e) timestamp isDirectory]
| exists && isCreated -> [Added (path e) timestamp isDirectory]
| (not exists) && hasFlag e FSE.eventFlagItemRemoved -> [Removed (path e) timestamp isDirectory]
-- Rename stuff
| exists && isRenamed -> [Added (path e) timestamp isDirectory]
| (not exists) && isRenamed -> [Removed (path e) timestamp isDirectory]
| otherwise -> []
where
isDirectory = hasFlag e FSE.eventFlagItemIsDir
isFile = hasFlag e FSE.eventFlagItemIsFile
isCreated = hasFlag e FSE.eventFlagItemCreated
isRenamed = hasFlag e FSE.eventFlagItemRenamed
isModified = hasFlag e FSE.eventFlagItemModified || hasFlag e FSE.eventFlagItemInodeMetaMod
path = canonicalEventPath
hasFlag event flag = FSE.eventFlags event .&. flag /= 0
handleEvent :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO ()
handleEvent isRecursive actPred chan dirPath dbp fseEvent = do
currentTime <- getCurrentTime
events <- fsnEvents currentTime fseEvent
handleEvents isRecursive actPred chan dirPath dbp events
-- | For non-recursive monitoring, test if an event takes place directly inside the monitored folder
isDirectlyInside :: FilePath -> Event -> Bool
isDirectlyInside dirPath event = isRelevantFileEvent || isRelevantDirEvent
where
isRelevantFileEvent = (not $ eventIsDirectory event) && (takeDirectory dirPath == (takeDirectory $ eventPath event))
isRelevantDirEvent = eventIsDirectory event && (takeDirectory dirPath == (takeDirectory $ takeDirectory $ eventPath event))
handleEvents :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO ()
handleEvents isRecursive actPred chan dirPath dbp (event:events) = do
when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $ case dbp of
(Just (DebounceData epsilon ior)) -> do
lastEvent <- readIORef ior
when (not $ debounce epsilon lastEvent event) (writeChan chan event)
atomicModifyIORef ior (\_ -> (event, ()))
Nothing -> writeChan chan event
handleEvents isRecursive actPred chan dirPath dbp events
handleEvents _ _ _ _ _ [] = return ()
listenFn :: (ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO a)
-> WatchConfig
-> OSXManager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO StopListening
listenFn handler conf (OSXManager mvarMap) path actPred chan = do
path' <- canonicalizeDirPath path
dbp <- newDebouncePayload $ confDebounce conf
unique <- newUnique
eventStream <- FSE.eventStreamCreate [path'] 0.0 True False True (handler actPred chan path' dbp)
modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream chan) watchMap)
return $ do
FSE.eventStreamDestroy eventStream
modifyMVar_ mvarMap $ \watchMap -> return $ Map.delete unique watchMap
instance FileListener OSXManager where
initSession = do
(v1, v2, _) <- FSE.osVersion
if not $ v1 > 10 || (v1 == 10 && v2 > 6) then return Nothing else
fmap (Just . OSXManager) $ newMVar Map.empty
killSession (OSXManager mvarMap) = do
watchMap <- readMVar mvarMap
forM_ (Map.elems watchMap) eventStreamDestroy'
where
eventStreamDestroy' :: WatchData -> IO ()
eventStreamDestroy' (WatchData eventStream _) = FSE.eventStreamDestroy eventStream
listen = listenFn $ handleEvent False
listenRecursive = listenFn $ handleEvent True
usesPolling = const False