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
type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
-- internal state storage
data AnnexState = AnnexState
{ repo :: Git.Repo
, backends :: [Backend Annex]
, remotes :: [Types.Remote.Remote Annex]
, backends :: [BackendA Annex]
, remotes :: [Types.Remote.RemoteA Annex]
, repoqueue :: Git.Queue.Queue
, output :: OutputType
, force :: Bool
@ -81,7 +83,7 @@ data AnnexState = AnnexState
, forcenumcopies :: Maybe Int
, toremote :: 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)]
, trustmap :: Maybe TrustMap
, ciphers :: M.Map EncryptedCipher Cipher

31
Annex/Branch.hs
View file

@ -9,8 +9,11 @@ module Annex.Branch (
name,
hasOrigin,
hasSibling,
siblingBranches,
create,
update,
forceUpdate,
updateTo,
get,
change,
commit,
@ -55,7 +58,7 @@ hasSibling = not . null <$> siblingBranches
{- List of git-annex (refs, branches), including the main one and any
- from remotes. Duplicate refs are filtered out. -}
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. -}
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
- 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
- journal into the index. Otherwise, any changes in the journal would
- 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
- 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
- made.
-}
update :: Annex ()
update = runUpdateOnce $ do
updateTo :: [(Git.Ref, Git.Branch)] -> Annex ()
updateTo pairs = do
-- ensure branch exists, and get its current ref
branchref <- getBranch
-- check what needs updating before taking the lock
dirty <- journalDirty
(refs, branches) <- unzip <$> newerSiblings
(refs, branches) <- unzip <$> filterM isnewer pairs
if (not dirty && null refs)
then updateIndex branchref
else withIndex $ lockJournal $ do
@ -110,7 +126,7 @@ update = runUpdateOnce $ do
" into " ++ show name
unless (null branches) $ do
showSideAction merge_desc
mergeIndex branches
mergeIndex refs
ff <- if dirty
then return False
else inRepo $ Git.Branch.fastForward fullname refs
@ -120,8 +136,7 @@ update = runUpdateOnce $ do
(nub $ fullname:refs)
invalidateCache
where
newerSiblings = filterM isnewer =<< siblingBranches
isnewer (_, b) = inRepo $ Git.Branch.changed fullname b
isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
{- Gets the content of a file on the branch, or content from the journal, or
- staged in the index.
@ -238,7 +253,7 @@ genIndex :: Git.Repo -> IO ()
genIndex g = Git.UnionMerge.stream_update_index 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. -}
mergeIndex :: [Git.Ref] -> Annex ()
mergeIndex branches = do

16
Backend.hs
View file

@ -31,11 +31,11 @@ import qualified Backend.SHA
import qualified Backend.WORM
import qualified Backend.URL
list :: [Backend Annex]
list :: [Backend]
list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends
{- List of backends in the order to try them when storing a new key. -}
orderedList :: Annex [Backend Annex]
orderedList :: Annex [Backend]
orderedList = do
l <- Annex.getState Annex.backends -- list is cached here
if not $ null l
@ -54,12 +54,12 @@ orderedList = do
{- Generates a key for a file, trying each backend in turn until one
- accepts it. -}
genKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
genKey :: FilePath -> Maybe Backend -> Annex (Maybe (Key, Backend))
genKey file trybackend = do
bs <- orderedList
let bs' = maybe bs (: bs) trybackend
genKey' bs' file
genKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
genKey' :: [Backend] -> FilePath -> Annex (Maybe (Key, Backend))
genKey' [] _ = return Nothing
genKey' (b:bs) file = do
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,
- by examining what the file symlinks to. -}
lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex))
lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile file = do
tl <- liftIO $ try getsymlink
case tl of
@ -94,7 +94,7 @@ lookupFile file = do
bname ++ ")"
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.
- 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
{- Looks up a backend by name. May fail if unknown. -}
lookupBackendName :: String -> Backend Annex
lookupBackendName :: String -> Backend
lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
where
unknown = error $ "unknown backend " ++ s
maybeLookupBackendName :: String -> Maybe (Backend Annex)
maybeLookupBackendName :: String -> Maybe Backend
maybeLookupBackendName s = headMaybe matches
where
matches = filter (\b -> s == B.name b) list

8
Backend/SHA.hs
View file

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

6
Backend/URL.hs
View file

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

6
Backend/WORM.hs
View file

@ -11,11 +11,11 @@ import Common.Annex
import Types.Backend
import Types.Key
backends :: [Backend Annex]
backends :: [Backend]
backends = [backend]
backend :: Backend Annex
backend = Types.Backend.Backend {
backend :: Backend
backend = Backend {
name = "WORM",
getKey = keyValue,
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,
- 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)
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
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.
-- 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 $
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 = [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
from <- Annex.getState Annex.fromremote
case from of
@ -41,7 +41,7 @@ startLocal file numcopies key = stopUnless (inAnnex key) $ do
showStart "drop" file
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
showStart "drop" file
next $ performRemote key numcopies remote
@ -55,7 +55,7 @@ performLocal key numcopies = lockContent key $ do
whenM (inAnnex key) $ removeAnnex 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
-- Filter the remote it's being dropped from out of the lists of
-- places assumed to have the key, and places to check.
@ -79,7 +79,7 @@ cleanupLocal key = do
logStatus key InfoMissing
return True
cleanupRemote :: Key -> Remote.Remote Annex -> Bool -> CommandCleanup
cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup
cleanupRemote key remote ok = do
-- better safe than sorry: assume the remote dropped the key
-- 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
- 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. -}
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
force <- Annex.getState Annex.force
if force || numcopiesM == Just 0
@ -99,7 +99,7 @@ canDropKey key numcopiesM have check skip = do
need <- getNumCopies numcopiesM
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 []
where
helper bad have []
@ -116,7 +116,7 @@ findCopies key need skip = helper []
(False, Left _) -> helper (r: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
unsafe
showLongNote $

2
Command/Find.hs
View file

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

2
Command/Fix.hs
View file

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

8
Command/Fsck.hs
View file

@ -30,12 +30,12 @@ seek =
, withBarePresentKeys startBare
]
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart
start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, backend) = do
showStart "fsck" file
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
-- order matters
[ 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
- getting the numcopies value requires a working copy with .gitattributes
- files. -}
performBare :: Key -> Backend Annex -> CommandPerform
performBare :: Key -> Backend -> CommandPerform
performBare key backend = check
[ verifyLocationLog key (show key)
, checkKeySize key
@ -136,7 +136,7 @@ checkKeySize key = do
return False
checkBackend :: Backend Annex -> Key -> Annex Bool
checkBackend :: Backend -> Key -> Annex Bool
checkBackend = Types.Backend.fsckKey
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 = [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) $
autoCopies key (<) numcopies $ do
from <- Annex.getState Annex.fromremote

4
Command/InitRemote.hs
View file

@ -42,7 +42,7 @@ start (name:ws) = do
where
config = Logs.Remote.keyValToConfig ws
perform :: R.RemoteType Annex -> UUID -> R.RemoteConfig -> CommandPerform
perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do
c' <- R.setup t u c
next $ cleanup u c'
@ -77,7 +77,7 @@ remoteNames = do
return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m
{- 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
where
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 = [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
exists <- inAnnex key
newbackend <- choosebackend b
@ -47,7 +47,7 @@ upgradableKey key = isNothing $ Types.Key.keySize key
- backends that allow the filename to influence the keys they
- generate.
-}
perform :: FilePath -> Key -> Backend Annex -> CommandPerform
perform :: FilePath -> Key -> Backend -> CommandPerform
perform file oldkey newbackend = do
src <- inRepo $ gitAnnexLocation oldkey
tmp <- fromRepo gitAnnexTmpDir

12
Command/Move.hs
View file

@ -23,7 +23,7 @@ def = [dontCheck toOpt $ dontCheck fromOpt $
seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed $ start True]
start :: Bool -> FilePath -> (Key, Backend Annex) -> CommandStart
start :: Bool -> FilePath -> (Key, Backend) -> CommandStart
start move file (key, _) = do
noAuto
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
- 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
u <- getUUID
ishere <- inAnnex key
@ -63,7 +63,7 @@ toStart dest move file key = do
else do
showMoveAction move file
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
-- Checking the remote is expensive, so not done in the start step.
-- 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
- from the remote.
-}
fromStart :: Remote.Remote Annex -> Bool -> FilePath -> Key -> CommandStart
fromStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
fromStart src move file key
| move = go
| otherwise = stopUnless (not <$> inAnnex key) go
@ -113,12 +113,12 @@ fromStart src move file key
go = stopUnless (fromOk src key) $ do
showMoveAction move file
next $ fromPerform src move key
fromOk :: Remote.Remote Annex -> Key -> Annex Bool
fromOk :: Remote -> Key -> Annex Bool
fromOk src key = do
u <- getUUID
remotes <- Remote.keyPossibilities key
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
ishere <- inAnnex key
if ishere

4
Command/Reinject.hs
View file

@ -33,7 +33,7 @@ start (src:dest:[])
next $ whenAnnexed (perform src) dest
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
unlessM move $ error "mv failed!"
next $ cleanup key backend
@ -45,7 +45,7 @@ perform src _dest (key, backend) = do
move = getViaTmp key $ \tmp ->
liftIO $ boolSystem "mv" [File src, File tmp]
cleanup :: Key -> Backend Annex -> CommandCleanup
cleanup :: Key -> Backend -> CommandCleanup
cleanup key backend = do
logStatus key InfoPresent

180
Command/Sync.hs
View file

@ -1,28 +1,74 @@
{- git-annex command
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
- Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Command.Sync where
import Common.Annex
import Command
import qualified Remote
import qualified Annex
import qualified Annex.Branch
import qualified Git.Command
import qualified Git.Config
import qualified Git.Branch
import qualified Git.Ref
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 "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
seek :: [CommandSeek]
seek = map withNothing [commit, pull, push]
-- syncing involves several operations, any of which can independently fail
seek :: CommandSeek
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 = do
@ -31,44 +77,96 @@ commit = do
showOutput
-- Commit will fail when the tree is clean, so ignore failure.
_ <- inRepo $ Git.Command.runBool "commit"
[Param "-a", Param "-m", Param "sync"]
[Param "-a", Param "-m", Param "git-annex automatic sync"]
return True
pull :: CommandStart
pull = do
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]
mergeLocal :: Git.Ref -> CommandStart
mergeLocal branch = go =<< needmerge
where
-- git push may be configured to not push matching
-- branches; this should ensure it always does.
matchingbranches = Param ":"
syncbranch = syncBranch branch
needmerge = do
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
defaultRemote :: Annex String
defaultRemote = do
branch <- currentBranch
fromRepo $ Git.Config.get ("branch." ++ branch ++ ".remote") "origin"
pushLocal :: Git.Ref -> CommandStart
pushLocal branch = do
updateBranch $ syncBranch branch
stop
currentBranch :: Annex String
currentBranch = Git.Ref.describe . Git.Ref . firstLine . L.unpack <$>
inRepo (Git.Command.pipeRead [Param "symbolic-ref", Param "HEAD"])
updateBranch :: Git.Ref -> Annex ()
updateBranch syncbranch =
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 ()
checkRemote remote = do
remoteurl <- fromRepo $
Git.Config.get ("remote." ++ remote ++ ".url") ""
when (null remoteurl) $ do
error $ "No url is configured for the remote: " ++ remote
pullRemote :: Remote -> Git.Ref -> CommandStart
pullRemote remote branch = do
showStart "pull" (Remote.name remote)
next $ do
showOutput
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 = [withFilesInGit $ whenAnnexed start]
start :: FilePath -> (Key, Backend Annex) -> CommandStart
start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = stopUnless (inAnnex key) $ do
showStart "unannex" file
next $ perform file key

2
Command/Uninit.hs
View file

@ -36,7 +36,7 @@ check = do
seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed startUnannex, withNothing start]
startUnannex :: FilePath -> (Key, Backend Annex) -> CommandStart
startUnannex :: FilePath -> (Key, Backend) -> CommandStart
startUnannex file info = do
-- Force fast mode before running unannex. This way, if multiple
-- 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
- content. -}
start :: FilePath -> (Key, Backend Annex) -> CommandStart
start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do
showStart "unlock" file
next $ perform file key

6
Command/Unused.hs
View file

@ -66,7 +66,7 @@ checkRemoteUnused name = do
checkRemoteUnused' =<< Remote.byName name
next $ return True
checkRemoteUnused' :: Remote.Remote Annex -> Annex ()
checkRemoteUnused' :: Remote -> Annex ()
checkRemoteUnused' r = do
showAction "checking for unused data"
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')"] ++
trailer
remoteUnusedMsg :: Remote.Remote Annex -> [(Int, Key)] -> String
remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
remoteUnusedMsg r u = unusedMsg' u
["Some annexed data on " ++ name ++ " is not used by any files:"]
[dropMsg $ Just r]
where
name = Remote.name r
dropMsg :: Maybe (Remote.Remote Annex) -> String
dropMsg :: Maybe Remote -> String
dropMsg Nothing = dropMsg' ""
dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r
dropMsg' :: String -> String

2
Command/Whereis.hs
View file

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

8
Git/Branch.hs
View file

@ -14,6 +14,14 @@ import Git
import Git.Sha
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
- branch. -}
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) $
pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
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. -}
hRead :: Repo -> Handle -> IO Repo

29
Git/Ref.hs
View file

@ -13,14 +13,26 @@ import Common
import Git
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 = 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
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) 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. -}
exists :: Ref -> Repo -> IO Bool
exists ref = runBool "show-ref"
@ -36,13 +48,18 @@ sha branch repo = process . L.unpack <$> showref repo
process [] = Nothing
process s = Just $ Ref $ firstLine s
{- List of (refs, branches) matching a given ref spec.
- Duplicate refs are filtered out. -}
{- List of (refs, branches) matching a given ref spec. -}
matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = do
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
uniqref (a, _) (b, _) = a == b
gen l = let (r, b) = separate (== ' ') l in
(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,
remoteTypes,
remoteList,
enabledRemoteList,
remoteMap,
byName,
prettyPrintUUIDs,
@ -52,7 +54,7 @@ import qualified Remote.Rsync
import qualified Remote.Web
import qualified Remote.Hook
remoteTypes :: [RemoteType Annex]
remoteTypes :: [RemoteType]
remoteTypes =
[ Remote.Git.remote
, Remote.S3.remote
@ -65,8 +67,8 @@ remoteTypes =
{- Builds a list of all available Remotes.
- Since doing so can be expensive, the list is cached. -}
genList :: Annex [Remote Annex]
genList = do
remoteList :: Annex [Remote]
remoteList = do
rs <- Annex.getState Annex.remotes
if null rs
then do
@ -84,23 +86,26 @@ genList = do
u <- getRepoUUID r
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. -}
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
- git remotes. -}
byName :: String -> Annex (Remote Annex)
byName :: String -> Annex (Remote)
byName n = do
res <- byName' n
case res of
Left e -> error e
Right r -> return r
byName' :: String -> Annex (Either String (Remote Annex))
byName' :: String -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified"
byName' n = do
allremotes <- genList
let match = filter matching allremotes
match <- filter matching <$> remoteList
if null match
then return $ Left $ "there is no git remote named \"" ++ n ++ "\""
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. -}
remotesWithUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
remotesWithUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
{- 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
{- 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
{- 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
- (some may not have configured remotes).
-}
keyPossibilitiesTrusted :: Key -> Annex ([Remote Annex], [UUID])
keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID])
keyPossibilitiesTrusted = keyPossibilities' True
keyPossibilities' :: Bool -> Key -> Annex ([Remote Annex], [UUID])
keyPossibilities' :: Bool -> Key -> Annex ([Remote], [UUID])
keyPossibilities' withtrusted key = do
u <- getUUID
trusted <- if withtrusted then trustGet Trusted else return []
@ -196,7 +201,7 @@ keyPossibilities' withtrusted key = do
let validtrusteduuids = validuuids `intersect` trusted
-- remotes that match uuids that have the key
allremotes <- filterM (repoNotIgnored . repo) =<< genList
allremotes <- enabledRemoteList
let validremotes = remotesWithUUID allremotes validuuids
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 rs us = message rs [] ++ message [] us
showTriedRemotes :: [Remote Annex] -> Annex ()
showTriedRemotes :: [Remote] -> Annex ()
showTriedRemotes [] = return ()
showTriedRemotes 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
- key to the remote, or removing the key from it *may* log the change
- 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
where
status = if present then InfoPresent else InfoMissing

7
Remote/Bup.hs
View file

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

7
Remote/Directory.hs
View file

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

16
Remote/Git.hs
View file

@ -5,7 +5,7 @@
- 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 qualified Data.Map as M
@ -28,7 +28,7 @@ import Utility.TempFile
import Config
import Init
remote :: RemoteType Annex
remote :: RemoteType
remote = RemoteType {
typename = "git",
enumerate = list,
@ -50,7 +50,7 @@ list = do
Git.Construct.remoteNamed n $
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
{- 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,
@ -79,7 +79,8 @@ gen r u _ = do
hasKey = inAnnex r',
hasKeyCheap = cheap,
config = Nothing,
repo = r'
repo = r',
remotetype = remote
}
{- Tries to read the config for a specified remote, updates state, and
@ -163,6 +164,13 @@ inAnnex r key
dispatch (Right Nothing) = unknown
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
- monad using that repository. -}
onLocal :: Git.Repo -> Annex a -> IO a

4
Remote/Helper/Encryptable.hs
View file

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

7
Remote/Hook.hs
View file

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

7
Remote/Rsync.hs
View file

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

29
Remote/S3real.hs
View file

@ -28,7 +28,7 @@ import Crypto
import Annex.Content
import Utility.Base64
remote :: RemoteType Annex
remote :: RemoteType
remote = RemoteType {
typename = "S3",
enumerate = findSpecialRemotes "s3",
@ -36,11 +36,11 @@ remote = RemoteType {
setup = s3Setup
}
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do
cst <- remoteCost r expensiveRemoteCost
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 =
encryptableRemote c
(storeEncrypted this)
@ -57,7 +57,8 @@ gen' r u c cst =
hasKey = checkPresent this,
hasKeyCheap = False,
config = c,
repo = r
repo = r,
remotetype = remote
}
s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
@ -110,13 +111,13 @@ s3Setup u c = handlehost $ M.lookup "host" c
-- be human-readable
M.delete "bucket" defaults
store :: Remote Annex -> Key -> Annex Bool
store :: Remote -> Key -> Annex Bool
store r k = s3Action r False $ \(conn, bucket) -> do
dest <- inRepo $ gitAnnexLocation k
res <- liftIO $ storeHelper (conn, bucket) r k dest
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) ->
-- To get file size of the encrypted content, have to use a temp file.
-- (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
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
content <- liftIO $ L.readFile file
-- 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
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
res <- liftIO $ getObject conn $ bucketKey r bucket k
case res of
@ -157,7 +158,7 @@ retrieve r k f = s3Action r False $ \(conn, bucket) -> do
return True
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
res <- liftIO $ getObject conn $ bucketKey r bucket enck
case res of
@ -167,12 +168,12 @@ retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do
return True
Left e -> s3Warning e
remove :: Remote Annex -> Key -> Annex Bool
remove :: Remote -> Key -> Annex Bool
remove r k = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ deleteObject conn $ bucketKey r bucket k
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
showAction $ "checking " ++ name r
res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k
@ -195,7 +196,7 @@ s3Bool :: AWSResult () -> Annex Bool
s3Bool (Right _) = return True
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
when (isNothing $ config 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)
_ -> return noconn
bucketFile :: Remote Annex -> Key -> FilePath
bucketFile :: Remote -> Key -> FilePath
bucketFile r = munge . show
where
munge s = case M.lookup "mungekeys" $ fromJust $ config r of
Just "ia" -> iaMunge s
_ -> s
bucketKey :: Remote Annex -> String -> Key -> S3Object
bucketKey :: Remote -> String -> Key -> S3Object
bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty
{- 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 :: RemoteType Annex
remote :: RemoteType
remote = RemoteType {
typename = "S3",
enumerate = return [],

7
Remote/Web.hs
View file

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

9
Types.hs
View file

@ -9,10 +9,17 @@ module Types (
Annex,
Backend,
Key,
UUID(..)
UUID(..),
Remote,
RemoteType
) where
import Annex
import Types.Backend
import Types.Key
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
-
- 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>
-
@ -11,7 +11,7 @@ module Types.Backend where
import Types.Key
data Backend a = Backend {
data BackendA a = Backend {
-- name of this backend
name :: String,
-- converts a filename to a key
@ -20,8 +20,8 @@ data Backend a = Backend {
fsckKey :: Key -> a Bool
}
instance Show (Backend a) where
instance Show (BackendA a) where
show backend = "Backend { name =\"" ++ name backend ++ "\" }"
instance Eq (Backend a) where
instance Eq (BackendA a) where
a == b = name a == name b

21
Types/Remote.hs
View file

@ -1,6 +1,6 @@
{- 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>
-
@ -19,19 +19,22 @@ import Types.UUID
type RemoteConfig = M.Map String String
{- There are different types of remotes. -}
data RemoteType a = RemoteType {
data RemoteTypeA a = RemoteType {
-- human visible type name
typename :: String,
-- enumerates remotes of this type
enumerate :: a [Git.Repo],
-- 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
setup :: UUID -> RemoteConfig -> a RemoteConfig
}
instance Eq (RemoteTypeA a) where
x == y = typename x == typename y
{- An individual remote. -}
data Remote a = Remote {
data RemoteA a = Remote {
-- each Remote has a unique uuid
uuid :: UUID,
-- each Remote has a human visible name
@ -53,16 +56,18 @@ data Remote a = Remote {
-- a Remote can have a persistent configuration store
config :: Maybe RemoteConfig,
-- 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 ++ "\" }"
-- 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
-- order remotes by cost
instance Ord (Remote a) where
instance Ord (RemoteA a) where
compare = comparing cost

2
Upgrade/V0.hs
View file

@ -33,7 +33,7 @@ keyFile0 :: Key -> FilePath
keyFile0 = Upgrade.V1.keyFile1
fileKey0 :: FilePath -> Key
fileKey0 = Upgrade.V1.fileKey1
lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend Annex))
lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile0 = Upgrade.V1.lookupFile1
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 file = catchDefaultIO (parseLog <$> readFileStrict file) []
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex))
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile1 file = do
tl <- liftIO $ try getsymlink
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
binary should only be used with old git.
* 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

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
the files, or have made modifications you want to discard.
* sync
* sync [remote ...]
Use this command when you want to synchronize the local repository
with its default remote (typically "origin"). The sync process involves
first committing all local changes, then pulling and merging any changes
from the remote, and finally pushing the repository's state to the remote.
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.
Use this command when you want to synchronize the local repository with
one or more of its remotes. You can specifiy the remotes to sync with;
the default is to sync with all remotes. Or specify --fast to sync with
the remotes with the lowest annex-cost value.
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 ...]

1
doc/index.mdwn
View file

@ -45,6 +45,7 @@ files with git.
* [[git-annex man page|git-annex]]
* [[key-value backends|backends]] for data storage
* [[special_remotes]] (including [[special_remotes/S3]] and [[special_remotes/bup]])
* [[sync]]
* [[encryption]]
* [[bare_repositories]]
* [[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)
_ -> assertFailure $ f ++ " failed to look up key"
checkbackend :: FilePath -> Types.Backend Types.Annex -> Assertion
checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do
r <- annexeval $ Backend.lookupFile file
let b = snd $ fromJust r
@ -936,14 +936,14 @@ changecontent f = writeFile f $ changedcontent f
changedcontent :: FilePath -> String
changedcontent f = (content f) ++ " (modified)"
backendSHA1 :: Types.Backend Types.Annex
backendSHA1 :: Types.Backend
backendSHA1 = backend_ "SHA1"
backendSHA256 :: Types.Backend Types.Annex
backendSHA256 :: Types.Backend
backendSHA256 = backend_ "SHA256"
backendWORM :: Types.Backend Types.Annex
backendWORM :: Types.Backend
backendWORM = backend_ "WORM"
backend_ :: String -> Types.Backend Types.Annex
backend_ :: String -> Types.Backend
backend_ name = Backend.lookupBackendName name