    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE TypeSynonymInstances #-}
    {-# LANGUAGE FlexibleInstances #-}
    --
    -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
    -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
    --

    module System.FSNotify.Polling (
      createPollManager
      , PollManager(..)
      , FileListener(..)
      ) where

    import Control.Concurrent
    import Control.Exception.Safe
    import Control.Monad (forM_)
    import Data.Map (Map)
    import qualified Data.Map as Map
    import Data.Maybe
    import Data.Time.Clock (UTCTime)
    import Data.Time.Clock.POSIX
    import Prelude hiding (FilePath)
    import System.Directory (doesDirectoryExist)
    import System.FSNotify.Listener
    import System.FSNotify.Path (findFilesAndDirs, canonicalizeDirPath)
    import System.FSNotify.Types
    import System.FilePath
    import System.PosixCompat.Files
    import System.PosixCompat.Types

    data EventType = AddedEvent
                   | ModifiedEvent
                   | RemovedEvent

    newtype WatchKey = WatchKey ThreadId deriving (WatchKey -> WatchKey -> Bool
    (WatchKey -> WatchKey -> Bool)
    -> (WatchKey -> WatchKey -> Bool) -> Eq WatchKey
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: WatchKey -> WatchKey -> Bool
    == :: WatchKey -> WatchKey -> Bool
    $c/= :: WatchKey -> WatchKey -> Bool
    /= :: WatchKey -> WatchKey -> Bool
    Eq, Eq WatchKey
    Eq WatchKey =>
    (WatchKey -> WatchKey -> Ordering)
    -> (WatchKey -> WatchKey -> Bool)
    -> (WatchKey -> WatchKey -> Bool)
    -> (WatchKey -> WatchKey -> Bool)
    -> (WatchKey -> WatchKey -> Bool)
    -> (WatchKey -> WatchKey -> WatchKey)
    -> (WatchKey -> WatchKey -> WatchKey)
    -> Ord WatchKey
    WatchKey -> WatchKey -> Bool
    WatchKey -> WatchKey -> Ordering
    WatchKey -> WatchKey -> WatchKey
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: WatchKey -> WatchKey -> Ordering
    compare :: WatchKey -> WatchKey -> Ordering
    $c< :: WatchKey -> WatchKey -> Bool
    < :: WatchKey -> WatchKey -> Bool
    $c<= :: WatchKey -> WatchKey -> Bool
    <= :: WatchKey -> WatchKey -> Bool
    $c> :: WatchKey -> WatchKey -> Bool
    > :: WatchKey -> WatchKey -> Bool
    $c>= :: WatchKey -> WatchKey -> Bool
    >= :: WatchKey -> WatchKey -> Bool
    $cmax :: WatchKey -> WatchKey -> WatchKey
    max :: WatchKey -> WatchKey -> WatchKey
    $cmin :: WatchKey -> WatchKey -> WatchKey
    min :: WatchKey -> WatchKey -> WatchKey
    Ord)
    data WatchData = WatchData FilePath EventCallback
    type WatchMap = Map WatchKey WatchData
    data PollManager = PollManager {
      PollManager -> MVar WatchMap
    pollManagerWatchMap :: MVar WatchMap
      , PollManager -> Int
    pollManagerInterval :: Int
      }

    generateEvent :: UTCTime -> EventIsDirectory -> EventType -> FilePath -> Maybe Event
    generateEvent :: UTCTime -> EventIsDirectory -> EventType -> FilePath -> Maybe Event
    generateEvent UTCTime
    timestamp EventIsDirectory
    isDir EventType
    AddedEvent FilePath
    filePath = Event -> Maybe Event
    forall a. a -> Maybe a
    Just (FilePath -> UTCTime -> EventIsDirectory -> Event
    Added FilePath
    filePath UTCTime
    timestamp EventIsDirectory
    isDir)
    generateEvent UTCTime
    timestamp EventIsDirectory
    isDir EventType
    ModifiedEvent FilePath
    filePath = Event -> Maybe Event
    forall a. a -> Maybe a
    Just (FilePath -> UTCTime -> EventIsDirectory -> Event
    Modified FilePath
    filePath UTCTime
    timestamp EventIsDirectory
    isDir)
    generateEvent UTCTime
    timestamp EventIsDirectory
    isDir EventType
    RemovedEvent FilePath
    filePath = Event -> Maybe Event
    forall a. a -> Maybe a
    Just (FilePath -> UTCTime -> EventIsDirectory -> Event
    Removed FilePath
    filePath UTCTime
    timestamp EventIsDirectory
    isDir)

    generateEvents :: UTCTime -> EventType -> [(FilePath, EventIsDirectory)] -> [Event]
    generateEvents :: UTCTime -> EventType -> [(FilePath, EventIsDirectory)] -> [Event]
    generateEvents UTCTime
    timestamp EventType
    eventType = ((FilePath, EventIsDirectory) -> Maybe Event)
    -> [(FilePath, EventIsDirectory)] -> [Event]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (\(FilePath
    path, EventIsDirectory
    isDir) -> UTCTime -> EventIsDirectory -> EventType -> FilePath -> Maybe Event
    generateEvent UTCTime
    timestamp EventIsDirectory
    isDir EventType
    eventType FilePath
    path)

    -- | Do not return modified events for directories.
    -- These can arise when files are created inside subdirectories, resulting in the modification time
    -- of the directory being bumped. However, to increase consistency with the other FileListeners,
    -- we ignore these events.
    handleEvent :: EventCallback -> ActionPredicate -> Event -> IO ()
    handleEvent :: EventCallback -> ActionPredicate -> EventCallback
    handleEvent EventCallback
    _ ActionPredicate
    _ (Modified FilePath
    _ UTCTime
    _ EventIsDirectory
    IsDirectory) = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    handleEvent EventCallback
    callback ActionPredicate
    actPred Event
    event
      | ActionPredicate
    actPred Event
    event = EventCallback
    callback Event
    event
      | Bool
    otherwise = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, EventIsDirectory))
    pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, EventIsDirectory))
    pathModMap Bool
    recursive FilePath
    path = Bool -> FilePath -> IO [FilePath]
    findFilesAndDirs Bool
    recursive FilePath
    path IO [FilePath]
    -> ([FilePath] -> IO (Map FilePath (UTCTime, EventIsDirectory)))
    -> IO (Map FilePath (UTCTime, EventIsDirectory))
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= [FilePath] -> IO (Map FilePath (UTCTime, EventIsDirectory))
    pathModMap'
      where
        pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, EventIsDirectory))
        pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, EventIsDirectory))
    pathModMap' [FilePath]
    files = ([(FilePath, (UTCTime, EventIsDirectory))]
    -> Map FilePath (UTCTime, EventIsDirectory)
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(FilePath, (UTCTime, EventIsDirectory))]
     -> Map FilePath (UTCTime, EventIsDirectory))
    -> ([Maybe (FilePath, (UTCTime, EventIsDirectory))]
        -> [(FilePath, (UTCTime, EventIsDirectory))])
    -> [Maybe (FilePath, (UTCTime, EventIsDirectory))]
    -> Map FilePath (UTCTime, EventIsDirectory)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Maybe (FilePath, (UTCTime, EventIsDirectory))]
    -> [(FilePath, (UTCTime, EventIsDirectory))]
    forall a. [Maybe a] -> [a]
    catMaybes) ([Maybe (FilePath, (UTCTime, EventIsDirectory))]
     -> Map FilePath (UTCTime, EventIsDirectory))
    -> IO [Maybe (FilePath, (UTCTime, EventIsDirectory))]
    -> IO (Map FilePath (UTCTime, EventIsDirectory))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (FilePath -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory))))
    -> [FilePath] -> IO [Maybe (FilePath, (UTCTime, EventIsDirectory))]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM FilePath -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
    pathAndInfo [FilePath]
    files

        pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
        pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
    pathAndInfo FilePath
    p = (IOException -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory))))
    -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
    -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
    forall (m :: * -> *) e a.
    (HasCallStack, MonadCatch m, Exception e) =>
    (e -> m a) -> m a -> m a
    handle (\(IOException
    _ :: IOException) -> Maybe (FilePath, (UTCTime, EventIsDirectory))
    -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (FilePath, (UTCTime, EventIsDirectory))
    forall a. Maybe a
    Nothing) (IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
     -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory))))
    -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
    -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))
    forall a b. (a -> b) -> a -> b
    $ do
          modTime <- FilePath -> IO UTCTime
    getModificationTime FilePath
    p
          isDir <- doesDirectoryExist p
          return $ Just (p, (modTime, if isDir then IsDirectory else IsFile))

    pollPath :: Int -> Bool -> EventCallback -> FilePath -> ActionPredicate -> Map FilePath (UTCTime, EventIsDirectory) -> IO ()
    pollPath :: Int
    -> Bool
    -> EventCallback
    -> FilePath
    -> ActionPredicate
    -> Map FilePath (UTCTime, EventIsDirectory)
    -> IO ()
    pollPath Int
    interval Bool
    recursive EventCallback
    callback FilePath
    filePath ActionPredicate
    actPred Map FilePath (UTCTime, EventIsDirectory)
    oldPathMap = do
      Int -> IO ()
    threadDelay Int
    interval
      maybeNewPathMap <- (IOException
     -> IO (Maybe (Map FilePath (UTCTime, EventIsDirectory))))
    -> IO (Maybe (Map FilePath (UTCTime, EventIsDirectory)))
    -> IO (Maybe (Map FilePath (UTCTime, EventIsDirectory)))
    forall (m :: * -> *) e a.
    (HasCallStack, MonadCatch m, Exception e) =>
    (e -> m a) -> m a -> m a
    handle (\(IOException
    _ :: IOException) -> Maybe (Map FilePath (UTCTime, EventIsDirectory))
    -> IO (Maybe (Map FilePath (UTCTime, EventIsDirectory)))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Map FilePath (UTCTime, EventIsDirectory))
    forall a. Maybe a
    Nothing) (Map FilePath (UTCTime, EventIsDirectory)
    -> Maybe (Map FilePath (UTCTime, EventIsDirectory))
    forall a. a -> Maybe a
    Just (Map FilePath (UTCTime, EventIsDirectory)
     -> Maybe (Map FilePath (UTCTime, EventIsDirectory)))
    -> IO (Map FilePath (UTCTime, EventIsDirectory))
    -> IO (Maybe (Map FilePath (UTCTime, EventIsDirectory)))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Bool -> FilePath -> IO (Map FilePath (UTCTime, EventIsDirectory))
    pathModMap Bool
    recursive FilePath
    filePath)
      case maybeNewPathMap of
        -- Something went wrong while listing directories; we'll try again on the next poll
        Maybe (Map FilePath (UTCTime, EventIsDirectory))
    Nothing -> Int
    -> Bool
    -> EventCallback
    -> FilePath
    -> ActionPredicate
    -> Map FilePath (UTCTime, EventIsDirectory)
    -> IO ()
    pollPath Int
    interval Bool
    recursive EventCallback
    callback FilePath
    filePath ActionPredicate
    actPred Map FilePath (UTCTime, EventIsDirectory)
    oldPathMap

        Just Map FilePath (UTCTime, EventIsDirectory)
    newPathMap -> do
          currentTime <- IO UTCTime
    getCurrentTime
          let deletedMap = Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    forall k a b. Ord k => Map k a -> Map k b -> Map k a
    Map.difference Map FilePath (UTCTime, EventIsDirectory)
    oldPathMap Map FilePath (UTCTime, EventIsDirectory)
    newPathMap
              createdMap = Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    forall k a b. Ord k => Map k a -> Map k b -> Map k a
    Map.difference Map FilePath (UTCTime, EventIsDirectory)
    newPathMap Map FilePath (UTCTime, EventIsDirectory)
    oldPathMap
              modifiedAndCreatedMap = ((UTCTime, EventIsDirectory)
     -> (UTCTime, EventIsDirectory)
     -> Maybe (UTCTime, EventIsDirectory))
    -> Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    forall k a b.
    Ord k =>
    (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
    Map.differenceWith (UTCTime, EventIsDirectory)
    -> (UTCTime, EventIsDirectory) -> Maybe (UTCTime, EventIsDirectory)
    modifiedDifference Map FilePath (UTCTime, EventIsDirectory)
    newPathMap Map FilePath (UTCTime, EventIsDirectory)
    oldPathMap
              modifiedMap = Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    -> Map FilePath (UTCTime, EventIsDirectory)
    forall k a b. Ord k => Map k a -> Map k b -> Map k a
    Map.difference Map FilePath (UTCTime, EventIsDirectory)
    modifiedAndCreatedMap Map FilePath (UTCTime, EventIsDirectory)
    createdMap
              generateEvents' = UTCTime -> EventType -> [(FilePath, EventIsDirectory)] -> [Event]
    generateEvents UTCTime
    currentTime

          handleEvents $ generateEvents' AddedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList createdMap]
          handleEvents $ generateEvents' ModifiedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList modifiedMap]
          handleEvents $ generateEvents' RemovedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList deletedMap]

          pollPath interval recursive callback filePath actPred newPathMap

      where
        modifiedDifference :: (UTCTime, EventIsDirectory) -> (UTCTime, EventIsDirectory) -> Maybe (UTCTime, EventIsDirectory)
        modifiedDifference :: (UTCTime, EventIsDirectory)
    -> (UTCTime, EventIsDirectory) -> Maybe (UTCTime, EventIsDirectory)
    modifiedDifference (UTCTime
    newTime, EventIsDirectory
    isDir1) (UTCTime
    oldTime, EventIsDirectory
    isDir2)
          | UTCTime
    oldTime UTCTime -> UTCTime -> Bool
    forall a. Eq a => a -> a -> Bool
    /= UTCTime
    newTime Bool -> Bool -> Bool
    || EventIsDirectory
    isDir1 EventIsDirectory -> EventIsDirectory -> Bool
    forall a. Eq a => a -> a -> Bool
    /= EventIsDirectory
    isDir2 = (UTCTime, EventIsDirectory) -> Maybe (UTCTime, EventIsDirectory)
    forall a. a -> Maybe a
    Just (UTCTime
    newTime, EventIsDirectory
    isDir1)
          | Bool
    otherwise = Maybe (UTCTime, EventIsDirectory)
    forall a. Maybe a
    Nothing

        handleEvents :: [Event] -> IO ()
        handleEvents :: [Event] -> IO ()
    handleEvents = EventCallback -> [Event] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (EventCallback -> ActionPredicate -> EventCallback
    handleEvent EventCallback
    callback ActionPredicate
    actPred)

    -- Additional init function exported to allow startManager to unconditionally
    -- create a poll manager as a fallback when other managers will not instantiate.
    createPollManager :: Int -> IO PollManager
    createPollManager :: Int -> IO PollManager
    createPollManager Int
    interval  = MVar WatchMap -> Int -> PollManager
    PollManager (MVar WatchMap -> Int -> PollManager)
    -> IO (MVar WatchMap) -> IO (Int -> PollManager)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> WatchMap -> IO (MVar WatchMap)
    forall a. a -> IO (MVar a)
    newMVar WatchMap
    forall k a. Map k a
    Map.empty IO (Int -> PollManager) -> IO Int -> IO PollManager
    forall a b. IO (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Int -> IO Int
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Int
    interval

    killWatchingThread :: WatchKey -> IO ()
    killWatchingThread :: WatchKey -> IO ()
    killWatchingThread (WatchKey ThreadId
    threadId) = ThreadId -> IO ()
    killThread ThreadId
    threadId

    killAndUnregister :: MVar WatchMap -> WatchKey -> IO ()
    killAndUnregister :: MVar WatchMap -> WatchKey -> IO ()
    killAndUnregister MVar WatchMap
    mvarMap WatchKey
    wk = do
      _ <- MVar WatchMap -> (WatchMap -> IO WatchMap) -> IO WatchMap
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar MVar WatchMap
    mvarMap ((WatchMap -> IO WatchMap) -> IO WatchMap)
    -> (WatchMap -> IO WatchMap) -> IO WatchMap
    forall a b. (a -> b) -> a -> b
    $ \WatchMap
    m -> do
        WatchKey -> IO ()
    killWatchingThread WatchKey
    wk
        WatchMap -> IO WatchMap
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (WatchMap -> IO WatchMap) -> WatchMap -> IO WatchMap
    forall a b. (a -> b) -> a -> b
    $ WatchKey -> WatchMap -> WatchMap
    forall k a. Ord k => k -> Map k a -> Map k a
    Map.delete WatchKey
    wk WatchMap
    m
      return ()

    listen' :: Bool -> WatchConfig -> PollManager -> FilePath -> ActionPredicate -> EventCallback -> IO (IO ())
    listen' :: Bool
    -> WatchConfig
    -> PollManager
    -> FilePath
    -> ActionPredicate
    -> EventCallback
    -> IO (IO ())
    listen' Bool
    isRecursive WatchConfig
    _conf (PollManager MVar WatchMap
    mvarMap Int
    interval) FilePath
    path ActionPredicate
    actPred EventCallback
    callback = do
      path' <- FilePath -> IO FilePath
    canonicalizeDirPath FilePath
    path
      pmMap <- pathModMap isRecursive path'
      threadId <- forkIO $ pollPath interval isRecursive callback path' actPred pmMap
      let wk = ThreadId -> WatchKey
    WatchKey ThreadId
    threadId
      modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' callback)
      return $ killAndUnregister mvarMap wk

    instance FileListener PollManager Int where
      initSession :: Int -> IO (Either Text PollManager)
    initSession Int
    interval = PollManager -> Either Text PollManager
    forall a b. b -> Either a b
    Right (PollManager -> Either Text PollManager)
    -> IO PollManager -> IO (Either Text PollManager)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> IO PollManager
    createPollManager Int
    interval

      killSession :: PollManager -> IO ()
    killSession (PollManager MVar WatchMap
    mvarMap Int
    _) = do
        watchMap <- MVar WatchMap -> IO WatchMap
    forall a. MVar a -> IO a
    readMVar MVar WatchMap
    mvarMap
        forM_ (Map.keys watchMap) killWatchingThread

      listen :: ListenFn PollManager Int
    listen = Bool
    -> WatchConfig
    -> PollManager
    -> FilePath
    -> ActionPredicate
    -> EventCallback
    -> IO (IO ())
    listen' Bool
    False

      listenRecursive :: ListenFn PollManager Int
    listenRecursive = Bool
    -> WatchConfig
    -> PollManager
    -> FilePath
    -> ActionPredicate
    -> EventCallback
    -> IO (IO ())
    listen' Bool
    True

    getModificationTime :: FilePath -> IO UTCTime
    getModificationTime :: FilePath -> IO UTCTime
    getModificationTime FilePath
    p = EpochTime -> UTCTime
    fromEpoch (EpochTime -> UTCTime)
    -> (FileStatus -> EpochTime) -> FileStatus -> UTCTime
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FileStatus -> EpochTime
    modificationTime (FileStatus -> UTCTime) -> IO FileStatus -> IO UTCTime
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> IO FileStatus
    getFileStatus FilePath
    p

    fromEpoch :: EpochTime -> UTCTime
    fromEpoch :: EpochTime -> UTCTime
    fromEpoch = POSIXTime -> UTCTime
    posixSecondsToUTCTime (POSIXTime -> UTCTime)
    -> (EpochTime -> POSIXTime) -> EpochTime -> UTCTime
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . EpochTime -> POSIXTime
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac