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

-- | 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(..)
  , EventIsDirectory(..)
  , EventChannel
  , Action
  , ActionPredicate

  -- * Starting/Stopping
  , WatchManager
  , withManager
  , startManager
  , stopManager

  -- * Configuration
  , defaultConfig
  , WatchConfig
  , confWatchMode
  , confThreadingMode
  , confOnHandlerException
  , WatchMode(..)
  , ThreadingMode(..)

  -- * Lower level
  , withManagerConf
  , startManagerConf
  , StopListening

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

import Prelude hiding (FilePath)

import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception.Safe as E
import Control.Monad
import Control.Monad.IO.Class
import Data.Text as T
import System.FSNotify.Polling
import System.FSNotify.Types
import System.FilePath

import System.FSNotify.Listener (ListenFn, StopListening)

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif

#ifdef OS_Linux
import System.FSNotify.Linux
#endif

#ifdef OS_Win32
import System.FSNotify.Win32
#endif

#ifdef OS_Mac
import System.FSNotify.OSX
#endif


-- | Watch manager. You need one in order to create watching jobs.
data WatchManager = forall manager argType. FileListener manager argType =>
  WatchManager { WatchManager -> WatchConfig
watchManagerConfig :: WatchConfig
               , ()
watchManagerManager :: manager
               , WatchManager -> MVar (Maybe (IO ()))
watchManagerCleanupVar :: (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped
               , WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
               }

-- | Default configuration
--
-- * Uses OS watch mode and single thread.
defaultConfig :: WatchConfig
defaultConfig :: WatchConfig
defaultConfig = WatchConfig {
#ifdef OS_BSD
  confWatchMode = WatchModePoll 500000
#else
  confWatchMode :: WatchMode
confWatchMode = WatchMode
WatchModeOS
#endif
  , confThreadingMode :: ThreadingMode
confThreadingMode = ThreadingMode
SingleThread
  , confOnHandlerException :: SomeException -> IO ()
confOnHandlerException = SomeException -> IO ()
defaultOnHandlerException
  }

defaultOnHandlerException :: SomeException -> IO ()
defaultOnHandlerException :: SomeException -> IO ()
defaultOnHandlerException SomeException
e = String -> IO ()
putStrLn (String
"fsnotify: handler threw exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
e)

-- | 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 :: forall a. (WatchManager -> IO a) -> IO a
withManager  = 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 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 {manager
Maybe (EventAndActionChannel, Async ())
MVar (Maybe (IO ()))
WatchConfig
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
watchManagerCleanupVar :: MVar (Maybe (IO ()))
watchManagerManager :: manager
watchManagerConfig :: WatchConfig
watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerCleanupVar :: WatchManager -> MVar (Maybe (IO ()))
watchManagerManager :: ()
watchManagerConfig :: WatchManager -> WatchConfig
..}) = do
  Maybe (IO ())
mbCleanup <- forall a. MVar a -> a -> IO a
swapMVar MVar (Maybe (IO ()))
watchManagerCleanupVar forall a. Maybe a
Nothing
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Maybe (IO ())
mbCleanup
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall sessionType argType.
FileListener sessionType argType =>
sessionType -> IO ()
killSession manager
watchManagerManager
  case Maybe (EventAndActionChannel, Async ())
watchManagerGlobalChan of
    Maybe (EventAndActionChannel, Async ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (EventAndActionChannel
_, Async ()
t) -> forall a. Async a -> IO ()
cancel Async ()
t

-- | Like 'withManager', but configurable.
withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf :: forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
conf = forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m 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 = do
# ifdef OS_Win32
  -- See https://github.com/haskell-fswatch/hfsnotify/issues/50
  unless rtsSupportsBoundThreads $ throwIO $ userError "startManagerConf must be called with -threaded on Windows"
# endif

  case WatchConfig -> WatchMode
confWatchMode WatchConfig
conf of
    WatchModePoll Int
interval -> forall manager argType.
FileListener manager argType =>
WatchConfig
-> manager
-> MVar (Maybe (IO ()))
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
WatchManager WatchConfig
conf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO PollManager
createPollManager Int
interval) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar (Maybe (IO ())))
cleanupVar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {t} {a}. IO (Maybe (Chan (t, t -> IO ()), Async a))
globalWatchChan
#ifndef OS_BSD
    WatchMode
WatchModeOS -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall sessionType argType.
FileListener sessionType argType =>
argType -> IO (Either Text sessionType)
initSession ()) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Text NativeManager -> IO WatchManager
createManager
#endif

  where
#ifndef OS_BSD
    createManager :: Either Text NativeManager -> IO WatchManager
    createManager :: Either Text NativeManager -> IO WatchManager
createManager (Right NativeManager
nativeManager) = forall manager argType.
FileListener manager argType =>
WatchConfig
-> manager
-> MVar (Maybe (IO ()))
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
WatchManager WatchConfig
conf NativeManager
nativeManager forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar (Maybe (IO ())))
cleanupVar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {t} {a}. IO (Maybe (Chan (t, t -> IO ()), Async a))
globalWatchChan
    createManager (Left Text
err) = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"Error: couldn't start native file manager: " forall a. Semigroup a => a -> a -> a
<> Text
err
#endif

    globalWatchChan :: IO (Maybe (Chan (t, t -> IO ()), Async a))
globalWatchChan = case WatchConfig -> ThreadingMode
confThreadingMode WatchConfig
conf of
      ThreadingMode
SingleThread -> do
        Chan (t, t -> IO ())
globalChan <- forall a. IO (Chan a)
newChan
        Async a
globalReaderThread <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
          (t
event, t -> IO ()
action) <- forall a. Chan a -> IO a
readChan Chan (t, t -> IO ())
globalChan
          forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny (t -> IO ()
action t
event) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO: surface the exception somehow?
            Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Chan (t, t -> IO ())
globalChan, Async a
globalReaderThread)
      ThreadingMode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

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

-- | 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
-> String -> ActionPredicate -> EventChannel -> IO (IO ())
watchDirChan (WatchManager {manager
Maybe (EventAndActionChannel, Async ())
MVar (Maybe (IO ()))
WatchConfig
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
watchManagerCleanupVar :: MVar (Maybe (IO ()))
watchManagerManager :: manager
watchManagerConfig :: WatchConfig
watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerCleanupVar :: WatchManager -> MVar (Maybe (IO ()))
watchManagerManager :: ()
watchManagerConfig :: WatchManager -> WatchConfig
..}) String
path ActionPredicate
actionPredicate EventChannel
chan = forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listen WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actionPredicate (forall a. Chan a -> a -> IO ()
writeChan EventChannel
chan)

-- | 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
-> String -> ActionPredicate -> EventChannel -> IO (IO ())
watchTreeChan (WatchManager {manager
Maybe (EventAndActionChannel, Async ())
MVar (Maybe (IO ()))
WatchConfig
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
watchManagerCleanupVar :: MVar (Maybe (IO ()))
watchManagerManager :: manager
watchManagerConfig :: WatchConfig
watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerCleanupVar :: WatchManager -> MVar (Maybe (IO ()))
watchManagerManager :: ()
watchManagerConfig :: WatchManager -> WatchConfig
..}) String
path ActionPredicate
actionPredicate EventChannel
chan = forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listenRecursive WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actionPredicate (forall a. Chan a -> a -> IO ()
writeChan EventChannel
chan)

-- | 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 -> String -> ActionPredicate -> Action -> IO (IO ())
watchDir wm :: WatchManager
wm@(WatchManager {WatchConfig
watchManagerConfig :: WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerConfig}) String
fp ActionPredicate
actionPredicate Action
action = (forall a b. ListenFn a b)
-> WatchManager
-> String
-> ActionPredicate
-> Action
-> IO (IO ())
threadChan forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listen WatchManager
wm String
fp ActionPredicate
actionPredicate Action
wrappedAction
  where wrappedAction :: Action
wrappedAction Event
x = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (WatchConfig -> SomeException -> IO ()
confOnHandlerException WatchConfig
watchManagerConfig) (Action
action Event
x)

-- | 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 -> String -> ActionPredicate -> Action -> IO (IO ())
watchTree wm :: WatchManager
wm@(WatchManager {WatchConfig
watchManagerConfig :: WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerConfig}) String
fp ActionPredicate
actionPredicate Action
action = (forall a b. ListenFn a b)
-> WatchManager
-> String
-> ActionPredicate
-> Action
-> IO (IO ())
threadChan forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listenRecursive WatchManager
wm String
fp ActionPredicate
actionPredicate Action
wrappedAction
  where wrappedAction :: Action
wrappedAction Event
x = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (WatchConfig -> SomeException -> IO ()
confOnHandlerException WatchConfig
watchManagerConfig) (Action
action Event
x)

-- * Main threading logic

threadChan :: (forall a b. ListenFn a b) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening
threadChan :: (forall a b. ListenFn a b)
-> WatchManager
-> String
-> ActionPredicate
-> Action
-> IO (IO ())
threadChan forall a b. ListenFn a b
listenFn (WatchManager {watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerGlobalChan=(Just (EventAndActionChannel
globalChan, Async ()
_)), manager
MVar (Maybe (IO ()))
WatchConfig
watchManagerCleanupVar :: MVar (Maybe (IO ()))
watchManagerManager :: manager
watchManagerConfig :: WatchConfig
watchManagerCleanupVar :: WatchManager -> MVar (Maybe (IO ()))
watchManagerManager :: ()
watchManagerConfig :: WatchManager -> WatchConfig
..}) String
path ActionPredicate
actPred Action
action =
  forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe (IO ()))
watchManagerCleanupVar forall a b. (a -> b) -> a -> b
$ \case
    Maybe (IO ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall (m :: * -> *) a. Monad m => a -> m a
return ()) -- we've been stopped. Throw an exception?
    Just IO ()
cleanup -> do
      IO ()
stopListener <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. ListenFn a b
listenFn WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actPred (\Event
event -> forall a. Chan a -> a -> IO ()
writeChan EventAndActionChannel
globalChan (Event
event, Action
action))
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (IO ()
cleanup forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
stopListener), IO ()
stopListener)
threadChan forall a b. ListenFn a b
listenFn (WatchManager {watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerGlobalChan=Maybe (EventAndActionChannel, Async ())
Nothing, manager
MVar (Maybe (IO ()))
WatchConfig
watchManagerCleanupVar :: MVar (Maybe (IO ()))
watchManagerManager :: manager
watchManagerConfig :: WatchConfig
watchManagerCleanupVar :: WatchManager -> MVar (Maybe (IO ()))
watchManagerManager :: ()
watchManagerConfig :: WatchManager -> WatchConfig
..}) String
path ActionPredicate
actPred Action
action =
  forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe (IO ()))
watchManagerCleanupVar forall a b. (a -> b) -> a -> b
$ \case
    Maybe (IO ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall (m :: * -> *) a. Monad m => a -> m a
return ()) -- we've been stopped. Throw an exception?
    Just IO ()
cleanup -> do
      EventChannel
chan <- forall a. IO (Chan a)
newChan
      let forkThreadPerEvent :: Bool
forkThreadPerEvent = case WatchConfig -> ThreadingMode
confThreadingMode WatchConfig
watchManagerConfig of
            ThreadingMode
SingleThread -> forall a. HasCallStack => String -> a
error String
"Should never happen"
            ThreadingMode
ThreadPerWatch -> Bool
False
            ThreadingMode
ThreadPerEvent -> Bool
True
      Async ()
readerThread <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ Bool -> EventChannel -> IO ()
readEvents Bool
forkThreadPerEvent EventChannel
chan
      IO ()
stopListener <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. ListenFn a b
listenFn WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actPred (forall a. Chan a -> a -> IO ()
writeChan EventChannel
chan)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (IO ()
cleanup forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
stopListener forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Async a -> IO ()
cancel Async ()
readerThread), IO ()
stopListener forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Async a -> IO ()
cancel Async ()
readerThread)

  where
    readEvents :: Bool -> EventChannel -> IO ()
    readEvents :: Bool -> EventChannel -> IO ()
readEvents Bool
True EventChannel
chan = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
readChan EventChannel
chan forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. IO a -> IO (Async a)
async forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action
action)
    readEvents Bool
False EventChannel
chan = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
readChan EventChannel
chan forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Action
action