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