Notify.hs

module System.Win32.Notify
  ( Event(..)
  , EventVariety(..)
  , Handler
  , WatchId(..)
  , WatchManager(..)
  , initWatchManager
  , killWatch
  , killWatchManager
  , watch
  , watchDirectory
  , fILE_NOTIFY_CHANGE_FILE_NAME
  , fILE_NOTIFY_CHANGE_DIR_NAME
  , fILE_NOTIFY_CHANGE_ATTRIBUTES
  , fILE_NOTIFY_CHANGE_SIZE
  , fILE_NOTIFY_CHANGE_LAST_WRITE
  -- , fILE_NOTIFY_CHANGE_LAST_ACCESS
  -- , fILE_NOTIFY_CHANGE_CREATION
  , fILE_NOTIFY_CHANGE_SECURITY
  ) where

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (forever)
import Data.Bits
import Data.List (intersect)
import Data.Map (Map)
import qualified Data.Map as Map
import System.Directory
import System.FilePath
import System.Win32 (closeHandle)
import System.Win32.File
import System.Win32.FileNotify

data EventVariety = Modify
                  | Create
                  | Delete
                  | Move deriving Eq

data Event
    -- | A file was modified. @Modified isDirectory file@
    = Modified { filePath :: FilePath }
    -- | A file was created. @Created isDirectory file@
    | Created { filePath :: FilePath }
    -- | A file was deleted. @Deleted isDirectory file@
    | Deleted { filePath :: FilePath }
    deriving (Eq, Show)

type Handler = Event -> IO ()

data WatchId = WatchId ThreadId ThreadId Handle deriving (Eq, Ord, Show)
type WatchMap = Map WatchId Handler
data WatchManager = WatchManager (MVar WatchMap)

initWatchManager :: IO WatchManager
initWatchManager =  do
  mvarMap <- newMVar Map.empty
  return (WatchManager mvarMap)

killWatchManager :: WatchManager -> IO ()
killWatchManager (WatchManager mvarMap) = do
  watchMap <- readMVar mvarMap
  flip mapM_ (Map.keys watchMap) $ killWatch

watchDirectory :: WatchManager -> FilePath -> Bool -> FileNotificationFlag -> Handler -> IO WatchId
watchDirectory (WatchManager mvarMap) dir watchSubTree flags handler = do
  watchHandle <- getWatchHandle dir
  chanEvents <- newChan
  tid1 <- forkIO $ dispatcher chanEvents
  tid2 <- forkIO $ osEventsReader watchHandle chanEvents
  modifyMVar_ mvarMap $ \watchMap -> return (Map.insert (WatchId tid1 tid2 watchHandle) handler watchMap)
  return (WatchId tid1 tid2 watchHandle)

  where
    dispatcher :: Chan [Event] -> IO ()
    dispatcher chanEvents = forever $ readChan chanEvents >>= mapM_ handler

    osEventsReader :: Handle -> Chan [Event] -> IO ()
    osEventsReader watchHandle chanEvents = forever $ do
      (readDirectoryChanges watchHandle watchSubTree flags >>= (actsToEvents dir) >>= writeChan chanEvents)

watch :: WatchManager -> FilePath -> Bool -> FileNotificationFlag -> IO (WatchId, Chan [Event])
watch (WatchManager mvarMap) dir watchSubTree flags = do
  watchHandle <- getWatchHandle dir
  chanEvents <- newChan
  tid <- forkIO $ osEventsReader watchHandle chanEvents
  modifyMVar_ mvarMap $ \watchMap -> return (Map.insert (WatchId tid tid watchHandle) (const $ return ()) watchMap)
  return ((WatchId tid tid watchHandle), chanEvents)

  where
    osEventsReader :: Handle -> Chan [Event] -> IO ()
    osEventsReader watchHandle chanEvents = forever $ do
      (readDirectoryChanges watchHandle watchSubTree flags >>= (actsToEvents dir) >>= writeChan chanEvents)

killWatch :: WatchId -> IO ()
killWatch (WatchId tid1 tid2 handle) = do
    killThread tid1
    if tid1 /= tid2 then killThread tid2 else return ()
    closeHandle handle

actsToEvents :: FilePath -> [(Action, String)] -> IO [Event]
actsToEvents baseDir = mapM actToEvent
  where
    actToEvent (act, fn) = do
      case act of
        FileModified -> return $ Modified $ baseDir </> fn
        FileAdded -> return $ Created $ baseDir </> fn
        FileRemoved -> return $ Deleted $ baseDir </> fn
        FileRenamedOld -> return $ Deleted $ baseDir </> fn
        FileRenamedNew -> return $ Created $ baseDir </> fn