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

-- | 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 qualified 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 -> 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: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
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  = 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 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 ())
WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerManager :: ()
watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerConfig :: WatchConfig
watchManagerManager :: manager
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
..}) = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ manager -> IO ()
forall sessionType argType.
FileListener sessionType argType =>
sessionType -> IO ()
killSession manager
watchManagerManager
  case Maybe (EventAndActionChannel, Async ())
watchManagerGlobalChan of
    Maybe (EventAndActionChannel, Async ())
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (EventAndActionChannel
_, Async ()
t) -> Async () -> IO ()
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 = IO WatchManager
-> (WatchManager -> IO ()) -> (WatchManager -> IO a) -> IO a
forall (m :: * -> *) a b c.
(HasCallStack, 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 -> WatchConfig
-> PollManager
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
forall manager argType.
FileListener manager argType =>
WatchConfig
-> manager
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
WatchManager WatchConfig
conf (PollManager
 -> Maybe (EventAndActionChannel, Async ()) -> WatchManager)
-> IO PollManager
-> IO (Maybe (EventAndActionChannel, Async ()) -> WatchManager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO PollManager -> IO PollManager
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO PollManager
createPollManager Int
interval) IO (Maybe (EventAndActionChannel, Async ()) -> WatchManager)
-> IO (Maybe (EventAndActionChannel, Async ())) -> IO WatchManager
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Maybe (EventAndActionChannel, Async ()))
forall {t} {a}. IO (Maybe (Chan (t, t -> IO ()), Async a))
globalWatchChan
#ifndef OS_BSD
    WatchMode
WatchModeOS -> IO (Either Text NativeManager) -> IO (Either Text NativeManager)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (() -> IO (Either Text NativeManager)
forall sessionType argType.
FileListener sessionType argType =>
argType -> IO (Either Text sessionType)
initSession ()) IO (Either Text NativeManager)
-> (Either Text NativeManager -> IO WatchManager)
-> IO WatchManager
forall a b. IO a -> (a -> IO b) -> IO b
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 T.Text NativeManager -> IO WatchManager
    createManager :: Either Text NativeManager -> IO WatchManager
createManager (Right NativeManager
nativeManager) = WatchConfig
-> NativeManager
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
forall manager argType.
FileListener manager argType =>
WatchConfig
-> manager
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
WatchManager WatchConfig
conf NativeManager
nativeManager (Maybe (EventAndActionChannel, Async ()) -> WatchManager)
-> IO (Maybe (EventAndActionChannel, Async ())) -> IO WatchManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (EventAndActionChannel, Async ()))
forall {t} {a}. IO (Maybe (Chan (t, t -> IO ()), Async a))
globalWatchChan
    createManager (Left Text
err) = IOError -> IO WatchManager
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (IOError -> IO WatchManager) -> IOError -> IO WatchManager
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Error: couldn't start native file manager: " Text -> Text -> Text
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 <- IO (Chan (t, t -> IO ()))
forall a. IO (Chan a)
newChan
        Async a
globalReaderThread <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async (IO a -> IO (Async a)) -> IO a -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ do
          (t
event, t -> IO ()
action) <- Chan (t, t -> IO ()) -> IO (t, t -> IO ())
forall a. Chan a -> IO a
readChan Chan (t, t -> IO ())
globalChan
          IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny (t -> IO ()
action t
event) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO: surface the exception somehow?
            Right () -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe (Chan (t, t -> IO ()), Async a)
-> IO (Maybe (Chan (t, t -> IO ()), Async a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Chan (t, t -> IO ()), Async a)
 -> IO (Maybe (Chan (t, t -> IO ()), Async a)))
-> Maybe (Chan (t, t -> IO ()), Async a)
-> IO (Maybe (Chan (t, t -> IO ()), Async a))
forall a b. (a -> b) -> a -> b
$ (Chan (t, t -> IO ()), Async a)
-> Maybe (Chan (t, t -> IO ()), Async a)
forall a. a -> Maybe a
Just (Chan (t, t -> IO ())
globalChan, Async a
globalReaderThread)
      ThreadingMode
_ -> Maybe (Chan (t, t -> IO ()), Async a)
-> IO (Maybe (Chan (t, t -> IO ()), Async a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Chan (t, t -> IO ()), Async a)
forall a. Maybe a
Nothing

-- | 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 ())
WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerManager :: ()
watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerConfig :: WatchConfig
watchManagerManager :: manager
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
..}) String
path ActionPredicate
actionPredicate EventChannel
chan = WatchConfig
-> manager
-> String
-> ActionPredicate
-> EventCallback
-> IO (IO ())
forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listen WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actionPredicate (EventChannel -> EventCallback
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 ())
WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerManager :: ()
watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerConfig :: WatchConfig
watchManagerManager :: manager
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
..}) String
path ActionPredicate
actionPredicate EventChannel
chan = WatchConfig
-> manager
-> String
-> ActionPredicate
-> EventCallback
-> IO (IO ())
forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listenRecursive WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actionPredicate (EventChannel -> EventCallback
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 -> EventCallback -> IO (IO ())
watchDir wm :: WatchManager
wm@(WatchManager {WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerConfig :: WatchConfig
watchManagerConfig}) String
fp ActionPredicate
actionPredicate EventCallback
action = (forall a b. ListenFn a b)
-> WatchManager
-> String
-> ActionPredicate
-> EventCallback
-> IO (IO ())
threadChan WatchConfig
-> a -> String -> ActionPredicate -> EventCallback -> IO (IO ())
forall a b. ListenFn a b
forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listen WatchManager
wm String
fp ActionPredicate
actionPredicate EventCallback
wrappedAction
  where wrappedAction :: EventCallback
wrappedAction Event
x = (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (WatchConfig -> SomeException -> IO ()
confOnHandlerException WatchConfig
watchManagerConfig) (EventCallback
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 -> EventCallback -> IO (IO ())
watchTree wm :: WatchManager
wm@(WatchManager {WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerConfig :: WatchConfig
watchManagerConfig}) String
fp ActionPredicate
actionPredicate EventCallback
action = (forall a b. ListenFn a b)
-> WatchManager
-> String
-> ActionPredicate
-> EventCallback
-> IO (IO ())
threadChan WatchConfig
-> a -> String -> ActionPredicate -> EventCallback -> IO (IO ())
forall a b. ListenFn a b
forall sessionType argType.
FileListener sessionType argType =>
ListenFn sessionType argType
listenRecursive WatchManager
wm String
fp ActionPredicate
actionPredicate EventCallback
wrappedAction
  where wrappedAction :: EventCallback
wrappedAction Event
x = (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (WatchConfig -> SomeException -> IO ()
confOnHandlerException WatchConfig
watchManagerConfig) (EventCallback
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
-> EventCallback
-> IO (IO ())
threadChan forall a b. ListenFn a b
listenFn (WatchManager {watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerGlobalChan=(Just (EventAndActionChannel
globalChan, Async ()
_)), manager
WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerManager :: ()
watchManagerConfig :: WatchConfig
watchManagerManager :: manager
..}) String
path ActionPredicate
actPred EventCallback
action =
  WatchConfig
-> manager
-> String
-> ActionPredicate
-> EventCallback
-> IO (IO ())
forall a b. ListenFn a b
listenFn WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actPred (\Event
event -> EventAndActionChannel -> (Event, EventCallback) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan EventAndActionChannel
globalChan (Event
event, EventCallback
action))
threadChan forall a b. ListenFn a b
listenFn (WatchManager {watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerGlobalChan=Maybe (EventAndActionChannel, Async ())
Nothing, manager
WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerManager :: ()
watchManagerConfig :: WatchConfig
watchManagerManager :: manager
..}) String
path ActionPredicate
actPred EventCallback
action = do
  let wrappedAction :: EventCallback
wrappedAction = case WatchConfig -> ThreadingMode
confThreadingMode WatchConfig
watchManagerConfig of
        ThreadingMode
SingleThread -> String -> EventCallback
forall a. HasCallStack => String -> a
error String
"Should never happen"
        ThreadingMode
ThreadPerWatch -> EventCallback
action
        ThreadingMode
ThreadPerEvent -> IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ())
-> (Event -> IO (Async ())) -> EventCallback
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> EventCallback -> Event -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventCallback
action
  WatchConfig
-> manager
-> String
-> ActionPredicate
-> EventCallback
-> IO (IO ())
forall a b. ListenFn a b
listenFn WatchConfig
watchManagerConfig manager
watchManagerManager String
path ActionPredicate
actPred EventCallback
wrappedAction