module System.Hiernotify (Difference (..), onDifferenceDaemon) where
import Control.Applicative ((<$>))
import Data.Monoid (Monoid (..), mempty, mappend)
import Control.Monad.List (ListT (ListT), runListT,guard, forever)
import Control.Concurrent (forkIO, threadDelay, killThread)
import Control.Concurrent.STM ( newTVar, readTVar, writeTVar, atomically)
import Control.Monad.Trans (lift)
import Data.List ((\\), nub, intersect)
import Data.Maybe (catMaybes)
import System.Directory (getModificationTime, doesDirectoryExist, getDirectoryContents)
import System.FilePath (normalise, (</>))
import System.Time (ClockTime)
import Control.Concurrent.STM.TMonoid (TMonoid, newDelayedTMonoid, readTMonoid, writeTMonoid)
data Difference = Difference {
created :: [FilePath],
deleted :: [FilePath],
modified :: [FilePath]
} deriving (Show, Eq)
getRecursiveContents
:: (FilePath -> Bool)
-> FilePath
-> IO [(FilePath, ClockTime)]
getRecursiveContents g = runListT . getRecursiveContents' where
getRecursiveContents' path = do
pathIsDir <- lift $ doesDirectoryExist path
if pathIsDir then do
name <- ListT $ getDirectoryContents path
guard . g $ name
getRecursiveContents' . normalise $ path </> name
else (path,) <$> lift (getModificationTime path)
instance Monoid Difference where
Difference n d m `mappend` Difference n' d' m' = let
mm = nub $ m ++ m'
nn = nub $ n ++ n'
dd = nub $ d ++ d'
in Difference ((nn \\ dd) \\ mm) ((dd \\ nn) \\ mm) (nub $ mm ++ intersect nn dd)
mempty = Difference [] [] []
checkDifference :: (FilePath -> Bool)
-> FilePath
-> IO (IO Difference)
checkDifference g top = do
t <- atomically $ newTVar []
return $ do
xs <- getRecursiveContents g top
ws <- atomically $ do
ws <- readTVar t
writeTVar t xs
return ws
let news' = map fst xs \\ map fst ws
deleteds' = map fst ws \\ map fst xs
modified' = catMaybes $ do
(x,y) <- xs
return $ lookup x ws >>= \y' -> if y /= y' then Just x else Nothing
return $ Difference news' deleteds' modified'
trackPollFiles :: Int
-> (FilePath -> Bool)
-> FilePath
-> TMonoid Difference
-> IO (IO ())
trackPollFiles n g top tm = do
s <- checkDifference g top
k <- forkIO . forever $ threadDelay (1000000 * n) >> s >>= atomically . writeTMonoid tm
return $ killThread k
onDifferenceDaemon :: Int
-> Int
-> (FilePath -> Bool)
-> FilePath
-> (Difference -> IO ())
-> IO (IO ())
onDifferenceDaemon n n2 g top f = do
tm <- atomically $ newDelayedTMonoid n2
kt' <- trackPollFiles n g top tm
k <- forkIO . forever $ atomically (readTMonoid tm) >>= f
return $ killThread k >> kt'