--
-- 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: " 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 ())
MVar (Maybe (IO ()))
WatchConfig
watchManagerConfig :: WatchManager -> WatchConfig
watchManagerManager :: ()
watchManagerCleanupVar :: WatchManager -> MVar (Maybe (IO ()))
watchManagerGlobalChan :: WatchManager -> Maybe (EventAndActionChannel, Async ())
watchManagerConfig :: WatchConfig
watchManagerManager :: manager
watchManagerCleanupVar :: MVar (Maybe (IO ()))
watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
..}) = do
  Maybe (IO ())
mbCleanup <- MVar (Maybe (IO ())) -> Maybe (IO ()) -> IO (Maybe (IO ()))
forall a. MVar a -> a -> IO a
swapMVar MVar (Maybe (IO ()))
watchManagerCleanupVar Maybe (IO ())
forall a. Maybe a
Nothing
  IO () -> (IO () -> IO ()) -> Maybe (IO ()) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Maybe (IO ())
mbCleanup
  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
-> MVar (Maybe (IO ()))
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
forall manager argType.
FileListener manager argType =>
WatchConfig
-> manager
-> MVar (Maybe (IO ()))
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
WatchManager WatchConfig
conf (PollManager
 -> MVar (Maybe (IO ()))
 -> Maybe (EventAndActionChannel, Async ())
 -> WatchManager)
-> IO PollManager
-> IO
     (MVar (Maybe (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
  (MVar (Maybe (IO ()))
   -> Maybe (EventAndActionChannel, Async ()) -> WatchManager)
-> IO (MVar (Maybe (IO ())))
-> IO (Maybe (EventAndActionChannel, Async ()) -> 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 (MVar (Maybe (IO ())))
cleanupVar 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 Text NativeManager -> IO WatchManager
    createManager :: Either Text NativeManager -> IO WatchManager
createManager (Right NativeManager
nativeManager) = WatchConfig
-> NativeManager
-> MVar (Maybe (IO ()))
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
forall manager argType.
FileListener manager argType =>
WatchConfig
-> manager
-> MVar (Maybe (IO ()))
-> Maybe (EventAndActionChannel, Async ())
-> WatchManager
WatchManager WatchConfig
conf NativeManager
nativeManager (MVar (Maybe (IO ()))
 -> Maybe (EventAndActionChannel, Async ()) -> WatchManager)
-> IO (MVar (Maybe (IO ())))
-> IO (Maybe (EventAndActionChannel, Async ()) -> WatchManager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar (Maybe (IO ())))
cleanupVar 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
    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

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

  where
    readEvents :: Bool -> EventChannel -> IO ()
    readEvents :: Bool -> EventChannel -> IO ()
readEvents Bool
True EventChannel
chan = IO (Async ()) -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ EventChannel -> IO Event
forall a. Chan a -> IO a
readChan EventChannel
chan IO Event -> (Event -> IO (Async ())) -> IO (Async ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (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)
    readEvents Bool
False EventChannel
chan = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EventChannel -> IO Event
forall a. Chan a -> IO a
readChan EventChannel
chan IO Event -> EventCallback -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EventCallback
action