Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
231 lines (191 sloc) 9.89 KB
--
-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module System.FSNotify.Linux
( FileListener(..)
, NativeManager
) where
import Control.Concurrent.MVar
import Control.Exception.Safe as E
import Control.Monad
import qualified Data.ByteString as BS
import Data.Function
import Data.Monoid
import Data.String
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX
import qualified GHC.Foreign as F
import GHC.IO.Encoding (getFileSystemEncoding)
import Prelude hiding (FilePath)
import System.FSNotify.Find
import System.FSNotify.Listener
import System.FSNotify.Types
import System.FilePath (FilePath, (</>))
import qualified System.INotify as INo
import System.Posix.ByteString (RawFilePath)
import System.Posix.Directory.ByteString (openDirStream, readDirStream, closeDirStream)
import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes)
data INotifyListener = INotifyListener { listenerINotify :: INo.INotify }
type NativeManager = INotifyListener
data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable)
instance Exception EventVarietyMismatchException
fsnEvents :: RawFilePath -> UTCTime -> INo.Event -> IO [Event]
fsnEvents basePath' timestamp (INo.Attributes (boolToIsDirectory -> isDir) (Just raw)) = do
basePath <- fromRawFilePath basePath'
fromRawFilePath raw >>= \name -> return [ModifiedAttributes (basePath </> name) timestamp isDir]
fsnEvents basePath' timestamp (INo.Modified (boolToIsDirectory -> isDir) (Just raw)) = do
basePath <- fromRawFilePath basePath'
fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]
fsnEvents basePath' timestamp (INo.Created (boolToIsDirectory -> isDir) raw) = do
basePath <- fromRawFilePath basePath'
fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]
fsnEvents basePath' timestamp (INo.MovedOut (boolToIsDirectory -> isDir) raw _cookie) = do
basePath <- fromRawFilePath basePath'
fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]
fsnEvents basePath' timestamp (INo.MovedIn (boolToIsDirectory -> isDir) raw _cookie) = do
basePath <- fromRawFilePath basePath'
fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]
fsnEvents basePath' timestamp (INo.Deleted (boolToIsDirectory -> isDir) raw) = do
basePath <- fromRawFilePath basePath'
fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]
fsnEvents basePath' timestamp INo.DeletedSelf = do
basePath <- fromRawFilePath basePath'
return [WatchedDirectoryRemoved basePath timestamp IsDirectory]
fsnEvents _ _ INo.Ignored = return []
fsnEvents basePath' timestamp inoEvent = do
basePath <- fromRawFilePath basePath'
return [Unknown basePath timestamp IsFile (show inoEvent)]
handleInoEvent :: ActionPredicate -> EventCallback -> RawFilePath -> MVar Bool -> INo.Event -> IO ()
handleInoEvent actPred callback basePath watchStillExistsVar inoEvent = do
when (INo.DeletedSelf == inoEvent) $ modifyMVar_ watchStillExistsVar $ const $ return False
currentTime <- getCurrentTime
events <- fsnEvents basePath currentTime inoEvent
forM_ events $ \event -> when (actPred event) $ callback event
varieties :: [INo.EventVariety]
varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify, INo.DeleteSelf]
instance FileListener INotifyListener () where
initSession _ = E.handle (\(e :: IOException) -> return $ Left $ fromString $ show e) $ do
inotify <- INo.initINotify
return $ Right $ INotifyListener inotify
killSession (INotifyListener {listenerINotify}) = INo.killINotify listenerINotify
listen _conf (INotifyListener {listenerINotify}) path actPred callback = do
rawPath <- toRawFilePath path
canonicalRawPath <- canonicalizeRawDirPath rawPath
watchStillExistsVar <- newMVar True
wd <- INo.addWatch listenerINotify varieties canonicalRawPath (handleInoEvent actPred callback canonicalRawPath watchStillExistsVar)
return $ do
watchStillExists <- readMVar watchStillExistsVar
when watchStillExists $ INo.removeWatch wd
listenRecursive _conf listener initialPath actPred callback = do
-- wdVar stores the list of created watch descriptors. We use it to
-- cancel the whole recursive listening task.
--
-- To avoid a race condition (when a new watch is added right after
-- we've stopped listening), we replace the MVar contents with Nothing
-- to signify that the listening task is cancelled, and no new watches
-- should be added.
wdVar <- newMVar (Just [])
let
removeWatches wds = forM_ wds $ \(wd, watchStillExistsVar) ->
handle (\(e :: SomeException) -> putStrLn ("Error removing watch: " <> show wd <> " (" <> show e <> ")"))
(readMVar watchStillExistsVar >>= flip when (INo.removeWatch wd))
stopListening = modifyMVar_ wdVar $ \x -> maybe (return ()) removeWatches x >> return Nothing
-- Add watches to this directory plus every sub-directory
rawInitialPath <- toRawFilePath initialPath
rawCanonicalInitialPath <- canonicalizeRawDirPath rawInitialPath
watchDirectoryRecursively listener wdVar actPred callback True rawCanonicalInitialPath
traverseAllDirs rawCanonicalInitialPath $ \subPath ->
watchDirectoryRecursively listener wdVar actPred callback False subPath
return stopListening
type RecursiveWatches = MVar (Maybe [(INo.WatchDescriptor, MVar Bool)])
watchDirectoryRecursively :: INotifyListener -> RecursiveWatches -> ActionPredicate -> EventCallback -> Bool -> RawFilePath -> IO ()
watchDirectoryRecursively listener@(INotifyListener {listenerINotify}) wdVar actPred callback isRootWatchedDir rawFilePath = do
modifyMVar_ wdVar $ \case
Nothing -> return Nothing
Just wds -> do
watchStillExistsVar <- newMVar True
wd <- INo.addWatch listenerINotify varieties rawFilePath (handleRecursiveEvent rawFilePath actPred callback watchStillExistsVar isRootWatchedDir listener wdVar)
return $ Just ((wd, watchStillExistsVar):wds)
handleRecursiveEvent :: RawFilePath -> ActionPredicate -> EventCallback -> MVar Bool -> Bool -> INotifyListener -> RecursiveWatches -> INo.Event -> IO ()
handleRecursiveEvent baseDir actPred callback watchStillExistsVar isRootWatchedDir listener wdVar event = do
case event of
(INo.Created True rawDirPath) -> do
-- A new directory was created, so add recursive inotify watches to it
let newRawDir = baseDir <//> rawDirPath
timestampBeforeAddingWatch <- getPOSIXTime
watchDirectoryRecursively listener wdVar actPred callback False newRawDir
newDir <- fromRawFilePath newRawDir
-- Find all files/folders that might have been created *after* the timestamp, and hence might have been
-- missed by the watch
-- TODO: there's a chance of this generating double events, fix
files <- find False newDir -- TODO: expose the ability to set followSymlinks to True?
forM_ files $ \newPath -> do
fileStatus <- getFileStatus newPath
let modTime = modificationTimeHiRes fileStatus
when (modTime > timestampBeforeAddingWatch) $ do
let isDir = if isDirectory fileStatus then IsDirectory else IsFile
let addedEvent = (Added (newDir </> newPath) (posixSecondsToUTCTime timestampBeforeAddingWatch) isDir)
when (actPred addedEvent) $ callback addedEvent
_ -> return ()
-- If the watched directory was removed, mark the watch as already removed
case event of
INo.DeletedSelf -> modifyMVar_ watchStillExistsVar $ const $ return False
_ -> return ()
-- Forward the event. Ignore a DeletedSelf if we're not on the root directory,
-- since the watch above us will pick up the delete of that directory.
case event of
INo.DeletedSelf | not isRootWatchedDir -> return ()
_ -> handleInoEvent actPred callback baseDir watchStillExistsVar event
-- * Util
canonicalizeRawDirPath :: RawFilePath -> IO RawFilePath
canonicalizeRawDirPath = return . id -- TODO: do the same stuff that System.Directory.canonicalize does
-- | Same as </> but for RawFilePath
-- TODO: make sure this is correct or find in a library
(<//>) :: RawFilePath -> RawFilePath -> RawFilePath
x <//> y = x <> "/" <> y
traverseAllDirs :: RawFilePath -> (RawFilePath -> IO ()) -> IO ()
traverseAllDirs dir cb = traverseAll dir $ \subPath ->
-- TODO: wish we didn't need fromRawFilePath here
-- TODO: make sure this does the right thing with symlinks
fromRawFilePath subPath >>= getFileStatus >>= \case
(isDirectory -> True) -> cb subPath >> return True
_ -> return False
traverseAll :: RawFilePath -> (RawFilePath -> IO Bool) -> IO ()
traverseAll dir cb = bracket (openDirStream dir) closeDirStream $ \dirStream ->
fix $ \loop -> do
readDirStream dirStream >>= \case
x | BS.null x -> return ()
"." -> loop
".." -> loop
subDir -> flip finally loop $ do
-- TODO: canonicalize?
let fullSubDir = dir <//> subDir
shouldRecurse <- cb fullSubDir
when shouldRecurse $ traverseAll fullSubDir cb
boolToIsDirectory :: Bool -> EventIsDirectory
boolToIsDirectory False = IsFile
boolToIsDirectory True = IsDirectory
#if MIN_VERSION_hinotify(0, 3, 10)
toRawFilePath :: FilePath -> IO BS.ByteString
toRawFilePath fp = do
enc <- getFileSystemEncoding
F.withCString enc fp BS.packCString
fromRawFilePath :: BS.ByteString -> IO FilePath
fromRawFilePath bs = do
enc <- getFileSystemEncoding
BS.useAsCString bs (F.peekCString enc)
#else
toRawFilePath = return . id
fromRawFilePath = return . id
#endif