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
6{-# LANGUAGE MultiWayIf #-}
7
8module System.FSNotify.OSX
9       ( FileListener(..)
10       , NativeManager
11       ) where
12
13import Control.Concurrent.Chan
14import Control.Concurrent.MVar
15import Control.Monad
16import Data.Bits
17import Data.IORef (atomicModifyIORef, readIORef)
18import Data.Map (Map)
19import qualified Data.Map as Map
20import Data.Time.Clock (UTCTime, getCurrentTime)
21import Data.Unique
22import Data.Word
23import Prelude hiding (FilePath)
24import System.Directory
25import System.FSNotify.Listener
26import System.FSNotify.Path (canonicalizeDirPath)
27import System.FSNotify.Types
28import System.FilePath
29import qualified System.OSX.FSEvents as FSE
30
31
32data WatchData = WatchData FSE.EventStream EventChannel
33
34type WatchMap = Map Unique WatchData
35data OSXManager = OSXManager (MVar WatchMap)
36type NativeManager = OSXManager
37
38nil :: Word64
39nil = 0x00
40
41-- OS X reports the absolute (canonical) path without a trailing slash. Add
42-- the trailing slash when the path refers to a directory
43canonicalEventPath :: FSE.Event -> FilePath
44canonicalEventPath event =
45  if flags .&. dirFlag /= nil then addTrailingPathSeparator path else path
46  where
47    flags = FSE.eventFlags event
48    dirFlag = FSE.eventFlagItemIsDir
49    path = FSE.eventPath event
50
51-- We have to be careful about interpreting the flags in a given event, because
52-- "really it's an OR of all the changes made since the FSEventsListener is created"
53-- See https://stackoverflow.com/questions/18415285/osx-fseventstreameventflags-not-working-correctly
54-- Thus, we try to look at whether the path exists or not to determine whether it was created, modified, etc.
55
56-- Note that there's still some bugs possible due to event coalescing, which the docs say is a possibility:
57-- for example, a file could be created and modified within a short time interval, and then we'd only emit one
58-- event (the "modified" one, given the logic below)
59-- See https://developer.apple.com/library/content/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html
60fsnEvents :: UTCTime -> FSE.Event -> IO [Event]
61fsnEvents timestamp e = do
62  -- Note: we *don't* want to use the canonical event path in the existence check, because of the aforementioned crazy event coalescing.
63  -- 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
64  -- still be turned on, which could lead us to construct a canonical event path with a trailing slash, which would then cause the existence
65  -- check to fail and make us think the file was removed.
66  -- 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
67  -- on the event is for :(
68  exists <- doesPathExist $ FSE.eventPath e
69
70  -- Uncomment for an easy way to see flag activity when testing manually
71  -- putStrLn $ show ["Event", show e, "isDirectory", show isDirectory, "isFile", show isFile, "isModified", show isModified, "isCreated", show isCreated, "path", path e, "exists", show exists]
72
73  return $ if | exists && isModified -> [Modified (path e) timestamp isDirectory]
74              | exists && isCreated -> [Added (path e) timestamp isDirectory]
75              | (not exists) && hasFlag e FSE.eventFlagItemRemoved -> [Removed (path e) timestamp isDirectory]
76
77              -- Rename stuff
78              | exists && isRenamed -> [Added (path e) timestamp isDirectory]
79              | (not exists) && isRenamed -> [Removed (path e) timestamp isDirectory]
80
81              | otherwise -> []
82  where
83    isDirectory = hasFlag e FSE.eventFlagItemIsDir
84    isFile = hasFlag e FSE.eventFlagItemIsFile
85    isCreated = hasFlag e FSE.eventFlagItemCreated
86    isRenamed = hasFlag e FSE.eventFlagItemRenamed
87    isModified = hasFlag e FSE.eventFlagItemModified || hasFlag e FSE.eventFlagItemInodeMetaMod
88    path = canonicalEventPath
89    hasFlag event flag = FSE.eventFlags event .&. flag /= 0
90
91handleEvent :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO ()
92handleEvent isRecursive actPred chan dirPath dbp fseEvent = do
93  currentTime <- getCurrentTime
94  events <- fsnEvents currentTime fseEvent
95  handleEvents isRecursive actPred chan dirPath dbp events
96
97-- | For non-recursive monitoring, test if an event takes place directly inside the monitored folder
98isDirectlyInside :: FilePath -> Event -> Bool
99isDirectlyInside dirPath event = isRelevantFileEvent || isRelevantDirEvent
100  where
101    isRelevantFileEvent = (not $ eventIsDirectory event) && (takeDirectory dirPath == (takeDirectory $ eventPath event))
102    isRelevantDirEvent = eventIsDirectory event && (takeDirectory dirPath == (takeDirectory $ takeDirectory $ eventPath event))
103
104handleEvents :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO ()
105handleEvents isRecursive actPred chan dirPath dbp (event:events) = do
106  when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $ case dbp of
107      (Just (DebounceData epsilon ior)) -> do
108        lastEvent <- readIORef ior
109        when (not $ debounce epsilon lastEvent event) (writeChan chan event)
110        atomicModifyIORef ior (\_ -> (event, ()))
111      Nothing -> writeChan chan event
112  handleEvents isRecursive actPred chan dirPath dbp events
113handleEvents _ _ _ _ _ [] = return ()
114
115listenFn :: (ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO a)
116         -> WatchConfig
117         -> OSXManager
118         -> FilePath
119         -> ActionPredicate
120         -> EventChannel
121         -> IO StopListening
122listenFn handler conf (OSXManager mvarMap) path actPred chan = do
123  path' <- canonicalizeDirPath path
124  dbp <- newDebouncePayload $ confDebounce conf
125  unique <- newUnique
126  eventStream <- FSE.eventStreamCreate [path'] 0.0 True False True (handler actPred chan path' dbp)
127  modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream chan) watchMap)
128  return $ do
129    FSE.eventStreamDestroy eventStream
130    modifyMVar_ mvarMap $ \watchMap -> return $ Map.delete unique watchMap
131
132instance FileListener OSXManager where
133  initSession = do
134    (v1, v2, _) <- FSE.osVersion
135    if not $ v1 > 10 || (v1 == 10 && v2 > 6) then return Nothing else
136      fmap (Just . OSXManager) $ newMVar Map.empty
137
138  killSession (OSXManager mvarMap) = do
139    watchMap <- readMVar mvarMap
140    forM_ (Map.elems watchMap) eventStreamDestroy'
141    where
142      eventStreamDestroy' :: WatchData -> IO ()
143      eventStreamDestroy' (WatchData eventStream _) = FSE.eventStreamDestroy eventStream
144
145  listen = listenFn $ handleEvent False
146  listenRecursive = listenFn $ handleEvent True
147
148  usesPolling = const False
149