diff options
author | Joey Hess <joeyh@joeyh.name> | 2018-10-19 15:17:48 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2018-10-19 17:29:18 -0400 |
commit | 8be5a7269a0813b64116d80b130d86a905a20fcf (patch) | |
tree | e13a7eaac88ac40f9729969551376d025ee22588 | |
parent | c94e62cab50cee37c96fb161735d5d65273580e3 (diff) |
refactor getCurrentBranch
Both Command.Sync and Annex.Ingest had their own versions of this.
The one in Annex.Ingest used Git.Branch.currentUnsafe, but does not seem
to need it. That is only checking to see if it's in an adjusted unlocked
branch, and when in an adjusted branch, the branch does in fact exist,
so the added check that Git.Branch.current does is fine.
This commit was sponsored by Denis Dzyubenko on Patreon.
-rw-r--r-- | Annex.hs | 3 | ||||
-rw-r--r-- | Annex/AdjustedBranch.hs | 102 | ||||
-rw-r--r-- | Annex/AdjustedBranch/Name.hs | 83 | ||||
-rw-r--r-- | Annex/CurrentBranch.hs | 41 | ||||
-rw-r--r-- | Annex/Ingest.hs | 20 | ||||
-rw-r--r-- | Assistant/Sync.hs | 6 | ||||
-rw-r--r-- | Assistant/Threads/Committer.hs | 3 | ||||
-rw-r--r-- | Assistant/Threads/Exporter.hs | 3 | ||||
-rw-r--r-- | Assistant/Threads/Merger.hs | 3 | ||||
-rw-r--r-- | Assistant/WebApp/Configurators/Local.hs | 4 | ||||
-rw-r--r-- | Command/Merge.hs | 5 | ||||
-rw-r--r-- | Command/PostReceive.hs | 5 | ||||
-rw-r--r-- | Command/Sync.hs | 63 | ||||
-rw-r--r-- | Types/AdjustedBranch.hs | 53 | ||||
-rw-r--r-- | git-annex.cabal | 3 |
15 files changed, 228 insertions, 169 deletions
@@ -65,6 +65,7 @@ import Types.NumCopies import Types.LockCache import Types.DesktopNotify import Types.CleanupActions +import Types.AdjustedBranch import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url @@ -144,7 +145,7 @@ data AnnexState = AnnexState , activekeys :: TVar (M.Map Key ThreadId) , activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) , keysdbhandle :: Maybe Keys.DbHandle - , cachedcurrentbranch :: Maybe Git.Branch + , cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) , cachedgitenv :: Maybe [(String, String)] , urloptions :: Maybe UrlOptions } diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index a23b70154e..a9193b49bf 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -11,6 +11,7 @@ module Annex.AdjustedBranch ( Adjustment(..), LinkAdjustment(..), PresenceAdjustment(..), + adjustmentHidesFiles, OrigBranch, AdjBranch(..), originalToAdjusted, @@ -29,6 +30,8 @@ module Annex.AdjustedBranch ( ) where import Annex.Common +import Types.AdjustedBranch +import Annex.AdjustedBranch.Name import qualified Annex import Git import Git.Types @@ -59,46 +62,6 @@ import Config import qualified Data.Map as M -data Adjustment - = LinkAdjustment LinkAdjustment - | PresenceAdjustment PresenceAdjustment (Maybe LinkAdjustment) - deriving (Show, Eq) - --- Doesn't make sense to combine unlock with fix. -data LinkAdjustment - = UnlockAdjustment - | LockAdjustment - | FixAdjustment - | UnFixAdjustment - deriving (Show, Eq) - -data PresenceAdjustment - = HideMissingAdjustment - | ShowMissingAdjustment - deriving (Show, Eq) - --- Adjustments have to be able to be reversed, so that commits made to the --- adjusted branch can be reversed to the commit that would have been made --- without the adjustment and applied to the original branch. -class ReversableAdjustment t where - reverseAdjustment :: t -> t - -instance ReversableAdjustment Adjustment where - reverseAdjustment (LinkAdjustment l) = - LinkAdjustment (reverseAdjustment l) - reverseAdjustment (PresenceAdjustment p ml) = - PresenceAdjustment (reverseAdjustment p) (fmap reverseAdjustment ml) - -instance ReversableAdjustment LinkAdjustment where - reverseAdjustment UnlockAdjustment = LockAdjustment - reverseAdjustment LockAdjustment = UnlockAdjustment - reverseAdjustment FixAdjustment = UnFixAdjustment - reverseAdjustment UnFixAdjustment = FixAdjustment - -instance ReversableAdjustment PresenceAdjustment where - reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment - reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment - -- How to perform various adjustments to a TreeItem. class AdjustTreeItem t where adjustTreeItem :: t -> TreeItem -> Annex (Maybe TreeItem) @@ -156,9 +119,6 @@ adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case <$> hashSymlink linktarget Nothing -> return (Just ti) -type OrigBranch = Branch -newtype AdjBranch = AdjBranch { adjBranch :: Branch } - -- This is a hidden branch ref, that's used as the basis for the AdjBranch, -- since pushes can overwrite the OrigBranch at any time. So, changes -- are propigated from the AdjBranch to the head of the BasisBranch. @@ -170,62 +130,6 @@ basisBranch :: AdjBranch -> BasisBranch basisBranch (AdjBranch adjbranch) = BasisBranch $ Ref ("refs/basis/" ++ fromRef (Git.Ref.base adjbranch)) -adjustedBranchPrefix :: String -adjustedBranchPrefix = "refs/heads/adjusted/" - -class SerializeAdjustment t where - serialize :: t -> String - deserialize :: String -> Maybe t - -instance SerializeAdjustment Adjustment where - serialize (LinkAdjustment l) = serialize l - serialize (PresenceAdjustment p Nothing) = serialize p - serialize (PresenceAdjustment p (Just l)) = - serialize p ++ "-" ++ serialize l - deserialize s = - (LinkAdjustment <$> deserialize s) - <|> - (PresenceAdjustment <$> deserialize s1 <*> pure (deserialize s2)) - <|> - (PresenceAdjustment <$> deserialize s <*> pure Nothing) - where - (s1, s2) = separate (== '-') s - -instance SerializeAdjustment LinkAdjustment where - serialize UnlockAdjustment = "unlocked" - serialize LockAdjustment = "locked" - serialize FixAdjustment = "fixed" - serialize UnFixAdjustment = "unfixed" - deserialize "unlocked" = Just UnlockAdjustment - deserialize "locked" = Just UnlockAdjustment - deserialize "fixed" = Just FixAdjustment - deserialize "unfixed" = Just UnFixAdjustment - deserialize _ = Nothing - -instance SerializeAdjustment PresenceAdjustment where - serialize HideMissingAdjustment = "hidemissing" - serialize ShowMissingAdjustment = "showmissing" - deserialize "hidemissing" = Just HideMissingAdjustment - deserialize "showmissing" = Just ShowMissingAdjustment - deserialize _ = Nothing - -originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch -originalToAdjusted orig adj = AdjBranch $ Ref $ - adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")" - where - base = fromRef (Git.Ref.base orig) - -adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch) -adjustedToOriginal b - | adjustedBranchPrefix `isPrefixOf` bs = do - let (base, as) = separate (== '(') (drop prefixlen bs) - adj <- deserialize (takeWhile (/= ')') as) - Just (adj, Git.Ref.branchRef (Ref base)) - | otherwise = Nothing - where - bs = fromRef b - prefixlen = length adjustedBranchPrefix - getAdjustment :: Branch -> Maybe Adjustment getAdjustment = fmap fst . adjustedToOriginal diff --git a/Annex/AdjustedBranch/Name.hs b/Annex/AdjustedBranch/Name.hs new file mode 100644 index 0000000000..8c074affb2 --- /dev/null +++ b/Annex/AdjustedBranch/Name.hs @@ -0,0 +1,83 @@ +{- adjusted branch names + - + - Copyright 2016-2018 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.AdjustedBranch.Name ( + originalToAdjusted, + adjustedToOriginal, + AdjBranch(..), + OrigBranch, +) where + +import Types.AdjustedBranch +import Git +import qualified Git.Ref +import Utility.Misc + +import Control.Applicative +import Data.List + +adjustedBranchPrefix :: String +adjustedBranchPrefix = "refs/heads/adjusted/" + +class SerializeAdjustment t where + serializeAdjustment :: t -> String + deserializeAdjustment :: String -> Maybe t + +instance SerializeAdjustment Adjustment where + serializeAdjustment (LinkAdjustment l) = + serializeAdjustment l + serializeAdjustment (PresenceAdjustment p Nothing) = + serializeAdjustment p + serializeAdjustment (PresenceAdjustment p (Just l)) = + serializeAdjustment p ++ "-" ++ serializeAdjustment l + deserializeAdjustment s = + (LinkAdjustment <$> deserializeAdjustment s) + <|> + (PresenceAdjustment <$> deserializeAdjustment s1 <*> pure (deserializeAdjustment s2)) + <|> + (PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing) + where + (s1, s2) = separate (== '-') s + +instance SerializeAdjustment LinkAdjustment where + serializeAdjustment UnlockAdjustment = "unlocked" + serializeAdjustment LockAdjustment = "locked" + serializeAdjustment FixAdjustment = "fixed" + serializeAdjustment UnFixAdjustment = "unfixed" + deserializeAdjustment "unlocked" = Just UnlockAdjustment + deserializeAdjustment "locked" = Just UnlockAdjustment + deserializeAdjustment "fixed" = Just FixAdjustment + deserializeAdjustment "unfixed" = Just UnFixAdjustment + deserializeAdjustment _ = Nothing + +instance SerializeAdjustment PresenceAdjustment where + serializeAdjustment HideMissingAdjustment = "hidemissing" + serializeAdjustment ShowMissingAdjustment = "showmissing" + deserializeAdjustment "hidemissing" = Just HideMissingAdjustment + deserializeAdjustment "showmissing" = Just ShowMissingAdjustment + deserializeAdjustment _ = Nothing + +newtype AdjBranch = AdjBranch { adjBranch :: Branch } + +originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch +originalToAdjusted orig adj = AdjBranch $ Ref $ + adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")" + where + base = fromRef (Git.Ref.base orig) + +type OrigBranch = Branch + +adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch) +adjustedToOriginal b + | adjustedBranchPrefix `isPrefixOf` bs = do + let (base, as) = separate (== '(') (drop prefixlen bs) + adj <- deserializeAdjustment (takeWhile (/= ')') as) + Just (adj, Git.Ref.branchRef (Ref base)) + | otherwise = Nothing + where + bs = fromRef b + prefixlen = length adjustedBranchPrefix diff --git a/Annex/CurrentBranch.hs b/Annex/CurrentBranch.hs new file mode 100644 index 0000000000..f6ae28442f --- /dev/null +++ b/Annex/CurrentBranch.hs @@ -0,0 +1,41 @@ +{- currently checked out branch + - + - Copyright 2018 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.CurrentBranch where + +import Annex.Common +import Types.AdjustedBranch +import Annex.AdjustedBranch.Name +import qualified Annex +import qualified Git +import qualified Git.Branch + +type CurrBranch = (Maybe Git.Branch, Maybe Adjustment) + +{- Gets the currently checked out branch. + - When on an adjusted branch, gets the original branch, and the adjustment. + - + - Cached for speed. + - + - Until a commit is made in a new repository, no branch is checked out. + - Since git-annex may make the first commit, this does not cache + - the absence of a branch. + -} +getCurrentBranch :: Annex CurrBranch +getCurrentBranch = maybe cache return + =<< Annex.getState Annex.cachedcurrentbranch + where + cache = inRepo Git.Branch.current >>= \case + Just b -> do + let v = case adjustedToOriginal b of + Nothing -> (Just b, Nothing) + Just (adj, origbranch) -> + (Just origbranch, Just adj) + Annex.changeState $ \s -> + s { Annex.cachedcurrentbranch = Just v } + return v + Nothing -> return (Nothing, Nothing) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index fa8d1eafcd..cd60fa6230 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -32,12 +32,12 @@ import Annex.Content.Direct import Annex.Perms import Annex.Link import Annex.MetaData +import Annex.CurrentBranch import Annex.Version import Logs.Location import qualified Annex import qualified Annex.Queue import qualified Database.Keys -import qualified Git import qualified Git.Branch import Config import Utility.InodeCache @@ -329,26 +329,14 @@ addUnlocked = isDirect <||> (versionSupportsUnlockedPointers <&&> ((not . coreSymlinks <$> Annex.getGitConfig) <||> (annexAddUnlocked <$> Annex.getGitConfig) <||> - (maybe False (isadjustedunlocked . getAdjustment) <$> cachedCurrentBranch) + (maybe False isadjustedunlocked . snd <$> getCurrentBranch) ) ) where - isadjustedunlocked (Just (LinkAdjustment UnlockAdjustment)) = True - isadjustedunlocked (Just (PresenceAdjustment _ (Just UnlockAdjustment))) = True + isadjustedunlocked (LinkAdjustment UnlockAdjustment) = True + isadjustedunlocked (PresenceAdjustment _ (Just UnlockAdjustment)) = True isadjustedunlocked _ = False -cachedCurrentBranch :: Annex (Maybe Git.Branch) -cachedCurrentBranch = maybe cache (return . Just) - =<< Annex.getState Annex.cachedcurrentbranch - where - cache :: Annex (Maybe Git.Branch) - cache = inRepo Git.Branch.currentUnsafe >>= \case - Nothing -> return Nothing - Just b -> do - Annex.changeState $ \s -> - s { Annex.cachedcurrentbranch = Just b } - return (Just b) - {- Adds a file to the work tree for the key, and stages it in the index. - The content of the key may be provided in a temp file, which will be - moved into place. diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 6792c13033..64ba174762 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -25,6 +25,7 @@ import qualified Annex.Branch import Annex.UUID import Annex.TaggedPush import Annex.Ssh +import Annex.CurrentBranch import qualified Config import Git.Config import Config.DynamicConfig @@ -79,8 +80,7 @@ reconnectRemotes rs = void $ do {- No local branch exists yet, but we can try pulling. -} sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes go = do - (failed, diverged) <- sync - =<< liftAnnex (join Command.Sync.getCurrBranch) + (failed, diverged) <- sync =<< liftAnnex getCurrentBranch addScanRemotes diverged =<< filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs return failed @@ -127,7 +127,7 @@ pushToRemotes' now remotes = do Annex.Branch.commit =<< Annex.Branch.commitMessage (,,) <$> gitRepo - <*> join Command.Sync.getCurrBranch + <*> getCurrentBranch <*> getUUID ret <- go True branch g u remotes return ret diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index aa57d26a86..4439667ec1 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -32,6 +32,7 @@ import Annex.Link import Annex.CatFile import Annex.InodeSentinal import Annex.Version +import Annex.CurrentBranch import qualified Annex import Utility.InodeCache import Annex.Content.Direct @@ -228,7 +229,7 @@ commitStaged msg = do Right _ -> do ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg when ok $ - Command.Sync.updateSyncBranch =<< join Command.Sync.getCurrBranch + Command.Sync.updateSyncBranch =<< getCurrentBranch return ok {- OSX needs a short delay after a file is added before locking it down, diff --git a/Assistant/Threads/Exporter.hs b/Assistant/Threads/Exporter.hs index 6a43954bcb..983c46747e 100644 --- a/Assistant/Threads/Exporter.hs +++ b/Assistant/Threads/Exporter.hs @@ -12,6 +12,7 @@ import Assistant.Commits import Assistant.Pushes import Assistant.DaemonStatus import Annex.Concurrent +import Annex.CurrentBranch import Utility.ThreadScheduler import qualified Annex import qualified Remote @@ -64,7 +65,7 @@ exportToRemotes rs = do Annex.changeState $ \st -> st { Annex.errcounter = 0 } start <- liftIO getCurrentTime void $ Command.Sync.seekExportContent rs - =<< join Command.Sync.getCurrBranch + =<< getCurrentBranch -- Look at command error counter to see if the export -- didn't work. failed <- (> 0) <$> Annex.getState Annex.errcounter diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index ff2fdc9a00..24f4705226 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -13,6 +13,7 @@ import Assistant.BranchChange import Assistant.Sync import Utility.DirWatcher import Utility.DirWatcher.Types +import Annex.CurrentBranch import qualified Annex.Branch import qualified Git import qualified Git.Branch @@ -71,7 +72,7 @@ onChange file changedbranch = fileToBranch file mergecurrent = - mergecurrent' =<< liftAnnex (join Command.Sync.getCurrBranch) + mergecurrent' =<< liftAnnex getCurrentBranch mergecurrent' currbranch@(Just b, _) | changedbranch `isRelatedTo` b = whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index f1134dca62..b0ea9833f0 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -20,7 +20,6 @@ import qualified Annex import qualified Git import qualified Git.Config import qualified Git.Command -import qualified Command.Sync import Config.Files import Utility.FreeDesktop import Utility.DiskFree @@ -30,6 +29,7 @@ import Utility.Mounts import Utility.DataUnits import Remote (prettyUUID) import Annex.UUID +import Annex.CurrentBranch import Types.StandardGroups import Logs.PreferredContent import Logs.UUID @@ -212,7 +212,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do - immediately pulling from it. Also spawns a sync to push to it as well. -} immediateSyncRemote :: Remote -> Assistant () immediateSyncRemote r = do - currentbranch <- liftAnnex $ join Command.Sync.getCurrBranch + currentbranch <- liftAnnex $ getCurrentBranch void $ manualPull currentbranch [r] syncRemote r diff --git a/Command/Merge.hs b/Command/Merge.hs index 1ed669aff0..7893613e40 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -9,7 +9,8 @@ module Command.Merge where import Command import qualified Annex.Branch -import Command.Sync (prepMerge, mergeLocal, getCurrBranch, mergeConfig) +import Annex.CurrentBranch +import Command.Sync (prepMerge, mergeLocal, mergeConfig) cmd :: Command cmd = command "merge" SectionMaintenance @@ -33,4 +34,4 @@ mergeBranch = do mergeSynced :: CommandStart mergeSynced = do prepMerge - mergeLocal mergeConfig def =<< join getCurrBranch + mergeLocal mergeConfig def =<< getCurrentBranch diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs index 4db7752148..1d3b076338 100644 --- a/Command/PostReceive.hs +++ b/Command/PostReceive.hs @@ -11,7 +11,8 @@ import Command import qualified Annex import Git.Types import Annex.UpdateInstead -import Command.Sync (mergeLocal, prepMerge, mergeConfig, getCurrBranch) +import Annex.CurrentBranch +import Command.Sync (mergeLocal, prepMerge, mergeConfig) -- This does not need to modify the git-annex branch to update the -- work tree, but auto-initialization might change the git-annex branch. @@ -48,4 +49,4 @@ fixPostReceiveHookEnv = do updateInsteadEmulation :: CommandStart updateInsteadEmulation = do prepMerge - mergeLocal mergeConfig def =<< join getCurrBranch + mergeLocal mergeConfig def =<< getCurrentBranch diff --git a/Command/Sync.hs b/Command/Sync.hs index 5f691aabb6..5e42e6eff3 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -9,7 +9,6 @@ module Command.Sync ( cmd, CurrBranch, - getCurrBranch, mergeConfig, merge, prepMerge, @@ -60,6 +59,7 @@ import Annex.UpdateInstead import Annex.Export import Annex.LockFile import Annex.TaggedPush +import Annex.CurrentBranch import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse @@ -162,8 +162,7 @@ seek :: SyncOptions -> CommandSeek seek o = allowConcurrentOutput $ do prepMerge - getbranch <- getCurrBranch - let withbranch a = a =<< getbranch + let withbranch a = a =<< getCurrentBranch remotes <- syncRemotes (syncWith o) let gitremotes = filter Remote.gitSyncableRemote remotes @@ -188,7 +187,7 @@ seek o = allowConcurrentOutput $ do ] whenM shouldsynccontent $ do - syncedcontent <- seekSyncContent o dataremotes + syncedcontent <- withbranch $ seekSyncContent o dataremotes exportedcontent <- withbranch $ seekExportContent exportremotes -- Transferring content can take a while, -- and other changes can be pushed to the @@ -209,35 +208,6 @@ seek o = allowConcurrentOutput $ do <||> pure (not (null (contentOfOption o))) <||> (pure (not (noContentOption o)) <&&> getGitConfigVal annexSyncContent) -type CurrBranch = (Maybe Git.Branch, Maybe Adjustment) - -{- There may not be a branch checked out until after the commit, - - or perhaps after it gets merged from the remote, or perhaps - - never. - - - - So only look it up once it's needed, and once there is a - - branch, cache it. - - - - When on an adjusted branch, gets the original branch, and the adjustment. - -} -getCurrBranch :: Annex (Annex CurrBranch) -getCurrBranch = do - mvar <- liftIO newEmptyMVar - return $ ifM (liftIO $ isEmptyMVar mvar) - ( do - currbranch <- inRepo Git.Branch.current - case currbranch of - Nothing -> return (Nothing, Nothing) - Just b -> do - let v = case adjustedToOriginal b of - Nothing -> (Just b, Nothing) - Just (adj, origbranch) -> - (Just origbranch, Just adj) - liftIO $ putMVar mvar v - return v - , liftIO $ readMVar mvar - ) - {- Merging may delete the current directory, so go to the top - of the repo. This also means that sync always acts on all files in the - repository, not just on a subdirectory. -} @@ -568,8 +538,11 @@ newer remote b = do , return True ) -{- Without --all, only looks at files in the work tree. With --all, - - makes 2 passes, first looking at the work tree and then all keys. +{- Without --all, only looks at files in the work tree. + - (Or, when in an ajusted branch where some files are hidden, at files in + - the original branch.) + - + - With --all, makes a second pass over all keys. - This ensures that preferred content expressions that match on - filenames work, even when in --all mode. - @@ -577,15 +550,19 @@ newer remote b = do - - When concurrency is enabled, files are processed concurrently. -} -seekSyncContent :: SyncOptions -> [Remote] -> Annex Bool -seekSyncContent o rs = do +seekSyncContent :: SyncOptions -> [Remote] -> CurrBranch -> Annex Bool +seekSyncContent o rs currbranch = do mvar <- liftIO newEmptyMVar bloom <- case keyOptions o of Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar []) - _ -> do - l <- workTreeItems (contentOfOption o) - seekworktree mvar l (const noop) - pure Nothing + _ -> case currbranch of + (origbranch, Just adj) | adjustmentHidesFiles adj -> do + seekbranch origbranch (contentOfOption o) + pure Nohing + _ = do + l <- workTreeItems (contentOfOption o) + seekworktree mvar l (const noop) + pure Nothing withKeyOptions' (keyOptions o) False (return (seekkeys mvar bloom)) (const noop) @@ -595,7 +572,11 @@ seekSyncContent o rs = do where seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>= mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (AssociatedFile (Just f))) noop) + + seekbranch origbranch l = + seekkeys mvar bloom (k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k + go ebloom mvar af k = commandAction $ do whenM (syncFile ebloom rs af k) $ void $ liftIO $ tryPutMVar mvar () diff --git a/Types/AdjustedBranch.hs b/Types/AdjustedBranch.hs new file mode 100644 index 0000000000..bf59658403 --- /dev/null +++ b/Types/AdjustedBranch.hs @@ -0,0 +1,53 @@ +{- adjusted branch types + - + - Copyright 2016-2018 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.AdjustedBranch where + +data Adjustment + = LinkAdjustment LinkAdjustment + | PresenceAdjustment PresenceAdjustment (Maybe LinkAdjustment) + deriving (Show, Eq) + +-- Doesn't make sense to combine unlock with fix. +data LinkAdjustment + = UnlockAdjustment + | LockAdjustment + | FixAdjustment + | UnFixAdjustment + deriving (Show, Eq) + +data PresenceAdjustment + = HideMissingAdjustment + | ShowMissingAdjustment + deriving (Show, Eq) + +-- Adjustments have to be able to be reversed, so that commits made to the +-- adjusted branch can be reversed to the commit that would have been made +-- without the adjustment and applied to the original branch. +class ReversableAdjustment t where + reverseAdjustment :: t -> t + +instance ReversableAdjustment Adjustment where + reverseAdjustment (LinkAdjustment l) = + LinkAdjustment (reverseAdjustment l) + reverseAdjustment (PresenceAdjustment p ml) = + PresenceAdjustment (reverseAdjustment p) (fmap reverseAdjustment ml) + +instance ReversableAdjustment LinkAdjustment where + reverseAdjustment UnlockAdjustment = LockAdjustment + reverseAdjustment LockAdjustment = UnlockAdjustment + reverseAdjustment FixAdjustment = UnFixAdjustment + reverseAdjustment UnFixAdjustment = FixAdjustment + +instance ReversableAdjustment PresenceAdjustment where + reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment + reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment + +adjustmentHidesFiles :: Adjustment -> Bool +adjustmentHidesFiles (PresenceAdjustment HideMissingAdjustment _) = True +adjustmentHidesFiles _ = False + diff --git a/git-annex.cabal b/git-annex.cabal index 7b9f04eac6..a2c6b4df0c 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -595,6 +595,7 @@ Executable git-annex Annex Annex.Action Annex.AdjustedBranch + Annex.AdjustedBranch.Name Annex.AutoMerge Annex.BloomFilter Annex.Branch @@ -610,6 +611,7 @@ Executable git-annex Annex.Content.Direct Annex.Content.LowLevel Annex.Content.PointerFile + Annex.CurrentBranch Annex.Difference Annex.DirHashes Annex.Direct @@ -942,6 +944,7 @@ Executable git-annex Test.Framework Types Types.ActionItem + Types.AdjustedBranch Types.Availability Types.Backend Types.BranchState |