1--
2-- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
3-- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
4--
5{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
6{-# OPTIONS_GHC -fno-warn-orphans #-}
7
8module System.FSNotify.Linux
9       ( FileListener(..)
10       , NativeManager
11       ) where
12
13import Control.Concurrent.Chan
14import Control.Concurrent.MVar
15import Control.Exception as E
16import Control.Monad
17import qualified Data.ByteString as BS
18import Data.IORef (atomicModifyIORef, readIORef)
19import Data.String
20import qualified Data.Text as T
21import Data.Time.Clock (UTCTime, getCurrentTime)
22import Data.Time.Clock.POSIX
23import Data.Typeable
24import qualified GHC.Foreign as F
25import GHC.IO.Encoding (getFileSystemEncoding)
26import Prelude hiding (FilePath)
27import qualified Shelly as S
28import System.FSNotify.Listener
29import System.FSNotify.Path (findDirs, canonicalizeDirPath)
30import System.FSNotify.Types
31import System.FilePath
32import qualified System.INotify as INo
33import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes)
34
35type NativeManager = INo.INotify
36
37data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable)
38instance Exception EventVarietyMismatchException
39
40#if MIN_VERSION_hinotify(0, 3, 10)
41toRawFilePath :: FilePath -> IO BS.ByteString
42toRawFilePath fp = do
43  enc <- getFileSystemEncoding
44  F.withCString enc fp BS.packCString
45
46fromRawFilePath :: BS.ByteString -> IO FilePath
47fromRawFilePath bs = do
48  enc <- getFileSystemEncoding
49  BS.useAsCString bs (F.peekCString enc)
50#else
51toRawFilePath = return . id
52fromRawFilePath = return . id
53#endif
54
55fsnEvents :: FilePath -> UTCTime -> INo.Event -> IO [Event]
56fsnEvents basePath timestamp (INo.Attributes isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]
57fsnEvents basePath timestamp (INo.Modified isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]
58fsnEvents basePath timestamp (INo.Created isDir raw) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]
59fsnEvents basePath timestamp (INo.MovedOut isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]
60fsnEvents basePath timestamp (INo.MovedIn isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]
61fsnEvents basePath timestamp (INo.Deleted isDir raw) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]
62fsnEvents _ _ (INo.Ignored) = return []
63fsnEvents basePath timestamp inoEvent = return [Unknown basePath timestamp (show inoEvent)]
64
65handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO ()
66handleInoEvent actPred chan basePath dbp inoEvent = do
67  currentTime <- getCurrentTime
68  events <- fsnEvents basePath currentTime inoEvent
69  mapM_ (handleEvent actPred chan dbp) events
70
71handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO ()
72handleEvent actPred chan dbp event =
73  when (actPred event) $ case dbp of
74    (Just (DebounceData epsilon ior)) -> do
75      lastEvent <- readIORef ior
76      unless (debounce epsilon lastEvent event) writeToChan
77      atomicModifyIORef ior (const (event, ()))
78    Nothing -> writeToChan
79  where
80    writeToChan = writeChan chan event
81
82varieties :: [INo.EventVariety]
83varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify]
84
85instance FileListener INo.INotify where
86  initSession = E.catch (fmap Just INo.initINotify) (\(_ :: IOException) -> return Nothing)
87
88  killSession = INo.killINotify
89
90  listen conf iNotify path actPred chan = do
91    path' <- canonicalizeDirPath path
92    dbp <- newDebouncePayload $ confDebounce conf
93    rawPath <- toRawFilePath path'
94    wd <- INo.addWatch iNotify varieties rawPath (handler path' dbp)
95    return $ INo.removeWatch wd
96    where
97      handler :: FilePath -> DebouncePayload -> INo.Event -> IO ()
98      handler = handleInoEvent actPred chan
99
100  listenRecursive conf iNotify initialPath actPred chan = do
101    -- wdVar stores the list of created watch descriptors. We use it to
102    -- cancel the whole recursive listening task.
103    --
104    -- To avoid a race condition (when a new watch is added right after
105    -- we've stopped listening), we replace the MVar contents with Nothing
106    -- to signify that the listening task is cancelled, and no new watches
107    -- should be added.
108    wdVar <- newMVar (Just [])
109
110    let
111      stopListening = do
112        modifyMVar_ wdVar $ \mbWds -> do
113          maybe (return ()) (mapM_ (\x -> catch (INo.removeWatch x) (\(_ :: SomeException) -> putStrLn ("Error removing watch: " `mappend` show x)))) mbWds
114          return Nothing
115
116    listenRec initialPath wdVar
117
118    return stopListening
119
120    where
121      listenRec :: FilePath -> MVar (Maybe [INo.WatchDescriptor]) -> IO ()
122      listenRec path wdVar = do
123        path' <- canonicalizeDirPath path
124        paths <- findDirs True path'
125
126        mapM_ (pathHandler wdVar) (path':paths)
127
128      pathHandler :: MVar (Maybe [INo.WatchDescriptor]) -> FilePath -> IO ()
129      pathHandler wdVar filePath = do
130        dbp <- newDebouncePayload $ confDebounce conf
131        rawFilePath <- toRawFilePath filePath
132        modifyMVar_ wdVar $ \mbWds ->
133          -- Atomically add a watch and record its descriptor. Also, check
134          -- if the listening task is cancelled, in which case do nothing.
135          case mbWds of
136            Nothing -> return mbWds
137            Just wds -> do
138              wd <- INo.addWatch iNotify varieties rawFilePath (handler filePath dbp)
139              return $ Just (wd:wds)
140        where
141          handler :: FilePath -> DebouncePayload -> INo.Event -> IO ()
142          handler baseDir dbp event = do
143            -- When a new directory is created, add recursive inotify watches to it
144            -- TODO: there's a race condition here; if there are files present in the directory before
145            -- we add the watches, we'll miss them. The right thing to do would be to ls the directory
146            -- and trigger Added events for everything we find there
147            case event of
148              (INo.Created True rawDirPath) -> do
149                dirPath <- fromRawFilePath rawDirPath
150                let newDir = baseDir </> dirPath
151                timestampBeforeAddingWatch <- getPOSIXTime
152                listenRec newDir wdVar
153
154                -- Find all files/folders that might have been created *after* the timestamp, and hence might have been
155                -- missed by the watch
156                -- TODO: there's a chance of this generating double events, fix
157                files <- S.shelly $ S.find (fromString newDir)
158                forM_ files $ \file -> do
159                  let newPath = T.unpack $ S.toTextIgnore file
160                  fileStatus <- getFileStatus newPath
161                  let modTime = modificationTimeHiRes fileStatus
162                  when (modTime > timestampBeforeAddingWatch) $ do
163                    handleEvent actPred chan dbp (Added (newDir </> newPath) (posixSecondsToUTCTime timestampBeforeAddingWatch) (isDirectory fileStatus))
164
165              _ -> return ()
166
167            -- Remove watch when this directory is removed
168            case event of
169              (INo.DeletedSelf) -> do
170                -- putStrLn "Watched file/folder was deleted! TODO: remove watch."
171                return ()
172              (INo.Ignored) -> do
173                -- putStrLn "Watched file/folder was ignored, which possibly means it was deleted. TODO: remove watch."
174                return ()
175              _ -> return ()
176
177            -- Forward all events, including directory create
178            handleInoEvent actPred chan baseDir dbp event
179
180  usesPolling = const False
181