diff options
-rw-r--r-- | Annex.hs | 3 | ||||
-rw-r--r-- | Annex/CheckAttr.hs | 35 | ||||
-rw-r--r-- | Backend.hs | 21 | ||||
-rw-r--r-- | Command.hs | 17 | ||||
-rw-r--r-- | Command/Add.hs | 13 | ||||
-rw-r--r-- | Command/AddUrl.hs | 2 | ||||
-rw-r--r-- | Command/Copy.hs | 6 | ||||
-rw-r--r-- | Command/Drop.hs | 8 | ||||
-rw-r--r-- | Command/Fsck.hs | 7 | ||||
-rw-r--r-- | Command/Get.hs | 8 | ||||
-rw-r--r-- | Command/Lock.hs | 6 | ||||
-rw-r--r-- | Command/Migrate.hs | 8 | ||||
-rw-r--r-- | Command/PreCommit.hs | 11 | ||||
-rw-r--r-- | Git/CheckAttr.hs | 56 | ||||
-rw-r--r-- | Remote/List.hs | 4 | ||||
-rw-r--r-- | Seek.hs | 33 |
16 files changed, 141 insertions, 97 deletions
@@ -35,6 +35,7 @@ import Common import qualified Git import qualified Git.Config import Git.CatFile +import Git.CheckAttr import qualified Git.Queue import Types.Backend import qualified Types.Remote @@ -82,6 +83,7 @@ data AnnexState = AnnexState , auto :: Bool , branchstate :: BranchState , catfilehandle :: Maybe CatFileHandle + , checkattrhandle :: Maybe CheckAttrHandle , forcebackend :: Maybe String , forcenumcopies :: Maybe Int , limit :: Matcher (FilePath -> Annex Bool) @@ -105,6 +107,7 @@ newState gitrepo = AnnexState , auto = False , branchstate = startBranchState , catfilehandle = Nothing + , checkattrhandle = Nothing , forcebackend = Nothing , forcenumcopies = Nothing , limit = Left [] diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs new file mode 100644 index 000000000..01779e813 --- /dev/null +++ b/Annex/CheckAttr.hs @@ -0,0 +1,35 @@ +{- git check-attr interface, with handle automatically stored in the Annex monad + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.CheckAttr ( + checkAttr, + checkAttrHandle +) where + +import Common.Annex +import qualified Git.CheckAttr as Git +import qualified Annex + +{- All gitattributes used by git-annex. -} +annexAttrs :: [Git.Attr] +annexAttrs = + [ "annex.backend" + , "annex.numcopies" + ] + +checkAttr :: Git.Attr -> FilePath -> Annex String +checkAttr attr file = do + h <- checkAttrHandle + liftIO $ Git.checkAttr h attr file + +checkAttrHandle :: Annex Git.CheckAttrHandle +checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle + where + startup = do + h <- inRepo $ Git.checkAttrStart annexAttrs + Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h } + return h diff --git a/Backend.hs b/Backend.hs index e351bb3b2..50c89ecc5 100644 --- a/Backend.hs +++ b/Backend.hs @@ -6,12 +6,11 @@ -} module Backend ( - BackendFile, list, orderedList, genKey, lookupFile, - chooseBackends, + chooseBackend, lookupBackendName, maybeLookupBackendName ) where @@ -22,6 +21,7 @@ import Common.Annex import qualified Git.Config import qualified Git.CheckAttr import qualified Annex +import Annex.CheckAttr import Types.Key import qualified Types.Backend as B @@ -93,20 +93,15 @@ lookupFile file = do bname ++ ")" return Nothing -type BackendFile = (Maybe Backend, FilePath) - -{- Looks up the backends that should be used for each file in a list. +{- Looks up the backend that should be used for a file. - That can be configured on a per-file basis in the gitattributes file. -} -chooseBackends :: [FilePath] -> Annex [BackendFile] -chooseBackends fs = Annex.getState Annex.forcebackend >>= go +chooseBackend :: FilePath -> Annex (Maybe Backend) +chooseBackend f = Annex.getState Annex.forcebackend >>= go where - go Nothing = do - pairs <- inRepo $ Git.CheckAttr.lookup "annex.backend" fs - return $ map (\(f,b) -> (maybeLookupBackendName b, f)) pairs - go (Just _) = do - l <- orderedList - return $ map (\f -> (Just $ Prelude.head l, f)) fs + go Nothing = maybeLookupBackendName <$> + checkAttr "annex.backend" f + go (Just _) = Just . Prelude.head <$> orderedList {- Looks up a backend by name. May fail if unknown. -} lookupBackendName :: String -> Backend diff --git a/Command.hs b/Command.hs index 386efafde..e7ce335c7 100644 --- a/Command.hs +++ b/Command.hs @@ -18,6 +18,7 @@ module Command ( ifAnnexed, notBareRepo, isBareRepo, + numCopies, autoCopies, module ReExported ) where @@ -34,6 +35,7 @@ import Checks as ReExported import Usage as ReExported import Logs.Trust import Config +import Annex.CheckAttr {- Generates a normal command -} command :: String -> String -> [CommandSeek] -> String -> Command @@ -98,17 +100,22 @@ notBareRepo a = do isBareRepo :: Annex Bool isBareRepo = fromRepo Git.repoIsLocalBare +numCopies :: FilePath -> Annex (Maybe Int) +numCopies file = readish <$> checkAttr "annex.numcopies" file + {- Used for commands that have an auto mode that checks the number of known - copies of a key. - - In auto mode, first checks that the number of known - copies of the key is > or < than the numcopies setting, before running - the action. -} -autoCopies :: Key -> (Int -> Int -> Bool) -> Maybe Int -> CommandStart -> CommandStart -autoCopies key vs numcopiesattr a = Annex.getState Annex.auto >>= auto +autoCopies :: FilePath -> Key -> (Int -> Int -> Bool) -> (Maybe Int -> CommandStart) -> CommandStart +autoCopies file key vs a = do + numcopiesattr <- numCopies file + Annex.getState Annex.auto >>= auto numcopiesattr where - auto False = a - auto True = do + auto numcopiesattr False = a numcopiesattr + auto numcopiesattr True = do needed <- getNumCopies numcopiesattr (_, have) <- trustPartition UnTrusted =<< Remote.keyLocations key - if length have `vs` needed then a else stop + if length have `vs` needed then a numcopiesattr else stop diff --git a/Command/Add.hs b/Command/Add.hs index 9410601b8..28971529a 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -16,7 +16,6 @@ import qualified Backend import Logs.Location import Annex.Content import Utility.Touch -import Backend def :: [Command] def = [command "add" paramPaths seek "add files to annex"] @@ -28,8 +27,8 @@ 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. -} -start :: BackendFile -> CommandStart -start p@(_, file) = notBareRepo $ ifAnnexed file fixup add +start :: FilePath -> CommandStart +start file = notBareRepo $ ifAnnexed file fixup add where add = do s <- liftIO $ getSymbolicLinkStatus file @@ -37,7 +36,7 @@ start p@(_, file) = notBareRepo $ ifAnnexed file fixup add then stop else do showStart "add" file - next $ perform p + next $ perform file fixup (key, _) = do -- fixup from an interrupted add; the symlink -- is present but not yet added to git @@ -45,8 +44,10 @@ start p@(_, file) = notBareRepo $ ifAnnexed file fixup add liftIO $ removeFile file next $ next $ cleanup file key =<< inAnnex key -perform :: BackendFile -> CommandPerform -perform (backend, file) = Backend.genKey file backend >>= go +perform :: FilePath -> CommandPerform +perform file = do + backend <- Backend.chooseBackend file + Backend.genKey file backend >>= go where go Nothing = stop go (Just (key, _)) = do diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index db73f14e9..f91d6dd55 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -63,7 +63,7 @@ download url file = do tmp <- fromRepo $ gitAnnexTmpLocation dummykey liftIO $ createDirectoryIfMissing True (parentDir tmp) stopUnless (downloadUrl [url] tmp) $ do - [(backend, _)] <- Backend.chooseBackends [file] + backend <- Backend.chooseBackend file k <- Backend.genKey tmp backend case k of Nothing -> stop diff --git a/Command/Copy.hs b/Command/Copy.hs index 32b83a526..a8ec22570 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -19,10 +19,10 @@ def = [withOptions Command.Move.options $ command "copy" paramPaths seek seek :: [CommandSeek] seek = [withField Command.Move.toOption Remote.byName $ \to -> withField Command.Move.fromOption Remote.byName $ \from -> - withNumCopies $ \n -> whenAnnexed $ start to from n] + withFilesInGit $ whenAnnexed $ start to from] -- A copy is just a move that does not delete the source file. -- However, --auto mode avoids unnecessary copies. -start :: Maybe Remote -> Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart -start to from numcopies file (key, backend) = autoCopies key (<) numcopies $ +start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start to from file (key, backend) = autoCopies file key (<) $ \_numcopies -> Command.Move.start to from False file (key, backend) diff --git a/Command/Drop.hs b/Command/Drop.hs index b40de00cb..9eb36a22f 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -26,11 +26,11 @@ fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote" seek :: [CommandSeek] -seek = [withField fromOption Remote.byName $ \from -> withNumCopies $ \n -> - whenAnnexed $ start from n] +seek = [withField fromOption Remote.byName $ \from -> + withFilesInGit $ whenAnnexed $ start from] -start :: Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart -start from numcopies file (key, _) = autoCopies key (>) numcopies $ do +start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start from file (key, _) = autoCopies file key (>) $ \numcopies -> do case from of Nothing -> startLocal file numcopies key Just remote -> do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 469fad749..94b360104 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -36,12 +36,13 @@ options = [fromOption] seek :: [CommandSeek] seek = [ withField fromOption Remote.byName $ \from -> - withNumCopies $ \n -> whenAnnexed $ start from n + withFilesInGit $ whenAnnexed $ start from , withBarePresentKeys startBare ] -start :: Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart -start from numcopies file (key, backend) = do +start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start from file (key, backend) = do + numcopies <- numCopies file showStart "fsck" file case from of Nothing -> next $ perform key file backend numcopies diff --git a/Command/Get.hs b/Command/Get.hs index 5d032e13c..928ab0f1b 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -19,11 +19,11 @@ def = [withOptions [Command.Move.fromOption] $ command "get" paramPaths seek seek :: [CommandSeek] seek = [withField Command.Move.fromOption Remote.byName $ \from -> - withNumCopies $ \n -> whenAnnexed $ start from n] + withFilesInGit $ whenAnnexed $ start from] -start :: Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart -start from numcopies file (key, _) = stopUnless (not <$> inAnnex key) $ - autoCopies key (<) numcopies $ do +start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start from file (key, _) = stopUnless (not <$> inAnnex key) $ + autoCopies file key (<) $ \_numcopies -> do case from of Nothing -> go $ perform key Just src -> do diff --git a/Command/Lock.hs b/Command/Lock.hs index 329fd3eff..b8aedb252 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -10,7 +10,6 @@ module Command.Lock where import Common.Annex import Command import qualified Annex.Queue -import Backend def :: [Command] def = [command "lock" paramPaths seek "undo unlock command"] @@ -18,9 +17,8 @@ def = [command "lock" paramPaths seek "undo unlock command"] seek :: [CommandSeek] seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start] -{- Undo unlock -} -start :: BackendFile -> CommandStart -start (_, file) = do +start :: FilePath -> CommandStart +start file = do showStart "lock" file next $ perform file diff --git a/Command/Migrate.hs b/Command/Migrate.hs index f6467463d..c6b0f086c 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -19,12 +19,12 @@ def :: [Command] def = [command "migrate" paramPaths seek "switch data to different backend"] seek :: [CommandSeek] -seek = [withBackendFilesInGit $ \(b, f) -> whenAnnexed (start b) f] +seek = [withFilesInGit $ whenAnnexed start] -start :: Maybe Backend -> FilePath -> (Key, Backend) -> CommandStart -start b file (key, oldbackend) = do +start :: FilePath -> (Key, Backend) -> CommandStart +start file (key, oldbackend) = do exists <- inAnnex key - newbackend <- choosebackend b + newbackend <- choosebackend =<< Backend.chooseBackend file if (newbackend /= oldbackend || upgradableKey key) && exists then do showStart "migrate" file diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 57bc7ac13..b0328ca19 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -10,7 +10,6 @@ module Command.PreCommit where import Command import qualified Command.Add import qualified Command.Fix -import Backend def :: [Command] def = [command "pre-commit" paramPaths seek "run by git pre-commit hook"] @@ -22,12 +21,12 @@ seek = [ withFilesToBeCommitted $ whenAnnexed Command.Fix.start , withFilesUnlockedToBeCommitted start] -start :: BackendFile -> CommandStart -start p = next $ perform p +start :: FilePath -> CommandStart +start file = next $ perform file -perform :: BackendFile -> CommandPerform -perform pair@(_, file) = do - ok <- doCommand $ Command.Add.start pair +perform :: FilePath -> CommandPerform +perform file = do + ok <- doCommand $ Command.Add.start file if ok then next $ return True else error $ "failed to add " ++ file ++ "; canceling commit" diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index 5c747a951..669a9c54e 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -1,6 +1,6 @@ {- git check-attr interface - - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,20 +12,44 @@ import Git import Git.Command import qualified Git.Version -{- Efficiently looks up a gitattributes value for each file in a list. -} -lookup :: String -> [FilePath] -> Repo -> IO [(FilePath, String)] -lookup attr files repo = do +type CheckAttrHandle = (PipeHandle, Handle, Handle, [Attr], String) + +type Attr = String + +{- Starts git check-attr running to look up the specified gitattributes + - values and return a handle. -} +checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle +checkAttrStart attrs repo = do cwd <- getCurrentDirectory - (_, r) <- pipeBoth "git" (toCommand params) $ - join "\0" $ input cwd - return $ zip files $ map attrvalue $ lines r + (pid, from, to) <- hPipeBoth "git" $ toCommand $ + gitCommandLine params repo + return (pid, from, to, attrs, cwd) where - params = gitCommandLine - [ Param "check-attr" - , Param attr - , Params "-z --stdin" - ] repo + params = + [ Param "check-attr" ] + ++ map Param attrs ++ + [ Params "-z --stdin" ] +{- Stops git check-attr. -} +checkAttrStop :: CheckAttrHandle -> IO () +checkAttrStop (pid, from, to, _, _) = do + hClose to + hClose from + forceSuccess pid + +{- Gets an attribute of a file. -} +checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String +checkAttr (_, from, to, attrs, cwd) want file = do + hPutStr to $ file' ++ "\0" + hFlush to + pairs <- forM attrs $ \attr -> do + l <- hGetLine from + return (attr, attrvalue attr l) + let vals = map snd $ filter (\(attr, _) -> attr == want) pairs + case vals of + [v] -> return v + _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file + where {- Before git 1.7.7, git check-attr worked best with - absolute filenames; using them worked around some bugs - with relative filenames. @@ -34,10 +58,10 @@ lookup attr files repo = do - filenames, and the bugs that necessitated them were fixed, - so use relative filenames. -} oldgit = Git.Version.older "1.7.7" - input cwd - | oldgit = map (absPathFrom cwd) files - | otherwise = map (relPathDirToFile cwd . absPathFrom cwd) files - attrvalue l = end bits !! 0 + file' + | oldgit = absPathFrom cwd file + | otherwise = relPathDirToFile cwd $ absPathFrom cwd file + attrvalue attr l = end bits !! 0 where bits = split sep l sep = ": " ++ attr ++ ": " diff --git a/Remote/List.hs b/Remote/List.hs index e589b4401..7c419c75d 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -17,7 +17,7 @@ import Annex.UUID import Config import qualified Remote.Git -import qualified Remote.S3 +--import qualified Remote.S3 import qualified Remote.Bup import qualified Remote.Directory import qualified Remote.Rsync @@ -27,7 +27,7 @@ import qualified Remote.Hook remoteTypes :: [RemoteType] remoteTypes = [ Remote.Git.remote - , Remote.S3.remote +-- , Remote.S3.remote , Remote.Bup.remote , Remote.Directory.remote , Remote.Rsync.remote @@ -14,11 +14,9 @@ module Seek where import Common.Annex import Types.Command import Types.Key -import Backend import qualified Annex import qualified Git import qualified Git.LsFiles as LsFiles -import qualified Git.CheckAttr import qualified Limit import qualified Option @@ -28,26 +26,12 @@ seekHelper a params = inRepo $ \g -> runPreserveOrder (`a` g) params withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params -withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek -withAttrFilesInGit attr a params = do - files <- seekHelper LsFiles.inRepo params - prepFilteredGen a fst $ inRepo $ Git.CheckAttr.lookup attr files - -withNumCopies :: (Maybe Int -> FilePath -> CommandStart) -> CommandSeek -withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params - where - go (file, v) = a (readish v) file - -withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek -withBackendFilesInGit a params = - prepBackendPairs a =<< seekHelper LsFiles.inRepo params - -withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek +withFilesNotInGit :: (FilePath -> CommandStart) -> CommandSeek withFilesNotInGit a params = do {- dotfiles are not acted on unless explicitly listed -} files <- filter (not . dotfile) <$> seek ps dotfiles <- if null dotps then return [] else seek dotps - prepBackendPairs a $ preserveOrder params (files++dotfiles) + prepFiltered a $ return $ preserveOrder params (files++dotfiles) where (dotps, ps) = partition dotfile params seek l = do @@ -65,20 +49,20 @@ withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek withFilesToBeCommitted a params = prepFiltered a $ seekHelper LsFiles.stagedNotDeleted params -withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek +withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged -withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek +withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CommandSeek withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged -withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek +withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> (FilePath -> CommandStart) -> CommandSeek withFilesUnlocked' typechanged a params = do -- unlocked files have changed type from a symlink to a regular file top <- fromRepo Git.workTree typechangedfiles <- seekHelper typechanged params - unlockedfiles <- liftIO $ filterM notSymlink $ + let unlockedfiles = liftIO $ filterM notSymlink $ map (\f -> top ++ "/" ++ f) typechangedfiles - prepBackendPairs a unlockedfiles + prepFiltered a unlockedfiles withKeys :: (Key -> CommandStart) -> CommandSeek withKeys a params = return $ map (a . parse) params @@ -109,9 +93,6 @@ withNothing _ _ = error "This command takes no parameters." prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart] prepFiltered a = prepFilteredGen a id -prepBackendPairs :: (BackendFile -> CommandStart) -> CommandSeek -prepBackendPairs a fs = prepFilteredGen a snd (chooseBackends fs) - prepFilteredGen :: (b -> CommandStart) -> (b -> FilePath) -> Annex [b] -> Annex [CommandStart] prepFilteredGen a d fs = do matcher <- Limit.getMatcher |