Merge branch 'master' into v8
This commit is contained in:
commit
029c883713
456 changed files with 6341 additions and 1085 deletions
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
201
Command/Sync.hs
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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. -}
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue