summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex.hs3
-rw-r--r--Annex/CheckAttr.hs35
-rw-r--r--Backend.hs21
-rw-r--r--Command.hs17
-rw-r--r--Command/Add.hs13
-rw-r--r--Command/AddUrl.hs2
-rw-r--r--Command/Copy.hs6
-rw-r--r--Command/Drop.hs8
-rw-r--r--Command/Fsck.hs7
-rw-r--r--Command/Get.hs8
-rw-r--r--Command/Lock.hs6
-rw-r--r--Command/Migrate.hs8
-rw-r--r--Command/PreCommit.hs11
-rw-r--r--Git/CheckAttr.hs56
-rw-r--r--Remote/List.hs4
-rw-r--r--Seek.hs33
16 files changed, 141 insertions, 97 deletions
diff --git a/Annex.hs b/Annex.hs
index de36c816d..534415207 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -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
diff --git a/Seek.hs b/Seek.hs
index b4e1218e2..a9c034d22 100644
--- a/Seek.hs
+++ b/Seek.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-24 06:37:57 +0000