mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Merge branch 'autosync'

Browse source
This commit is contained in:
Joey Hess 2011-12-31 14:32:59 -04:00
commit 09905f6655
46 changed files with 418 additions and 193 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Annex.hs
View file

@ -64,11 +64,13 @@ instance MonadBaseControl IO Annex where
data OutputType = NormalOutput | QuietOutput | JSONOutput data OutputType = NormalOutput | QuietOutput | JSONOutput
type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
-- internal state storage -- internal state storage
data AnnexState = AnnexState data AnnexState = AnnexState
{ repo :: Git.Repo { repo :: Git.Repo
, backends :: [Backend Annex] , backends :: [BackendA Annex]
, remotes :: [Types.Remote.Remote Annex] , remotes :: [Types.Remote.RemoteA Annex]
, repoqueue :: Git.Queue.Queue , repoqueue :: Git.Queue.Queue
, output :: OutputType , output :: OutputType
, force :: Bool , force :: Bool
@ -81,7 +83,7 @@ data AnnexState = AnnexState
, forcenumcopies :: Maybe Int , forcenumcopies :: Maybe Int
, toremote :: Maybe String , toremote :: Maybe String
, fromremote :: Maybe String , fromremote :: Maybe String
, limit :: Either [Utility.Matcher.Token (FilePath -> Annex Bool)] (Utility.Matcher.Matcher (FilePath -> Annex Bool)) , limit :: Matcher (FilePath -> Annex Bool)
, forcetrust :: [(UUID, TrustLevel)] , forcetrust :: [(UUID, TrustLevel)]
, trustmap :: Maybe TrustMap , trustmap :: Maybe TrustMap
, ciphers :: M.Map EncryptedCipher Cipher , ciphers :: M.Map EncryptedCipher Cipher

31
Annex/Branch.hs
View file

@ -9,8 +9,11 @@ module Annex.Branch (
name, name,
hasOrigin, hasOrigin,
hasSibling, hasSibling,
siblingBranches,
create, create,
update, update,
forceUpdate,
updateTo,
get, get,
change, change,
commit, commit,
@ -55,7 +58,7 @@ hasSibling = not . null <$> siblingBranches
{- List of git-annex (refs, branches), including the main one and any {- List of git-annex (refs, branches), including the main one and any
- from remotes. Duplicate refs are filtered out. -} - from remotes. Duplicate refs are filtered out. -}
siblingBranches :: Annex [(Git.Ref, Git.Branch)] siblingBranches :: Annex [(Git.Ref, Git.Branch)]
siblingBranches = inRepo $ Git.Ref.matching name siblingBranches = inRepo $ Git.Ref.matchingUniq name
{- Creates the branch, if it does not already exist. -} {- Creates the branch, if it does not already exist. -}
create :: Annex () create :: Annex ()
@ -81,10 +84,23 @@ getBranch = maybe (hasOrigin >>= go >>= use) (return) =<< branchsha
{- Ensures that the branch and index are is up-to-date; should be {- Ensures that the branch and index are is up-to-date; should be
- called before data is read from it. Runs only once per git-annex run. - called before data is read from it. Runs only once per git-annex run.
-}
update :: Annex ()
update = runUpdateOnce $ updateTo =<< siblingBranches
{- Forces an update even if one has already been run. -}
forceUpdate :: Annex ()
forceUpdate = updateTo =<< siblingBranches
{- Merges the specified Refs into the index, if they have any changes not
- already in it. The Branch names are only used in the commit message;
- it's even possible that the provided Branches have not been updated to
- point to the Refs yet.
- -
- Before refs are merged into the index, it's important to first stage the - Before refs are merged into the index, it's important to first stage the
- journal into the index. Otherwise, any changes in the journal would - journal into the index. Otherwise, any changes in the journal would
- later get staged, and might overwrite changes made during the merge. - later get staged, and might overwrite changes made during the merge.
- If no Refs are provided, the journal is still staged and committed.
- -
- (It would be cleaner to handle the merge by updating the journal, not the - (It would be cleaner to handle the merge by updating the journal, not the
- index, with changes from the branches.) - index, with changes from the branches.)
@ -92,13 +108,13 @@ getBranch = maybe (hasOrigin >>= go >>= use) (return) =<< branchsha
- The branch is fast-forwarded if possible, otherwise a merge commit is - The branch is fast-forwarded if possible, otherwise a merge commit is
- made. - made.
-} -}
update :: Annex () updateTo :: [(Git.Ref, Git.Branch)] -> Annex ()
update = runUpdateOnce $ do updateTo pairs = do
-- ensure branch exists, and get its current ref -- ensure branch exists, and get its current ref
branchref <- getBranch branchref <- getBranch
-- check what needs updating before taking the lock -- check what needs updating before taking the lock
dirty <- journalDirty dirty <- journalDirty
(refs, branches) <- unzip <$> newerSiblings (refs, branches) <- unzip <$> filterM isnewer pairs
if (not dirty && null refs) if (not dirty && null refs)
then updateIndex branchref then updateIndex branchref
else withIndex $ lockJournal $ do else withIndex $ lockJournal $ do
@ -110,7 +126,7 @@ update = runUpdateOnce $ do
" into " ++ show name " into " ++ show name
unless (null branches) $ do unless (null branches) $ do
showSideAction merge_desc showSideAction merge_desc
mergeIndex branches mergeIndex refs
ff <- if dirty ff <- if dirty
then return False then return False
else inRepo $ Git.Branch.fastForward fullname refs else inRepo $ Git.Branch.fastForward fullname refs
@ -120,8 +136,7 @@ update = runUpdateOnce $ do
(nub $ fullname:refs) (nub $ fullname:refs)
invalidateCache invalidateCache
where where
newerSiblings = filterM isnewer =<< siblingBranches isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
isnewer (_, b) = inRepo $ Git.Branch.changed fullname b
{- Gets the content of a file on the branch, or content from the journal, or {- Gets the content of a file on the branch, or content from the journal, or
- staged in the index. - staged in the index.
@ -238,7 +253,7 @@ genIndex :: Git.Repo -> IO ()
genIndex g = Git.UnionMerge.stream_update_index g genIndex g = Git.UnionMerge.stream_update_index g
[Git.UnionMerge.ls_tree fullname g] [Git.UnionMerge.ls_tree fullname g]
{- Merges the specified branches into the index. {- Merges the specified refs into the index.
- Any changes staged in the index will be preserved. -} - Any changes staged in the index will be preserved. -}
mergeIndex :: [Git.Ref] -> Annex () mergeIndex :: [Git.Ref] -> Annex ()
mergeIndex branches = do mergeIndex branches = do

16
Backend.hs
View file

@ -31,11 +31,11 @@ import qualified Backend.SHA
import qualified Backend.WORM import qualified Backend.WORM
import qualified Backend.URL import qualified Backend.URL
list :: [Backend Annex] list :: [Backend]
list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends
{- List of backends in the order to try them when storing a new key. -} {- List of backends in the order to try them when storing a new key. -}
orderedList :: Annex [Backend Annex] orderedList :: Annex [Backend]
orderedList = do orderedList = do
l <- Annex.getState Annex.backends -- list is cached here l <- Annex.getState Annex.backends -- list is cached here
if not $ null l if not $ null l
@ -54,12 +54,12 @@ orderedList = do
{- Generates a key for a file, trying each backend in turn until one {- Generates a key for a file, trying each backend in turn until one
- accepts it. -} - accepts it. -}
genKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex)) genKey :: FilePath -> Maybe Backend -> Annex (Maybe (Key, Backend))
genKey file trybackend = do genKey file trybackend = do
bs <- orderedList bs <- orderedList
let bs' = maybe bs (: bs) trybackend let bs' = maybe bs (: bs) trybackend
genKey' bs' file genKey' bs' file
genKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex)) genKey' :: [Backend] -> FilePath -> Annex (Maybe (Key, Backend))
genKey' [] _ = return Nothing genKey' [] _ = return Nothing
genKey' (b:bs) file = do genKey' (b:bs) file = do
r <- (B.getKey b) file r <- (B.getKey b) file
@ -75,7 +75,7 @@ genKey' (b:bs) file = do
{- Looks up the key and backend corresponding to an annexed file, {- Looks up the key and backend corresponding to an annexed file,
- by examining what the file symlinks to. -} - by examining what the file symlinks to. -}
lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile file = do lookupFile file = do
tl <- liftIO $ try getsymlink tl <- liftIO $ try getsymlink
case tl of case tl of
@ -94,7 +94,7 @@ lookupFile file = do
bname ++ ")" bname ++ ")"
return Nothing return Nothing
type BackendFile = (Maybe (Backend Annex), FilePath) type BackendFile = (Maybe Backend, FilePath)
{- Looks up the backends that should be used for each file in a list. {- Looks up the backends that should be used for each file in a list.
- That can be configured on a per-file basis in the gitattributes file. - That can be configured on a per-file basis in the gitattributes file.
@ -110,11 +110,11 @@ chooseBackends fs = Annex.getState Annex.forcebackend >>= go
return $ map (\f -> (Just $ Prelude.head l, f)) fs return $ map (\f -> (Just $ Prelude.head l, f)) fs
{- Looks up a backend by name. May fail if unknown. -} {- Looks up a backend by name. May fail if unknown. -}
lookupBackendName :: String -> Backend Annex lookupBackendName :: String -> Backend
lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
where where
unknown = error $ "unknown backend " ++ s unknown = error $ "unknown backend " ++ s
maybeLookupBackendName :: String -> Maybe (Backend Annex) maybeLookupBackendName :: String -> Maybe Backend
maybeLookupBackendName s = headMaybe matches maybeLookupBackendName s = headMaybe matches
where where
matches = filter (\b -> s == B.name b) list matches = filter (\b -> s == B.name b) list

8
Backend/SHA.hs
View file

@ -21,21 +21,21 @@ type SHASize = Int
sizes :: [Int] sizes :: [Int]
sizes = [256, 1, 512, 224, 384] sizes = [256, 1, 512, 224, 384]
backends :: [Backend Annex] backends :: [Backend]
backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes
genBackend :: SHASize -> Maybe (Backend Annex) genBackend :: SHASize -> Maybe Backend
genBackend size genBackend size
| isNothing (shaCommand size) = Nothing | isNothing (shaCommand size) = Nothing
| otherwise = Just b | otherwise = Just b
where where
b = Types.Backend.Backend b = Backend
{ name = shaName size { name = shaName size
, getKey = keyValue size , getKey = keyValue size
, fsckKey = checkKeyChecksum size , fsckKey = checkKeyChecksum size
} }
genBackendE :: SHASize -> Maybe (Backend Annex) genBackendE :: SHASize -> Maybe Backend
genBackendE size = genBackendE size =
case genBackend size of case genBackend size of
Nothing -> Nothing Nothing -> Nothing

6
Backend/URL.hs
View file

@ -14,11 +14,11 @@ import Common.Annex
import Types.Backend import Types.Backend
import Types.Key import Types.Key
backends :: [Backend Annex] backends :: [Backend]
backends = [backend] backends = [backend]
backend :: Backend Annex backend :: Backend
backend = Types.Backend.Backend { backend = Backend {
name = "URL", name = "URL",
getKey = const (return Nothing), getKey = const (return Nothing),
fsckKey = const (return True) fsckKey = const (return True)

6
Backend/WORM.hs
View file

@ -11,11 +11,11 @@ import Common.Annex
import Types.Backend import Types.Backend
import Types.Key import Types.Key
backends :: [Backend Annex] backends :: [Backend]
backends = [backend] backends = [backend]
backend :: Backend Annex backend :: Backend
backend = Types.Backend.Backend { backend = Backend {
name = "WORM", name = "WORM",
getKey = keyValue, getKey = keyValue,
fsckKey = const (return True) fsckKey = const (return True)

4
Command.hs
View file

@ -77,10 +77,10 @@ doCommand = start
{- Modifies an action to only act on files that are already annexed, {- Modifies an action to only act on files that are already annexed,
- and passes the key and backend on to it. -} - and passes the key and backend on to it. -}
whenAnnexed :: (FilePath -> (Key, Backend Annex) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a) whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
whenAnnexed a file = ifAnnexed file (a file) (return Nothing) whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
ifAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex a) -> Annex a -> Annex a ifAnnexed :: FilePath -> ((Key, Backend) -> Annex a) -> Annex a -> Annex a
ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file
notBareRepo :: Annex a -> Annex a notBareRepo :: Annex a -> Annex a

2
Command/Copy.hs
View file

@ -21,6 +21,6 @@ seek = [withNumCopies $ \n -> whenAnnexed $ start n]
-- A copy is just a move that does not delete the source file. -- A copy is just a move that does not delete the source file.
-- However, --auto mode avoids unnecessary copies. -- However, --auto mode avoids unnecessary copies.
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, backend) = autoCopies key (<) numcopies $ start numcopies file (key, backend) = autoCopies key (<) numcopies $
Command.Move.start False file (key, backend) Command.Move.start False file (key, backend)

14
Command/Drop.hs
View file

@ -24,7 +24,7 @@ def = [dontCheck fromOpt $ command "drop" paramPaths seek
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withNumCopies $ \n -> whenAnnexed $ start n] seek = [withNumCopies $ \n -> whenAnnexed $ start n]
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, _) = autoCopies key (>) numcopies $ do start numcopies file (key, _) = autoCopies key (>) numcopies $ do
from <- Annex.getState Annex.fromremote from <- Annex.getState Annex.fromremote
case from of case from of
@ -41,7 +41,7 @@ startLocal file numcopies key = stopUnless (inAnnex key) $ do
showStart "drop" file showStart "drop" file
next $ performLocal key numcopies next $ performLocal key numcopies
startRemote :: FilePath -> Maybe Int -> Key -> Remote.Remote Annex -> CommandStart startRemote :: FilePath -> Maybe Int -> Key -> Remote -> CommandStart
startRemote file numcopies key remote = do startRemote file numcopies key remote = do
showStart "drop" file showStart "drop" file
next $ performRemote key numcopies remote next $ performRemote key numcopies remote
@ -55,7 +55,7 @@ performLocal key numcopies = lockContent key $ do
whenM (inAnnex key) $ removeAnnex key whenM (inAnnex key) $ removeAnnex key
next $ cleanupLocal key next $ cleanupLocal key
performRemote :: Key -> Maybe Int -> Remote.Remote Annex -> CommandPerform performRemote :: Key -> Maybe Int -> Remote -> CommandPerform
performRemote key numcopies remote = lockContent key $ do performRemote key numcopies remote = lockContent key $ do
-- Filter the remote it's being dropped from out of the lists of -- Filter the remote it's being dropped from out of the lists of
-- places assumed to have the key, and places to check. -- places assumed to have the key, and places to check.
@ -79,7 +79,7 @@ cleanupLocal key = do
logStatus key InfoMissing logStatus key InfoMissing
return True return True
cleanupRemote :: Key -> Remote.Remote Annex -> Bool -> CommandCleanup cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup
cleanupRemote key remote ok = do cleanupRemote key remote ok = do
-- better safe than sorry: assume the remote dropped the key -- better safe than sorry: assume the remote dropped the key
-- even if it seemed to fail; the failure could have occurred -- even if it seemed to fail; the failure could have occurred
@ -90,7 +90,7 @@ cleanupRemote key remote ok = do
{- Checks specified remotes to verify that enough copies of a key exist to {- Checks specified remotes to verify that enough copies of a key exist to
- allow it to be safely removed (with no data loss). Can be provided with - allow it to be safely removed (with no data loss). Can be provided with
- some locations where the key is known/assumed to be present. -} - some locations where the key is known/assumed to be present. -}
canDropKey :: Key -> Maybe Int -> [UUID] -> [Remote.Remote Annex] -> [UUID] -> Annex Bool canDropKey :: Key -> Maybe Int -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
canDropKey key numcopiesM have check skip = do canDropKey key numcopiesM have check skip = do
force <- Annex.getState Annex.force force <- Annex.getState Annex.force
if force || numcopiesM == Just 0 if force || numcopiesM == Just 0
@ -99,7 +99,7 @@ canDropKey key numcopiesM have check skip = do
need <- getNumCopies numcopiesM need <- getNumCopies numcopiesM
findCopies key need skip have check findCopies key need skip have check
findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote.Remote Annex] -> Annex Bool findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
findCopies key need skip = helper [] findCopies key need skip = helper []
where where
helper bad have [] helper bad have []
@ -116,7 +116,7 @@ findCopies key need skip = helper []
(False, Left _) -> helper (r:bad) have rs (False, Left _) -> helper (r:bad) have rs
_ -> helper bad have rs _ -> helper bad have rs
notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote.Remote Annex] -> Annex Bool notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
notEnoughCopies key need have skip bad = do notEnoughCopies key need have skip bad = do
unsafe unsafe
showLongNote $ showLongNote $

2
Command/Find.hs
View file

@ -24,7 +24,7 @@ def = [command "find" paramPaths seek "lists available files"]
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
-- only files inAnnex are shown, unless the user has requested -- only files inAnnex are shown, unless the user has requested
-- others via a limit -- others via a limit

2
Command/Fix.hs
View file

@ -20,7 +20,7 @@ seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
{- Fixes the symlink to an annexed file. -} {- Fixes the symlink to an annexed file. -}
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
link <- calcGitLink file key link <- calcGitLink file key
stopUnless ((/=) link <$> liftIO (readSymbolicLink file)) $ do stopUnless ((/=) link <$> liftIO (readSymbolicLink file)) $ do

8
Command/Fsck.hs
View file

@ -30,12 +30,12 @@ seek =
, withBarePresentKeys startBare , withBarePresentKeys startBare
] ]
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, backend) = do start numcopies file (key, backend) = do
showStart "fsck" file showStart "fsck" file
next $ perform key file backend numcopies next $ perform key file backend numcopies
perform :: Key -> FilePath -> Backend Annex -> Maybe Int -> CommandPerform perform :: Key -> FilePath -> Backend -> Maybe Int -> CommandPerform
perform key file backend numcopies = check perform key file backend numcopies = check
-- order matters -- order matters
[ verifyLocationLog key file [ verifyLocationLog key file
@ -64,7 +64,7 @@ startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName ke
{- Note that numcopies cannot be checked in a bare repository, because {- Note that numcopies cannot be checked in a bare repository, because
- getting the numcopies value requires a working copy with .gitattributes - getting the numcopies value requires a working copy with .gitattributes
- files. -} - files. -}
performBare :: Key -> Backend Annex -> CommandPerform performBare :: Key -> Backend -> CommandPerform
performBare key backend = check performBare key backend = check
[ verifyLocationLog key (show key) [ verifyLocationLog key (show key)
, checkKeySize key , checkKeySize key
@ -136,7 +136,7 @@ checkKeySize key = do
return False return False
checkBackend :: Backend Annex -> Key -> Annex Bool checkBackend :: Backend -> Key -> Annex Bool
checkBackend = Types.Backend.fsckKey checkBackend = Types.Backend.fsckKey
checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool

2
Command/Get.hs
View file

@ -21,7 +21,7 @@ def = [dontCheck fromOpt $ command "get" paramPaths seek
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withNumCopies $ \n -> whenAnnexed $ start n] seek = [withNumCopies $ \n -> whenAnnexed $ start n]
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, _) = stopUnless (not <$> inAnnex key) $ start numcopies file (key, _) = stopUnless (not <$> inAnnex key) $
autoCopies key (<) numcopies $ do autoCopies key (<) numcopies $ do
from <- Annex.getState Annex.fromremote from <- Annex.getState Annex.fromremote

4
Command/InitRemote.hs
View file

@ -42,7 +42,7 @@ start (name:ws) = do
where where
config = Logs.Remote.keyValToConfig ws config = Logs.Remote.keyValToConfig ws
perform :: R.RemoteType Annex -> UUID -> R.RemoteConfig -> CommandPerform perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do perform t u c = do
c' <- R.setup t u c c' <- R.setup t u c
next $ cleanup u c' next $ cleanup u c'
@ -77,7 +77,7 @@ remoteNames = do
return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m
{- find the specified remote type -} {- find the specified remote type -}
findType :: R.RemoteConfig -> Annex (R.RemoteType Annex) findType :: R.RemoteConfig -> Annex RemoteType
findType config = maybe unspecified specified $ M.lookup typeKey config findType config = maybe unspecified specified $ M.lookup typeKey config
where where
unspecified = error "Specify the type of remote with type=" unspecified = error "Specify the type of remote with type="

4
Command/Migrate.hs
View file

@ -21,7 +21,7 @@ def = [command "migrate" paramPaths seek "switch data to different backend"]
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withBackendFilesInGit $ \(b, f) -> whenAnnexed (start b) f] seek = [withBackendFilesInGit $ \(b, f) -> whenAnnexed (start b) f]
start :: Maybe (Backend Annex) -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Backend -> FilePath -> (Key, Backend) -> CommandStart
start b file (key, oldbackend) = do start b file (key, oldbackend) = do
exists <- inAnnex key exists <- inAnnex key
newbackend <- choosebackend b newbackend <- choosebackend b
@ -47,7 +47,7 @@ upgradableKey key = isNothing $ Types.Key.keySize key
- backends that allow the filename to influence the keys they - backends that allow the filename to influence the keys they
- generate. - generate.
-} -}
perform :: FilePath -> Key -> Backend Annex -> CommandPerform perform :: FilePath -> Key -> Backend -> CommandPerform
perform file oldkey newbackend = do perform file oldkey newbackend = do
src <- inRepo $ gitAnnexLocation oldkey src <- inRepo $ gitAnnexLocation oldkey
tmp <- fromRepo gitAnnexTmpDir tmp <- fromRepo gitAnnexTmpDir

12
Command/Move.hs
View file

@ -23,7 +23,7 @@ def = [dontCheck toOpt $ dontCheck fromOpt $
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed $ start True] seek = [withFilesInGit $ whenAnnexed $ start True]
start :: Bool -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Bool -> FilePath -> (Key, Backend) -> CommandStart
start move file (key, _) = do start move file (key, _) = do
noAuto noAuto
to <- Annex.getState Annex.toremote to <- Annex.getState Annex.toremote
@ -54,7 +54,7 @@ showMoveAction False file = showStart "copy" file
- A file's content can be moved even if there are insufficient copies to - A file's content can be moved even if there are insufficient copies to
- allow it to be dropped. - allow it to be dropped.
-} -}
toStart :: Remote.Remote Annex -> Bool -> FilePath -> Key -> CommandStart toStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
toStart dest move file key = do toStart dest move file key = do
u <- getUUID u <- getUUID
ishere <- inAnnex key ishere <- inAnnex key
@ -63,7 +63,7 @@ toStart dest move file key = do
else do else do
showMoveAction move file showMoveAction move file
next $ toPerform dest move key next $ toPerform dest move key
toPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform toPerform :: Remote -> Bool -> Key -> CommandPerform
toPerform dest move key = moveLock move key $ do toPerform dest move key = moveLock move key $ do
-- Checking the remote is expensive, so not done in the start step. -- Checking the remote is expensive, so not done in the start step.
-- In fast mode, location tracking is assumed to be correct, -- In fast mode, location tracking is assumed to be correct,
@ -105,7 +105,7 @@ toPerform dest move key = moveLock move key $ do
- If the current repository already has the content, it is still removed - If the current repository already has the content, it is still removed
- from the remote. - from the remote.
-} -}
fromStart :: Remote.Remote Annex -> Bool -> FilePath -> Key -> CommandStart fromStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
fromStart src move file key fromStart src move file key
| move = go | move = go
| otherwise = stopUnless (not <$> inAnnex key) go | otherwise = stopUnless (not <$> inAnnex key) go
@ -113,12 +113,12 @@ fromStart src move file key
go = stopUnless (fromOk src key) $ do go = stopUnless (fromOk src key) $ do
showMoveAction move file showMoveAction move file
next $ fromPerform src move key next $ fromPerform src move key
fromOk :: Remote.Remote Annex -> Key -> Annex Bool fromOk :: Remote -> Key -> Annex Bool
fromOk src key = do fromOk src key = do
u <- getUUID u <- getUUID
remotes <- Remote.keyPossibilities key remotes <- Remote.keyPossibilities key
return $ u /= Remote.uuid src && any (== src) remotes return $ u /= Remote.uuid src && any (== src) remotes
fromPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform fromPerform :: Remote -> Bool -> Key -> CommandPerform
fromPerform src move key = moveLock move key $ do fromPerform src move key = moveLock move key $ do
ishere <- inAnnex key ishere <- inAnnex key
if ishere if ishere

4
Command/Reinject.hs
View file

@ -33,7 +33,7 @@ start (src:dest:[])
next $ whenAnnexed (perform src) dest next $ whenAnnexed (perform src) dest
start _ = error "specify a src file and a dest file" start _ = error "specify a src file and a dest file"
perform :: FilePath -> FilePath -> (Key, Backend Annex) -> CommandPerform perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform
perform src _dest (key, backend) = do perform src _dest (key, backend) = do
unlessM move $ error "mv failed!" unlessM move $ error "mv failed!"
next $ cleanup key backend next $ cleanup key backend
@ -45,7 +45,7 @@ perform src _dest (key, backend) = do
move = getViaTmp key $ \tmp -> move = getViaTmp key $ \tmp ->
liftIO $ boolSystem "mv" [File src, File tmp] liftIO $ boolSystem "mv" [File src, File tmp]
cleanup :: Key -> Backend Annex -> CommandCleanup cleanup :: Key -> Backend -> CommandCleanup
cleanup key backend = do cleanup key backend = do
logStatus key InfoPresent logStatus key InfoPresent

180
Command/Sync.hs
View file

@ -1,28 +1,74 @@
{- git-annex command {- git-annex command
- -
- Copyright 2011 Joey Hess <joey@kitenet.net> - Copyright 2011 Joey Hess <joey@kitenet.net>
- Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE BangPatterns #-}
module Command.Sync where module Command.Sync where
import Common.Annex import Common.Annex
import Command import Command
import qualified Remote
import qualified Annex
import qualified Annex.Branch import qualified Annex.Branch
import qualified Git.Command import qualified Git.Command
import qualified Git.Config import qualified Git.Branch
import qualified Git.Ref import qualified Git.Ref
import qualified Git import qualified Git
import qualified Types.Remote
import qualified Remote.Git
import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M
def :: [Command] def :: [Command]
def = [command "sync" paramPaths seek "synchronize local repository with remote"] def = [command "sync" (paramOptional (paramRepeating paramRemote))
[seek] "synchronize local repository with remotes"]
-- syncing involves several operations, any of which can independantly fail -- syncing involves several operations, any of which can independently fail
seek :: [CommandSeek] seek :: CommandSeek
seek = map withNothing [commit, pull, push] seek rs = do
!branch <- fromMaybe nobranch <$> inRepo (Git.Branch.current)
remotes <- syncRemotes rs
return $ concat $
[ [ commit ]
, [ mergeLocal branch ]
, [ pullRemote remote branch | remote <- remotes ]
, [ mergeAnnex ]
, [ pushLocal branch ]
, [ pushRemote remote branch | remote <- remotes ]
]
where
nobranch = error "no branch is checked out"
syncBranch :: Git.Ref -> Git.Ref
syncBranch = Git.Ref.under "refs/heads/synced/"
remoteBranch :: Remote -> Git.Ref -> Git.Ref
remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
syncRemotes :: [String] -> Annex [Remote]
syncRemotes rs = do
fast <- Annex.getState Annex.fast
if fast
then nub <$> pickfast
else wanted
where
pickfast = (++) <$> listed <*> (good =<< fastest <$> available)
wanted
| null rs = good =<< available
| otherwise = listed
listed = mapM Remote.byName rs
available = filter nonspecial <$> Remote.enabledRemoteList
good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
nonspecial r = Types.Remote.remotetype r == Remote.Git.remote
fastest = fromMaybe [] . headMaybe .
map snd . sort . M.toList . costmap
costmap = M.fromListWith (++) . map costpair
costpair r = (Types.Remote.cost r, [r])
commit :: CommandStart commit :: CommandStart
commit = do commit = do
@ -31,44 +77,96 @@ commit = do
showOutput showOutput
-- Commit will fail when the tree is clean, so ignore failure. -- Commit will fail when the tree is clean, so ignore failure.
_ <- inRepo $ Git.Command.runBool "commit" _ <- inRepo $ Git.Command.runBool "commit"
[Param "-a", Param "-m", Param "sync"] [Param "-a", Param "-m", Param "git-annex automatic sync"]
return True return True
pull :: CommandStart mergeLocal :: Git.Ref -> CommandStart
pull = do mergeLocal branch = go =<< needmerge
remote <- defaultRemote
showStart "pull" remote
next $ next $ do
showOutput
checkRemote remote
inRepo $ Git.Command.runBool "pull" [Param remote]
push :: CommandStart
push = do
remote <- defaultRemote
showStart "push" remote
next $ next $ do
Annex.Branch.update
showOutput
inRepo $ Git.Command.runBool "push" [Param remote, matchingbranches]
where where
-- git push may be configured to not push matching syncbranch = syncBranch branch
-- branches; this should ensure it always does. needmerge = do
matchingbranches = Param ":" unlessM (inRepo $ Git.Ref.exists syncbranch) $
updateBranch syncbranch
inRepo $ Git.Branch.changed branch syncbranch
go False = stop
go True = do
showStart "merge" $ Git.Ref.describe syncbranch
next $ next $ mergeFrom syncbranch
-- the remote defaults to origin when not configured pushLocal :: Git.Ref -> CommandStart
defaultRemote :: Annex String pushLocal branch = do
defaultRemote = do updateBranch $ syncBranch branch
branch <- currentBranch stop
fromRepo $ Git.Config.get ("branch." ++ branch ++ ".remote") "origin"
currentBranch :: Annex String updateBranch :: Git.Ref -> Annex ()
currentBranch = Git.Ref.describe . Git.Ref . firstLine . L.unpack <$> updateBranch syncbranch =
inRepo (Git.Command.pipeRead [Param "symbolic-ref", Param "HEAD"]) unlessM go $ error $ "failed to update " ++ show syncbranch
where
go = inRepo $ Git.Command.runBool "branch"
[ Param "-f"
, Param $ show $ Git.Ref.base syncbranch
]
checkRemote :: String -> Annex () pullRemote :: Remote -> Git.Ref -> CommandStart
checkRemote remote = do pullRemote remote branch = do
remoteurl <- fromRepo $ showStart "pull" (Remote.name remote)
Git.Config.get ("remote." ++ remote ++ ".url") "" next $ do
when (null remoteurl) $ do showOutput
error $ "No url is configured for the remote: " ++ remote fetched <- inRepo $ Git.Command.runBool "fetch"
[Param $ Remote.name remote]
if fetched
then next $ mergeRemote remote branch
else stop
{- The remote probably has both a master and a synced/master branch.
- Which to merge from? Well, the master has whatever latest changes
- were committed, while the synced/master may have changes that some
- other remote synced to this remote. So, merge them both. -}
mergeRemote :: Remote -> Git.Ref -> CommandCleanup
mergeRemote remote branch = all id <$> (mapM merge =<< tomerge)
where
merge = mergeFrom . remoteBranch remote
tomerge = filterM (changed remote) [branch, syncBranch branch]
pushRemote :: Remote -> Git.Ref -> CommandStart
pushRemote remote branch = go =<< needpush
where
needpush = anyM (newer remote) [syncbranch, Annex.Branch.name]
go False = stop
go True = do
showStart "push" (Remote.name remote)
next $ next $ do
showOutput
inRepo $ Git.Command.runBool "push" $
[ Param (Remote.name remote)
, Param (show $ Annex.Branch.name)
, Param refspec
]
refspec = show (Git.Ref.base branch) ++ ":" ++ show (Git.Ref.base syncbranch)
syncbranch = syncBranch branch
mergeAnnex :: CommandStart
mergeAnnex = do
Annex.Branch.forceUpdate
stop
mergeFrom :: Git.Ref -> CommandCleanup
mergeFrom branch = do
showOutput
inRepo $ Git.Command.runBool "merge" [Param $ show branch]
changed :: Remote -> Git.Ref -> Annex Bool
changed remote b = do
let r = remoteBranch remote b
e <- inRepo $ Git.Ref.exists r
if e
then inRepo $ Git.Branch.changed b r
else return False
newer :: Remote -> Git.Ref -> Annex Bool
newer remote b = do
let r = remoteBranch remote b
e <- inRepo $ Git.Ref.exists r
if e
then inRepo $ Git.Branch.changed r b
else return True

2
Command/Unannex.hs
View file

@ -22,7 +22,7 @@ def = [command "unannex" paramPaths seek "undo accidential add command"]
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = stopUnless (inAnnex key) $ do start file (key, _) = stopUnless (inAnnex key) $ do
showStart "unannex" file showStart "unannex" file
next $ perform file key next $ perform file key

2
Command/Uninit.hs
View file

@ -36,7 +36,7 @@ check = do
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed startUnannex, withNothing start] seek = [withFilesInGit $ whenAnnexed startUnannex, withNothing start]
startUnannex :: FilePath -> (Key, Backend Annex) -> CommandStart startUnannex :: FilePath -> (Key, Backend) -> CommandStart
startUnannex file info = do startUnannex file info = do
-- Force fast mode before running unannex. This way, if multiple -- Force fast mode before running unannex. This way, if multiple
-- files link to a key, it will be left in the annex and hardlinked -- files link to a key, it will be left in the annex and hardlinked

2
Command/Unlock.hs
View file

@ -26,7 +26,7 @@ seek = [withFilesInGit $ whenAnnexed start]
{- The unlock subcommand replaces the symlink with a copy of the file's {- The unlock subcommand replaces the symlink with a copy of the file's
- content. -} - content. -}
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
showStart "unlock" file showStart "unlock" file
next $ perform file key next $ perform file key

6
Command/Unused.hs
View file

@ -66,7 +66,7 @@ checkRemoteUnused name = do
checkRemoteUnused' =<< Remote.byName name checkRemoteUnused' =<< Remote.byName name
next $ return True next $ return True
checkRemoteUnused' :: Remote.Remote Annex -> Annex () checkRemoteUnused' :: Remote -> Annex ()
checkRemoteUnused' r = do checkRemoteUnused' r = do
showAction "checking for unused data" showAction "checking for unused data"
remotehas <- loggedKeysFor (Remote.uuid r) remotehas <- loggedKeysFor (Remote.uuid r)
@ -112,14 +112,14 @@ unusedMsg' u header trailer = unlines $
["(To see where data was previously used, try: git log --stat -S'KEY')"] ++ ["(To see where data was previously used, try: git log --stat -S'KEY')"] ++
trailer trailer
remoteUnusedMsg :: Remote.Remote Annex -> [(Int, Key)] -> String remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
remoteUnusedMsg r u = unusedMsg' u remoteUnusedMsg r u = unusedMsg' u
["Some annexed data on " ++ name ++ " is not used by any files:"] ["Some annexed data on " ++ name ++ " is not used by any files:"]
[dropMsg $ Just r] [dropMsg $ Just r]
where where
name = Remote.name r name = Remote.name r
dropMsg :: Maybe (Remote.Remote Annex) -> String dropMsg :: Maybe Remote -> String
dropMsg Nothing = dropMsg' "" dropMsg Nothing = dropMsg' ""
dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r
dropMsg' :: String -> String dropMsg' :: String -> String

2
Command/Whereis.hs
View file

@ -20,7 +20,7 @@ def = [command "whereis" paramPaths seek
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
showStart "whereis" file showStart "whereis" file
next $ perform key next $ perform key

8
Git/Branch.hs
View file

@ -14,6 +14,14 @@ import Git
import Git.Sha import Git.Sha
import Git.Command import Git.Command
{- The currently checked out branch. -}
current :: Repo -> IO (Maybe Git.Ref)
current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r
where
parse v
| L.null v = Nothing
| otherwise = Just $ Git.Ref $ firstLine $ L.unpack v
{- Checks if the second branch has any commits not present on the first {- Checks if the second branch has any commits not present on the first
- branch. -} - branch. -}
changed :: Branch -> Branch -> Repo -> IO Bool changed :: Branch -> Branch -> Repo -> IO Bool

3
Git/Config.hs
View file

@ -29,7 +29,8 @@ read repo@(Repo { location = Dir d }) = do
bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) $ bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) $
pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
hRead repo hRead repo
read r = assertLocal r $ error "internal" read r = assertLocal r $
error $ "internal error; trying to read config of " ++ show r
{- Reads git config from a handle and populates a repo with it. -} {- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo hRead :: Repo -> Handle -> IO Repo

29
Git/Ref.hs
View file

@ -13,14 +13,26 @@ import Common
import Git import Git
import Git.Command import Git.Command
{- Converts a fully qualified git ref into a user-visible version. -} {- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String describe :: Ref -> String
describe = remove "refs/heads/" . remove "refs/remotes/" . show describe = show . base
{- Often git refs are fully qualified (eg: refs/heads/master).
- Converts such a fully qualified ref into a base ref (eg: master). -}
base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
where where
remove prefix s remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s | prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s | otherwise = s
{- Given a directory such as "refs/remotes/origin", and a ref such as
- refs/heads/master, yields a version of that ref under the directory,
- such as refs/remotes/origin/master. -}
under :: String -> Ref -> Ref
under dir r = Ref $ dir </> show (base r)
{- Checks if a ref exists. -} {- Checks if a ref exists. -}
exists :: Ref -> Repo -> IO Bool exists :: Ref -> Repo -> IO Bool
exists ref = runBool "show-ref" exists ref = runBool "show-ref"
@ -36,13 +48,18 @@ sha branch repo = process . L.unpack <$> showref repo
process [] = Nothing process [] = Nothing
process s = Just $ Ref $ firstLine s process s = Just $ Ref $ firstLine s
{- List of (refs, branches) matching a given ref spec. {- List of (refs, branches) matching a given ref spec. -}
- Duplicate refs are filtered out. -}
matching :: Ref -> Repo -> IO [(Ref, Branch)] matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = do matching ref repo = do
r <- pipeRead [Param "show-ref", Param $ show ref] repo r <- pipeRead [Param "show-ref", Param $ show ref] repo
return $ nubBy uniqref $ map (gen . L.unpack) (L.lines r) return $ map (gen . L.unpack) (L.lines r)
where where
uniqref (a, _) (b, _) = a == b
gen l = let (r, b) = separate (== ' ') l in gen l = let (r, b) = separate (== ' ') l in
(Ref r, Ref b) (Ref r, Ref b)
{- List of (refs, branches) matching a given ref spec.
- Duplicate refs are filtered out. -}
matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
matchingUniq ref repo = nubBy uniqref <$> matching ref repo
where
uniqref (a, _) (b, _) = a == b

37
Remote.hs
View file

@ -16,6 +16,8 @@ module Remote (
hasKeyCheap, hasKeyCheap,
remoteTypes, remoteTypes,
remoteList,
enabledRemoteList,
remoteMap, remoteMap,
byName, byName,
prettyPrintUUIDs, prettyPrintUUIDs,
@ -52,7 +54,7 @@ import qualified Remote.Rsync
import qualified Remote.Web import qualified Remote.Web
import qualified Remote.Hook import qualified Remote.Hook
remoteTypes :: [RemoteType Annex] remoteTypes :: [RemoteType]
remoteTypes = remoteTypes =
[ Remote.Git.remote [ Remote.Git.remote
, Remote.S3.remote , Remote.S3.remote
@ -65,8 +67,8 @@ remoteTypes =
{- Builds a list of all available Remotes. {- Builds a list of all available Remotes.
- Since doing so can be expensive, the list is cached. -} - Since doing so can be expensive, the list is cached. -}
genList :: Annex [Remote Annex] remoteList :: Annex [Remote]
genList = do remoteList = do
rs <- Annex.getState Annex.remotes rs <- Annex.getState Annex.remotes
if null rs if null rs
then do then do
@ -84,23 +86,26 @@ genList = do
u <- getRepoUUID r u <- getRepoUUID r
generate t r u (M.lookup u m) generate t r u (M.lookup u m)
{- All remotes that are not ignored. -}
enabledRemoteList :: Annex [Remote]
enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList
{- Map of UUIDs of Remotes and their names. -} {- Map of UUIDs of Remotes and their names. -}
remoteMap :: Annex (M.Map UUID String) remoteMap :: Annex (M.Map UUID String)
remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> genList remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> remoteList
{- Looks up a remote by name. (Or by UUID.) Only finds currently configured {- Looks up a remote by name. (Or by UUID.) Only finds currently configured
- git remotes. -} - git remotes. -}
byName :: String -> Annex (Remote Annex) byName :: String -> Annex (Remote)
byName n = do byName n = do
res <- byName' n res <- byName' n
case res of case res of
Left e -> error e Left e -> error e
Right r -> return r Right r -> return r
byName' :: String -> Annex (Either String (Remote Annex)) byName' :: String -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified" byName' "" = return $ Left "no remote specified"
byName' n = do byName' n = do
allremotes <- genList match <- filter matching <$> remoteList
let match = filter matching allremotes
if null match if null match
then return $ Left $ "there is no git remote named \"" ++ n ++ "\"" then return $ Left $ "there is no git remote named \"" ++ n ++ "\""
else return $ Right $ Prelude.head match else return $ Right $ Prelude.head match
@ -163,16 +168,16 @@ prettyPrintUUIDs desc uuids = do
] ]
{- Filters a list of remotes to ones that have the listed uuids. -} {- Filters a list of remotes to ones that have the listed uuids. -}
remotesWithUUID :: [Remote Annex] -> [UUID] -> [Remote Annex] remotesWithUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
{- Filters a list of remotes to ones that do not have the listed uuids. -} {- Filters a list of remotes to ones that do not have the listed uuids. -}
remotesWithoutUUID :: [Remote Annex] -> [UUID] -> [Remote Annex] remotesWithoutUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
{- Cost ordered lists of remotes that the Logs.Location indicate may have a key. {- Cost ordered lists of remotes that the Logs.Location indicate may have a key.
-} -}
keyPossibilities :: Key -> Annex [Remote Annex] keyPossibilities :: Key -> Annex [Remote]
keyPossibilities key = fst <$> keyPossibilities' False key keyPossibilities key = fst <$> keyPossibilities' False key
{- Cost ordered lists of remotes that the Logs.Location indicate may have a key. {- Cost ordered lists of remotes that the Logs.Location indicate may have a key.
@ -180,10 +185,10 @@ keyPossibilities key = fst <$> keyPossibilities' False key
- Also returns a list of UUIDs that are trusted to have the key - Also returns a list of UUIDs that are trusted to have the key
- (some may not have configured remotes). - (some may not have configured remotes).
-} -}
keyPossibilitiesTrusted :: Key -> Annex ([Remote Annex], [UUID]) keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID])
keyPossibilitiesTrusted = keyPossibilities' True keyPossibilitiesTrusted = keyPossibilities' True
keyPossibilities' :: Bool -> Key -> Annex ([Remote Annex], [UUID]) keyPossibilities' :: Bool -> Key -> Annex ([Remote], [UUID])
keyPossibilities' withtrusted key = do keyPossibilities' withtrusted key = do
u <- getUUID u <- getUUID
trusted <- if withtrusted then trustGet Trusted else return [] trusted <- if withtrusted then trustGet Trusted else return []
@ -196,7 +201,7 @@ keyPossibilities' withtrusted key = do
let validtrusteduuids = validuuids `intersect` trusted let validtrusteduuids = validuuids `intersect` trusted
-- remotes that match uuids that have the key -- remotes that match uuids that have the key
allremotes <- filterM (repoNotIgnored . repo) =<< genList allremotes <- enabledRemoteList
let validremotes = remotesWithUUID allremotes validuuids let validremotes = remotesWithUUID allremotes validuuids
return (sort validremotes, validtrusteduuids) return (sort validremotes, validtrusteduuids)
@ -219,7 +224,7 @@ showLocations key exclude = do
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
message rs us = message rs [] ++ message [] us message rs us = message rs [] ++ message [] us
showTriedRemotes :: [Remote Annex] -> Annex () showTriedRemotes :: [Remote] -> Annex ()
showTriedRemotes [] = return () showTriedRemotes [] = return ()
showTriedRemotes remotes = showTriedRemotes remotes =
showLongNote $ "Unable to access these remotes: " ++ showLongNote $ "Unable to access these remotes: " ++
@ -235,7 +240,7 @@ forceTrust level remotename = do
- in the local repo, not on the remote. The process of transferring the - in the local repo, not on the remote. The process of transferring the
- key to the remote, or removing the key from it *may* log the change - key to the remote, or removing the key from it *may* log the change
- on the remote, but this cannot always be relied on. -} - on the remote, but this cannot always be relied on. -}
logStatus :: Remote Annex -> Key -> Bool -> Annex () logStatus :: Remote -> Key -> Bool -> Annex ()
logStatus remote key present = logChange key (uuid remote) status logStatus remote key present = logChange key (uuid remote) status
where where
status = if present then InfoPresent else InfoMissing status = if present then InfoPresent else InfoMissing

7
Remote/Bup.hs
View file

@ -26,7 +26,7 @@ import Crypto
type BupRepo = String type BupRepo = String
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "bup", typename = "bup",
enumerate = findSpecialRemotes "buprepo", enumerate = findSpecialRemotes "buprepo",
@ -34,7 +34,7 @@ remote = RemoteType {
setup = bupSetup setup = bupSetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
buprepo <- getConfig r "buprepo" (error "missing buprepo") buprepo <- getConfig r "buprepo" (error "missing buprepo")
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost) cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)
@ -54,7 +54,8 @@ gen r u c = do
hasKey = checkPresent r bupr', hasKey = checkPresent r bupr',
hasKeyCheap = bupLocal buprepo, hasKeyCheap = bupLocal buprepo,
config = c, config = c,
repo = r repo = r,
remotetype = remote
} }
bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig

7
Remote/Directory.hs
View file

@ -20,7 +20,7 @@ import Remote.Helper.Special
import Remote.Helper.Encryptable import Remote.Helper.Encryptable
import Crypto import Crypto
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "directory", typename = "directory",
enumerate = findSpecialRemotes "directory", enumerate = findSpecialRemotes "directory",
@ -28,7 +28,7 @@ remote = RemoteType {
setup = directorySetup setup = directorySetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
dir <- getConfig r "directory" (error "missing directory") dir <- getConfig r "directory" (error "missing directory")
cst <- remoteCost r cheapRemoteCost cst <- remoteCost r cheapRemoteCost
@ -45,7 +45,8 @@ gen r u c = do
hasKey = checkPresent dir, hasKey = checkPresent dir,
hasKeyCheap = True, hasKeyCheap = True,
config = Nothing, config = Nothing,
repo = r repo = r,
remotetype = remote
} }
directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig

16
Remote/Git.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
module Remote.Git (remote) where module Remote.Git (remote, repoAvail) where
import Control.Exception.Extensible import Control.Exception.Extensible
import qualified Data.Map as M import qualified Data.Map as M
@ -28,7 +28,7 @@ import Utility.TempFile
import Config import Config
import Init import Init
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "git", typename = "git",
enumerate = list, enumerate = list,
@ -50,7 +50,7 @@ list = do
Git.Construct.remoteNamed n $ Git.Construct.remoteNamed n $
Git.Construct.fromRemoteLocation url g Git.Construct.fromRemoteLocation url g
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u _ = do gen r u _ = do
{- It's assumed to be cheap to read the config of non-URL remotes, {- It's assumed to be cheap to read the config of non-URL remotes,
- so this is done each time git-annex is run. Conversely, - so this is done each time git-annex is run. Conversely,
@ -79,7 +79,8 @@ gen r u _ = do
hasKey = inAnnex r', hasKey = inAnnex r',
hasKeyCheap = cheap, hasKeyCheap = cheap,
config = Nothing, config = Nothing,
repo = r' repo = r',
remotetype = remote
} }
{- Tries to read the config for a specified remote, updates state, and {- Tries to read the config for a specified remote, updates state, and
@ -163,6 +164,13 @@ inAnnex r key
dispatch (Right Nothing) = unknown dispatch (Right Nothing) = unknown
unknown = Left $ "unable to check " ++ Git.repoDescribe r unknown = Left $ "unable to check " ++ Git.repoDescribe r
{- Checks inexpensively if a repository is available for use. -}
repoAvail :: Git.Repo -> Annex Bool
repoAvail r
| Git.repoIsHttp r = return True
| Git.repoIsUrl r = return True
| otherwise = liftIO $ catchBoolIO $ onLocal r $ return True
{- Runs an action on a local repository inexpensively, by making an annex {- Runs an action on a local repository inexpensively, by making an annex
- monad using that repository. -} - monad using that repository. -}
onLocal :: Git.Repo -> Annex a -> IO a onLocal :: Git.Repo -> Annex a -> IO a

4
Remote/Helper/Encryptable.hs
View file

@ -41,8 +41,8 @@ encryptableRemote
:: Maybe RemoteConfig :: Maybe RemoteConfig
-> ((Cipher, Key) -> Key -> Annex Bool) -> ((Cipher, Key) -> Key -> Annex Bool)
-> ((Cipher, Key) -> FilePath -> Annex Bool) -> ((Cipher, Key) -> FilePath -> Annex Bool)
-> Remote Annex -> Remote
-> Remote Annex -> Remote
encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
r { r {
storeKey = store, storeKey = store,

7
Remote/Hook.hs
View file

@ -20,7 +20,7 @@ import Remote.Helper.Special
import Remote.Helper.Encryptable import Remote.Helper.Encryptable
import Crypto import Crypto
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "hook", typename = "hook",
enumerate = findSpecialRemotes "hooktype", enumerate = findSpecialRemotes "hooktype",
@ -28,7 +28,7 @@ remote = RemoteType {
setup = hookSetup setup = hookSetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
hooktype <- getConfig r "hooktype" (error "missing hooktype") hooktype <- getConfig r "hooktype" (error "missing hooktype")
cst <- remoteCost r expensiveRemoteCost cst <- remoteCost r expensiveRemoteCost
@ -45,7 +45,8 @@ gen r u c = do
hasKey = checkPresent r hooktype, hasKey = checkPresent r hooktype,
hasKeyCheap = False, hasKeyCheap = False,
config = Nothing, config = Nothing,
repo = r repo = r,
remotetype = remote
} }
hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig

7
Remote/Rsync.hs
View file

@ -27,7 +27,7 @@ data RsyncOpts = RsyncOpts {
rsyncOptions :: [CommandParam] rsyncOptions :: [CommandParam]
} }
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "rsync", typename = "rsync",
enumerate = findSpecialRemotes "rsyncurl", enumerate = findSpecialRemotes "rsyncurl",
@ -35,7 +35,7 @@ remote = RemoteType {
setup = rsyncSetup setup = rsyncSetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
o <- genRsyncOpts r o <- genRsyncOpts r
cst <- remoteCost r expensiveRemoteCost cst <- remoteCost r expensiveRemoteCost
@ -52,7 +52,8 @@ gen r u c = do
hasKey = checkPresent r o, hasKey = checkPresent r o,
hasKeyCheap = False, hasKeyCheap = False,
config = Nothing, config = Nothing,
repo = r repo = r,
remotetype = remote
} }
genRsyncOpts :: Git.Repo -> Annex RsyncOpts genRsyncOpts :: Git.Repo -> Annex RsyncOpts

29
Remote/S3real.hs
View file

@ -28,7 +28,7 @@ import Crypto
import Annex.Content import Annex.Content
import Utility.Base64 import Utility.Base64
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "S3", typename = "S3",
enumerate = findSpecialRemotes "s3", enumerate = findSpecialRemotes "s3",
@ -36,11 +36,11 @@ remote = RemoteType {
setup = s3Setup setup = s3Setup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
cst <- remoteCost r expensiveRemoteCost cst <- remoteCost r expensiveRemoteCost
return $ gen' r u c cst return $ gen' r u c cst
gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote Annex gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote
gen' r u c cst = gen' r u c cst =
encryptableRemote c encryptableRemote c
(storeEncrypted this) (storeEncrypted this)
@ -57,7 +57,8 @@ gen' r u c cst =
hasKey = checkPresent this, hasKey = checkPresent this,
hasKeyCheap = False, hasKeyCheap = False,
config = c, config = c,
repo = r repo = r,
remotetype = remote
} }
s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
@ -110,13 +111,13 @@ s3Setup u c = handlehost $ M.lookup "host" c
-- be human-readable -- be human-readable
M.delete "bucket" defaults M.delete "bucket" defaults
store :: Remote Annex -> Key -> Annex Bool store :: Remote -> Key -> Annex Bool
store r k = s3Action r False $ \(conn, bucket) -> do store r k = s3Action r False $ \(conn, bucket) -> do
dest <- inRepo $ gitAnnexLocation k dest <- inRepo $ gitAnnexLocation k
res <- liftIO $ storeHelper (conn, bucket) r k dest res <- liftIO $ storeHelper (conn, bucket) r k dest
s3Bool res s3Bool res
storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted :: Remote -> (Cipher, Key) -> Key -> Annex Bool
storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
-- To get file size of the encrypted content, have to use a temp file. -- To get file size of the encrypted content, have to use a temp file.
-- (An alternative would be chunking to to a constant size.) -- (An alternative would be chunking to to a constant size.)
@ -126,7 +127,7 @@ storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
res <- liftIO $ storeHelper (conn, bucket) r enck tmp res <- liftIO $ storeHelper (conn, bucket) r enck tmp
s3Bool res s3Bool res
storeHelper :: (AWSConnection, String) -> Remote Annex -> Key -> FilePath -> IO (AWSResult ()) storeHelper :: (AWSConnection, String) -> Remote -> Key -> FilePath -> IO (AWSResult ())
storeHelper (conn, bucket) r k file = do storeHelper (conn, bucket) r k file = do
content <- liftIO $ L.readFile file content <- liftIO $ L.readFile file
-- size is provided to S3 so the whole content does not need to be -- size is provided to S3 so the whole content does not need to be
@ -148,7 +149,7 @@ storeHelper (conn, bucket) r k file = do
xheaders = filter isxheader $ M.assocs $ fromJust $ config r xheaders = filter isxheader $ M.assocs $ fromJust $ config r
isxheader (h, _) = "x-amz-" `isPrefixOf` h isxheader (h, _) = "x-amz-" `isPrefixOf` h
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool retrieve :: Remote -> Key -> FilePath -> Annex Bool
retrieve r k f = s3Action r False $ \(conn, bucket) -> do retrieve r k f = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ getObject conn $ bucketKey r bucket k res <- liftIO $ getObject conn $ bucketKey r bucket k
case res of case res of
@ -157,7 +158,7 @@ retrieve r k f = s3Action r False $ \(conn, bucket) -> do
return True return True
Left e -> s3Warning e Left e -> s3Warning e
retrieveEncrypted :: Remote Annex -> (Cipher, Key) -> FilePath -> Annex Bool retrieveEncrypted :: Remote -> (Cipher, Key) -> FilePath -> Annex Bool
retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ getObject conn $ bucketKey r bucket enck res <- liftIO $ getObject conn $ bucketKey r bucket enck
case res of case res of
@ -167,12 +168,12 @@ retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do
return True return True
Left e -> s3Warning e Left e -> s3Warning e
remove :: Remote Annex -> Key -> Annex Bool remove :: Remote -> Key -> Annex Bool
remove r k = s3Action r False $ \(conn, bucket) -> do remove r k = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ deleteObject conn $ bucketKey r bucket k res <- liftIO $ deleteObject conn $ bucketKey r bucket k
s3Bool res s3Bool res
checkPresent :: Remote Annex -> Key -> Annex (Either String Bool) checkPresent :: Remote -> Key -> Annex (Either String Bool)
checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do
showAction $ "checking " ++ name r showAction $ "checking " ++ name r
res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k
@ -195,7 +196,7 @@ s3Bool :: AWSResult () -> Annex Bool
s3Bool (Right _) = return True s3Bool (Right _) = return True
s3Bool (Left e) = s3Warning e s3Bool (Left e) = s3Warning e
s3Action :: Remote Annex -> a -> ((AWSConnection, String) -> Annex a) -> Annex a s3Action :: Remote -> a -> ((AWSConnection, String) -> Annex a) -> Annex a
s3Action r noconn action = do s3Action r noconn action = do
when (isNothing $ config r) $ when (isNothing $ config r) $
error $ "Missing configuration for special remote " ++ name r error $ "Missing configuration for special remote " ++ name r
@ -205,14 +206,14 @@ s3Action r noconn action = do
(Just b, Just c) -> action (c, b) (Just b, Just c) -> action (c, b)
_ -> return noconn _ -> return noconn
bucketFile :: Remote Annex -> Key -> FilePath bucketFile :: Remote -> Key -> FilePath
bucketFile r = munge . show bucketFile r = munge . show
where where
munge s = case M.lookup "mungekeys" $ fromJust $ config r of munge s = case M.lookup "mungekeys" $ fromJust $ config r of
Just "ia" -> iaMunge s Just "ia" -> iaMunge s
_ -> s _ -> s
bucketKey :: Remote Annex -> String -> Key -> S3Object bucketKey :: Remote -> String -> Key -> S3Object
bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty
{- Internet Archive limits filenames to a subset of ascii, {- Internet Archive limits filenames to a subset of ascii,

2
Remote/S3stub.hs
View file

@ -4,7 +4,7 @@ module Remote.S3 (remote) where
import Types.Remote import Types.Remote
import Types import Types
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "S3", typename = "S3",
enumerate = return [], enumerate = return [],

7
Remote/Web.hs
View file

@ -15,7 +15,7 @@ import Config
import Logs.Web import Logs.Web
import qualified Utility.Url as Url import qualified Utility.Url as Url
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "web", typename = "web",
enumerate = list, enumerate = list,
@ -31,7 +31,7 @@ list = do
r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown
return [r] return [r]
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r _ _ = gen r _ _ =
return Remote { return Remote {
uuid = webUUID, uuid = webUUID,
@ -43,7 +43,8 @@ gen r _ _ =
hasKey = checkKey, hasKey = checkKey,
hasKeyCheap = False, hasKeyCheap = False,
config = Nothing, config = Nothing,
repo = r repo = r,
remotetype = remote
} }
downloadKey :: Key -> FilePath -> Annex Bool downloadKey :: Key -> FilePath -> Annex Bool

9
Types.hs
View file

@ -9,10 +9,17 @@ module Types (
Annex, Annex,
Backend, Backend,
Key, Key,
UUID(..) UUID(..),
Remote,
RemoteType
) where ) where
import Annex import Annex
import Types.Backend import Types.Backend
import Types.Key import Types.Key
import Types.UUID import Types.UUID
import Types.Remote
type Backend = BackendA Annex
type Remote = RemoteA Annex
type RemoteType = RemoteTypeA Annex

8
Types/Backend.hs
View file

@ -1,6 +1,6 @@
{- git-annex key/value backend data type {- git-annex key/value backend data type
- -
- Most things should not need this, using Remotes instead - Most things should not need this, using Types instead
- -
- Copyright 2010 Joey Hess <joey@kitenet.net> - Copyright 2010 Joey Hess <joey@kitenet.net>
- -
@ -11,7 +11,7 @@ module Types.Backend where
import Types.Key import Types.Key
data Backend a = Backend { data BackendA a = Backend {
-- name of this backend -- name of this backend
name :: String, name :: String,
-- converts a filename to a key -- converts a filename to a key
@ -20,8 +20,8 @@ data Backend a = Backend {
fsckKey :: Key -> a Bool fsckKey :: Key -> a Bool
} }
instance Show (Backend a) where instance Show (BackendA a) where
show backend = "Backend { name =\"" ++ name backend ++ "\" }" show backend = "Backend { name =\"" ++ name backend ++ "\" }"
instance Eq (Backend a) where instance Eq (BackendA a) where
a == b = name a == name b a == b = name a == name b

21
Types/Remote.hs
View file

@ -1,6 +1,6 @@
{- git-annex remotes types {- git-annex remotes types
- -
- Most things should not need this, using Remote instead - Most things should not need this, using Types instead
- -
- Copyright 2011 Joey Hess <joey@kitenet.net> - Copyright 2011 Joey Hess <joey@kitenet.net>
- -
@ -19,19 +19,22 @@ import Types.UUID
type RemoteConfig = M.Map String String type RemoteConfig = M.Map String String
{- There are different types of remotes. -} {- There are different types of remotes. -}
data RemoteType a = RemoteType { data RemoteTypeA a = RemoteType {
-- human visible type name -- human visible type name
typename :: String, typename :: String,
-- enumerates remotes of this type -- enumerates remotes of this type
enumerate :: a [Git.Repo], enumerate :: a [Git.Repo],
-- generates a remote of this type -- generates a remote of this type
generate :: Git.Repo -> UUID -> Maybe RemoteConfig -> a (Remote a), generate :: Git.Repo -> UUID -> Maybe RemoteConfig -> a (RemoteA a),
-- initializes or changes a remote -- initializes or changes a remote
setup :: UUID -> RemoteConfig -> a RemoteConfig setup :: UUID -> RemoteConfig -> a RemoteConfig
} }
instance Eq (RemoteTypeA a) where
x == y = typename x == typename y
{- An individual remote. -} {- An individual remote. -}
data Remote a = Remote { data RemoteA a = Remote {
-- each Remote has a unique uuid -- each Remote has a unique uuid
uuid :: UUID, uuid :: UUID,
-- each Remote has a human visible name -- each Remote has a human visible name
@ -53,16 +56,18 @@ data Remote a = Remote {
-- a Remote can have a persistent configuration store -- a Remote can have a persistent configuration store
config :: Maybe RemoteConfig, config :: Maybe RemoteConfig,
-- git configuration for the remote -- git configuration for the remote
repo :: Git.Repo repo :: Git.Repo,
-- the type of the remote
remotetype :: RemoteTypeA a
} }
instance Show (Remote a) where instance Show (RemoteA a) where
show remote = "Remote { name =\"" ++ name remote ++ "\" }" show remote = "Remote { name =\"" ++ name remote ++ "\" }"
-- two remotes are the same if they have the same uuid -- two remotes are the same if they have the same uuid
instance Eq (Remote a) where instance Eq (RemoteA a) where
x == y = uuid x == uuid y x == y = uuid x == uuid y
-- order remotes by cost -- order remotes by cost
instance Ord (Remote a) where instance Ord (RemoteA a) where
compare = comparing cost compare = comparing cost

2
Upgrade/V0.hs
View file

@ -33,7 +33,7 @@ keyFile0 :: Key -> FilePath
keyFile0 = Upgrade.V1.keyFile1 keyFile0 = Upgrade.V1.keyFile1
fileKey0 :: FilePath -> Key fileKey0 :: FilePath -> Key
fileKey0 = Upgrade.V1.fileKey1 fileKey0 = Upgrade.V1.fileKey1
lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile0 = Upgrade.V1.lookupFile1 lookupFile0 = Upgrade.V1.lookupFile1
getKeysPresent0 :: FilePath -> Annex [Key] getKeysPresent0 :: FilePath -> Annex [Key]

2
Upgrade/V1.hs
View file

@ -181,7 +181,7 @@ writeLog1 file ls = viaTmp writeFile file (showLog ls)
readLog1 :: FilePath -> IO [LogLine] readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) [] readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) []
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile1 file = do lookupFile1 file = do
tl <- liftIO $ try getsymlink tl <- liftIO $ try getsymlink
case tl of case tl of

4
debian/changelog vendored
View file

@ -16,6 +16,10 @@ git-annex (3.20111212) UNRELEASED; urgency=low
* Can now be built with older git versions (before 1.7.7); the resulting * Can now be built with older git versions (before 1.7.7); the resulting
binary should only be used with old git. binary should only be used with old git.
* Updated to build with monad-control 0.3. * Updated to build with monad-control 0.3.
* sync: Improved to work well without a central bare repository.
Thanks to Joachim Breitner.
* sync --fast: Selects some of the remotes with the lowest annex.cost
and syncs those, in addition to any specified at the command line.
-- Joey Hess <joeyh@debian.org> Mon, 12 Dec 2011 01:57:49 -0400 -- Joey Hess <joeyh@debian.org> Mon, 12 Dec 2011 01:57:49 -0400

27
doc/git-annex.mdwn
View file

@ -120,16 +120,27 @@ subdirectories).
Use this to undo an unlock command if you don't want to modify Use this to undo an unlock command if you don't want to modify
the files, or have made modifications you want to discard. the files, or have made modifications you want to discard.
* sync * sync [remote ...]
Use this command when you want to synchronize the local repository Use this command when you want to synchronize the local repository with
with its default remote (typically "origin"). The sync process involves one or more of its remotes. You can specifiy the remotes to sync with;
first committing all local changes, then pulling and merging any changes the default is to sync with all remotes. Or specify --fast to sync with
from the remote, and finally pushing the repository's state to the remote. the remotes with the lowest annex-cost value.
You can use standard git commands to do each of those steps by hand,
or if you don't want to worry about the details, you can use sync.
Note that sync does not transfer any file contents from or to the remote. The sync process involves first committing all local changes, then
fetching and merging the `synced/master` and the `git-annex` branch
from the remote repositories and finally pushing the changes back to
those branches on the remote repositories. You can use standard git
commands to do each of those steps by hand, or if you don't want to
worry about the details, you can use sync.
Note that syncing with a remote will not update the remote's working
tree with changes made to the local repository. However, those changes
are pushed to the remote, so can be merged into its working tree
by running "git annex sync" on the remote.
Note that sync does not transfer any file contents from or to the remote
repositories.
* addurl [url ...] * addurl [url ...]

1
doc/index.mdwn
View file

@ -45,6 +45,7 @@ files with git.
* [[git-annex man page|git-annex]] * [[git-annex man page|git-annex]]
* [[key-value backends|backends]] for data storage * [[key-value backends|backends]] for data storage
* [[special_remotes]] (including [[special_remotes/S3]] and [[special_remotes/bup]]) * [[special_remotes]] (including [[special_remotes/S3]] and [[special_remotes/bup]])
* [[sync]]
* [[encryption]] * [[encryption]]
* [[bare_repositories]] * [[bare_repositories]]
* [[internals]] * [[internals]]

37
doc/sync.mdwn Normal file
View file

@ -0,0 +1,37 @@
The `git annex sync` command provides an easy way to keep several
repositories in sync.
Often git is used in a centralized fashion with a central bare repositry
which changes are pulled and pushed to using normal git commands.
That works fine, if you don't mind having a central repository.
But it can be harder to use git in a fully decentralized fashion, with no
central repository and still keep repositories in sync with one another.
You have to remember to pull from each remote, and merge the appopriate
branch after pulling. It's difficult to *push* to a remote, since git does
not allow pushes into the currently checked out branch.
`git annex sync` makes it easier using a scheme devised by Joachim
Breitner. The idea is to have a branch `synced/master` (actually,
`synced/$currentbranch`), that is never directly checked out, and serves
as a drop-point for other repositories to use to push changes.
When you run `git annex sync`, it merges the `synced/master` branch
into `master`, receiving anything that's been pushed to it. Then it
fetches from each remote, and merges in any changes that have been made
to the remotes too. Finally, it updates `synced/master` to reflect the new
state of `master`, and pushes it out to each of the remotes.
This way, changes propigate around between repositories as `git annex sync`
is run on each of them. Every repository does not need to be able to talk
to every other repository; as long as the graph of repositories is
connected, and `git annex sync` is run from time to time on each, a given
change, made anywhere, will eventually reach every other repository.
The workflow for using `git annex sync` is simple:
* Make some changes to files in the repository, using `git-annex`,
or anything else.
* Run `git annex sync` to save the changes.
* Next time you're working on a different clone of that repository,
run `git annex sync` to update it.

10
test.hs
View file

@ -850,7 +850,7 @@ checklocationlog f expected = do
expected (thisuuid `elem` uuids) expected (thisuuid `elem` uuids)
_ -> assertFailure $ f ++ " failed to look up key" _ -> assertFailure $ f ++ " failed to look up key"
checkbackend :: FilePath -> Types.Backend Types.Annex -> Assertion checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do checkbackend file expected = do
r <- annexeval $ Backend.lookupFile file r <- annexeval $ Backend.lookupFile file
let b = snd $ fromJust r let b = snd $ fromJust r
@ -936,14 +936,14 @@ changecontent f = writeFile f $ changedcontent f
changedcontent :: FilePath -> String changedcontent :: FilePath -> String
changedcontent f = (content f) ++ " (modified)" changedcontent f = (content f) ++ " (modified)"
backendSHA1 :: Types.Backend Types.Annex backendSHA1 :: Types.Backend
backendSHA1 = backend_ "SHA1" backendSHA1 = backend_ "SHA1"
backendSHA256 :: Types.Backend Types.Annex backendSHA256 :: Types.Backend
backendSHA256 = backend_ "SHA256" backendSHA256 = backend_ "SHA256"
backendWORM :: Types.Backend Types.Annex backendWORM :: Types.Backend
backendWORM = backend_ "WORM" backendWORM = backend_ "WORM"
backend_ :: String -> Types.Backend Types.Annex backend_ :: String -> Types.Backend
backend_ name = Backend.lookupBackendName name backend_ name = Backend.lookupBackendName name