{-# LANGUAGE ScopedTypeVariables #-}
--
-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
--

module System.FSNotify.Polling
  ( createPollManager
  , PollManager(..)
  , FileListener(..)
  ) where

import Control.Concurrent
import Control.Exception
import Control.Monad (forM_)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX
import Prelude hiding (FilePath)
import System.Directory (doesDirectoryExist)
import System.FSNotify.Listener
import System.FSNotify.Path (findFilesAndDirs, canonicalizeDirPath)
import System.FSNotify.Types
import System.FilePath
import System.PosixCompat.Files
import System.PosixCompat.Types

data EventType = AddedEvent
               | ModifiedEvent
               | RemovedEvent

newtype WatchKey = WatchKey ThreadId deriving (WatchKey -> WatchKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WatchKey -> WatchKey -> Bool
$c/= :: WatchKey -> WatchKey -> Bool
== :: WatchKey -> WatchKey -> Bool
$c== :: WatchKey -> WatchKey -> Bool
Eq, Eq WatchKey
WatchKey -> WatchKey -> Bool
WatchKey -> WatchKey -> Ordering
WatchKey -> WatchKey -> WatchKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WatchKey -> WatchKey -> WatchKey
$cmin :: WatchKey -> WatchKey -> WatchKey
max :: WatchKey -> WatchKey -> WatchKey
$cmax :: WatchKey -> WatchKey -> WatchKey
>= :: WatchKey -> WatchKey -> Bool
$c>= :: WatchKey -> WatchKey -> Bool
> :: WatchKey -> WatchKey -> Bool
$c> :: WatchKey -> WatchKey -> Bool
<= :: WatchKey -> WatchKey -> Bool
$c<= :: WatchKey -> WatchKey -> Bool
< :: WatchKey -> WatchKey -> Bool
$c< :: WatchKey -> WatchKey -> Bool
compare :: WatchKey -> WatchKey -> Ordering
$ccompare :: WatchKey -> WatchKey -> Ordering
Ord)
data WatchData = WatchData FilePath EventChannel
type WatchMap = Map WatchKey WatchData
newtype PollManager = PollManager (MVar WatchMap)

generateEvent :: UTCTime -> Bool -> EventType -> FilePath -> Maybe Event
generateEvent :: UTCTime -> Bool -> EventType -> FilePath -> Maybe Event
generateEvent UTCTime
timestamp Bool
isDir EventType
AddedEvent FilePath
filePath = forall a. a -> Maybe a
Just (FilePath -> UTCTime -> Bool -> Event
Added FilePath
filePath UTCTime
timestamp Bool
isDir)
generateEvent UTCTime
timestamp Bool
isDir EventType
ModifiedEvent FilePath
filePath = forall a. a -> Maybe a
Just (FilePath -> UTCTime -> Bool -> Event
Modified FilePath
filePath UTCTime
timestamp Bool
isDir)
generateEvent UTCTime
timestamp Bool
isDir EventType
RemovedEvent FilePath
filePath = forall a. a -> Maybe a
Just (FilePath -> UTCTime -> Bool -> Event
Removed FilePath
filePath UTCTime
timestamp Bool
isDir)

generateEvents :: UTCTime -> EventType -> [(FilePath, Bool)] -> [Event]
generateEvents :: UTCTime -> EventType -> [(FilePath, Bool)] -> [Event]
generateEvents UTCTime
timestamp EventType
eventType = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(FilePath
path, Bool
isDir) -> UTCTime -> Bool -> EventType -> FilePath -> Maybe Event
generateEvent UTCTime
timestamp Bool
isDir EventType
eventType FilePath
path)

-- | Do not return modified events for directories.
-- These can arise when files are created inside subdirectories, resulting in the modification time
-- of the directory being bumped. However, to increase consistency with the other FileListeners,
-- we ignore these events.
handleEvent :: EventChannel -> ActionPredicate -> Event -> IO ()
handleEvent :: EventChannel -> ActionPredicate -> Event -> IO ()
handleEvent EventChannel
_ ActionPredicate
_ (Modified FilePath
_ UTCTime
_ Bool
True) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleEvent EventChannel
chan ActionPredicate
actPred Event
event
  | ActionPredicate
actPred Event
event = forall a. Chan a -> a -> IO ()
writeChan EventChannel
chan Event
event
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, Bool))
pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, Bool))
pathModMap Bool
recursive FilePath
path = Bool -> FilePath -> IO [FilePath]
findFilesAndDirs Bool
recursive FilePath
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FilePath] -> IO (Map FilePath (UTCTime, Bool))
pathModMap'
  where
    pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, Bool))
    pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, Bool))
pathModMap' [FilePath]
files = (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (Maybe (FilePath, (UTCTime, Bool)))
pathAndInfo [FilePath]
files

    pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, Bool)))
    pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, Bool)))
pathAndInfo FilePath
path = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
      UTCTime
modTime <- FilePath -> IO UTCTime
getModificationTime FilePath
path
      Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (FilePath
path, (UTCTime
modTime, Bool
isDir))

pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath (UTCTime, Bool) -> IO ()
pollPath :: Int
-> Bool
-> EventChannel
-> FilePath
-> ActionPredicate
-> Map FilePath (UTCTime, Bool)
-> IO ()
pollPath Int
interval Bool
recursive EventChannel
chan FilePath
filePath ActionPredicate
actPred Map FilePath (UTCTime, Bool)
oldPathMap = do
  Int -> IO ()
threadDelay Int
interval
  Maybe (Map FilePath (UTCTime, Bool))
maybeNewPathMap <- forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> FilePath -> IO (Map FilePath (UTCTime, Bool))
pathModMap Bool
recursive FilePath
filePath)
  case Maybe (Map FilePath (UTCTime, Bool))
maybeNewPathMap of
    -- Something went wrong while listing directories; we'll try again on the next poll
    Maybe (Map FilePath (UTCTime, Bool))
Nothing -> Int
-> Bool
-> EventChannel
-> FilePath
-> ActionPredicate
-> Map FilePath (UTCTime, Bool)
-> IO ()
pollPath Int
interval Bool
recursive EventChannel
chan FilePath
filePath ActionPredicate
actPred Map FilePath (UTCTime, Bool)
oldPathMap

    Just Map FilePath (UTCTime, Bool)
newPathMap -> do
      UTCTime
currentTime <- IO UTCTime
getCurrentTime
      let deletedMap :: Map FilePath (UTCTime, Bool)
deletedMap = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map FilePath (UTCTime, Bool)
oldPathMap Map FilePath (UTCTime, Bool)
newPathMap
          createdMap :: Map FilePath (UTCTime, Bool)
createdMap = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map FilePath (UTCTime, Bool)
newPathMap Map FilePath (UTCTime, Bool)
oldPathMap
          modifiedAndCreatedMap :: Map FilePath (UTCTime, Bool)
modifiedAndCreatedMap = forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith (UTCTime, Bool) -> (UTCTime, Bool) -> Maybe (UTCTime, Bool)
modifiedDifference Map FilePath (UTCTime, Bool)
newPathMap Map FilePath (UTCTime, Bool)
oldPathMap
          modifiedMap :: Map FilePath (UTCTime, Bool)
modifiedMap = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map FilePath (UTCTime, Bool)
modifiedAndCreatedMap Map FilePath (UTCTime, Bool)
createdMap
          generateEvents' :: EventType -> [(FilePath, Bool)] -> [Event]
generateEvents' = UTCTime -> EventType -> [(FilePath, Bool)] -> [Event]
generateEvents UTCTime
currentTime

      [Event] -> IO ()
handleEvents forall a b. (a -> b) -> a -> b
$ EventType -> [(FilePath, Bool)] -> [Event]
generateEvents' EventType
AddedEvent [(FilePath
path, Bool
isDir) | (FilePath
path, (UTCTime
_, Bool
isDir)) <- forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath (UTCTime, Bool)
createdMap]
      [Event] -> IO ()
handleEvents forall a b. (a -> b) -> a -> b
$ EventType -> [(FilePath, Bool)] -> [Event]
generateEvents' EventType
ModifiedEvent [(FilePath
path, Bool
isDir) | (FilePath
path, (UTCTime
_, Bool
isDir)) <- forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath (UTCTime, Bool)
modifiedMap]
      [Event] -> IO ()
handleEvents forall a b. (a -> b) -> a -> b
$ EventType -> [(FilePath, Bool)] -> [Event]
generateEvents' EventType
RemovedEvent [(FilePath
path, Bool
isDir) | (FilePath
path, (UTCTime
_, Bool
isDir)) <- forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath (UTCTime, Bool)
deletedMap]

      Int
-> Bool
-> EventChannel
-> FilePath
-> ActionPredicate
-> Map FilePath (UTCTime, Bool)
-> IO ()
pollPath Int
interval Bool
recursive EventChannel
chan FilePath
filePath ActionPredicate
actPred Map FilePath (UTCTime, Bool)
newPathMap

  where
    modifiedDifference :: (UTCTime, Bool) -> (UTCTime, Bool) -> Maybe (UTCTime, Bool)
    modifiedDifference :: (UTCTime, Bool) -> (UTCTime, Bool) -> Maybe (UTCTime, Bool)
modifiedDifference (UTCTime
newTime, Bool
isDir1) (UTCTime
oldTime, Bool
isDir2)
      | UTCTime
oldTime forall a. Eq a => a -> a -> Bool
/= UTCTime
newTime Bool -> Bool -> Bool
|| Bool
isDir1 forall a. Eq a => a -> a -> Bool
/= Bool
isDir2 = forall a. a -> Maybe a
Just (UTCTime
newTime, Bool
isDir1)
      | Bool
otherwise = forall a. Maybe a
Nothing

    handleEvents :: [Event] -> IO ()
    handleEvents :: [Event] -> IO ()
handleEvents = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EventChannel -> ActionPredicate -> Event -> IO ()
handleEvent EventChannel
chan ActionPredicate
actPred)


-- Additional init function exported to allow startManager to unconditionally
-- create a poll manager as a fallback when other managers will not instantiate.
createPollManager :: IO PollManager
createPollManager :: IO PollManager
createPollManager = MVar WatchMap -> PollManager
PollManager forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar forall k a. Map k a
Map.empty

killWatchingThread :: WatchKey -> IO ()
killWatchingThread :: WatchKey -> IO ()
killWatchingThread (WatchKey ThreadId
threadId) = ThreadId -> IO ()
killThread ThreadId
threadId

killAndUnregister :: MVar WatchMap -> WatchKey -> IO ()
killAndUnregister :: MVar WatchMap -> WatchKey -> IO ()
killAndUnregister MVar WatchMap
mvarMap WatchKey
wk = do
  WatchMap
_ <- forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar WatchMap
mvarMap forall a b. (a -> b) -> a -> b
$ \WatchMap
m -> do
    WatchKey -> IO ()
killWatchingThread WatchKey
wk
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete WatchKey
wk WatchMap
m
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

listen' :: Bool -> WatchConfig -> PollManager -> FilePath -> ActionPredicate -> EventChannel -> IO (IO ())
listen' :: Bool
-> WatchConfig
-> PollManager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listen' Bool
isRecursive WatchConfig
conf (PollManager MVar WatchMap
mvarMap) FilePath
path ActionPredicate
actPred EventChannel
chan = do
  FilePath
path' <- FilePath -> IO FilePath
canonicalizeDirPath FilePath
path
  Map FilePath (UTCTime, Bool)
pmMap <- Bool -> FilePath -> IO (Map FilePath (UTCTime, Bool))
pathModMap Bool
isRecursive FilePath
path'
  ThreadId
threadId <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Int
-> Bool
-> EventChannel
-> FilePath
-> ActionPredicate
-> Map FilePath (UTCTime, Bool)
-> IO ()
pollPath (WatchConfig -> Int
confPollInterval WatchConfig
conf) Bool
isRecursive EventChannel
chan FilePath
path' ActionPredicate
actPred Map FilePath (UTCTime, Bool)
pmMap
  let wk :: WatchKey
wk = ThreadId -> WatchKey
WatchKey ThreadId
threadId
  forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar WatchMap
mvarMap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert WatchKey
wk (FilePath -> EventChannel -> WatchData
WatchData FilePath
path' EventChannel
chan)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MVar WatchMap -> WatchKey -> IO ()
killAndUnregister MVar WatchMap
mvarMap WatchKey
wk


instance FileListener PollManager where
  initSession :: IO (Maybe PollManager)
initSession = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just IO PollManager
createPollManager

  killSession :: PollManager -> IO ()
killSession (PollManager MVar WatchMap
mvarMap) = do
    WatchMap
watchMap <- forall a. MVar a -> IO a
readMVar MVar WatchMap
mvarMap
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [k]
Map.keys WatchMap
watchMap) WatchKey -> IO ()
killWatchingThread

  listen :: WatchConfig
-> PollManager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listen = Bool
-> WatchConfig
-> PollManager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listen' Bool
False

  listenRecursive :: WatchConfig
-> PollManager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listenRecursive = Bool
-> WatchConfig
-> PollManager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listen' Bool
True

  usesPolling :: PollManager -> Bool
usesPolling = forall a b. a -> b -> a
const Bool
True


getModificationTime :: FilePath -> IO UTCTime
getModificationTime :: FilePath -> IO UTCTime
getModificationTime FilePath
p = EpochTime -> UTCTime
fromEpoch forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> EpochTime
modificationTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
getFileStatus FilePath
p

fromEpoch :: EpochTime -> UTCTime
fromEpoch :: EpochTime -> UTCTime
fromEpoch = POSIXTime -> UTCTime
posixSecondsToUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac