mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Merge branch 'master' into v8

Browse source
This commit is contained in:
Joey Hess 2020-02-19 14:32:11 -04:00
commit 029c883713
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
456 changed files with 6341 additions and 1085 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Command/AddUrl.hs
View file

@ -261,7 +261,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just (toRawFilePath file)))
where
urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing
downloader f p = downloadUrl urlkey p [url] f
downloader f p = Url.withUrlOptions $ downloadUrl urlkey p [url] f
go Nothing = return Nothing
-- If we downloaded a html file, try to use youtube-dl to
-- extract embedded media.

18
Command/EnableRemote.hs
View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2013-2019 Joey Hess <id@joeyh.name>
- Copyright 2013-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -24,13 +24,15 @@ import Annex.UUID
import Config
import Config.DynamicConfig
import Types.GitConfig
import Types.ProposedAccepted
import Git.Config
import qualified Data.Map as M
cmd :: Command
cmd = command "enableremote" SectionSetup
"enables git-annex to use a remote"
(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)
(withParams seek)
seek :: CmdParams -> CommandSeek
@ -41,7 +43,7 @@ start [] = unknownNameError "Specify the remote to enable."
start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes
where
matchingname r = Git.remoteName r == Just name
go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest)
go [] = startSpecialRemote name (Logs.Remote.keyValToConfig Proposed rest)
=<< SpecialRemote.findExisting name
go (r:_) = do
-- This could be either a normal git remote or a special
@ -85,21 +87,23 @@ startSpecialRemote name config (Just (u, c, mcu)) =
performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform
performSpecialRemote t u oldc c gc mcu = do
(c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc
next $ cleanupSpecialRemote u' c' mcu
next $ cleanupSpecialRemote t u' c' mcu
cleanupSpecialRemote :: UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup
cleanupSpecialRemote u c mcu = do
cleanupSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup
cleanupSpecialRemote t u c mcu = do
case mcu of
Nothing ->
Logs.Remote.configSet u c
Just (SpecialRemote.ConfigFrom cu) -> do
setConfig (remoteConfig c "config-uuid") (fromUUID cu)
setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)
Logs.Remote.configSet cu c
Remote.byUUID u >>= \case
Nothing -> noop
Just r -> do
repo <- R.getRepo r
setRemoteIgnore repo False
unless (Remote.gitSyncableRemoteType t) $
setConfig (remoteConfig c "skipFetchAll") (boolConfig True)
return True
unknownNameError :: String -> Annex a

8
Command/Export.hs
View file

@ -81,7 +81,7 @@ seek o = do
-- handle deprecated option
when (exportTracking o) $
setConfig (remoteConfig r "annex-tracking-branch")
setConfig (remoteAnnexConfig r "tracking-branch")
(fromRef $ exportTreeish o)
tree <- filterPreferredContent r =<<
@ -216,7 +216,7 @@ mkDiffMap old new db = do
, (, (Nothing, Just (Git.DiffTree.file i))) <$> dstek
]
getek sha
| sha == nullSha = return Nothing
| sha `elem` nullShas = return Nothing
| otherwise = Just <$> exportKey sha
newtype FileUploaded = FileUploaded { fromFileUploaded :: Bool }
@ -310,7 +310,7 @@ cleanupExport r db ek loc sent = do
startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
startUnexport r db f shas = do
eks <- forM (filter (/= nullSha) shas) exportKey
eks <- forM (filter (`notElem` nullShas) shas) exportKey
if null eks
then stop
else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $
@ -359,7 +359,7 @@ cleanupUnexport r db eks loc = do
startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
startRecoverIncomplete r db sha oldf
| sha == nullSha = stop
| sha `elem` nullShas = stop
| otherwise = do
ek <- exportKey sha
let loc = exportTempName ek

9
Command/Fsck.hs
View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
- Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -161,6 +161,11 @@ performRemote key afile backend numcopies remote =
]
ai = mkActionItem (key, afile)
withtmp a = do
-- Put it in the gitAnnexTmpObjectDir since that's on a
-- filesystem where object temp files are normally
-- stored. The pid prevents multiple fsck processes
-- contending over the same file. (Multiple threads cannot,
-- because OnlyActionOn is used.)
pid <- liftIO getPID
t <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory t
@ -541,7 +546,7 @@ badContentRemote remote localcopy key = do
runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart
runFsck inc ai key a = stopUnless (needFsck inc key) $
starting "fsck" ai $ do
starting "fsck" (OnlyActionOn key ai) $ do
ok <- a
when ok $
recordFsckTime inc key

65
Command/InitRemote.hs
View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2011-2019 Joey Hess <id@joeyh.name>
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -16,27 +16,36 @@ import Annex.SpecialRemote
import qualified Remote
import qualified Logs.Remote
import qualified Types.Remote as R
import Types.RemoteConfig
import Annex.UUID
import Logs.UUID
import Logs.Remote
import Types.GitConfig
import Types.ProposedAccepted
import Config
import Git.Config
cmd :: Command
cmd = command "initremote" SectionSetup
"creates a special (non-git) remote"
(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)
(seek <$$> optParser)
data InitRemoteOptions = InitRemoteOptions
{ cmdparams :: CmdParams
, sameas :: Maybe (DeferredParse UUID)
, whatElse :: Bool
}
optParser :: CmdParamsDesc -> Parser InitRemoteOptions
optParser desc = InitRemoteOptions
<$> cmdParams desc
<*> optional parseSameasOption
<*> switch
( long "whatelse"
<> short 'w'
<> help "describe other configuration parameters for a special remote"
)
parseSameasOption :: Parser (DeferredParse UUID)
parseSameasOption = parseUUIDOption <$> strOption
@ -63,35 +72,67 @@ start o (name:ws) = ifM (isJust <$> findExisting name)
(Just . Sameas <$$> getParsed)
(sameas o)
c <- newConfig name sameasuuid
(Logs.Remote.keyValToConfig ws)
(Logs.Remote.keyValToConfig Proposed ws)
<$> readRemoteLog
t <- either giveup return (findType c)
starting "initremote" (ActionItemOther (Just name)) $
perform t name c o
if whatElse o
then startingCustomOutput (ActionItemOther Nothing) $
describeOtherParamsFor c t
else starting "initremote" (ActionItemOther (Just name)) $
perform t name c o
)
)
perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform
perform t name c o = do
dummycfg <- liftIO dummyRemoteGitConfig
(c', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c dummycfg
next $ cleanup u name c' o
let c' = M.delete uuidField c
(c'', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c' dummycfg
next $ cleanup t u name c'' o
where
uuidfromuser = case M.lookup "uuid" c of
uuidfromuser = case fromProposedAccepted <$> M.lookup uuidField c of
Just s
| isUUID s -> Just (toUUID s)
| otherwise -> giveup "invalid uuid"
Nothing -> Nothing
sameasu = toUUID <$> M.lookup sameasUUIDField c
sameasu = toUUID . fromProposedAccepted <$> M.lookup sameasUUIDField c
cleanup :: UUID -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup
cleanup u name c o = do
uuidField :: R.RemoteConfigField
uuidField = Accepted "uuid"
cleanup :: RemoteType -> UUID -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup
cleanup t u name c o = do
case sameas o of
Nothing -> do
describeUUID u (toUUIDDesc name)
Logs.Remote.configSet u c
Just _ -> do
cu <- liftIO genUUID
setConfig (remoteConfig c "config-uuid") (fromUUID cu)
setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)
Logs.Remote.configSet cu c
unless (Remote.gitSyncableRemoteType t) $
setConfig (remoteConfig c "skipFetchAll") (boolConfig True)
return True
describeOtherParamsFor :: RemoteConfig -> RemoteType -> CommandPerform
describeOtherParamsFor c t = do
cp <- R.configParser t c
let l = map mk (filter notinconfig $ remoteConfigFieldParsers cp)
++ map mk' (maybe [] snd (remoteConfigRestPassthrough cp))
liftIO $ forM_ l $ \(p, fd, vd) -> case fd of
HiddenField -> return ()
FieldDesc d -> do
putStrLn p
putStrLn ("\t" ++ d)
case vd of
Nothing -> return ()
Just (ValueDesc d') ->
putStrLn $ "\t(" ++ d' ++ ")"
next $ return True
where
notinconfig fp = not (M.member (parserForField fp) c)
mk fp = ( fromProposedAccepted (parserForField fp)
, fieldDesc fp
, valueDesc fp
)
mk' (k, v) = (k, v, Nothing)

11
Command/Log.hs
View file

@ -210,17 +210,18 @@ getAllLog = getGitLog []
getGitLog :: [FilePath] -> [CommandParam] -> Annex ([RefChange], IO Bool)
getGitLog fs os = do
config <- Annex.getGitConfig
(ls, cleanup) <- inRepo $ pipeNullSplit $
[ Param "log"
, Param "-z"
, Param "--pretty=format:%ct"
, Param "--raw"
, Param "--abbrev=40"
, Param "--no-abbrev"
] ++ os ++
[ Param $ Git.fromRef Annex.Branch.fullname
, Param "--"
] ++ map Param fs
return (parseGitRawLog (map decodeBL' ls), cleanup)
return (parseGitRawLog config (map decodeBL' ls), cleanup)
-- Parses chunked git log --raw output, which looks something like:
--
@ -236,8 +237,8 @@ getGitLog fs os = do
--
-- The timestamp is not included before all changelines, so
-- keep track of the most recently seen timestamp.
parseGitRawLog :: [String] -> [RefChange]
parseGitRawLog = parse epoch
parseGitRawLog :: GitConfig -> [String] -> [RefChange]
parseGitRawLog config = parse epoch
where
epoch = toEnum 0 :: POSIXTime
parse oldts ([]:rest) = parse oldts rest
@ -250,7 +251,7 @@ parseGitRawLog = parse epoch
(tss, cl') -> (parseTimeStamp tss, cl')
mrc = do
(old, new) <- parseRawChangeLine cl
key <- locationLogFileKey (toRawFilePath c2)
key <- locationLogFileKey config (toRawFilePath c2)
return $ RefChange
{ changetime = ts
, oldref = old

5
Command/Merge.hs
View file

@ -12,7 +12,7 @@ import qualified Annex.Branch
import qualified Git
import qualified Git.Branch
import Annex.CurrentBranch
import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge)
import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge, SyncOptions(..))
cmd :: Command
cmd = command "merge" SectionMaintenance
@ -41,4 +41,5 @@ mergeSyncedBranch = mergeLocal mergeConfig def =<< getCurrentBranch
mergeBranch :: Git.Ref -> CommandStart
mergeBranch r = starting "merge" (ActionItemOther (Just (Git.fromRef r))) $ do
currbranch <- getCurrentBranch
next $ merge currbranch mergeConfig def Git.Branch.ManualCommit r
let o = def { notOnlyAnnexOption = True }
next $ merge currbranch mergeConfig o Git.Branch.ManualCommit r

2
Command/P2P.hs
View file

@ -320,7 +320,7 @@ setupLink remotename (P2PAddressAuth addr authtoken) = do
, Param (formatP2PAddress addr)
]
when ok $ do
storeUUIDIn (remoteConfig remotename "uuid") theiruuid
storeUUIDIn (remoteAnnexConfig remotename "uuid") theiruuid
storeP2PRemoteAuthToken addr authtoken
return LinkSuccess
go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again."

5
Command/PostReceive.hs
View file

@ -14,7 +14,7 @@ import qualified Annex
import Git.Types
import Annex.UpdateInstead
import Annex.CurrentBranch
import Command.Sync (mergeLocal, prepMerge, mergeConfig)
import Command.Sync (mergeLocal, prepMerge, mergeConfig, SyncOptions(..))
-- This does not need to modify the git-annex branch to update the
-- work tree, but auto-initialization might change the git-annex branch.
@ -51,4 +51,5 @@ fixPostReceiveHookEnv = do
updateInsteadEmulation :: CommandStart
updateInsteadEmulation = do
prepMerge
mergeLocal mergeConfig def =<< getCurrentBranch
let o = def { notOnlyAnnexOption = True }
mergeLocal mergeConfig o =<< getCurrentBranch

10
Command/Reinject.hs
View file

@ -13,6 +13,7 @@ import Annex.Content
import Backend
import Types.KeySource
import Utility.Metered
import qualified Git
cmd :: Command
cmd = command "reinject" SectionUtility
@ -65,8 +66,13 @@ startKnown src = notAnnexed src $
)
notAnnexed :: FilePath -> CommandStart -> CommandStart
notAnnexed src = ifAnnexed (toRawFilePath src) $
giveup $ "cannot used annexed file as src: " ++ src
notAnnexed src a =
ifM (fromRepo Git.repoIsLocalBare)
( a
, ifAnnexed (toRawFilePath src)
(giveup $ "cannot used annexed file as src: " ++ src)
a
)
perform :: FilePath -> Key -> CommandPerform
perform src key = ifM move

3
Command/RenameRemote.hs
View file

@ -13,6 +13,7 @@ import Annex.SpecialRemote.Config (nameField, sameasNameField)
import qualified Logs.Remote
import qualified Types.Remote as R
import qualified Remote
import Types.ProposedAccepted
import qualified Data.Map as M
@ -50,6 +51,6 @@ perform u cfg mcu newname = do
let (namefield, cu) = case mcu of
Nothing -> (nameField, u)
Just (Annex.SpecialRemote.ConfigFrom u') -> (sameasNameField, u')
Logs.Remote.configSet cu (M.insert namefield newname cfg)
Logs.Remote.configSet cu (M.insert namefield (Proposed newname) cfg)
next $ return True

201
Command/Sync.hs
View file

@ -1,7 +1,7 @@
{- git-annex command
-
- Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
- Copyright 2011-2019 Joey Hess <id@joeyh.name>
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -24,6 +24,7 @@ module Command.Sync (
syncBranch,
updateBranches,
seekExportContent,
SyncOptions(..),
) where
import Command
@ -43,6 +44,7 @@ import Git.FilePath
import qualified Remote.Git
import Config
import Config.GitConfig
import Annex.SpecialRemote.Config
import Config.DynamicConfig
import Config.Files
import Annex.Wanted
@ -77,8 +79,10 @@ cmd = withGlobalOptions [jobsOption] $
"synchronize local repository with remotes"
(paramRepeating paramRemote) (seek <--< optParser)
data SyncOptions = SyncOptions
data SyncOptions = SyncOptions
{ syncWith :: CmdParams
, onlyAnnexOption :: Bool
, notOnlyAnnexOption :: Bool
, commitOption :: Bool
, noCommitOption :: Bool
, messageOption :: Maybe String
@ -89,13 +93,26 @@ data SyncOptions = SyncOptions
, contentOfOption :: [FilePath]
, cleanupOption :: Bool
, keyOptions :: Maybe KeyOptions
, resolveMergeOverride :: ResolveMergeOverride
, resolveMergeOverride :: Bool
}
newtype ResolveMergeOverride = ResolveMergeOverride Bool
instance Default ResolveMergeOverride where
def = ResolveMergeOverride False
instance Default SyncOptions where
def = SyncOptions
{ syncWith = []
, onlyAnnexOption = False
, notOnlyAnnexOption = False
, commitOption = False
, noCommitOption = False
, messageOption = Nothing
, pullOption = False
, pushOption = False
, contentOption = False
, noContentOption = False
, contentOfOption = []
, cleanupOption = False
, keyOptions = Nothing
, resolveMergeOverride = False
}
optParser :: CmdParamsDesc -> Parser SyncOptions
optParser desc = SyncOptions
@ -103,6 +120,15 @@ optParser desc = SyncOptions
( metavar desc
<> completeRemotes
))
<*> switch
( long "only-annex"
<> short 'a'
<> help "only sync git-annex branch and annexed file contents"
)
<*> switch
( long "not-only-annex"
<> help "sync git branches as well as annex"
)
<*> switch
( long "commit"
<> help "commit changes to git"
@ -123,16 +149,16 @@ optParser desc = SyncOptions
)
<*> switch
( long "content"
<> help "transfer file contents"
<> help "transfer annexed file contents"
)
<*> switch
( long "no-content"
<> help "do not transfer file contents"
<> help "do not transfer annexed file contents"
)
<*> many (strOption
( long "content-of"
<> short 'C'
<> help "transfer file contents of files in a given location"
<> help "transfer contents of annexed files in a given location"
<> metavar paramPath
))
<*> switch
@ -140,15 +166,17 @@ optParser desc = SyncOptions
<> help "remove synced/ branches from previous sync"
)
<*> optional parseAllOption
<*> (ResolveMergeOverride <$> invertableSwitch "resolvemerge" True
<*> invertableSwitch "resolvemerge" True
( help "do not automatically resolve merge conflicts"
))
)
-- Since prepMerge changes the working directory, FilePath options
-- have to be adjusted.
instance DeferredParseClass SyncOptions where
finishParse v = SyncOptions
<$> pure (syncWith v)
<*> pure (onlyAnnexOption v)
<*> pure (notOnlyAnnexOption v)
<*> pure (commitOption v)
<*> pure (noCommitOption v)
<*> pure (messageOption v)
@ -171,7 +199,7 @@ seek' o = do
let withbranch a = a =<< getCurrentBranch
remotes <- syncRemotes (syncWith o)
let gitremotes = filter Remote.gitSyncableRemote remotes
let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes
dataremotes <- filter (\r -> Remote.uuid r /= NoUUID)
<$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes
let (exportremotes, keyvalueremotes) = partition (exportTree . Remote.config) dataremotes
@ -188,12 +216,12 @@ seek' o = do
-- These actions cannot be run concurrently.
mapM_ includeCommandAction $ concat
[ [ commit o ]
, [ withbranch (mergeLocal mergeConfig (resolveMergeOverride o)) ]
, [ withbranch (mergeLocal mergeConfig o) ]
, map (withbranch . pullRemote o mergeConfig) gitremotes
, [ mergeAnnex ]
]
whenM shouldsynccontent $ do
whenM (shouldSyncContent o) $ do
mapM_ (withbranch . importRemote o mergeConfig) importremotes
-- Send content to any exports before other
@ -214,13 +242,9 @@ seek' o = do
, [ commitAnnex, mergeAnnex ]
]
void $ includeCommandAction $ withbranch pushLocal
void $ includeCommandAction $ withbranch $ pushLocal o
-- Pushes to remotes can run concurrently.
mapM_ (commandAction . withbranch . pushRemote o) gitremotes
where
shouldsynccontent = pure (contentOption o)
<||> pure (not (null (contentOfOption o)))
<||> (pure (not (noContentOption o)) <&&> getGitConfigVal annexSyncContent)
{- 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
@ -240,14 +264,14 @@ mergeConfig =
, Git.Merge.MergeUnrelatedHistories
]
merge :: CurrBranch -> [Git.Merge.MergeConfig] -> ResolveMergeOverride -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool
merge currbranch mergeconfig resolvemergeoverride commitmode tomerge = case currbranch of
merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool
merge currbranch mergeconfig o commitmode tomerge = case currbranch of
(Just b, Just adj) -> mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode
(b, _) -> autoMergeFrom tomerge b mergeconfig canresolvemerge commitmode
where
canresolvemerge = case resolvemergeoverride of
ResolveMergeOverride True -> getGitConfigVal annexResolveMerge
ResolveMergeOverride False -> return False
canresolvemerge = if resolveMergeOverride o
then getGitConfigVal annexResolveMerge
else return False
syncBranch :: Git.Branch -> Git.Branch
syncBranch = Git.Ref.underBase "refs/heads/synced" . fromAdjustedBranch
@ -276,7 +300,7 @@ syncRemotes' ps available =
listed = concat <$> mapM Remote.byNameOrGroup ps
good r
| Remote.gitSyncableRemote r =
| Remote.gitSyncableRemoteType (Remote.remotetype r) =
Remote.Git.repoAvail =<< Remote.getRepo r
| otherwise = return True
@ -295,8 +319,10 @@ commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing)
]
return True
where
shouldcommit = pure (commitOption o)
shouldcommit = notOnlyAnnex o <&&>
( pure (commitOption o)
<||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit)
)
commitMsg :: Annex String
commitMsg = do
@ -315,14 +341,18 @@ commitStaged commitmode commitmessage = do
void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch parents
return True
mergeLocal :: [Git.Merge.MergeConfig] -> ResolveMergeOverride -> CurrBranch -> CommandStart
mergeLocal mergeconfig resolvemergeoverride currbranch@(Just _, _) =
mergeLocal :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart
mergeLocal mergeconfig o currbranch = stopUnless (notOnlyAnnex o) $
mergeLocal' mergeconfig o currbranch
mergeLocal' :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart
mergeLocal' mergeconfig o currbranch@(Just _, _) =
needMerge currbranch >>= \case
Nothing -> stop
Just syncbranch ->
starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $
next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch
mergeLocal _ _ (Nothing, madj) = do
next $ merge currbranch mergeconfig o Git.Branch.ManualCommit syncbranch
mergeLocal' _ _ (Nothing, madj) = do
b <- inRepo Git.Branch.currentUnsafe
needMerge (b, madj) >>= \case
Nothing -> stop
@ -347,8 +377,8 @@ needMerge (Just branch, madj) = ifM (allM id checks)
syncbranch = syncBranch branch
branch' = maybe branch (adjBranch . originalToAdjusted branch) madj
pushLocal :: CurrBranch -> CommandStart
pushLocal b = do
pushLocal :: SyncOptions -> CurrBranch -> CommandStart
pushLocal o b = stopUnless (notOnlyAnnex o) $ do
updateBranches b
stop
@ -387,16 +417,25 @@ pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch ->
pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $
starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do
showOutput
ifM fetch
( next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
, next $ return True
ifM (onlyAnnex o)
( do
void $ fetch $ map Git.fromRef
[ Annex.Branch.name
, syncBranch $ Annex.Branch.name
]
next $ return True
, ifM (fetch [])
( next $ mergeRemote remote branch mergeconfig o
, next $ return True
)
)
where
fetch = do
fetch bs = do
repo <- Remote.getRepo remote
inRepoWithSshOptionsTo repo (Remote.gitconfig remote) $
Git.Command.runBool
Git.Command.runBool $
[Param "fetch", Param $ Remote.name remote]
++ map Param bs
wantpull = remoteAnnexPull (Remote.gitconfig remote)
importRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek
@ -411,8 +450,7 @@ importRemote o mergeconfig remote currbranch
then Nothing
else Just (asTopFilePath (toRawFilePath s))
Command.Import.seekRemote remote branch subdir
void $ mergeRemote remote currbranch mergeconfig
(resolveMergeOverride o)
void $ mergeRemote remote currbranch mergeconfig o
where
wantpull = remoteAnnexPull (Remote.gitconfig remote)
@ -421,8 +459,8 @@ importRemote o mergeconfig remote currbranch
- were committed (or pushed changes, if this is a bare remote),
- while the synced/master may have changes that some
- other remote synced to this remote. So, merge them both. -}
mergeRemote :: Remote -> CurrBranch -> [Git.Merge.MergeConfig] -> ResolveMergeOverride -> CommandCleanup
mergeRemote remote currbranch mergeconfig resolvemergeoverride = ifM isBareRepo
mergeRemote :: Remote -> CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> CommandCleanup
mergeRemote remote currbranch mergeconfig o = ifM isBareRepo
( return True
, case currbranch of
(Nothing, _) -> do
@ -434,31 +472,36 @@ mergeRemote remote currbranch mergeconfig resolvemergeoverride = ifM isBareRepo
)
where
mergelisted getlist = and <$>
(mapM (merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit . remoteBranch remote) =<< getlist)
(mapM (merge currbranch mergeconfig o Git.Branch.ManualCommit . remoteBranch remote) =<< getlist)
tomerge = filterM (changed remote)
branchlist Nothing = []
branchlist (Just branch) = [fromAdjustedBranch branch, syncBranch branch]
pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart
pushRemote _o _remote (Nothing, _) = stop
pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $
starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do
repo <- Remote.getRepo remote
showOutput
ok <- inRepoWithSshOptionsTo repo gc $
pushBranch remote branch
if ok
then postpushupdate repo
else do
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"
return ok
pushRemote o remote (Just branch, _) = do
onlyannex <- onlyAnnex o
let mainbranch = if onlyannex then Nothing else Just branch
stopUnless (pure (pushOption o) <&&> needpush mainbranch) $
starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do
repo <- Remote.getRepo remote
showOutput
ok <- inRepoWithSshOptionsTo repo gc $
pushBranch remote mainbranch
if ok
then postpushupdate repo
else do
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
return ok
where
gc = Remote.gitconfig remote
needpush
needpush mainbranch
| remoteAnnexReadOnly gc = return False
| not (remoteAnnexPush gc) = return False
| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
| otherwise = anyM (newer remote) $ catMaybes
[ syncBranch <$> mainbranch
, Just (Annex.Branch.name)
]
-- Older remotes on crippled filesystems may not have a
-- post-receive hook set up, so when updateInstead emulation
-- is needed, run post-receive manually.
@ -504,20 +547,18 @@ pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> need
- But overwriting of data on synced/git-annex can happen, in a race.
- The only difference caused by using a forced push in that case is that
- the last repository to push wins the race, rather than the first to push.
-
- The sync push will fail to overwrite if receive.denyNonFastforwards is
- set on the remote.
-}
pushBranch :: Remote -> Git.Branch -> Git.Repo -> IO Bool
pushBranch remote branch g = directpush `after` annexpush `after` syncpush
pushBranch :: Remote -> Maybe Git.Branch -> Git.Repo -> IO Bool
pushBranch remote mbranch g = directpush `after` annexpush `after` syncpush
where
syncpush = flip Git.Command.runBool g $ pushparams
[ Git.Branch.forcePush $ refspec Annex.Branch.name
, refspec $ fromAdjustedBranch branch
syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes
[ Just $ Git.Branch.forcePush $ refspec Annex.Branch.name
, (refspec . fromAdjustedBranch) <$> mbranch
]
annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams
[ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ]
directpush = do
directpush = case mbranch of
Nothing -> noop
-- Git prints out an error message when this fails.
-- In the default configuration of receive.denyCurrentBranch,
-- the error message mentions that config setting
@ -528,11 +569,12 @@ pushBranch remote branch g = directpush `after` annexpush `after` syncpush
-- including the error displayed when
-- receive.denyCurrentBranch=updateInstead -- the user
-- will want to see that one.
let p = flip Git.Command.gitCreateProcess g $ pushparams
[ Git.fromRef $ Git.Ref.base $ fromAdjustedBranch branch ]
(transcript, ok) <- processTranscript' p Nothing
when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $
hPutStr stderr transcript
Just branch -> do
let p = flip Git.Command.gitCreateProcess g $ pushparams
[ Git.fromRef $ Git.Ref.base $ fromAdjustedBranch branch ]
(transcript, ok) <- processTranscript' p Nothing
when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $
hPutStr stderr transcript
pushparams branches =
[ Param "push"
, Param $ Remote.name remote
@ -746,7 +788,7 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go
]
_ -> noop
where
gitconfig = show (remoteConfig r "tracking-branch")
gitconfig = show (remoteAnnexConfig r "tracking-branch")
fillexport _ _ [] _ = return False
fillexport r db (tree:[]) mtbcommitsha = do
@ -783,3 +825,18 @@ cleanupRemote remote (Just b, _) =
, Param $ Git.fromRef $ syncBranch $
Git.Ref.base $ Annex.Branch.name
]
shouldSyncContent :: SyncOptions -> Annex Bool
shouldSyncContent o
| noContentOption o = pure False
| contentOption o || not (null (contentOfOption o)) = pure True
| otherwise = getGitConfigVal annexSyncContent <||> onlyAnnex o
notOnlyAnnex :: SyncOptions -> Annex Bool
notOnlyAnnex o = not <$> onlyAnnex o
onlyAnnex :: SyncOptions -> Annex Bool
onlyAnnex o
| notOnlyAnnexOption o = pure False
| onlyAnnexOption o = pure True
| otherwise = getGitConfigVal annexSyncOnlyAnnex

24
Command/TestRemote.hs
View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2014-2019 Joey Hess <id@joeyh.name>
- Copyright 2014-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -24,8 +24,12 @@ import Utility.DataUnits
import Utility.CopyFile
import Types.Messages
import Types.Export
import Types.Crypto
import Types.RemoteConfig
import Annex.SpecialRemote.Config (exportTreeField)
import Remote.Helper.ExportImport
import Remote.Helper.Chunked
import Remote.Helper.Encryptable (describeEncryption, encryptionField, highRandomQualityField)
import Git.Types
import Test.Tasty
@ -109,7 +113,7 @@ perform rs unavailrs exportr ks = do
desc r' k = intercalate "; " $ map unwords
[ [ "key size", show (fromKey keySize k) ]
, [ show (getChunkConfig (Remote.config r')) ]
, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
, ["encryption", describeEncryption (Remote.config r')]
]
descexport k1 k2 = intercalate "; " $ map unwords
[ [ "exporttree=yes" ]
@ -119,33 +123,35 @@ perform rs unavailrs exportr ks = do
adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)
adjustChunkSize r chunksize = adjustRemoteConfig r
(M.insert "chunk" (show chunksize))
(M.insert chunkField (RemoteConfigValue (show chunksize)))
-- Variants of a remote with no encryption, and with simple shared
-- encryption. Gpg key based encryption is not tested.
encryptionVariants :: Remote -> Annex [Remote]
encryptionVariants r = do
noenc <- adjustRemoteConfig r (M.insert "encryption" "none")
noenc <- adjustRemoteConfig r $
M.insert encryptionField (RemoteConfigValue NoneEncryption)
sharedenc <- adjustRemoteConfig r $
M.insert "encryption" "shared" .
M.insert "highRandomQuality" "false"
M.insert encryptionField (RemoteConfigValue SharedEncryption) .
M.insert highRandomQualityField (RemoteConfigValue False)
return $ catMaybes [noenc, sharedenc]
-- Variant of a remote with exporttree disabled.
disableExportTree :: Remote -> Annex Remote
disableExportTree r = maybe (error "failed disabling exportree") return
=<< adjustRemoteConfig r (M.delete "exporttree")
=<< adjustRemoteConfig r (M.delete exportTreeField)
-- Variant of a remote with exporttree enabled.
exportTreeVariant :: Remote -> Annex (Maybe Remote)
exportTreeVariant r = ifM (Remote.isExportSupported r)
( adjustRemoteConfig r $
M.insert "encryption" "none" . M.insert "exporttree" "yes"
M.insert encryptionField (RemoteConfigValue NoneEncryption) .
M.insert exportTreeField (RemoteConfigValue True)
, return Nothing
)
-- Regenerate a remote with a modified config.
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
adjustRemoteConfig :: Remote -> (Remote.ParsedRemoteConfig -> Remote.ParsedRemoteConfig) -> Annex (Maybe Remote)
adjustRemoteConfig r adjustconfig = do
repo <- Remote.getRepo r
Remote.generate (Remote.remotetype r)

2
Command/Undo.hs
View file

@ -58,7 +58,7 @@ perform p = do
-- Take two passes through the diff, first doing any removals,
-- and then any adds. This order is necessary to handle eg, removing
-- a directory and replacing it with a file.
let (removals, adds) = partition (\di -> dstsha di == nullSha) diff'
let (removals, adds) = partition (\di -> dstsha di `elem` nullShas) diff'
let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $
fromTopFilePath (file di) g

2
Command/Unused.hs
View file

@ -267,7 +267,7 @@ withKeysReferencedDiff a getdiff extractsha = do
where
go d = do
let sha = extractsha d
unless (sha == nullSha) $
unless (sha `elem` nullShas) $
catKey sha >>= maybe noop a
{- Filters out keys that have an associated file that's not modified. -}