FSNotify.hs

--
-- 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, LambdaCase, OverloadedStrings, MultiWayIf, FlexibleContexts, RecordWildCards, NamedFieldPuns #-}

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

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

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

       -- * Lower level
       , withManagerConf
       , startManagerConf
       , StopListening

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

       -- * Debouncing
       , makeDebouncedAction

       ) 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.Debounce
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
#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 argType. FileListener manager argType =>
  WatchManager { watchManagerConfig :: WatchConfig
               , watchManagerManager :: manager
               , watchManagerCleanupVar :: (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped
               , watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())
               }

-- | Default configuration
--
-- * Uses OS watch mode and single thread.
defaultConfig :: WatchConfig
defaultConfig =
  WatchConfig
    { confWatchMode = WatchModeOS
    , confThreadingMode = SingleThread
    , confOnHandlerException = defaultOnHandlerException
    }

defaultOnHandlerException :: SomeException -> IO ()
defaultOnHandlerException e = putStrLn ("fsnotify: handler threw exception: " <> show 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  = withManagerConf 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 = startManagerConf defaultConfig

-- | Stop a file watch manager.
-- Stopping a watch manager will immediately stop
-- watching for files and free resources.
stopManager :: WatchManager -> IO ()
stopManager (WatchManager {..}) = do
  mbCleanup <- swapMVar watchManagerCleanupVar Nothing
  maybe (return ()) liftIO mbCleanup
  liftIO $ killSession watchManagerManager
  case watchManagerGlobalChan of
    Nothing -> return ()
    Just (_, t) -> cancel t

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

-- | Like 'startManager', but configurable
startManagerConf :: WatchConfig -> IO (WatchManager)
startManagerConf 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 confWatchMode conf of
    WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> cleanupVar <*> globalWatchChan
    WatchModeOS -> liftIO (initSession ()) >>= createManager

  where
    createManager :: Either Text NativeManager -> IO (WatchManager)
    createManager (Right nativeManager) = WatchManager conf nativeManager <$> cleanupVar <*> globalWatchChan
    createManager (Left err) = throwIO $ userError $ T.unpack $ "Error: couldn't start native file manager: " <> err

    globalWatchChan = case confThreadingMode conf of
      SingleThread -> do
        globalChan <- newChan
        globalReaderThread <- async $ forever $ do
          (event, action) <- readChan globalChan
          tryAny (action event) >>= \case
            Left _ -> return () -- TODO: surface the exception somehow?
            Right () -> return ()
        return $ Just (globalChan, globalReaderThread)
      _ -> return Nothing

    cleanupVar = newMVar (Just (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 {..}) path actionPredicate chan = listen watchManagerConfig watchManagerManager path actionPredicate (writeChan 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 {..}) path actionPredicate chan = listenRecursive watchManagerConfig watchManagerManager path actionPredicate (writeChan 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 wm@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listen wm fp actionPredicate wrappedAction
  where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action 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 wm@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listenRecursive wm fp actionPredicate wrappedAction
  where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x)

-- * Main threading logic

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

  where
    readEvents :: Bool -> EventChannel -> IO ()
    readEvents True chan = forever $ readChan chan >>= (async . action)
    readEvents False chan = forever $ readChan chan >>= action