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

-- | NOTE: This library does not currently report changes made to directories,
-- only files within watched directories.
--
-- Minimal example:
--
-- >{-# LANGUAGE OverloadedStrings #-} -- for FilePath literals
-- >
-- >import System.FSNotify
-- >import Control.Concurrent (threadDelay)
-- >import Control.Monad (forever)
-- >
-- >main =
-- >  withManager $ \mgr -> do
-- >    -- start a watching job (in the background)
-- >    watchDir
-- >      mgr          -- manager
-- >      "."          -- directory to watch
-- >      (const True) -- predicate
-- >      print        -- action
-- >
-- >    -- sleep forever (until interrupted)
-- >    forever $ threadDelay 1000000

module System.FSNotify
       (

       -- * Events
         Event(..)
       , EventChannel
       , eventIsDirectory
       , eventTime
       , eventPath
       , Action
       , ActionPredicate

       -- * Starting/Stopping
       , WatchManager
       , withManager
       , startManager
       , stopManager
       , defaultConfig
       , WatchConfig(..)
       , Debounce(..)
       , withManagerConf
       , startManagerConf
       , StopListening
       , isPollingManager

       -- * Watching
       , watchDir
       , watchDirChan
       , watchTree
       , watchTreeChan
       ) where

import Prelude hiding (FilePath)

import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Data.Maybe
import System.FSNotify.Polling
import System.FSNotify.Types
import System.FilePath

import System.FSNotify.Listener (StopListening)

#ifdef OS_Linux
import System.FSNotify.Linux
#else
#  ifdef OS_Win32
import System.FSNotify.Win32
#  else
#    ifdef OS_Mac
import System.FSNotify.OSX
#    else
type NativeManager = PollManager
#    endif
#  endif
#endif

-- | Watch manager. You need one in order to create watching jobs.
data WatchManager
  =  forall manager . FileListener manager
  => WatchManager
       WatchConfig
       manager
       (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped

-- | Default configuration
--
-- * Debouncing is enabled with a time interval of 1 millisecond
--
-- * Polling is disabled
--
-- * The polling interval defaults to 1 second
defaultConfig :: WatchConfig
defaultConfig :: WatchConfig
defaultConfig =
  WatchConfig :: Debounce -> Int -> Bool -> WatchConfig
WatchConfig
    { confDebounce :: Debounce
confDebounce = Debounce
DebounceDefault
    , confPollInterval :: Int
confPollInterval = Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int) -- 1 second
    , confUsePolling :: Bool
confUsePolling = Bool
False
    }

-- | Perform an IO action with a WatchManager in place.
-- Tear down the WatchManager after the action is complete.
withManager :: (WatchManager -> IO a) -> IO a
withManager :: (WatchManager -> IO a) -> IO a
withManager  = WatchConfig -> (WatchManager -> IO a) -> IO a
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
defaultConfig

-- | Start a file watch manager.
-- Directories can only be watched when they are managed by a started watch
-- watch manager.
-- When finished watching. you must release resources via 'stopManager'.
-- It is preferrable if possible to use 'withManager' to handle this
-- automatically.
startManager :: IO WatchManager
startManager :: IO WatchManager
startManager = WatchConfig -> IO WatchManager
startManagerConf WatchConfig
defaultConfig

-- | Stop a file watch manager.
-- Stopping a watch manager will immediately stop
-- watching for files and free resources.
stopManager :: WatchManager -> IO ()
stopManager :: WatchManager -> IO ()
stopManager (WatchManager WatchConfig
_ manager
wm MVar (Maybe (IO ()))
cleanupVar) = do
  Maybe (IO ())
mbCleanup <- MVar (Maybe (IO ())) -> Maybe (IO ()) -> IO (Maybe (IO ()))
forall a. MVar a -> a -> IO a
swapMVar MVar (Maybe (IO ()))
cleanupVar Maybe (IO ())
forall a. Maybe a
Nothing
  IO () -> Maybe (IO ()) -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe (IO ())
mbCleanup
  manager -> IO ()
forall sessionType.
FileListener sessionType =>
sessionType -> IO ()
killSession manager
wm

-- | Like 'withManager', but configurable
withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
conf = IO WatchManager
-> (WatchManager -> IO ()) -> (WatchManager -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (WatchConfig -> IO WatchManager
startManagerConf WatchConfig
conf) WatchManager -> IO ()
stopManager

-- | Like 'startManager', but configurable
startManagerConf :: WatchConfig -> IO WatchManager
startManagerConf :: WatchConfig -> IO WatchManager
startManagerConf WatchConfig
conf
  | WatchConfig -> Bool
confUsePolling WatchConfig
conf = IO WatchManager
pollingManager
  | Bool
otherwise = IO (Maybe NativeManager)
forall sessionType.
FileListener sessionType =>
IO (Maybe sessionType)
initSession IO (Maybe NativeManager)
-> (Maybe NativeManager -> IO WatchManager) -> IO WatchManager
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe NativeManager -> IO WatchManager
createManager
  where
    createManager :: Maybe NativeManager -> IO WatchManager
    createManager :: Maybe NativeManager -> IO WatchManager
createManager (Just NativeManager
nativeManager) =
      WatchConfig
-> NativeManager -> MVar (Maybe (IO ())) -> WatchManager
forall manager.
FileListener manager =>
WatchConfig -> manager -> MVar (Maybe (IO ())) -> WatchManager
WatchManager WatchConfig
conf NativeManager
nativeManager (MVar (Maybe (IO ())) -> WatchManager)
-> IO (MVar (Maybe (IO ()))) -> IO WatchManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar (Maybe (IO ())))
cleanupVar
    createManager Maybe NativeManager
Nothing = IO WatchManager
pollingManager

    pollingManager :: IO WatchManager
pollingManager =
      WatchConfig -> PollManager -> MVar (Maybe (IO ())) -> WatchManager
forall manager.
FileListener manager =>
WatchConfig -> manager -> MVar (Maybe (IO ())) -> WatchManager
WatchManager WatchConfig
conf (PollManager -> MVar (Maybe (IO ())) -> WatchManager)
-> IO PollManager -> IO (MVar (Maybe (IO ())) -> WatchManager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO PollManager
createPollManager IO (MVar (Maybe (IO ())) -> WatchManager)
-> IO (MVar (Maybe (IO ()))) -> IO WatchManager
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar (Maybe (IO ())))
cleanupVar

    cleanupVar :: IO (MVar (Maybe (IO ())))
cleanupVar = Maybe (IO ()) -> IO (MVar (Maybe (IO ())))
forall a. a -> IO (MVar a)
newMVar (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

-- | Does this manager use polling?
isPollingManager :: WatchManager -> Bool
isPollingManager :: WatchManager -> Bool
isPollingManager (WatchManager WatchConfig
_ manager
wm MVar (Maybe (IO ()))
_) = manager -> Bool
forall sessionType. FileListener sessionType => sessionType -> Bool
usesPolling manager
wm

-- | Watch the immediate contents of a directory by streaming events to a Chan.
-- Watching the immediate contents of a directory will only report events
-- associated with files within the specified directory, and not files
-- within its subdirectories.
watchDirChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening
watchDirChan :: WatchManager
-> FilePath -> ActionPredicate -> EventChannel -> IO (IO ())
watchDirChan (WatchManager WatchConfig
db manager
wm MVar (Maybe (IO ()))
_) = WatchConfig
-> manager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
forall sessionType.
FileListener sessionType =>
WatchConfig
-> sessionType
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listen WatchConfig
db manager
wm

-- | Watch all the contents of a directory by streaming events to a Chan.
-- Watching all the contents of a directory will report events associated with
-- files within the specified directory and its subdirectories.
watchTreeChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening
watchTreeChan :: WatchManager
-> FilePath -> ActionPredicate -> EventChannel -> IO (IO ())
watchTreeChan (WatchManager WatchConfig
db manager
wm MVar (Maybe (IO ()))
_) = WatchConfig
-> manager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
forall sessionType.
FileListener sessionType =>
WatchConfig
-> sessionType
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listenRecursive WatchConfig
db manager
wm

-- | Watch the immediate contents of a directory by committing an Action for each event.
-- Watching the immediate contents of a directory will only report events
-- associated with files within the specified directory, and not files
-- within its subdirectories.
watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
wm = (forall sessionType.
 FileListener sessionType =>
 WatchConfig
 -> sessionType
 -> FilePath
 -> ActionPredicate
 -> EventChannel
 -> IO (IO ()))
-> WatchManager
-> FilePath
-> ActionPredicate
-> Action
-> IO (IO ())
threadChan forall sessionType.
FileListener sessionType =>
WatchConfig
-> sessionType
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listen WatchManager
wm

-- | Watch all the contents of a directory by committing an Action for each event.
-- Watching all the contents of a directory will report events associated with
-- files within the specified directory and its subdirectories.
watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchTree WatchManager
wm = (forall sessionType.
 FileListener sessionType =>
 WatchConfig
 -> sessionType
 -> FilePath
 -> ActionPredicate
 -> EventChannel
 -> IO (IO ()))
-> WatchManager
-> FilePath
-> ActionPredicate
-> Action
-> IO (IO ())
threadChan forall sessionType.
FileListener sessionType =>
WatchConfig
-> sessionType
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listenRecursive WatchManager
wm

threadChan
  :: (forall sessionType . FileListener sessionType =>
      WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening)
      -- (^ this is the type of listen and listenRecursive)
  ->  WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
threadChan :: (forall sessionType.
 FileListener sessionType =>
 WatchConfig
 -> sessionType
 -> FilePath
 -> ActionPredicate
 -> EventChannel
 -> IO (IO ()))
-> WatchManager
-> FilePath
-> ActionPredicate
-> Action
-> IO (IO ())
threadChan forall sessionType.
FileListener sessionType =>
WatchConfig
-> sessionType
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listenFn (WatchManager WatchConfig
db manager
listener MVar (Maybe (IO ()))
cleanupVar) FilePath
path ActionPredicate
actPred Action
action =
  MVar (Maybe (IO ()))
-> (Maybe (IO ()) -> IO (Maybe (IO ()), IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe (IO ()))
cleanupVar ((Maybe (IO ()) -> IO (Maybe (IO ()), IO ())) -> IO (IO ()))
-> (Maybe (IO ()) -> IO (Maybe (IO ()), IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Maybe (IO ())
mbCleanup -> case Maybe (IO ())
mbCleanup of
    -- check if we've been stopped
    Maybe (IO ())
Nothing -> (Maybe (IO ()), IO ()) -> IO (Maybe (IO ()), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO ())
forall a. Maybe a
Nothing, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) -- or throw an exception?
    Just IO ()
cleanup -> do
      EventChannel
chan <- IO EventChannel
forall a. IO (Chan a)
newChan
      Async ()
asy <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ EventChannel -> Action -> IO ()
readEvents EventChannel
chan Action
action
      -- Ideally, the the asy thread should be linked to the current one
      -- (@link asy@), so that it doesn't die quietly.
      -- However, if we do that, then cancelling asy will also kill
      -- ourselves. I haven't figured out how to do this (probably we
      -- should just abandon async and use lower-level primitives). For now
      -- we don't link the thread.
      IO ()
stopListener <- WatchConfig
-> manager
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
forall sessionType.
FileListener sessionType =>
WatchConfig
-> sessionType
-> FilePath
-> ActionPredicate
-> EventChannel
-> IO (IO ())
listenFn WatchConfig
db manager
listener FilePath
path ActionPredicate
actPred EventChannel
chan
      let cleanThisUp :: IO ()
cleanThisUp = Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
asy
      (Maybe (IO ()), IO ()) -> IO (Maybe (IO ()), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
cleanup IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
cleanThisUp
        , IO ()
stopListener IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
cleanThisUp
        )

readEvents :: EventChannel -> Action -> IO ()
readEvents :: EventChannel -> Action -> IO ()
readEvents EventChannel
chan Action
action = IO ThreadId -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Event
event <- EventChannel -> IO Event
forall a. Chan a -> IO a
readChan EventChannel
chan
  ThreadId
us <- IO ThreadId
myThreadId
  -- Execute the event handler in a separate thread, but throw any
  -- exceptions back to us.
  --
  -- Note that there's a possibility that we may miss some exceptions, if
  -- an event handler finishes after the listen is cancelled (and so this
  -- thread is dead). How bad is that? The alternative is to kill the
  -- handler anyway when we're cancelling.
  IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Action
action Event
event) ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
us) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

#if !MIN_VERSION_base(4,6,0)
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally action and_then =
  mask $ \restore ->
    forkIO $ try (restore action) >>= and_then
#endif