diff options
| -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 |