From da0de293d16ace6aac574d0cdc37ec41715b7d66 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 11 Nov 2010 18:54:52 -0400 Subject: refactor param seeking --- CmdLine.hs | 101 ++++++++------------------------------------------- Command.hs | 70 ++++++++++++++++++++++++++++++++++- Command/Add.hs | 4 ++ Command/Drop.hs | 3 ++ Command/DropKey.hs | 3 ++ Command/Fix.hs | 3 ++ Command/FromKey.hs | 3 ++ Command/Fsck.hs | 3 ++ Command/Get.hs | 3 ++ Command/Init.hs | 3 ++ Command/Lock.hs | 3 ++ Command/Move.hs | 5 ++- Command/PreCommit.hs | 9 ++++- Command/SetKey.hs | 3 ++ Command/Unannex.hs | 3 ++ Command/Unlock.hs | 3 ++ debian/changelog | 9 +++-- 17 files changed, 138 insertions(+), 93 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index 93404e546..efa541ebc 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -8,15 +8,9 @@ module CmdLine (parseCmd) where import System.Console.GetOpt -import Control.Monad.State (liftIO) -import System.Directory -import System.Posix.Files -import Control.Monad (filterM, when) +import Control.Monad (when) -import qualified GitRepo as Git import qualified Annex -import Locations -import qualified Backend import Types import Command @@ -37,37 +31,35 @@ import qualified Command.PreCommit subCmds :: [SubCommand] subCmds = - [ SubCommand "add" path [withFilesNotInGit Command.Add.start, - withFilesUnlocked Command.Add.start] + [ SubCommand "add" path Command.Add.seek "add files to annex" - , SubCommand "get" path [withFilesInGit Command.Get.start] + , SubCommand "get" path Command.Get.seek "make content of annexed files available" - , SubCommand "drop" path [withFilesInGit Command.Drop.start] + , SubCommand "drop" path Command.Drop.seek "indicate content of files not currently wanted" - , SubCommand "move" path [withFilesInGit Command.Move.start] + , SubCommand "move" path Command.Move.seek "transfer content of files to/from another repository" - , SubCommand "unlock" path [withFilesInGit Command.Unlock.start] + , SubCommand "unlock" path Command.Unlock.seek "unlock files for modification" - , SubCommand "edit" path [withFilesInGit Command.Unlock.start] + , SubCommand "edit" path Command.Unlock.seek "same as unlock" - , SubCommand "lock" path [withFilesUnlocked Command.Lock.start] + , SubCommand "lock" path Command.Lock.seek "undo unlock command" - , SubCommand "init" desc [withDescription Command.Init.start] + , SubCommand "init" desc Command.Init.seek "initialize git-annex with repository description" - , SubCommand "unannex" path [withFilesInGit Command.Unannex.start] + , SubCommand "unannex" path Command.Unannex.seek "undo accidential add command" - , SubCommand "pre-commit" path [withFilesToBeCommitted Command.Fix.start, - withUnlockedFilesToBeCommitted Command.PreCommit.start] + , SubCommand "pre-commit" path Command.PreCommit.seek "run by git pre-commit hook" - , SubCommand "fromkey" key [withFilesMissing Command.FromKey.start] + , SubCommand "fromkey" key Command.FromKey.seek "adds a file using a specific key" - , SubCommand "dropkey" key [withKeys Command.DropKey.start] + , SubCommand "dropkey" key Command.DropKey.seek "drops annexed content for specified keys" - , SubCommand "setkey" key [withTempFile Command.SetKey.start] + , SubCommand "setkey" key Command.SetKey.seek "sets annexed content for a key using a temp file" - , SubCommand "fix" path [withFilesInGit Command.Fix.start] + , SubCommand "fix" path Command.Fix.seek "fix up symlinks to point to annexed content" - , SubCommand "fsck" nothing [withNothing Command.Fsck.start] + , SubCommand "fsck" nothing Command.Fsck.seek "check annex for problems" ] where @@ -116,67 +108,6 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs indent l = " " ++ l pad n s = replicate (n - length s) ' ' -{- These functions find appropriate files or other things based on a - user's parameters, and run a specified action on them. -} -withFilesInGit :: SubCmdSeekStrings -withFilesInGit a params = do - repo <- Annex.gitRepo - files <- liftIO $ mapM (Git.inRepo repo) params - return $ map a $ filter notState $ foldl (++) [] files -withFilesMissing :: SubCmdSeekStrings -withFilesMissing a params = do - files <- liftIO $ filterM missing params - return $ map a $ filter notState files - where - missing f = do - e <- doesFileExist f - return $ not e -withFilesNotInGit :: SubCmdSeekBackendFiles -withFilesNotInGit a params = do - repo <- Annex.gitRepo - newfiles <- liftIO $ mapM (Git.notInRepo repo) params - backendPairs a $ filter notState $ foldl (++) [] newfiles -withFilesUnlocked :: SubCmdSeekBackendFiles -withFilesUnlocked a params = do - -- unlocked files have changed type from a symlink to a regular file - repo <- Annex.gitRepo - typechangedfiles <- liftIO $ mapM (Git.typeChangedFiles repo) params - unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles - backendPairs a $ filter notState unlockedfiles -backendPairs :: SubCmdSeekBackendFiles -backendPairs a files = do - pairs <- Backend.chooseBackends files - return $ map a pairs -withDescription :: SubCmdSeekStrings -withDescription a params = return [a $ unwords params] -withFilesToBeCommitted :: SubCmdSeekStrings -withFilesToBeCommitted a params = do - repo <- Annex.gitRepo - tocommit <- liftIO $ mapM (Git.stagedFiles repo) params - return $ map a $ filter notState $ foldl (++) [] tocommit -withUnlockedFilesToBeCommitted :: SubCmdSeekStrings -withUnlockedFilesToBeCommitted a params = do - repo <- Annex.gitRepo - typechangedfiles <- liftIO $ mapM (Git.typeChangedStagedFiles repo) params - unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles - return $ map a $ filter notState unlockedfiles -withKeys :: SubCmdSeekStrings -withKeys a params = return $ map a params -withTempFile :: SubCmdSeekStrings -withTempFile a params = return $ map a params -withNothing :: SubCmdSeekNothing -withNothing a _ = return [a] - -{- filter out files from the state directory -} -notState :: FilePath -> Bool -notState f = stateLoc /= take (length stateLoc) f - -{- filter out symlinks -} -notSymlink :: FilePath -> IO Bool -notSymlink f = do - s <- liftIO $ getSymbolicLinkStatus f - return $ not $ isSymbolicLink s - {- Parses command line and returns two lists of actions to be - run in the Annex monad. The first actions configure it - according to command line options, while the second actions diff --git a/Command.hs b/Command.hs index 90c4d5385..21d636463 100644 --- a/Command.hs +++ b/Command.hs @@ -1,4 +1,4 @@ -{- git-annex command types +{- git-annex commands - - Copyright 2010 Joey Hess - @@ -7,10 +7,17 @@ module Command where +import Control.Monad.State (liftIO) +import System.Directory +import System.Posix.Files +import Control.Monad (filterM) + import Types import qualified Backend import Messages import qualified Annex +import qualified GitRepo as Git +import Locations {- A subcommand runs in four stages. - @@ -87,3 +94,64 @@ isAnnexed file a = do case (r) of Just v -> a v Nothing -> return Nothing + +{- These functions find appropriate files or other things based on a + user's parameters, and run a specified action on them. -} +withFilesInGit :: SubCmdSeekStrings +withFilesInGit a params = do + repo <- Annex.gitRepo + files <- liftIO $ mapM (Git.inRepo repo) params + return $ map a $ filter notState $ foldl (++) [] files +withFilesMissing :: SubCmdSeekStrings +withFilesMissing a params = do + files <- liftIO $ filterM missing params + return $ map a $ filter notState files + where + missing f = do + e <- doesFileExist f + return $ not e +withFilesNotInGit :: SubCmdSeekBackendFiles +withFilesNotInGit a params = do + repo <- Annex.gitRepo + newfiles <- liftIO $ mapM (Git.notInRepo repo) params + backendPairs a $ filter notState $ foldl (++) [] newfiles +withFilesUnlocked :: SubCmdSeekBackendFiles +withFilesUnlocked a params = do + -- unlocked files have changed type from a symlink to a regular file + repo <- Annex.gitRepo + typechangedfiles <- liftIO $ mapM (Git.typeChangedFiles repo) params + unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles + backendPairs a $ filter notState unlockedfiles +backendPairs :: SubCmdSeekBackendFiles +backendPairs a files = do + pairs <- Backend.chooseBackends files + return $ map a pairs +withDescription :: SubCmdSeekStrings +withDescription a params = return [a $ unwords params] +withFilesToBeCommitted :: SubCmdSeekStrings +withFilesToBeCommitted a params = do + repo <- Annex.gitRepo + tocommit <- liftIO $ mapM (Git.stagedFiles repo) params + return $ map a $ filter notState $ foldl (++) [] tocommit +withUnlockedFilesToBeCommitted :: SubCmdSeekStrings +withUnlockedFilesToBeCommitted a params = do + repo <- Annex.gitRepo + typechangedfiles <- liftIO $ mapM (Git.typeChangedStagedFiles repo) params + unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles + return $ map a $ filter notState unlockedfiles +withKeys :: SubCmdSeekStrings +withKeys a params = return $ map a params +withTempFile :: SubCmdSeekStrings +withTempFile a params = return $ map a params +withNothing :: SubCmdSeekNothing +withNothing a _ = return [a] + +{- filter out files from the state directory -} +notState :: FilePath -> Bool +notState f = stateLoc /= take (length stateLoc) f + +{- filter out symlinks -} +notSymlink :: FilePath -> IO Bool +notSymlink f = do + s <- liftIO $ getSymbolicLinkStatus f + return $ not $ isSymbolicLink s diff --git a/Command/Add.hs b/Command/Add.hs index 649b466bb..586807b53 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -18,6 +18,10 @@ import Types import Core import Messages +{- Add acts on both files not checked into git yet, and unlocked files. -} +seek :: [SubCmdSeek] +seek = [withFilesNotInGit start, withFilesUnlocked start] + {- The add subcommand annexes a file, storing it in a backend, and then - moving it into the annex directory and setting up the symlink pointing - to its content. -} diff --git a/Command/Drop.hs b/Command/Drop.hs index 48433b14c..1e73d8b82 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -16,6 +16,9 @@ import Types import Core import Messages +seek :: [SubCmdSeek] +seek = [withFilesInGit start] + {- Indicates a file's content is not wanted anymore, and should be removed - if it's safe to do so. -} start :: SubCmdStartString diff --git a/Command/DropKey.hs b/Command/DropKey.hs index e0b20918c..34010481d 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -15,6 +15,9 @@ import Types import Core import Messages +seek :: [SubCmdSeek] +seek = [withKeys start] + {- Drops cached content for a key. -} start :: SubCmdStartString start keyname = do diff --git a/Command/Fix.hs b/Command/Fix.hs index 9db832cc7..323aca95e 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -17,6 +17,9 @@ import Utility import Core import Messages +seek :: [SubCmdSeek] +seek = [withFilesInGit start] + {- Fixes the symlink to an annexed file. -} start :: SubCmdStartString start file = isAnnexed file $ \(key, _) -> do diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 229a93684..f25de23a2 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -20,6 +20,9 @@ import Types import Core import Messages +seek :: [SubCmdSeek] +seek = [withFilesMissing start] + {- Adds a file pointing at a manually-specified key -} start :: SubCmdStartString start file = do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 5405ce120..e5f0debe0 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -14,6 +14,9 @@ import Types import Core import Messages +seek :: [SubCmdSeek] +seek = [withNothing start] + {- Checks the whole annex for problems. -} start :: SubCmdStart start = do diff --git a/Command/Get.hs b/Command/Get.hs index c50b5a377..13d137537 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -13,6 +13,9 @@ import Types import Core import Messages +seek :: [SubCmdSeek] +seek = [withFilesInGit start] + {- Gets an annexed file from one of the backends. -} start :: SubCmdStartString start file = isAnnexed file $ \(key, backend) -> do diff --git a/Command/Init.hs b/Command/Init.hs index fa5725c48..e3b05a83f 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -18,6 +18,9 @@ import UUID import Version import Messages +seek :: [SubCmdSeek] +seek = [withDescription start] + {- Stores description for the repository etc. -} start :: SubCmdStartString start description = do diff --git a/Command/Lock.hs b/Command/Lock.hs index f03d6b6c8..27a030bc2 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -15,6 +15,9 @@ import Messages import qualified Annex import qualified GitRepo as Git +seek :: [SubCmdSeek] +seek = [withFilesUnlocked start] + {- Undo unlock -} start :: SubCmdStartBackendFile start (file, _) = do diff --git a/Command/Move.hs b/Command/Move.hs index e0b079193..7f8f40737 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -11,7 +11,7 @@ import Control.Monad.State (liftIO) import Monad (when) import Command -import Command.Drop +import qualified Command.Drop import qualified Annex import Locations import LocationLog @@ -22,6 +22,9 @@ import qualified Remotes import UUID import Messages +seek :: [SubCmdSeek] +seek = [withFilesInGit start] + {- Move a file either --to or --from a repository. - - This only operates on the cached file content; it does not involve diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index b3b940cdd..a15510bd9 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -14,9 +14,14 @@ import qualified Annex import qualified Backend import qualified GitRepo as Git import qualified Command.Add +import qualified Command.Fix + +{- The pre-commit hook needs to fix symlinks to all files being committed. + - And, it needs to inject unlocked files into the annex. -} +seek :: [SubCmdSeek] +seek = [withFilesToBeCommitted Command.Fix.start, + withUnlockedFilesToBeCommitted start] -{- Run by git pre-commit hook; passed unlocked files that are being - - committed. -} start :: SubCmdStartString start file = return $ Just $ perform file diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 50e9a590b..e8d407b83 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -19,6 +19,9 @@ import Types import Core import Messages +seek :: [SubCmdSeek] +seek = [withTempFile start] + {- Sets cached content for a key. -} start :: SubCmdStartString start file = do diff --git a/Command/Unannex.hs b/Command/Unannex.hs index f5e78e55a..e85e8486f 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -20,6 +20,9 @@ import Core import qualified GitRepo as Git import Messages +seek :: [SubCmdSeek] +seek = [withFilesInGit start] + {- The unannex subcommand undoes an add. -} start :: SubCmdStartString start file = isAnnexed file $ \(key, backend) -> do diff --git a/Command/Unlock.hs b/Command/Unlock.hs index de21988de..3ff3023b2 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -18,6 +18,9 @@ import Locations import Utility import Core +seek :: [SubCmdSeek] +seek = [withFilesInGit start] + {- The unlock subcommand replaces the symlink with a copy of the file's - content. -} start :: SubCmdStartString diff --git a/debian/changelog b/debian/changelog index f705bfaf5..b9f9569ab 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,14 +1,15 @@ -git-annex (0.05) UNRELEASED; urgency=low +git-annex (0.05) unstable; urgency=low * Optimize both pre-commit and lock subcommands to not call git diff - on every file being committed or locked. + on every file being committed/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. + git-annex 0.04 pre-commit to sometimes corrupt filename being read + from git ls-files 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 Thu, 11 Nov 2010 14:52:05 -0400 + -- Joey Hess Thu, 11 Nov 2010 18:31:09 -0400 git-annex (0.04) unstable; urgency=low -- cgit v1.2.3