summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2018-10-19 15:17:48 -0400
committerJoey Hess <joeyh@joeyh.name>2018-10-19 17:29:18 -0400
commit8be5a7269a0813b64116d80b130d86a905a20fcf (patch)
treee13a7eaac88ac40f9729969551376d025ee22588
parentc94e62cab50cee37c96fb161735d5d65273580e3 (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.hs3
-rw-r--r--Annex/AdjustedBranch.hs102
-rw-r--r--Annex/AdjustedBranch/Name.hs83
-rw-r--r--Annex/CurrentBranch.hs41
-rw-r--r--Annex/Ingest.hs20
-rw-r--r--Assistant/Sync.hs6
-rw-r--r--Assistant/Threads/Committer.hs3
-rw-r--r--Assistant/Threads/Exporter.hs3
-rw-r--r--Assistant/Threads/Merger.hs3
-rw-r--r--Assistant/WebApp/Configurators/Local.hs4
-rw-r--r--Command/Merge.hs5
-rw-r--r--Command/PostReceive.hs5
-rw-r--r--Command/Sync.hs63
-rw-r--r--Types/AdjustedBranch.hs53
-rw-r--r--git-annex.cabal3
15 files changed, 228 insertions, 169 deletions
diff --git a/Annex.hs b/Annex.hs
index bdedec3c69..e1406d2419 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -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