diff options
author | Joey Hess <joey@kitenet.net> | 2011-12-31 14:32:59 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2011-12-31 14:32:59 -0400 |
commit | 09905f66559f964ad36dc40da03d4f7f96804a91 (patch) | |
tree | b871c8a2372e6cba00aaa9b707c091f65837016b | |
parent | 38195a6363e54874ce072eb2d3ced448e0b68e02 (diff) | |
parent | f0957426c586610d16ad9694e002b73324baa29a (diff) |
Merge branch 'autosync'
46 files changed, 421 insertions, 196 deletions
@@ -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 diff --git a/Annex/Branch.hs b/Annex/Branch.hs index af1878479..d3a81d8e5 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -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 diff --git a/Backend.hs b/Backend.hs index 2f788fcd0..003d62bfc 100644 --- a/Backend.hs +++ b/Backend.hs @@ -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 diff --git a/Backend/SHA.hs b/Backend/SHA.hs index eca312944..a1124dfe2 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -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 diff --git a/Backend/URL.hs b/Backend/URL.hs index 32a72335a..7f621b00f 100644 --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -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) diff --git a/Backend/WORM.hs b/Backend/WORM.hs index 5a3e2d694..ae9833e30 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -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) diff --git a/Command.hs b/Command.hs index 813a239cb..dea6a97a3 100644 --- a/Command.hs +++ b/Command.hs @@ -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 diff --git a/Command/Copy.hs b/Command/Copy.hs index 16de423ac..77beb4b4f 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -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) diff --git a/Command/Drop.hs b/Command/Drop.hs index 0a4c9dfd6..89e7c8e42 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -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 $ diff --git a/Command/Find.hs b/Command/Find.hs index 1961e6b74..0c96369ee 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -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 diff --git a/Command/Fix.hs b/Command/Fix.hs index f264106c3..c4f981381 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index a803207e2..4e83455e1 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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 diff --git a/Command/Get.hs b/Command/Get.hs index b7023e2de..f2b70baeb 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -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 diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 1e6bc2ef1..698d60455 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -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=" diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 8778743ff..f6467463d 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -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 diff --git a/Command/Move.hs b/Command/Move.hs index 85fdff739..bd1490b0c 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -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 diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 0648e90fc..480806e11 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs index 36c4eeef0..445a37137 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -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 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 --- syncing involves several operations, any of which can independantly fail -seek :: [CommandSeek] -seek = map withNothing [commit, pull, push] +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] +mergeLocal :: Git.Ref -> CommandStart +mergeLocal branch = go =<< needmerge + where + 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 -push :: CommandStart -push = do - remote <- defaultRemote - showStart "push" remote - next $ next $ do - Annex.Branch.update +pushLocal :: Git.Ref -> CommandStart +pushLocal branch = do + updateBranch $ syncBranch branch + stop + +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 + ] + +pullRemote :: Remote -> Git.Ref -> CommandStart +pullRemote remote branch = do + showStart "pull" (Remote.name remote) + next $ do showOutput - inRepo $ Git.Command.runBool "push" [Param remote, matchingbranches] + 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 - -- git push may be configured to not push matching - -- branches; this should ensure it always does. - matchingbranches = Param ":" - --- the remote defaults to origin when not configured -defaultRemote :: Annex String -defaultRemote = do - branch <- currentBranch - fromRepo $ Git.Config.get ("branch." ++ branch ++ ".remote") "origin" - -currentBranch :: Annex String -currentBranch = Git.Ref.describe . Git.Ref . firstLine . L.unpack <$> - inRepo (Git.Command.pipeRead [Param "symbolic-ref", Param "HEAD"]) - -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 + 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 diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 66611cbd7..fee67429d 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -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 diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 21ad4c7df..cef89a5cf 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -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 diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 673a7038a..afee10145 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -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 diff --git a/Command/Unused.hs b/Command/Unused.hs index ef398b01e..8d45c51cb 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -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 diff --git a/Command/Whereis.hs b/Command/Whereis.hs index eb2ae3d4e..9e57f361b 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -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 diff --git a/Git/Branch.hs b/Git/Branch.hs index cce56dcfa..98811a987 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -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 diff --git a/Git/Config.hs b/Git/Config.hs index b2587aa44..d9109548b 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -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 diff --git a/Git/Ref.hs b/Git/Ref.hs index 0197ae789..557d24a37 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -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 @@ -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 diff --git a/Remote/Bup.hs b/Remote/Bup.hs index cbd5d584a..04cd49026 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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 diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 7f78b2f49..8ca2a2875 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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 diff --git a/Remote/Git.hs b/Remote/Git.hs index e527fa4fe..b9d9966a4 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 99f48fe7b..3abea7bc6 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -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, diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 5c761f43b..6c4a044ac 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 68566c52a..2fe302ba5 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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 diff --git a/Remote/S3real.hs b/Remote/S3real.hs index b79939b90..bef89b553 100644 --- a/Remote/S3real.hs +++ b/Remote/S3real.hs @@ -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, diff --git a/Remote/S3stub.hs b/Remote/S3stub.hs index d91a222e8..31e8a339e 100644 --- a/Remote/S3stub.hs +++ b/Remote/S3stub.hs @@ -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 [], diff --git a/Remote/Web.hs b/Remote/Web.hs index e31539f88..93e5770f0 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -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,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 diff --git a/Types/Backend.hs b/Types/Backend.hs index 4f8226704..025293a90 100644 --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -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 diff --git a/Types/Remote.hs b/Types/Remote.hs index ec9b7a7a7..216b34857 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -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 diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index eae5c87ce..c5310c641 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -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] diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 80554dc3b..add50fcf3 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -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 diff --git a/debian/changelog b/debian/changelog index f3e830c01..db447fea4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -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 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 8096005ce..a0dd3d3f1 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -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 - - 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. - - Note that sync does not transfer any file contents from or to the remote. +* sync [remote ...] + + 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. + + 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 ...] diff --git a/doc/index.mdwn b/doc/index.mdwn index 5bd42074f..e0791bf71 100644 --- a/doc/index.mdwn +++ b/doc/index.mdwn @@ -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]] diff --git a/doc/sync.mdwn b/doc/sync.mdwn new file mode 100644 index 000000000..765c1e43f --- /dev/null +++ b/doc/sync.mdwn @@ -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. @@ -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 |