diff options
author | Joey Hess <joey@kitenet.net> | 2010-11-11 17:58:55 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2010-11-11 17:58:55 -0400 |
commit | ce62f5abf16e578f9f4b86cd140ea2ddfb1e4217 (patch) | |
tree | d50e4c639c2eb5a16ff292827378608f4ee6d68d | |
parent | b5ce88dd2aa2d6cc5eac6fd014f94d387c38bce0 (diff) |
rework command dispatching for add and pre-commit
Both subcommands do two different operations on different sets of files, so
allowing a subcommand to perform a list of operations cleans things up.
-rw-r--r-- | CmdLine.hs | 57 | ||||
-rw-r--r-- | Command.hs | 6 | ||||
-rw-r--r-- | Command/Lock.hs | 28 | ||||
-rw-r--r-- | Command/PreCommit.hs | 42 | ||||
-rw-r--r-- | Core.hs | 14 | ||||
-rw-r--r-- | debian/changelog | 8 |
6 files changed, 84 insertions, 71 deletions
diff --git a/CmdLine.hs b/CmdLine.hs index 7e6626573..7c9d75c18 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -17,6 +17,7 @@ import qualified Annex import Locations import qualified Backend import Types +import Core import Command import qualified Command.Add @@ -36,35 +37,37 @@ import qualified Command.PreCommit subCmds :: [SubCommand] subCmds = - [ SubCommand "add" path (withFilesToAdd Command.Add.start) + [ SubCommand "add" path [withFilesNotInGit Command.Add.start, + withFilesUnlocked Command.Add.start] "add files to annex" - , SubCommand "get" path (withFilesInGit Command.Get.start) + , SubCommand "get" path [withFilesInGit Command.Get.start] "make content of annexed files available" - , SubCommand "drop" path (withFilesInGit Command.Drop.start) + , SubCommand "drop" path [withFilesInGit Command.Drop.start] "indicate content of files not currently wanted" - , SubCommand "move" path (withFilesInGit Command.Move.start) + , SubCommand "move" path [withFilesInGit Command.Move.start] "transfer content of files to/from another repository" - , SubCommand "unlock" path (withFilesInGit Command.Unlock.start) + , SubCommand "unlock" path [withFilesInGit Command.Unlock.start] "unlock files for modification" - , SubCommand "edit" path (withFilesInGit Command.Unlock.start) + , SubCommand "edit" path [withFilesInGit Command.Unlock.start] "same as unlock" - , SubCommand "lock" path (withFilesInGit Command.Lock.start) + , SubCommand "lock" path [withFilesUnlocked Command.Lock.start] "undo unlock command" - , SubCommand "init" desc (withDescription Command.Init.start) + , SubCommand "init" desc [withDescription Command.Init.start] "initialize git-annex with repository description" - , SubCommand "unannex" path (withFilesInGit Command.Unannex.start) + , SubCommand "unannex" path [withFilesInGit Command.Unannex.start] "undo accidential add command" - , SubCommand "pre-commit" path (withFilesToBeCommitted Command.PreCommit.start) + , SubCommand "pre-commit" path [withFilesToBeCommitted Command.Fix.start, + withUnlockedFilesToBeCommitted Command.PreCommit.start] "run by git pre-commit hook" - , SubCommand "fromkey" key (withFilesMissing Command.FromKey.start) + , SubCommand "fromkey" key [withFilesMissing Command.FromKey.start] "adds a file using a specific key" - , SubCommand "dropkey" key (withKeys Command.DropKey.start) + , SubCommand "dropkey" key [withKeys Command.DropKey.start] "drops annexed content for specified keys" - , SubCommand "setkey" key (withTempFile Command.SetKey.start) + , SubCommand "setkey" key [withTempFile Command.SetKey.start] "sets annexed content for a key using a temp file" - , SubCommand "fix" path (withFilesInGit Command.Fix.start) + , SubCommand "fix" path [withFilesInGit Command.Fix.start] "fix up symlinks to point to annexed content" - , SubCommand "fsck" nothing (withNothing Command.Fsck.start) + , SubCommand "fsck" nothing [withNothing Command.Fsck.start] "check annex for problems" ] where @@ -128,12 +131,17 @@ withFilesMissing a params = do missing f = do e <- doesFileExist f return $ not e -withFilesToAdd :: SubCmdSeekBackendFiles -withFilesToAdd a params = do +withFilesNotInGit :: SubCmdSeekBackendFiles +withFilesNotInGit a params = do repo <- Annex.gitRepo newfiles <- liftIO $ mapM (Git.notInRepo repo) params - unlockedfiles <- liftIO $ mapM (Git.typeChangedFiles repo) params - let files = foldl (++) [] $ newfiles ++ unlockedfiles + backendPairs a $ foldl (++) [] newfiles +withFilesUnlocked :: SubCmdSeekBackendFiles +withFilesUnlocked a params = do + unlocked <- mapM unlockedFiles params + backendPairs a $ foldl (++) [] unlocked +backendPairs :: SubCmdSeekBackendFiles +backendPairs a files = do pairs <- Backend.chooseBackends files return $ map a $ filter (\(f,_) -> notState f) pairs withDescription :: SubCmdSeekStrings @@ -141,8 +149,15 @@ withDescription a params = return [a $ unwords params] withFilesToBeCommitted :: SubCmdSeekStrings withFilesToBeCommitted a params = do repo <- Annex.gitRepo - files <- liftIO $ mapM (Git.stagedFiles repo) params - return $ map a $ filter notState $ foldl (++) [] files + tocommit <- liftIO $ mapM (Git.stagedFiles repo) params + return $ map a $ filter notState $ foldl (++) [] tocommit +withUnlockedFilesToBeCommitted :: SubCmdSeekStrings +withUnlockedFilesToBeCommitted a params = do + repo <- Annex.gitRepo + unlocked <- mapM unlockedFiles params + tocommit <- liftIO $ mapM (Git.stagedFiles repo) $ + filter notState $ foldl (++) [] unlocked + return $ map a $ foldl (++) [] tocommit withKeys :: SubCmdSeekStrings withKeys a params = return $ map a params withTempFile :: SubCmdSeekStrings diff --git a/Command.hs b/Command.hs index f896a53f6..90c4d5385 100644 --- a/Command.hs +++ b/Command.hs @@ -41,7 +41,7 @@ type SubCmdSeekNothing = SubCmdStart -> SubCmdSeek data SubCommand = SubCommand { subcmdname :: String, subcmdparams :: String, - subcmdseek :: SubCmdSeek, + subcmdseek :: [SubCmdSeek], subcmddesc :: String } @@ -49,8 +49,8 @@ data SubCommand = SubCommand { - the parameters passed to it. -} prepSubCmd :: SubCommand -> AnnexState -> [String] -> IO [Annex Bool] prepSubCmd SubCommand { subcmdseek = seek } state params = do - list <- Annex.eval state $ seek params - return $ map doSubCmd list + lists <- Annex.eval state $ mapM (\s -> s params) seek + return $ map doSubCmd $ foldl (++) [] lists {- Runs a subcommand through the start, perform and cleanup stages -} doSubCmd :: SubCmdStart -> SubCmdCleanup diff --git a/Command/Lock.hs b/Command/Lock.hs index 6ae59221c..f03d6b6c8 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -9,23 +9,17 @@ module Command.Lock where import Control.Monad.State (liftIO) import System.Directory -import System.Posix.Files -import Types import Command import Messages import qualified Annex import qualified GitRepo as Git {- Undo unlock -} -start :: SubCmdStartString -start file = do - locked <- isLocked file - if locked - then return Nothing - else do - showStart "lock" file - return $ Just $ perform file +start :: SubCmdStartBackendFile +start (file, _) = do + showStart "lock" file + return $ Just $ perform file perform :: FilePath -> SubCmdPerform perform file = do @@ -36,17 +30,3 @@ perform file = do -- checkout the symlink liftIO $ Git.run g ["checkout", "--", file] return $ Just $ return True -- no cleanup needed - -{- Checks if a file is unlocked for edit. -} -isLocked :: FilePath -> Annex Bool -isLocked file = do - -- check if it's a symlink first, as that's cheapest - s <- liftIO $ getSymbolicLinkStatus file - if (isSymbolicLink s) - then return True -- Symlinked files are always locked. - else do - -- Not a symlink, so see if the type has changed, - -- if so it is presumed to have been unlocked. - g <- Annex.gitRepo - typechanged <- liftIO $ Git.typeChangedFiles g file - return $ not $ elem file typechanged diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 72cece8d5..b3b940cdd 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -8,34 +8,32 @@ module Command.PreCommit where import Control.Monad.State (liftIO) -import Control.Monad (when, unless) import Command import qualified Annex import qualified Backend import qualified GitRepo as Git -import qualified Command.Fix -import qualified Command.Lock import qualified Command.Add -{- Run by git pre-commit hook. -} +{- Run by git pre-commit hook; passed unlocked files that are being + - committed. -} start :: SubCmdStartString -start file = do - -- If a file is unlocked for edit, add its new content to the - -- annex. -} - locked <- Command.Lock.isLocked file - when (not locked) $ do - pairs <- Backend.chooseBackends [file] - ok <- doSubCmd $ Command.Add.start $ pairs !! 0 - unless (ok) $ do - error $ "failed to add " ++ file ++ "; canceling commit" - -- git commit will have staged the file's content; - -- drop that and run command queued by Add.state to - -- stage the symlink - g <- Annex.gitRepo - liftIO $ Git.run g ["reset", "-q", "--", file] - Annex.queueRun +start file = return $ Just $ perform file - -- Fix symlinks as they are committed, this ensures the - -- relative links are not broken when moved around. - Command.Fix.start file +perform :: FilePath -> SubCmdPerform +perform file = do + pairs <- Backend.chooseBackends [file] + ok <- doSubCmd $ Command.Add.start $ pairs !! 0 + if ok + then return $ Just $ cleanup file + else error $ "failed to add " ++ file ++ "; canceling commit" + +cleanup :: FilePath -> SubCmdCleanup +cleanup file = do + -- git commit will have staged the file's content; + -- drop that and run command queued by Add.state to + -- stage the symlink + g <- Annex.gitRepo + liftIO $ Git.run g ["reset", "-q", "--", file] + Annex.queueRun + return True @@ -224,6 +224,20 @@ getKeysReferenced = do keypairs <- mapM Backend.lookupFile files return $ map fst $ catMaybes keypairs +{- Passed a location (a directory or a single file, returns + - files there that are unlocked for editing. -} +unlockedFiles :: FilePath -> Annex [FilePath] +unlockedFiles l = do + -- unlocked files have changed type from a symlink to a regular file + g <- Annex.gitRepo + typechangedfiles <- liftIO $ Git.typeChangedFiles g l + unlockedfiles <- filterM notsymlink typechangedfiles + return unlockedfiles + where + notsymlink f = do + s <- liftIO $ getSymbolicLinkStatus f + return $ not $ isSymbolicLink s + {- Uses the annex.version git config setting to automate upgrades. -} autoUpgrade :: Annex () autoUpgrade = do diff --git a/debian/changelog b/debian/changelog index a4c8bceac..f705bfaf5 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,12 @@ git-annex (0.05) UNRELEASED; urgency=low - * Optimize both pre-commit and lock subcommands. + * Optimize both pre-commit and lock subcommands to not call git diff + on every file being committed or locked. + (This actually also works around a bug in ghc 6.12.1, that caused + git-annex 0.04 pre-commit to sometimes corrupt filenames and fail. + The excessive number of calls made by pre-commit exposed the ghc bug. + Thanks Josh Triplett for the debugging.) + * Build with -O3. -- Joey Hess <joeyh@debian.org> Thu, 11 Nov 2010 14:52:05 -0400 |