diff options
| -rw-r--r-- | Annex.hs | 3 | ||||
| -rw-r--r-- | Annex/Branch.hs | 4 | ||||
| -rw-r--r-- | Annex/Content.hs | 2 | ||||
| -rw-r--r-- | Annex/Queue.hs | 2 | ||||
| -rw-r--r-- | Command/Add.hs | 56 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 2 | ||||
| -rw-r--r-- | Command/Watch.hs | 150 | ||||
| -rw-r--r-- | Git/FilePath.hs | 34 | ||||
| -rw-r--r-- | Git/Queue.hs | 28 | ||||
| -rw-r--r-- | Git/Types.hs | 8 | ||||
| -rw-r--r-- | Git/UnionMerge.hs | 3 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 15 | ||||
| -rw-r--r-- | GitAnnex.hs | 2 | ||||
| -rw-r--r-- | Utility/Directory.hs | 7 | ||||
| -rw-r--r-- | Utility/Inotify.hs | 199 | ||||
| -rw-r--r-- | Utility/ThreadLock.hs | 35 | ||||
| -rw-r--r-- | debian/changelog | 3 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | doc/git-annex.mdwn | 7 | ||||
| -rw-r--r-- | doc/install.mdwn | 1 | ||||
| -rw-r--r-- | git-annex.cabal | 3 | ||||
| -rw-r--r-- | git-union-merge.hs | 2 |
22 files changed, 462 insertions, 105 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/Branch.hs b/Annex/Branch.hs index c8d0719b0..1dacd5f32 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -35,6 +35,8 @@ import qualified Git.Branch import qualified Git.UnionMerge import qualified Git.UpdateIndex import Git.HashObject +import Git.Types +import Git.FilePath import qualified Git.Index import Annex.CatFile import Annex.Perms @@ -344,5 +346,5 @@ stageJournal = do let path = dir </> file sha <- hashFile h path _ <- streamer $ Git.UpdateIndex.update_index_line - sha (fileJournal file) + sha FileBlob (asTopFilePath $ fileJournal file) removeFile path diff --git a/Annex/Content.hs b/Annex/Content.hs index 26b332e24..232b43b2c 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -168,7 +168,7 @@ withTmp :: Key -> (FilePath -> Annex a) -> Annex a withTmp key action = do tmp <- prepTmp key res <- action tmp - liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp + liftIO $ nukeFile tmp return res {- Checks that there is disk space available to store a given key, 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/Add.hs b/Command/Add.hs index 2c671eea2..ea0f85033 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -50,34 +50,40 @@ start file = notBareRepo $ ifAnnexed file fixup add - to prevent it from being modified in between. It's hard linked into a - temporary location, and its writable bits are removed. It could still be - written to by a process that already has it open for writing. -} -perform :: FilePath -> CommandPerform -perform file = do +lockDown :: FilePath -> Annex FilePath +lockDown file = do liftIO $ preventWrite file tmp <- fromRepo gitAnnexTmpDir createAnnexDirectory tmp pid <- liftIO getProcessID let tmpfile = tmp </> "add" ++ show pid ++ "." ++ takeFileName file - nuke tmpfile + liftIO $ nukeFile tmpfile liftIO $ createLink file tmpfile + return tmpfile + +{- Moves the file into the annex. -} +ingest :: FilePath -> Annex (Maybe Key) +ingest file = do + tmpfile <- lockDown file let source = KeySource { keyFilename = file, contentLocation = tmpfile } backend <- chooseBackend file genKey source backend >>= go tmpfile where - go _ Nothing = stop + go _ Nothing = return Nothing go tmpfile (Just (key, _)) = do handle (undo file key) $ moveAnnex key tmpfile - nuke file - next $ cleanup file key True + liftIO $ nukeFile file + return $ Just key -nuke :: FilePath -> Annex () -nuke file = liftIO $ whenM (doesFileExist file) $ removeFile file +perform :: FilePath -> CommandPerform +perform file = maybe stop (\key -> next $ cleanup file key True) =<< ingest file {- On error, put the file back so it doesn't seem to have vanished. - This can be called before or after the symlink is in place. -} undo :: FilePath -> Key -> IOException -> Annex a undo file key e = do whenM (inAnnex key) $ do - nuke file + liftIO $ nukeFile file handle tryharder $ fromAnnex key file logStatus key InfoMissing throw e @@ -88,21 +94,29 @@ undo file key e = do src <- inRepo $ gitAnnexLocation key liftIO $ moveFile src file -cleanup :: FilePath -> Key -> Bool -> CommandCleanup -cleanup file key hascontent = do - handle (undo file key) $ do - link <- calcGitLink file key - liftIO $ createSymbolicLink link file +{- Creates the symlink to the annexed content, and also returns the link's + - text. -} +link :: FilePath -> Key -> Bool -> Annex FilePath +link file key hascontent = handle (undo file key) $ do + l <- calcGitLink file key + liftIO $ createSymbolicLink l file - when hascontent $ do - logStatus key InfoPresent + when hascontent $ do + logStatus key InfoPresent - -- touch the symlink to have the same mtime as the - -- file it points to - liftIO $ do - mtime <- modificationTime <$> getFileStatus file - touch file (TimeSpec mtime) False + -- touch the symlink to have the same mtime as the + -- file it points to + liftIO $ do + mtime <- modificationTime <$> getFileStatus file + touch file (TimeSpec mtime) False + + return l +{- Note: Several other commands call this, and expect it to + - create the symlink and add it. -} +cleanup :: FilePath -> Key -> Bool -> CommandCleanup +cleanup file key hascontent = do + _ <- link file key hascontent params <- ifM (Annex.getState Annex.force) ( return [Param "-f"] , return [] diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index a94c2873d..597a4eec0 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -40,5 +40,5 @@ perform key = maybe droplocal dropremote =<< Remote.byName =<< from performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do f <- fromRepo $ filespec key - liftIO $ whenM (doesFileExist f) $ removeFile f + liftIO $ nukeFile f next $ return True diff --git a/Command/Watch.hs b/Command/Watch.hs new file mode 100644 index 000000000..046fca7d1 --- /dev/null +++ b/Command/Watch.hs @@ -0,0 +1,150 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +module Command.Watch where + +import Common.Annex +import Command +import Utility.Inotify +import Utility.ThreadLock +import qualified Annex +import qualified Command.Add +import qualified Git +import qualified Git.Command +import qualified Git.UpdateIndex +import Git.HashObject +import Git.Types +import Git.FilePath +import qualified Backend +import Annex.Content + +import Control.Exception as E +import Control.Concurrent.MVar + +#if defined linux_HOST_OS +import System.INotify +#endif + +def :: [Command] +def = [command "watch" paramPaths seek "watch for changes"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +#if defined linux_HOST_OS +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 + let hooks = WatchHooks + { addHook = hook onAdd + , delHook = hook onDel + , addSymlinkHook = hook onAddSymlink + , delDirHook = hook onDelDir + , errHook = hook onErr + } + watchDir i "." (ignored . takeFileName) hooks + putStrLn "(started)" + waitForTermination + return True +#else +start = error "watch mode is so far only available on Linux" +#endif + +ignored :: FilePath -> Bool +ignored ".git" = True +ignored ".gitignore" = True +ignored ".gitattributes" = True +ignored _ = False + +{- 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 tricky; the file has to be replaced with a symlink + - but this is race prone, as the symlink could be changed immediately + - after creation. To avoid that race, git add is not used to stage the + - symlink. -} +onAdd :: FilePath -> Annex () +onAdd file = do + showStart "add" file + Command.Add.ingest file >>= go + where + go Nothing = showEndFail + go (Just key) = do + link <- Command.Add.link file key True + inRepo $ stageSymlink file link + showEndOk + +{- 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 =<< liftIO (readSymbolicLink file) + go (Just (key, _)) = do + link <- calcGitLink file key + ifM ((==) link <$> liftIO (readSymbolicLink file)) + ( addlink link + , do + liftIO $ removeFile file + liftIO $ createSymbolicLink link file + addlink link + ) + addlink link = inRepo $ stageSymlink file link + +{- The file could reappear at any time, so --cached is used, to only delete + - it from the index. -} +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] + +{- Called when there's an error with inotify. -} +onErr :: String -> Annex () +onErr = warning + +{- Adds a symlink to the index, without ever accessing the actual symlink + - on disk. -} +stageSymlink :: FilePath -> String -> Git.Repo -> IO () +stageSymlink file linktext repo = Git.UpdateIndex.stream_update_index repo [stage] + where + stage streamer = do + line <- Git.UpdateIndex.update_index_line + <$> (hashObject repo BlobObject linktext) + <*> pure SymlinkBlob + <*> toTopFilePath file repo + streamer line diff --git a/Git/FilePath.hs b/Git/FilePath.hs new file mode 100644 index 000000000..6344353d6 --- /dev/null +++ b/Git/FilePath.hs @@ -0,0 +1,34 @@ +{- git FilePath library + - + - Different git commands use different types of FilePaths to refer to + - files in the repository. Some commands use paths relative to the + - top of the repository even when run in a subdirectory. Adding some + - types helps keep that straight. + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.FilePath ( + TopFilePath, + getTopFilePath, + toTopFilePath, + asTopFilePath, +) where + +import Common +import Git + +{- A FilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } + +{- The input FilePath can be absolute, or relative to the CWD. -} +toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath <$> + relPathDirToFile (repoPath repo) <$> absPath file + +{- The input FilePath must already be relative to the top of the git + - repository -} +asTopFilePath :: FilePath -> TopFilePath +asTopFilePath file = TopFilePath file 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/Git/Types.hs b/Git/Types.hs index 64d418a04..1df6e343b 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -63,3 +63,11 @@ readObjectType "commit" = Just CommitObject readObjectType "tree" = Just TreeObject readObjectType _ = Nothing +{- Types of blobs. -} +data BlobType = FileBlob | ExecutableBlob | SymlinkBlob + +{- Git uses magic numbers to denote the type of a blob. -} +instance Show BlobType where + show FileBlob = "100644" + show ExecutableBlob = "100755" + show SymlinkBlob = "120000" diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 822e6abbf..f65b59c53 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -22,6 +22,7 @@ import Git.Command import Git.UpdateIndex import Git.HashObject import Git.Types +import Git.FilePath {- Performs a union merge between two branches, staging it in the index. - Any previously staged changes in the index will be lost. @@ -79,7 +80,7 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of [_colonmode, _bmode, asha, bsha, _status] = words info getcontents s = map L.unpack . L.lines . L.decodeUtf8 <$> catObject h s - use sha = return $ Just $ update_index_line sha file + use sha = return $ Just $ update_index_line sha FileBlob $ asTopFilePath file {- Calculates a union merge between a list of refs, with contents. - diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 04bc4da5b..8c003dd13 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -8,15 +8,17 @@ module Git.UpdateIndex ( Streamer, stream_update_index, + ls_tree, update_index_line, - ls_tree ) where import System.Cmd.Utils import Common import Git +import Git.Types import Git.Command +import Git.FilePath {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} @@ -37,13 +39,14 @@ stream_update_index repo as = do hPutStr h s hPutStr h "\0" -{- Generates a line suitable to be fed into update-index, to add - - a given file with a given sha. -} -update_index_line :: Sha -> FilePath -> String -update_index_line sha file = "100644 blob " ++ show sha ++ "\t" ++ file - {- Gets the current tree for a ref. -} ls_tree :: Ref -> Repo -> Streamer ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo where params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] + +{- Generates a line suitable to be fed into update-index, to add + - a given file with a given sha. -} +update_index_line :: Sha -> BlobType -> TopFilePath -> String +update_index_line sha filetype file = + show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file 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/Directory.hs b/Utility/Directory.hs index 5bfd49a9c..52f2396d7 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -88,6 +88,13 @@ moveFile src dest = tryIO (rename src dest) >>= onrename (Left _) -> return False (Right s) -> return $ isDirectory s +{- Removes a file, which may or may not exist. + - + - Note that an exception is thrown if the file exists but + - cannot be removed. -} +nukeFile :: FilePath -> IO () +nukeFile file = whenM (doesFileExist file) $ removeFile file + {- Runs an action in another directory. -} bracketCd :: FilePath -> IO a -> IO a bracketCd dir a = go =<< getCurrentDirectory diff --git a/Utility/Inotify.hs b/Utility/Inotify.hs index d41e997d6..7329b5122 100644 --- a/Utility/Inotify.hs +++ b/Utility/Inotify.hs @@ -1,27 +1,34 @@ -{-# LANGUAGE CPP #-} +{- higher-level inotify interface + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} 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 +import System.IO.Error +import Control.Exception (throw) + +type Hook a = Maybe (a -> IO ()) + +data WatchHooks = WatchHooks + { addHook :: Hook FilePath + , addSymlinkHook :: Hook FilePath + , delHook :: Hook FilePath + , delDirHook :: Hook FilePath + , errHook :: Hook String -- error message + } {- 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 +44,127 @@ 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. The + - errHook is called when this happens. -} -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) -> WatchHooks -> IO () +watchDir i dir ignored hooks + | ignored dir = noop + | otherwise = do + lock <- newLock + let handler event = withLock lock (void $ go event) + void (addWatch i watchevents dir handler) + `catchIO` failedaddwatch + 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 = watchDir' scan i test add del - walk f = ifM (catchBoolIO $ Files.isDirectory <$> getFileStatus f) - ( recurse f - , when (scan && isJust add) $ fromJust add f - ) - - 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 + recurse d = watchDir i d ignored hooks + + -- Select only inotify events required by the enabled + -- hooks, but always include Create so new directories can + -- be walked. + watchevents = Create : addevents ++ delevents + addevents + | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite] + | otherwise = [] + delevents + | hashook delHook || hashook delDirHook = [MoveOut, Delete] + | otherwise = [] + + walk f = unless (ignored 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 -> addSymlinkHook <@> f + | Files.isRegularFile s -> addHook <@> f + | otherwise -> return () + + -- 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 + | hashook addSymlinkHook = + whenM (filetype Files.isSymbolicLink f) $ + addSymlinkHook <@> 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) $ + addHook <@> 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 = delDirHook <@> f + | otherwise = delHook <@> 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 $ delDirHook <@> f + | otherwise = guarded $ delHook <@> f + where + guarded = unlessM (filetype (const True) f) go _ = noop - - Just a <@> f = a $ dir </> 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 + + hashook h = isJust $ h hooks + + h <@> f + | ignored f = noop + | otherwise = maybe noop (\a -> a $ indir f) (h hooks) + + indir f = dir </> f + + filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) + + -- Inotify fails when there are too many watches with a + -- disk full error. + failedaddwatch e + | isFullError e = + case errHook hooks of + Nothing -> throw e + Just hook -> tooManyWatches hook dir + | otherwise = throw e + +tooManyWatches :: (String -> IO ()) -> FilePath -> IO () +tooManyWatches hook dir = do + sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) + hook $ unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval + where + maxwatches = "fs.inotify.max_user_watches" + basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" + withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] + withsysctl n = let new = n * 10 in + [ "Increase the limit permanently by running:" + , " echo " ++ maxwatches ++ "=" ++ show new ++ + " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p" + , "Or temporarily by running:" + , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new + ] + +querySysctl :: Read a => [CommandParam] -> IO (Maybe a) +querySysctl ps = do + v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps + case v of + Nothing -> return Nothing + Just (pid, h) -> do + val <- parsesysctl <$> hGetContentsStrict h + void $ getProcessStatus True False $ processID pid + return val where - check sig mv = void $ - installHandler sig (CatchOnce $ putMVar mv ()) Nothing + parsesysctl s = readish =<< lastMaybe (words s) 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/changelog b/debian/changelog index 8a734e0aa..8c2c68119 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,5 +1,8 @@ git-annex (3.20120606) UNRELEASED; urgency=low + * watch: New subcommand, which uses inotify to watch for changes to + files and automatically annexes new files, etc, so you don't need + to manually run git commands when manipulating files. * add: Prevent (most) modifications from being made to a file while it is being added to the annex. * initremote: Automatically describe a remote when creating it. 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/git-annex.mdwn b/doc/git-annex.mdwn index c7de59cd2..c1d8015ab 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -169,6 +169,13 @@ subdirectories). git annex import /media/camera/DCIM/ +* watch + + Watches for changes to files in the current directory and its subdirectories, + and takes care of automatically adding new files, as well as dealing with + deleted, copied, and moved files. Run this in the background, and you + no longer need to manually run git commands when manipulating your files. + # REPOSITORY SETUP COMMANDS * init [description] 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 diff --git a/git-union-merge.hs b/git-union-merge.hs index 2c2e7a46b..0e4cd644c 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -28,7 +28,7 @@ setup :: Git.Repo -> IO () setup = cleanup -- idempotency cleanup :: Git.Repo -> IO () -cleanup g = whenM (doesFileExist $ tmpIndex g) $ removeFile $ tmpIndex g +cleanup g = nukeFile $ tmpIndex g parseArgs :: IO [String] parseArgs = do |