diff options
| -rw-r--r-- | Annex.hs | 3 | ||||
| -rw-r--r-- | Annex/Queue.hs | 2 | ||||
| -rw-r--r-- | Command/Watch.hs | 107 | ||||
| -rw-r--r-- | Git/Queue.hs | 28 | ||||
| -rw-r--r-- | GitAnnex.hs | 2 | ||||
| -rw-r--r-- | Utility/Inotify.hs | 139 | ||||
| -rw-r--r-- | Utility/ThreadLock.hs | 35 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | doc/install.mdwn | 1 | ||||
| -rw-r--r-- | git-annex.cabal | 3 |
10 files changed, 253 insertions, 68 deletions
@@ -14,6 +14,7 @@ module Annex ( newState, run, eval, + exec, getState, changeState, setFlag, @@ -134,6 +135,8 @@ run :: AnnexState -> Annex a -> IO (a, AnnexState) run s a = runStateT (runAnnex a) s eval :: AnnexState -> Annex a -> IO a eval s a = evalStateT (runAnnex a) s +exec :: AnnexState -> Annex a -> IO AnnexState +exec s a = execStateT (runAnnex a) s {- Sets a flag to True -} setFlag :: String -> Annex () diff --git a/Annex/Queue.hs b/Annex/Queue.hs index 24575e906..d4a2c592e 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -20,7 +20,7 @@ import Config add :: String -> [CommandParam] -> [FilePath] -> Annex () add command params files = do q <- get - store $ Git.Queue.add q command params files + store =<< inRepo (Git.Queue.add q command params files) {- Runs the queue if it is full. Should be called periodically. -} flushWhenFull :: Annex () diff --git a/Command/Watch.hs b/Command/Watch.hs new file mode 100644 index 000000000..15c862bec --- /dev/null +++ b/Command/Watch.hs @@ -0,0 +1,107 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Command.Watch where + +import Common.Annex +import Command +import Utility.Inotify +import Utility.ThreadLock +import qualified Annex +import qualified Annex.Queue +import qualified Command.Add as Add +import qualified Git.Command +import qualified Backend +import Annex.Content + +import Control.Exception as E +import System.INotify +import Control.Concurrent.MVar + +def :: [Command] +def = [command "watch" paramPaths seek "watch for changes"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = notBareRepo $ do + showStart "watch" "." + showAction "scanning" + inRepo $ Git.Command.run "add" [Param "--update"] + state <- Annex.getState id + mvar <- liftIO $ newMVar state + next $ next $ liftIO $ withINotify $ \i -> do + let hook a = Just $ runAnnex mvar a + watchDir i "." (not . gitdir) + (hook onAdd) (hook onAddSymlink) + (hook onDel) (hook onDelDir) + putStrLn "(started)" + waitForTermination + return True + where + gitdir dir = takeFileName dir /= ".git" + +{- Runs a handler, inside the Annex monad. + - + - Exceptions by the handlers are ignored, otherwise a whole watcher + - thread could be crashed. + -} +runAnnex :: MVar Annex.AnnexState -> (FilePath -> Annex a) -> FilePath -> IO () +runAnnex mvar a f = do + startstate <- takeMVar mvar + r <- E.try (go startstate) :: IO (Either E.SomeException Annex.AnnexState) + case r of + Left e -> do + putStrLn (show e) + putMVar mvar startstate + Right !newstate -> + putMVar mvar newstate + where + go state = Annex.exec state $ a f + +{- Adding a file is the same as git-annex add. + - The git queue is immediately flushed, so the file is added to git + - now, rather than later (when it may have been already moved or deleted!) -} +onAdd :: FilePath -> Annex () +onAdd file = do + void $ doCommand $ do + showStart "add" file + next $ Add.perform file + Annex.Queue.flush + +{- A symlink might be an arbitrary symlink, which is just added. + - Or, if it is a git-annex symlink, ensure it points to the content + - before adding it. + -} +onAddSymlink :: FilePath -> Annex () +onAddSymlink file = go =<< Backend.lookupFile file + where + go Nothing = addlink + go (Just (key, _)) = do + link <- calcGitLink file key + ifM ((==) link <$> liftIO (readSymbolicLink file)) + ( addlink + , do + liftIO $ removeFile file + liftIO $ createSymbolicLink link file + addlink + ) + addlink = inRepo $ Git.Command.run "add" + [Params "--force --", File file] + +onDel :: FilePath -> Annex () +onDel file = inRepo $ Git.Command.run "rm" + [Params "--quiet --cached --ignore-unmatch --", File file] + +{- A directory has been deleted, or moved, so tell git to remove anything + - that was inside it from its cache. -} +onDelDir :: FilePath -> Annex () +onDelDir dir = inRepo $ Git.Command.run "rm" + [Params "--quiet -r --cached --ignore-unmatch --", File dir] diff --git a/Git/Queue.hs b/Git/Queue.hs index b8055ab44..956e9adb1 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -1,6 +1,6 @@ {- git repository command queue - - - Copyright 2010 Joey Hess <joey@kitenet.net> + - Copyright 2010,2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -33,6 +33,12 @@ data Action = Action , getParams :: [CommandParam] } deriving (Show, Eq, Ord) +{- Compares two actions by subcommand. -} +(===) :: Action -> Action -> Bool +a === b = getSubcommand a == getSubcommand b +(/==) :: Action -> Action -> Bool +a /== b = not $ a === b + {- A queue of actions to perform (in any order) on a git repository, - with lists of files to perform them on. This allows coalescing - similar git commands. -} @@ -59,16 +65,20 @@ defaultLimit = 10240 new :: Maybe Int -> Queue new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty -{- Adds an action to a queue. -} -add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue -add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m' +{- Adds an action to a queue. If the queue already contains a different + - action, it will be flushed; this is to ensure that conflicting actions, + - like add and rm, are run in the right order. -} +add :: Queue -> String -> [CommandParam] -> [FilePath] -> Repo -> IO Queue +add q@(Queue _ _ m) subcommand params files repo + | null (filter (/== action) (M.keys m)) = go q + | otherwise = go =<< flush q repo where action = Action subcommand params - -- There are probably few items in the map, but there - -- can be a lot of files per item. So, optimise adding - -- files. - m' = M.insertWith' const action fs m - !fs = files ++ M.findWithDefault [] action m + go (Queue cur lim m') = + return $ Queue (cur + 1) lim $ + M.insertWith' const action fs m' + where + !fs = files ++ M.findWithDefault [] action m' {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool diff --git a/GitAnnex.hs b/GitAnnex.hs index 149b37f93..a4c5eb849 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -58,6 +58,7 @@ import qualified Command.Import import qualified Command.Map import qualified Command.Upgrade import qualified Command.Version +import qualified Command.Watch cmds :: [Command] cmds = concat @@ -99,6 +100,7 @@ cmds = concat , Command.Map.def , Command.Upgrade.def , Command.Version.def + , Command.Watch.def ] options :: [Option] diff --git a/Utility/Inotify.hs b/Utility/Inotify.hs index d41e997d6..3c69a7ee2 100644 --- a/Utility/Inotify.hs +++ b/Utility/Inotify.hs @@ -1,27 +1,26 @@ +{- higher-level inotify interface + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + {-# LANGUAGE CPP #-} module Utility.Inotify where import Common hiding (isDirectory) +import Utility.ThreadLock + import System.INotify import qualified System.Posix.Files as Files -import System.Posix.Terminal -import Control.Concurrent.MVar -import System.Posix.Signals -demo :: IO () -demo = withINotify $ \i -> do - watchDir i (const True) (Just add) (Just del) "/home/joey/tmp/me" - putStrLn "started" - waitForTermination - where - add file = putStrLn $ "add " ++ file - del file = putStrLn $ "del " ++ file +type Hook = Maybe (FilePath -> IO ()) {- Watches for changes to files in a directory, and all its subdirectories - - that match a test, using inotify. This function returns after its initial - - setup is complete, leaving a thread running. Then callbacks are made for - - adding and deleting files. + - that are not ignored, using inotify. This function returns after + - its initial scan is complete, leaving a thread running. Callbacks are + - made for different events. - - Inotify is weak at recursive directory watching; the whole directory - tree must be walked and watches set explicitly for each subdirectory. @@ -37,59 +36,85 @@ demo = withINotify $ \i -> do - Note: Due to the race amelioration, multiple add events may occur - for the same file. - - - Note: Moving a file may involve deleting it from its old location and - - adding it to the new location. + - Note: Moving a file will cause events deleting it from its old location + - and adding it to the new location. - - Note: Modification of files is not detected, and it's assumed that when - - a file that was open for write is closed, it's done being written + - a file that was open for write is closed, it's finished being written - to, and can be added. - - Note: inotify has a limit to the number of watches allowed, - /proc/sys/fs/inotify/max_user_watches (default 8192). - - So This will fail if there are too many subdirectories. + - So this will fail if there are too many subdirectories. -} -watchDir :: INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO () -watchDir i test add del dir = watchDir' False i test add del dir -watchDir' :: Bool -> INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO () -watchDir' scan i test add del dir = do - if test dir - then void $ do - _ <- addWatch i watchevents dir go - mapM walk =<< dirContents dir - else noop +watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Hook -> Hook -> Hook -> Hook -> IO () +watchDir i dir ignored add addsymlink del deldir + | ignored dir = noop + | otherwise = do + lock <- newLock + void $ addWatch i watchevents dir $ \event -> + withLock lock (void $ go event) + withLock lock $ + mapM_ walk =<< filter (not . dirCruft) <$> + getDirectoryContents dir where - watchevents - | isJust add && isJust del = - [Create, MoveIn, MoveOut, Delete, CloseWrite] - | isJust add = [Create, MoveIn, CloseWrite] - | isJust del = [Create, MoveOut, Delete] - | otherwise = [Create] + recurse d = watchDir i d ignored add addsymlink del deldir + + -- Select only inotify events required by the enabled + -- hooks, but always include Create so new directories can + -- be walked. + watchevents = Create : addevents ++ delevents + addevents + | isJust add || isJust addsymlink = [MoveIn, CloseWrite] + | otherwise = [] + delevents + | isJust del || isJust deldir = [MoveOut, Delete] + | otherwise = [] - recurse = watchDir' scan i test add del - walk f = ifM (catchBoolIO $ Files.isDirectory <$> getFileStatus f) - ( recurse f - , when (scan && isJust add) $ fromJust add f - ) + walk f = do + let fullf = indir f + r <- catchMaybeIO $ getSymbolicLinkStatus fullf + case r of + Nothing -> return () + Just s + | Files.isDirectory s -> recurse fullf + | Files.isSymbolicLink s -> addsymlink <@> f + | Files.isRegularFile s -> add <@> f + | otherwise -> return () - go (Created { isDirectory = False }) = noop - go (Created { filePath = subdir }) = Just recurse <@> subdir - go (Closed { maybeFilePath = Just f }) = add <@> f - go (MovedIn { isDirectory = False, filePath = f }) = add <@> f - go (MovedOut { isDirectory = False, filePath = f }) = del <@> f - go (Deleted { isDirectory = False, filePath = f }) = del <@> f + -- Ignore creation events for regular files, which won't be + -- done being written when initially created, but handle for + -- directories and symlinks. + go (Created { isDirectory = isd, filePath = f }) + | isd = recurse $ indir f + | isJust addsymlink = + whenM (filetype Files.isSymbolicLink f) $ + addsymlink <@> f + | otherwise = noop + -- Closing a file is assumed to mean it's done being written. + go (Closed { isDirectory = False, maybeFilePath = Just f }) = + whenM (filetype Files.isRegularFile f) $ + add <@> f + -- When a file or directory is moved in, walk it to add new + -- stuff. + go (MovedIn { filePath = f }) = walk f + go (MovedOut { isDirectory = isd, filePath = f }) + | isd = deldir <@> f + | otherwise = del <@> f + -- Verify that the deleted item really doesn't exist, + -- since there can be spurious deletion events for items + -- in a directory that has been moved out, but is still + -- being watched. + go (Deleted { isDirectory = isd, filePath = f }) + | isd = guarded $ deldir <@> f + | otherwise = guarded $ del <@> f + where + guarded = unlessM (filetype (const True) f) go _ = noop - - Just a <@> f = a $ dir </> f + + Just a <@> f = a $ indir f Nothing <@> _ = noop -{- Pauses the main thread, letting children run until program termination. -} -waitForTermination :: IO () -waitForTermination = do - mv <- newEmptyMVar - check softwareTermination mv - whenM (queryTerminal stdInput) $ - check keyboardSignal mv - takeMVar mv - where - check sig mv = void $ - installHandler sig (CatchOnce $ putMVar mv ()) Nothing + indir f = dir </> f + + filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) diff --git a/Utility/ThreadLock.hs b/Utility/ThreadLock.hs new file mode 100644 index 000000000..4285c0ec5 --- /dev/null +++ b/Utility/ThreadLock.hs @@ -0,0 +1,35 @@ +{- locking between threads + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.ThreadLock where + +import Common + +import System.Posix.Terminal +import Control.Concurrent.MVar +import System.Posix.Signals + +type Lock = MVar () + +newLock :: IO Lock +newLock = newMVar () + +{- Runs an action with a lock held, so only one thread at a time can run it. -} +withLock :: Lock -> IO a -> IO a +withLock lock = withMVar lock . const + +{- Pauses the main thread, letting children run until program termination. -} +waitForTermination :: IO () +waitForTermination = do + lock <- newEmptyMVar + check softwareTermination lock + whenM (queryTerminal stdInput) $ + check keyboardSignal lock + takeMVar lock + where + check sig lock = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing diff --git a/debian/control b/debian/control index 2510e2b33..bfb0017bc 100644 --- a/debian/control +++ b/debian/control @@ -20,6 +20,7 @@ Build-Depends: libghc-ifelse-dev, libghc-bloomfilter-dev, libghc-edit-distance-dev, + libghc-hinotify-dev, ikiwiki, perlmagick, git, diff --git a/doc/install.mdwn b/doc/install.mdwn index fe0522aa0..ec3a7b013 100644 --- a/doc/install.mdwn +++ b/doc/install.mdwn @@ -41,6 +41,7 @@ To build and use git-annex, you will need: * [IfElse](http://hackage.haskell.org/package/IfElse) * [bloomfilter](http://hackage.haskell.org/package/bloomfilter) * [edit-distance](http://hackage.haskell.org/package/edit-distance) + * [hinotify](http://hackage.haskell.org/package/hinotify) * Shell commands * [git](http://git-scm.com/) * [uuid](http://www.ossp.org/pkg/lib/uuid/) diff --git a/git-annex.cabal b/git-annex.cabal index c15167831..114a4069f 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -35,7 +35,8 @@ Executable git-annex unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, base == 4.5.*, monad-control, transformers-base, lifted-base, - IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance + IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, + hinotify Other-Modules: Utility.Touch C-Sources: Utility/libdiskfree.c Extensions: CPP |