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{-# OPTIONS_GHC -fno-warn-orphans #-} 6 7module System.FSNotify.Win32 8 ( FileListener(..) 9 , NativeManager 10 ) where 11 12import Control.Concurrent 13import Control.Monad (when) 14import Data.Bits 15import Data.IORef (atomicModifyIORef, readIORef) 16import qualified Data.Map as Map 17import Data.Time (getCurrentTime, UTCTime) 18import Prelude 19import System.FSNotify.Listener 20import System.FSNotify.Path (canonicalizeDirPath) 21import System.FSNotify.Types 22import System.FilePath 23import qualified System.Win32.Notify as WNo 24 25type NativeManager = WNo.WatchManager 26 27-- | Apparently Win32 gives back relative paths, so we pass around the base 28-- directory to turn them into absolute ones 29type BaseDir = FilePath 30 31-- NEXT TODO: Need to ensure we use properly canonalized paths as 32-- event paths. In Linux this required passing the base dir to 33-- handle[native]Event. 34 35-- Win32-notify has (temporarily?) dropped support for Renamed events. 36fsnEvent :: Bool -> BaseDir -> UTCTime -> WNo.Event -> Event 37fsnEvent isDirectory basedir timestamp (WNo.Created name) = Added (normalise (basedir </> name)) timestamp isDirectory 38fsnEvent isDirectory basedir timestamp (WNo.Modified name) = Modified (normalise (basedir </> name)) timestamp isDirectory 39fsnEvent isDirectory basedir timestamp (WNo.Deleted name) = Removed (normalise (basedir </> name)) timestamp isDirectory 40 41handleWNoEvent :: Bool -> BaseDir -> ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () 42handleWNoEvent isDirectory basedir actPred chan dbp inoEvent = do 43 currentTime <- getCurrentTime 44 let event = fsnEvent isDirectory basedir currentTime inoEvent 45 handleEvent actPred chan dbp event 46 47handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO () 48handleEvent actPred chan dbp event | actPred event = do 49 case dbp of 50 (Just (DebounceData epsilon ior)) -> do 51 lastEvent <- readIORef ior 52 when (not $ debounce epsilon lastEvent event) $ writeChan chan event 53 atomicModifyIORef ior (\_ -> (event, ())) 54 Nothing -> writeChan chan event 55handleEvent _ _ _ _ = return () 56 57watchDirectory :: Bool -> WatchConfig -> WNo.WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO (IO ()) 58watchDirectory isRecursive conf watchManager@(WNo.WatchManager mvarMap) path actPred chan = do 59 path' <- canonicalizeDirPath path 60 dbp <- newDebouncePayload $ confDebounce conf 61 62 let fileFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_FILE_NAME, WNo.fILE_NOTIFY_CHANGE_SIZE, WNo.fILE_NOTIFY_CHANGE_ATTRIBUTES] 63 let dirFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_DIR_NAME] 64 65 -- Start one watch for file events and one for directory events 66 -- (There seems to be no other way to provide isDirectory information) 67 wid1 <- WNo.watchDirectory watchManager path' isRecursive fileFlags (handleWNoEvent False path' actPred chan dbp) 68 wid2 <- WNo.watchDirectory watchManager path' isRecursive dirFlags (handleWNoEvent True path' actPred chan dbp) 69 70 -- The StopListening action should make sure to remove the watches from the manager after they're killed. 71 -- Otherwise, a call to killSession would cause us to try to kill them again, resulting in an invalid handle error. 72 return $ do 73 WNo.killWatch wid1 74 modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid1 watchMap) 75 76 WNo.killWatch wid2 77 modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid2 watchMap) 78 79instance FileListener WNo.WatchManager where 80 -- TODO: This should actually lookup a Windows API version and possibly return 81 -- Nothing the calls we need are not available. This will require that API 82 -- version information be exposed by Win32-notify. 83 initSession = fmap Just WNo.initWatchManager 84 85 killSession = WNo.killWatchManager 86 87 listen = watchDirectory False 88 listenRecursive = watchDirectory True 89 90 usesPolling = const False 91