{-# LANGUAGE PatternGuards, TemplateHaskell #-}

module System.Directory.Watcher (
	EventType(..), Event(..), eventType, eventPath, eventTime,
	Watcher(..),
	withWatcher,
	watchDir, watchDir_, unwatchDir, isWatchingDir,
	watchTree, watchTree_, unwatchTree, isWatchingTree,
	-- * Working with events
	readEvent, eventGroup, onEvents, onEvents_
	) where

import Control.Lens (makeLenses)
import Control.Arrow
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (isJust)
import Data.Ratio ((%))
import Data.String (fromString)
import Data.Time.Clock (NominalDiffTime)
import Data.Time.Clock.POSIX
import System.FilePath (takeDirectory, isDrive)
import System.Directory
import qualified System.FSNotify as FS

import HsDev.Util (uniqueBy)

-- | Event type
data EventType = Added | Modified | Removed deriving (Eq, Ord, Enum, Bounded, Read, Show)

-- | Event
data Event = Event {
	_eventType :: EventType,
	_eventPath :: FilePath,
	_eventTime :: POSIXTime }
		deriving (Eq, Ord, Show)

makeLenses ''Event

-- | Directories watcher
data Watcher a = Watcher {
	-- | Map from directory to watch stopper
	watcherDirs :: MVar (Map FilePath (Bool, IO ())),
	watcherMan :: FS.WatchManager,
	watcherChan :: Chan (a, Event) }

-- | Create watcher
withWatcher :: (Watcher a -> IO b) -> IO b
withWatcher act = FS.withManager $ \man -> do
	ch <- newChan
	dirs <- newMVar M.empty
	act $ Watcher dirs man ch

-- | Watch directory
watchDir :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO ()
watchDir w f p v = do
	e <- doesDirectoryExist f
	when e $ do
		f' <- canonicalizePath f
		watching <- isWatchingDir w f'
		unless watching $ do
			stop <- FS.watchDir
				(watcherMan w)
				(fromString f')
				(p . fromEvent)
				(writeChan (watcherChan w) . (,) v . fromEvent)
			modifyMVar_ (watcherDirs w) $ return . M.insert f' (False, stop)

watchDir_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO ()
watchDir_ w f p = watchDir w f p ()

-- | Unwatch directory, return @False@, if not watched
unwatchDir :: Watcher a -> FilePath -> IO Bool
unwatchDir w f = do
	f' <- canonicalizePath f
	stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f')
	maybe (return ()) snd stop
	return $ isJust stop

-- | Check if we are watching dir
isWatchingDir :: Watcher a -> FilePath -> IO Bool
isWatchingDir w f = do
	f' <- canonicalizePath f
	dirs <- readMVar (watcherDirs w)
	return $ isWatchingDir' dirs f'

-- | Watch directory tree
watchTree :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO ()
watchTree w f p v = do
	e <- doesDirectoryExist f
	when e $ do
		f' <- canonicalizePath f
		watching <- isWatchingTree w f'
		unless watching $ do
			stop <- FS.watchTree
				(watcherMan w)
				(fromString f')
				(p . fromEvent)
				(writeChan (watcherChan w) . (,) v . fromEvent)
			modifyMVar_ (watcherDirs w) $ return . M.insert f' (True, stop)

watchTree_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO ()
watchTree_ w f p = watchTree w f p ()

-- | Unwatch directory tree
unwatchTree :: Watcher a -> FilePath -> IO Bool
unwatchTree w f = do
	f' <- canonicalizePath f
	stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f')
	maybe (return ()) snd stop
	return $ isJust stop

-- | Check if we are watching tree
isWatchingTree :: Watcher a -> FilePath -> IO Bool
isWatchingTree w f = do
	f' <- canonicalizePath f
	dirs <- readMVar (watcherDirs w)
	return $ isWatchingTree' dirs f'

-- | Read next event
readEvent :: Watcher a -> IO (a, Event)
readEvent = readChan . watcherChan

-- | Get event group
eventGroup :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO ()
eventGroup w tm onGroup = do
	groupVar <- newTMVarIO []
	syncVar <- newEmptyTMVarIO
	_ <- async $ forever $ do
		ev <- readChan (watcherChan w)
		_ <- atomically $ tryPutTMVar syncVar ()
		atomically $ do
			evs <- takeTMVar groupVar
			putTMVar groupVar (ev : evs)
	forever $ do
		_ <- atomically $ takeTMVar syncVar
		threadDelay $ floor (tm * 1e6)
		evs' <- atomically $ do
			evs <- takeTMVar groupVar
			putTMVar groupVar []
			_ <- tryTakeTMVar syncVar
			return $ reverse evs
		onGroup $ uniqueBy (\(_, ev') -> (_eventType ev', _eventPath ev')) evs'

-- | Process all events
onEvents :: Watcher a -> NominalDiffTime -> ([(a, Event)] -> IO ()) -> IO ()
onEvents = eventGroup

-- | Process all events
onEvents_ :: Watcher a -> ([(a, Event)] -> IO ()) -> IO ()
onEvents_ w = onEvents w (fromRational (1 % 5))

fromEvent :: FS.Event -> Event
fromEvent e = Event t (FS.eventPath e) (utcTimeToPOSIXSeconds $ FS.eventTime e) where
	t = case e of
		FS.Added _ _ -> Added
		FS.Modified _ _ -> Modified
		FS.Removed _ _ -> Removed

isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
isWatchingDir' m dir
	| Just (_, _) <- M.lookup dir m = True
	| isDrive dir = False
	| otherwise = isWatchingTree' m (takeDirectory dir)

isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
isWatchingTree' m dir
	| Just (True, _) <- M.lookup dir m = True
	| isDrive dir = False
	| otherwise = isWatchingTree' m (takeDirectory dir)