change Remote.repo to Remote.getRepo
This is groundwork for letting a repo be instantiated the first time it's actually used, instead of at startup. The only behavior change is that some old special cases for xmpp remotes were removed. Where before git-annex silently did nothing with those no-longer supported remotes, it may now fail in some way. The additional IO action should have no performance impact as long as it's simply return. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon
This commit is contained in:
Joey Hess
parent
dc5550a54e
commit
67e46229a5
36 changed files with 266 additions and 191 deletions
|
|
@ -55,8 +55,7 @@ calcSyncRemotes = do
|
|||
let good r = Remote.uuid r `elem` alive
|
||||
let syncable = filter good rs
|
||||
contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $
|
||||
filter (\r -> Remote.uuid r /= NoUUID) $
|
||||
filter (not . Remote.isXMPPRemote) syncable
|
||||
filter (\r -> Remote.uuid r /= NoUUID) syncable
|
||||
let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes
|
||||
|
||||
return $ \dstatus -> dstatus
|
||||
|
|
|
|||
|
|
@ -47,7 +47,8 @@ finishedLocalPairing msg keypair = do
|
|||
("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata))
|
||||
Nothing
|
||||
r <- liftAnnex $ addRemote $ makeSshRemote sshdata
|
||||
liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost
|
||||
repo <- liftAnnex $ Remote.getRepo r
|
||||
liftAnnex $ setRemoteCost repo semiExpensiveRemoteCost
|
||||
syncRemote r
|
||||
|
||||
{- Mostly a straightforward conversion. Except:
|
||||
|
|
|
|||
|
|
@ -64,26 +64,25 @@ reconnectRemotes rs = void $ do
|
|||
mapM_ signal $ filter (`notElem` failedrs) rs'
|
||||
recordExportCommit
|
||||
where
|
||||
gitremotes = filter (notspecialremote . Remote.repo) rs
|
||||
(_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
|
||||
gitremotes = liftAnnex $
|
||||
filterM (notspecialremote <$$> Remote.getRepo) rs
|
||||
notspecialremote r
|
||||
| Git.repoIsUrl r = True
|
||||
| Git.repoIsLocal r = True
|
||||
| Git.repoIsLocalUnknown r = True
|
||||
| otherwise = False
|
||||
sync currentbranch@(Just _, _) = do
|
||||
(failedpull, diverged) <- manualPull currentbranch gitremotes
|
||||
(failedpull, diverged) <- manualPull currentbranch =<< gitremotes
|
||||
now <- liftIO getCurrentTime
|
||||
failedpush <- pushToRemotes' now gitremotes
|
||||
failedpush <- pushToRemotes' now =<< gitremotes
|
||||
return (nub $ failedpull ++ failedpush, diverged)
|
||||
{- No local branch exists yet, but we can try pulling. -}
|
||||
sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes
|
||||
sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes
|
||||
go = do
|
||||
(failed, diverged) <- sync
|
||||
=<< liftAnnex (join Command.Sync.getCurrBranch)
|
||||
addScanRemotes diverged =<<
|
||||
filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig)
|
||||
nonxmppremotes
|
||||
filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs
|
||||
return failed
|
||||
signal r = liftIO . mapM_ (flip tryPutMVar ())
|
||||
=<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers
|
||||
|
|
@ -130,8 +129,7 @@ pushToRemotes' now remotes = do
|
|||
<$> gitRepo
|
||||
<*> join Command.Sync.getCurrBranch
|
||||
<*> getUUID
|
||||
let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
|
||||
ret <- go True branch g u normalremotes
|
||||
ret <- go True branch g u remotes
|
||||
return ret
|
||||
where
|
||||
go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
|
||||
|
|
@ -174,7 +172,8 @@ parallelPush g rs a = do
|
|||
where
|
||||
topush r = (,)
|
||||
<$> pure r
|
||||
<*> sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g
|
||||
<*> (Remote.getRepo r >>= \repo ->
|
||||
sshOptionsTo repo (Remote.gitconfig r) g)
|
||||
|
||||
{- Displays an alert while running an action that syncs with some remotes,
|
||||
- and returns any remotes that it failed to sync with.
|
||||
|
|
@ -187,7 +186,7 @@ syncAction rs a
|
|||
| otherwise = do
|
||||
i <- addAlert $ syncAlert visibleremotes
|
||||
failed <- a rs
|
||||
let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) failed
|
||||
failed' <- filterM (not . Git.repoIsLocalUnknown <$$> liftAnnex . Remote.getRepo) failed
|
||||
let succeeded = filter (`notElem` failed) visibleremotes
|
||||
if null succeeded && null failed'
|
||||
then removeAlert i
|
||||
|
|
@ -195,8 +194,7 @@ syncAction rs a
|
|||
syncResultAlert succeeded failed'
|
||||
return failed
|
||||
where
|
||||
visibleremotes = filter (not . Remote.readonly) $
|
||||
filter (not . Remote.isXMPPRemote) rs
|
||||
visibleremotes = filter (not . Remote.readonly) rs
|
||||
|
||||
{- Manually pull from remotes and merge their branches. Returns any
|
||||
- remotes that it failed to pull from, and a Bool indicating
|
||||
|
|
@ -206,17 +204,18 @@ syncAction rs a
|
|||
manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
|
||||
manualPull currentbranch remotes = do
|
||||
g <- liftAnnex gitRepo
|
||||
let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
|
||||
failed <- forM normalremotes $ \r -> if wantpull $ Remote.gitconfig r
|
||||
failed <- forM remotes $ \r -> if wantpull $ Remote.gitconfig r
|
||||
then do
|
||||
g' <- liftAnnex $ sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g
|
||||
g' <- liftAnnex $ do
|
||||
repo <- Remote.getRepo r
|
||||
sshOptionsTo repo (Remote.gitconfig r) g
|
||||
ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g')
|
||||
( return Nothing
|
||||
, return $ Just r
|
||||
)
|
||||
else return Nothing
|
||||
haddiverged <- liftAnnex Annex.Branch.forceUpdate
|
||||
forM_ normalremotes $ \r ->
|
||||
forM_ remotes $ \r ->
|
||||
liftAnnex $ Command.Sync.mergeRemote r
|
||||
currentbranch Command.Sync.mergeConfig def
|
||||
when haddiverged $
|
||||
|
|
@ -263,10 +262,10 @@ changeSyncable (Just r) False = do
|
|||
|
||||
changeSyncFlag :: Remote -> Bool -> Annex ()
|
||||
changeSyncFlag r enabled = do
|
||||
repo <- Remote.getRepo r
|
||||
let key = Config.remoteConfig repo "sync"
|
||||
Config.setConfig key (boolConfig enabled)
|
||||
void Remote.remoteListRefresh
|
||||
where
|
||||
key = Config.remoteConfig (Remote.repo r) "sync"
|
||||
|
||||
updateExportTreeFromLogAll :: Assistant ()
|
||||
updateExportTreeFromLogAll = do
|
||||
|
|
|
|||
|
|
@ -210,11 +210,11 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (r
|
|||
- Annex monad. -}
|
||||
go rmt =<< liftAnnex (mkfscker (annexFsckParams d))
|
||||
go rmt annexfscker = do
|
||||
repo <- liftAnnex $ Remote.getRepo rmt
|
||||
fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do
|
||||
void annexfscker
|
||||
let r = Remote.repo rmt
|
||||
if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r)
|
||||
then Just <$> Git.Fsck.findBroken True r
|
||||
if Git.repoIsLocal repo && not (Git.repoIsLocalUnknown repo)
|
||||
then Just <$> Git.Fsck.findBroken True repo
|
||||
else pure Nothing
|
||||
maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults
|
||||
|
||||
|
|
|
|||
|
|
@ -144,7 +144,8 @@ handleMounts urlrenderer wasmounted nowmounted =
|
|||
handleMount :: UrlRenderer -> FilePath -> Assistant ()
|
||||
handleMount urlrenderer dir = do
|
||||
debug ["detected mount of", dir]
|
||||
rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
|
||||
rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo)
|
||||
=<< remotesUnder dir
|
||||
mapM_ (fsckNudge urlrenderer . Just) rs
|
||||
reconnectRemotes rs
|
||||
|
||||
|
|
|
|||
|
|
@ -49,20 +49,23 @@ handleProblem urlrenderer repoproblem = do
|
|||
liftIO $ afterFix repoproblem
|
||||
|
||||
handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool
|
||||
handleRemoteProblem urlrenderer rmt
|
||||
| Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) =
|
||||
handleRemoteProblem urlrenderer rmt = do
|
||||
repo <- liftAnnex $ Remote.getRepo rmt
|
||||
handleRemoteProblem' repo urlrenderer rmt
|
||||
|
||||
handleRemoteProblem' :: Git.Repo -> UrlRenderer -> Remote -> Assistant Bool
|
||||
handleRemoteProblem' repo urlrenderer rmt
|
||||
| Git.repoIsLocal repo && not (Git.repoIsLocalUnknown repo) =
|
||||
ifM (liftIO $ checkAvailable True rmt)
|
||||
( do
|
||||
fixedlocks <- repairStaleGitLocks r
|
||||
fixedlocks <- repairStaleGitLocks repo
|
||||
fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $
|
||||
Git.Fsck.findBroken True r
|
||||
Git.Fsck.findBroken True repo
|
||||
repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults
|
||||
return $ fixedlocks || repaired
|
||||
, return False
|
||||
)
|
||||
| otherwise = return False
|
||||
where
|
||||
r = Remote.repo rmt
|
||||
|
||||
{- This is not yet used, and should probably do a fsck. -}
|
||||
handleLocalRepoProblem :: UrlRenderer -> Assistant Bool
|
||||
|
|
|
|||
|
|
@ -99,7 +99,7 @@ remoteResponderThread fromh urimap = go M.empty
|
|||
cont
|
||||
|
||||
getURIMap :: Annex (M.Map URI Remote)
|
||||
getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
|
||||
getURIMap = Remote.remoteMap' id (\r -> mkk . Git.location <$> Remote.getRepo r)
|
||||
where
|
||||
mkk (Git.Url u) = Just u
|
||||
mkk _ = Nothing
|
||||
|
|
|
|||
|
|
@ -106,13 +106,13 @@ runTransferThread' program batchmaker d run = go
|
|||
- already have been updated to include the transfer. -}
|
||||
genTransfer :: Transfer -> TransferInfo -> TransferGenerator
|
||||
genTransfer t info = case transferRemote info of
|
||||
Just remote
|
||||
| Git.repoIsLocalUnknown (Remote.repo remote) -> do
|
||||
-- optimisation for removable drives not plugged in
|
||||
Just remote -> ifM (unpluggedremovabledrive remote)
|
||||
( do
|
||||
-- optimisation, since the transfer would fail
|
||||
liftAnnex $ recordFailedTransfer t info
|
||||
void $ removeTransfer t
|
||||
return Nothing
|
||||
| otherwise -> ifM (liftAnnex $ shouldTransfer t info)
|
||||
, ifM (liftAnnex $ shouldTransfer t info)
|
||||
( do
|
||||
debug [ "Transferring:" , describeTransfer t info ]
|
||||
notifyTransfer
|
||||
|
|
@ -124,11 +124,15 @@ genTransfer t info = case transferRemote info of
|
|||
finishedTransfer t (Just info)
|
||||
return Nothing
|
||||
)
|
||||
)
|
||||
_ -> return Nothing
|
||||
where
|
||||
direction = transferDirection t
|
||||
isdownload = direction == Download
|
||||
|
||||
unpluggedremovabledrive remote = Git.repoIsLocalUnknown
|
||||
<$> liftAnnex (Remote.getRepo remote)
|
||||
|
||||
{- Alerts are only shown for successful transfers.
|
||||
- Transfers can temporarily fail for many reasons,
|
||||
- so there's no point in bothering the user about
|
||||
|
|
|
|||
|
|
@ -146,8 +146,8 @@ setRepoConfig uuid mremote oldc newc = do
|
|||
|
||||
legalName = makeLegalName . T.unpack . repoName
|
||||
|
||||
editRepositoryAForm :: Maybe Remote -> RepoConfig -> MkAForm RepoConfig
|
||||
editRepositoryAForm mremote d = RepoConfig
|
||||
editRepositoryAForm :: Maybe Git.Repo -> Maybe Remote -> RepoConfig -> MkAForm RepoConfig
|
||||
editRepositoryAForm mrepo mremote d = RepoConfig
|
||||
<$> areq (if ishere then readonlyTextField else textField)
|
||||
(bfs "Name") (Just $ repoName d)
|
||||
<*> aopt textField (bfs "Description") (Just $ repoDescription d)
|
||||
|
|
@ -156,8 +156,7 @@ editRepositoryAForm mremote d = RepoConfig
|
|||
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable d)
|
||||
where
|
||||
ishere = isNothing mremote
|
||||
isspecial = fromMaybe False $
|
||||
(== Git.Unknown) . Git.location . Remote.repo <$> mremote
|
||||
isspecial = maybe False ((== Git.Unknown) . Git.location) mrepo
|
||||
groups = customgroups ++ standardgroups
|
||||
standardgroups :: [(Text, RepoGroup)]
|
||||
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) $
|
||||
|
|
@ -204,8 +203,11 @@ editForm new (RepoUUID uuid)
|
|||
error "unknown remote"
|
||||
curr <- liftAnnex $ getRepoConfig uuid mremote
|
||||
liftAnnex $ checkAssociatedDirectory curr mremote
|
||||
mrepo <- liftAnnex $
|
||||
maybe (pure Nothing) (Just <$$> Remote.getRepo) mremote
|
||||
((result, form), enctype) <- liftH $
|
||||
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ editRepositoryAForm mremote curr
|
||||
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
|
||||
editRepositoryAForm mrepo mremote curr
|
||||
case result of
|
||||
FormSuccess input -> liftH $ do
|
||||
setRepoConfig uuid mremote curr input
|
||||
|
|
@ -221,7 +223,8 @@ editForm _new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do
|
|||
mr <- liftAnnex (repoIdRemote r)
|
||||
let repoInfo = getRepoInfo mr Nothing
|
||||
g <- liftAnnex gitRepo
|
||||
let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation . Remote.repo) mr
|
||||
mrepo <- liftAnnex $ maybe (pure Nothing) (Just <$$> Remote.getRepo) mr
|
||||
let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation) mrepo
|
||||
$(widgetFile "configurators/edit/nonannexremote")
|
||||
|
||||
{- Makes any directory associated with the repository. -}
|
||||
|
|
@ -246,7 +249,7 @@ getRepoInfo (Just r) (Just c) = case M.lookup "type" c of
|
|||
| otherwise -> AWS.getRepoInfo c
|
||||
Just t
|
||||
| t /= "git" -> [whamlet|#{t} remote|]
|
||||
_ -> getGitRepoInfo $ Remote.repo r
|
||||
_ -> getGitRepoInfo =<< liftAnnex (Remote.getRepo r)
|
||||
getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r)
|
||||
getRepoInfo _ _ = [whamlet|git repository|]
|
||||
|
||||
|
|
@ -283,9 +286,11 @@ getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
|
|||
go Nothing = redirect DashboardR
|
||||
go (Just rmt) = do
|
||||
liftIO fixSshKeyPairIdentitiesOnly
|
||||
liftAnnex $ setConfig
|
||||
(remoteConfig (Remote.repo rmt) "ignore")
|
||||
(Git.Config.boolConfig False)
|
||||
liftAnnex $ do
|
||||
repo <- Remote.getRepo rmt
|
||||
setConfig
|
||||
(remoteConfig repo "ignore")
|
||||
(Git.Config.boolConfig False)
|
||||
liftAnnex $ void Remote.remoteListRefresh
|
||||
liftAssistant updateSyncRemotes
|
||||
liftAssistant $ syncRemote rmt
|
||||
|
|
|
|||
|
|
@ -38,8 +38,9 @@ setupCloudRemote = setupRemote postsetup . Just
|
|||
setupRemote :: (Remote -> Handler a) -> Maybe StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
|
||||
setupRemote postsetup mgroup mcost getname = do
|
||||
r <- liftAnnex $ addRemote getname
|
||||
repo <- liftAnnex $ Remote.getRepo r
|
||||
liftAnnex $ do
|
||||
maybe noop (defaultStandardGroup (Remote.uuid r)) mgroup
|
||||
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
|
||||
maybe noop (Config.setRemoteCost repo) mcost
|
||||
liftAssistant $ syncRemote r
|
||||
postsetup r
|
||||
|
|
|
|||
|
|
@ -139,10 +139,11 @@ repoList reposelector
|
|||
unwanted <- S.fromList
|
||||
<$> filterM inUnwantedGroup (map Remote.uuid syncremotes)
|
||||
trustmap <- trustMap
|
||||
allrs <- concat . Remote.byCost <$> Remote.remoteList
|
||||
rs <- filter (\r -> M.lookup (Remote.uuid r) trustmap /= Just DeadTrusted)
|
||||
. filter selectedrepo
|
||||
. concat . Remote.byCost
|
||||
<$> Remote.remoteList
|
||||
. map fst
|
||||
. filter selectedrepo
|
||||
<$> forM allrs (\r -> (,) <$> pure r <*> Remote.getRepo r)
|
||||
let l = flip map (map mkRepoId rs) $ \r -> case r of
|
||||
(RepoUUID u)
|
||||
| u `S.member` unwanted -> (r, mkUnwantedRepoActions r)
|
||||
|
|
@ -165,11 +166,10 @@ repoList reposelector
|
|||
map snd . catMaybes . filter selectedremote
|
||||
. map (findinfo m g)
|
||||
<$> trustExclude DeadTrusted (M.keys m)
|
||||
selectedrepo r
|
||||
selectedrepo (r, repo)
|
||||
| Remote.readonly r = False
|
||||
| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r)
|
||||
| onlyCloud reposelector = Git.repoIsUrl repo
|
||||
&& Remote.uuid r /= NoUUID
|
||||
&& not (Remote.isXMPPRemote r)
|
||||
| otherwise = True
|
||||
selectedremote Nothing = False
|
||||
selectedremote (Just (iscloud, _))
|
||||
|
|
@ -238,8 +238,9 @@ getRepositoriesReorderR = do
|
|||
go list (Just remote) = do
|
||||
rs <- catMaybes <$> mapM repoIdRemote list
|
||||
forM_ (reorderCosts remote rs) $ \(r, newcost) ->
|
||||
when (Remote.cost r /= newcost) $
|
||||
setRemoteCost (Remote.repo r) newcost
|
||||
when (Remote.cost r /= newcost) $ do
|
||||
repo <- Remote.getRepo r
|
||||
setRemoteCost repo newcost
|
||||
void remoteListRefresh
|
||||
fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack
|
||||
|
||||
|
|
|
|||
|
|
@ -92,7 +92,9 @@ cleanupSpecialRemote u c = do
|
|||
Logs.Remote.configSet u c
|
||||
Remote.byUUID u >>= \case
|
||||
Nothing -> noop
|
||||
Just r -> setRemoteIgnore (R.repo r) False
|
||||
Just r -> do
|
||||
repo <- R.getRepo r
|
||||
setRemoteIgnore repo False
|
||||
return True
|
||||
|
||||
unknownNameError :: String -> Annex a
|
||||
|
|
|
|||
|
|
@ -275,8 +275,7 @@ remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
|
|||
syncRemotes :: [String] -> Annex [Remote]
|
||||
syncRemotes ps = do
|
||||
remotelist <- Remote.remoteList' True
|
||||
available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig)
|
||||
(filter (not . Remote.isXMPPRemote) remotelist)
|
||||
available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig) remotelist
|
||||
syncRemotes' ps available
|
||||
|
||||
syncRemotes' :: [String] -> [Remote] -> Annex [Remote]
|
||||
|
|
@ -292,7 +291,8 @@ syncRemotes' ps available =
|
|||
listed = concat <$> mapM Remote.byNameOrGroup ps
|
||||
|
||||
good r
|
||||
| Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r
|
||||
| Remote.gitSyncableRemote r =
|
||||
Remote.Git.repoAvail =<< Remote.getRepo r
|
||||
| otherwise = return True
|
||||
|
||||
fastest = fromMaybe [] . headMaybe . Remote.byCost
|
||||
|
|
@ -408,9 +408,11 @@ pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && want
|
|||
stopUnless fetch $
|
||||
next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
|
||||
where
|
||||
fetch = inRepoWithSshOptionsTo (Remote.repo remote) (Remote.gitconfig remote) $
|
||||
Git.Command.runBool
|
||||
[Param "fetch", Param $ Remote.name remote]
|
||||
fetch = do
|
||||
repo <- Remote.getRepo remote
|
||||
inRepoWithSshOptionsTo repo (Remote.gitconfig remote) $
|
||||
Git.Command.runBool
|
||||
[Param "fetch", Param $ Remote.name remote]
|
||||
wantpull = remoteAnnexPull (Remote.gitconfig remote)
|
||||
|
||||
{- The remote probably has both a master and a synced/master branch.
|
||||
|
|
@ -441,11 +443,12 @@ pushRemote _o _remote (Nothing, _) = stop
|
|||
pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do
|
||||
showStart' "push" (Just (Remote.name remote))
|
||||
next $ next $ do
|
||||
repo <- Remote.getRepo remote
|
||||
showOutput
|
||||
ok <- inRepoWithSshOptionsTo (Remote.repo remote) gc $
|
||||
ok <- inRepoWithSshOptionsTo repo gc $
|
||||
pushBranch remote branch
|
||||
if ok
|
||||
then postpushupdate
|
||||
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)"
|
||||
|
|
@ -457,11 +460,11 @@ pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> need
|
|||
| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
|
||||
-- Do updateInstead emulation for remotes on eg removable drives
|
||||
-- formatted FAT, where the post-update hook won't run.
|
||||
postpushupdate
|
||||
| annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) =
|
||||
case Git.repoWorkTree (Remote.repo remote) of
|
||||
postpushupdate repo
|
||||
| annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) =
|
||||
case Git.repoWorkTree repo of
|
||||
Nothing -> return True
|
||||
Just wt -> ifM (Remote.Git.onLocal remote needUpdateInsteadEmulation)
|
||||
Just wt -> ifM (Remote.Git.onLocal repo remote needUpdateInsteadEmulation)
|
||||
( liftIO $ do
|
||||
p <- readProgramFile
|
||||
boolSystem' p [Param "post-receive"]
|
||||
|
|
|
|||
|
|
@ -123,11 +123,13 @@ exportTreeVariant r = ifM (Remote.isExportSupported r)
|
|||
|
||||
-- Regenerate a remote with a modified config.
|
||||
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
|
||||
adjustRemoteConfig r adjustconfig = Remote.generate (Remote.remotetype r)
|
||||
(Remote.repo r)
|
||||
(Remote.uuid r)
|
||||
(adjustconfig (Remote.config r))
|
||||
(Remote.gitconfig r)
|
||||
adjustRemoteConfig r adjustconfig = do
|
||||
repo <- Remote.getRepo r
|
||||
Remote.generate (Remote.remotetype r)
|
||||
repo
|
||||
(Remote.uuid r)
|
||||
(adjustconfig (Remote.config r))
|
||||
(Remote.gitconfig r)
|
||||
|
||||
test :: Annex.AnnexState -> Remote -> Key -> [TestTree]
|
||||
test st r k =
|
||||
|
|
|
|||
21
Remote.hs
21
Remote.hs
|
|
@ -51,7 +51,6 @@ module Remote (
|
|||
forceTrust,
|
||||
logStatus,
|
||||
checkAvailable,
|
||||
isXMPPRemote,
|
||||
claimingUrl,
|
||||
isExportSupported,
|
||||
) where
|
||||
|
|
@ -72,21 +71,20 @@ import Remote.List
|
|||
import Config
|
||||
import Config.DynamicConfig
|
||||
import Git.Types (RemoteName)
|
||||
import qualified Git
|
||||
import Utility.Aeson
|
||||
|
||||
{- Map from UUIDs of Remotes to a calculated value. -}
|
||||
remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
|
||||
remoteMap mkv = remoteMap' mkv mkk
|
||||
remoteMap mkv = remoteMap' mkv (pure . mkk)
|
||||
where
|
||||
mkk r = case uuid r of
|
||||
NoUUID -> Nothing
|
||||
u -> Just u
|
||||
|
||||
remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Maybe k) -> Annex (M.Map k v)
|
||||
remoteMap' mkv mkk = M.fromList . mapMaybe mk <$> remoteList
|
||||
remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Annex (Maybe k)) -> Annex (M.Map k v)
|
||||
remoteMap' mkv mkk = M.fromList . catMaybes <$> (mapM mk =<< remoteList)
|
||||
where
|
||||
mk r = case mkk r of
|
||||
mk r = mkk r >>= return . \case
|
||||
Nothing -> Nothing
|
||||
Just k -> Just (k, mkv r)
|
||||
|
||||
|
|
@ -122,10 +120,11 @@ byNameWithUUID = checkuuid <=< byName
|
|||
where
|
||||
checkuuid Nothing = return Nothing
|
||||
checkuuid (Just r)
|
||||
| uuid r == NoUUID =
|
||||
| uuid r == NoUUID = do
|
||||
repo <- getRepo r
|
||||
ifM (liftIO $ getDynamicConfig $ remoteAnnexIgnore (gitconfig r))
|
||||
( giveup $ noRemoteUUIDMsg r ++
|
||||
" (" ++ show (remoteConfig (repo r) "ignore") ++
|
||||
" (" ++ show (remoteConfig repo "ignore") ++
|
||||
" is set)"
|
||||
, giveup $ noRemoteUUIDMsg r
|
||||
)
|
||||
|
|
@ -357,12 +356,6 @@ checkAvailable :: Bool -> Remote -> IO Bool
|
|||
checkAvailable assumenetworkavailable =
|
||||
maybe (return assumenetworkavailable) doesDirectoryExist . localpath
|
||||
|
||||
{- Old remotes using the XMPP transport have urls like xmpp::user@host -}
|
||||
isXMPPRemote :: Remote -> Bool
|
||||
isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
|
||||
where
|
||||
r = repo remote
|
||||
|
||||
hasKey :: Remote -> Key -> Annex (Either String Bool)
|
||||
hasKey r k = either (Left . show) Right <$> tryNonAsync (checkPresent r k)
|
||||
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ gen r u c gc = do
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = Nothing
|
||||
, remotetype = remote
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ gen r _ c gc =
|
|||
, config = c
|
||||
, gitconfig = gc
|
||||
, localpath = Nothing
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, readonly = True
|
||||
, availability = GloballyAvailable
|
||||
, remotetype = remote
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ gen r u c gc = do
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = if bupLocal buprepo && not (null buprepo)
|
||||
then Just buprepo
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ gen r u c gc = do
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = if ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo)
|
||||
then Just $ ddarRepoLocation ddarrepo
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ gen r u c gc = do
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = Just dir
|
||||
, readonly = False
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@ gen r u c gc
|
|||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, localpath = Nothing
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, readonly = False
|
||||
, availability = avail
|
||||
|
|
|
|||
|
|
@ -123,7 +123,7 @@ gen' r u c gc = do
|
|||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, localpath = localpathCalc r
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc { remoteGitConfig = extractGitConfig r }
|
||||
, readonly = Git.repoIsHttp r
|
||||
, availability = availabilityCalc r
|
||||
|
|
@ -328,17 +328,22 @@ setGcryptEncryption c remotename = do
|
|||
remoteconfig n = ConfigKey $ n remotename
|
||||
|
||||
store :: Remote -> Remote.Rsync.RsyncOpts -> Storer
|
||||
store r rsyncopts
|
||||
| not $ Git.repoIsUrl (repo r) =
|
||||
byteStorer $ \k b p -> guardUsable (repo r) (return False) $ liftIO $ do
|
||||
let tmpdir = Git.repoLocation (repo r) </> "tmp" </> keyFile k
|
||||
store r rsyncopts k s p = do
|
||||
repo <- getRepo r
|
||||
store' repo r rsyncopts k s p
|
||||
|
||||
store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Storer
|
||||
store' repo r rsyncopts
|
||||
| not $ Git.repoIsUrl repo =
|
||||
byteStorer $ \k b p -> guardUsable repo (return False) $ liftIO $ do
|
||||
let tmpdir = Git.repoLocation repo </> "tmp" </> keyFile k
|
||||
void $ tryIO $ createDirectoryIfMissing True tmpdir
|
||||
let tmpf = tmpdir </> keyFile k
|
||||
meteredWriteFile p tmpf b
|
||||
let destdir = parentDir $ gCryptLocation r k
|
||||
let destdir = parentDir $ gCryptLocation repo k
|
||||
Remote.Directory.finalizeStoreGeneric tmpdir destdir
|
||||
return True
|
||||
| Git.repoIsSsh (repo r) = if accessShell r
|
||||
| Git.repoIsSsh repo = if accessShell r
|
||||
then fileStorer $ \k f p -> do
|
||||
oh <- mkOutputHandler
|
||||
Ssh.rsyncHelper oh (Just p)
|
||||
|
|
@ -348,11 +353,16 @@ store r rsyncopts
|
|||
| otherwise = unsupportedUrl
|
||||
|
||||
retrieve :: Remote -> Remote.Rsync.RsyncOpts -> Retriever
|
||||
retrieve r rsyncopts
|
||||
| not $ Git.repoIsUrl (repo r) = byteRetriever $ \k sink ->
|
||||
guardUsable (repo r) (return False) $
|
||||
sink =<< liftIO (L.readFile $ gCryptLocation r k)
|
||||
| Git.repoIsSsh (repo r) = if accessShell r
|
||||
retrieve r rsyncopts k p sink = do
|
||||
repo <- getRepo r
|
||||
retrieve' repo r rsyncopts k p sink
|
||||
|
||||
retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Retriever
|
||||
retrieve' repo r rsyncopts
|
||||
| not $ Git.repoIsUrl repo = byteRetriever $ \k sink ->
|
||||
guardUsable repo (return False) $
|
||||
sink =<< liftIO (L.readFile $ gCryptLocation repo k)
|
||||
| Git.repoIsSsh repo = if accessShell r
|
||||
then fileRetriever $ \f k p -> do
|
||||
ps <- Ssh.rsyncParamsRemote False r Download k f
|
||||
(AssociatedFile Nothing)
|
||||
|
|
@ -364,30 +374,40 @@ retrieve r rsyncopts
|
|||
where
|
||||
|
||||
remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover
|
||||
remove r rsyncopts k
|
||||
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $
|
||||
liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k))
|
||||
| Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
|
||||
remove r rsyncopts k = do
|
||||
repo <- getRepo r
|
||||
remove' repo r rsyncopts k
|
||||
|
||||
remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Remover
|
||||
remove' repo r rsyncopts k
|
||||
| not $ Git.repoIsUrl repo = guardUsable repo (return False) $
|
||||
liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation repo) (parentDir (gCryptLocation repo k))
|
||||
| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
|
||||
| otherwise = unsupportedUrl
|
||||
where
|
||||
removersync = Remote.Rsync.remove rsyncopts k
|
||||
removeshell = Ssh.dropKey (repo r) k
|
||||
removeshell = Ssh.dropKey repo k
|
||||
|
||||
checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent
|
||||
checkKey r rsyncopts k
|
||||
| not $ Git.repoIsUrl (repo r) =
|
||||
guardUsable (repo r) (cantCheck $ repo r) $
|
||||
liftIO $ doesFileExist (gCryptLocation r k)
|
||||
| Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync
|
||||
checkKey r rsyncopts k = do
|
||||
repo <- getRepo r
|
||||
checkKey' repo r rsyncopts k
|
||||
|
||||
checkKey' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> CheckPresent
|
||||
checkKey' repo r rsyncopts k
|
||||
| not $ Git.repoIsUrl repo =
|
||||
guardUsable repo (cantCheck repo) $
|
||||
liftIO $ doesFileExist (gCryptLocation repo k)
|
||||
| Git.repoIsSsh repo = shellOrRsync r checkshell checkrsync
|
||||
| otherwise = unsupportedUrl
|
||||
where
|
||||
checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k
|
||||
checkshell = Ssh.inAnnex (repo r) k
|
||||
checkrsync = Remote.Rsync.checkKey repo rsyncopts k
|
||||
checkshell = Ssh.inAnnex repo k
|
||||
|
||||
{- Annexed objects are hashed using lower-case directories for max
|
||||
- portability. -}
|
||||
gCryptLocation :: Remote -> Key -> FilePath
|
||||
gCryptLocation r key = Git.repoLocation (repo r) </> objectDir </> keyPath key (hashDirLower def)
|
||||
gCryptLocation :: Git.Repo -> Key -> FilePath
|
||||
gCryptLocation repo key = Git.repoLocation repo </> objectDir </> keyPath key (hashDirLower def)
|
||||
|
||||
data AccessMethod = AccessDirect | AccessShell
|
||||
|
||||
|
|
|
|||
137
Remote/Git.hs
137
Remote/Git.hs
|
|
@ -175,7 +175,7 @@ gen r u c gc
|
|||
else Just $ repairRemote r
|
||||
, config = c
|
||||
, localpath = localpathCalc r
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc { remoteGitConfig = extractGitConfig r }
|
||||
, readonly = Git.repoIsHttp r
|
||||
, availability = availabilityCalc r
|
||||
|
|
@ -328,33 +328,37 @@ tryGitConfigRead autoinit r
|
|||
|
||||
{- Checks if a given remote has the content for a key in its annex. -}
|
||||
inAnnex :: Remote -> State -> Key -> Annex Bool
|
||||
inAnnex rmt (State connpool duc) key
|
||||
| Git.repoIsHttp r = checkhttp
|
||||
| Git.repoIsUrl r = checkremote
|
||||
inAnnex rmt st key = do
|
||||
repo <- getRepo rmt
|
||||
inAnnex' repo rmt st key
|
||||
|
||||
inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool
|
||||
inAnnex' repo rmt (State connpool duc) key
|
||||
| Git.repoIsHttp repo = checkhttp
|
||||
| Git.repoIsUrl repo = checkremote
|
||||
| otherwise = checklocal
|
||||
where
|
||||
r = repo rmt
|
||||
checkhttp = do
|
||||
showChecking r
|
||||
showChecking repo
|
||||
ifM (Url.withUrlOptions $ \uo -> liftIO $
|
||||
anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key))
|
||||
anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls repo rmt key))
|
||||
( return True
|
||||
, giveup "not found"
|
||||
)
|
||||
checkremote =
|
||||
let fallback = Ssh.inAnnex r key
|
||||
let fallback = Ssh.inAnnex repo key
|
||||
in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key
|
||||
checklocal = ifM duc
|
||||
( guardUsable r (cantCheck r) $
|
||||
maybe (cantCheck r) return
|
||||
=<< onLocalFast rmt (Annex.Content.inAnnexSafe key)
|
||||
, cantCheck r
|
||||
( guardUsable repo (cantCheck repo) $
|
||||
maybe (cantCheck repo) return
|
||||
=<< onLocalFast repo rmt (Annex.Content.inAnnexSafe key)
|
||||
, cantCheck repo
|
||||
)
|
||||
|
||||
keyUrls :: Remote -> Key -> [String]
|
||||
keyUrls r key = map tourl locs'
|
||||
keyUrls :: Git.Repo -> Remote -> Key -> [String]
|
||||
keyUrls repo r key = map tourl locs'
|
||||
where
|
||||
tourl l = Git.repoLocation (repo r) ++ "/" ++ l
|
||||
tourl l = Git.repoLocation repo ++ "/" ++ l
|
||||
-- If the remote is known to not be bare, try the hash locations
|
||||
-- used for non-bare repos first, as an optimisation.
|
||||
locs
|
||||
|
|
@ -369,10 +373,15 @@ keyUrls r key = map tourl locs'
|
|||
cfg = remoteGitConfig remoteconfig
|
||||
|
||||
dropKey :: Remote -> State -> Key -> Annex Bool
|
||||
dropKey r (State connpool duc) key
|
||||
| not $ Git.repoIsUrl (repo r) = ifM duc
|
||||
( guardUsable (repo r) (return False) $
|
||||
commitOnCleanup r $ onLocalFast r $ do
|
||||
dropKey r st key = do
|
||||
repo <- getRepo r
|
||||
dropKey' repo r st key
|
||||
|
||||
dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex Bool
|
||||
dropKey' repo r (State connpool duc) key
|
||||
| not $ Git.repoIsUrl repo = ifM duc
|
||||
( guardUsable repo (return False) $
|
||||
commitOnCleanup repo r $ onLocalFast repo r $ do
|
||||
ensureInitialized
|
||||
whenM (Annex.Content.inAnnex key) $ do
|
||||
Annex.Content.lockContentForRemoval key $ \lock -> do
|
||||
|
|
@ -382,25 +391,30 @@ dropKey r (State connpool duc) key
|
|||
return True
|
||||
, return False
|
||||
)
|
||||
| Git.repoIsHttp (repo r) = giveup "dropping from http remote not supported"
|
||||
| otherwise = commitOnCleanup r $ do
|
||||
let fallback = Ssh.dropKey (repo r) key
|
||||
| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
|
||||
| otherwise = commitOnCleanup repo r $ do
|
||||
let fallback = Ssh.dropKey repo key
|
||||
P2PHelper.remove (Ssh.runProto r connpool False fallback) key
|
||||
|
||||
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
||||
lockKey r (State connpool duc) key callback
|
||||
| not $ Git.repoIsUrl (repo r) = ifM duc
|
||||
( guardUsable (repo r) failedlock $ do
|
||||
lockKey r st key callback = do
|
||||
repo <- getRepo r
|
||||
lockKey' repo r st key callback
|
||||
|
||||
lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
||||
lockKey' repo r (State connpool duc) key callback
|
||||
| not $ Git.repoIsUrl repo = ifM duc
|
||||
( guardUsable repo failedlock $ do
|
||||
inorigrepo <- Annex.makeRunner
|
||||
-- Lock content from perspective of remote,
|
||||
-- and then run the callback in the original
|
||||
-- annex monad, not the remote's.
|
||||
onLocalFast r $
|
||||
onLocalFast repo r $
|
||||
Annex.Content.lockContentShared key $
|
||||
liftIO . inorigrepo . callback
|
||||
, failedlock
|
||||
)
|
||||
| Git.repoIsSsh (repo r) = do
|
||||
| Git.repoIsSsh repo = do
|
||||
showLocking r
|
||||
let withconn = Ssh.withP2PSshConnection r connpool fallback
|
||||
P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback
|
||||
|
|
@ -408,7 +422,7 @@ lockKey r (State connpool duc) key callback
|
|||
where
|
||||
fallback = do
|
||||
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
|
||||
(repo r) "lockcontent"
|
||||
repo "lockcontent"
|
||||
[Param $ key2file key] []
|
||||
(Just hin, Just hout, Nothing, p) <- liftIO $
|
||||
withFile devNull WriteMode $ \nullh ->
|
||||
|
|
@ -451,15 +465,20 @@ copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterU
|
|||
copyFromRemote = copyFromRemote' False
|
||||
|
||||
copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
|
||||
copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
|
||||
| Git.repoIsHttp (repo r) = unVerified $
|
||||
Annex.Content.downloadUrl key meterupdate (keyUrls r key) dest
|
||||
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (unVerified (return False)) $ do
|
||||
copyFromRemote' forcersync r st key file dest meterupdate = do
|
||||
repo <- getRepo r
|
||||
copyFromRemote'' repo forcersync r st key file dest meterupdate
|
||||
|
||||
copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
|
||||
copyFromRemote'' repo forcersync r (State connpool _) key file dest meterupdate
|
||||
| Git.repoIsHttp repo = unVerified $
|
||||
Annex.Content.downloadUrl key meterupdate (keyUrls repo r key) dest
|
||||
| not $ Git.repoIsUrl repo = guardUsable repo (unVerified (return False)) $ do
|
||||
params <- Ssh.rsyncParams r Download
|
||||
u <- getUUID
|
||||
hardlink <- wantHardLink
|
||||
-- run copy from perspective of remote
|
||||
onLocalFast r $ do
|
||||
onLocalFast repo r $ do
|
||||
ensureInitialized
|
||||
v <- Annex.Content.prepSendAnnex key
|
||||
case v of
|
||||
|
|
@ -469,7 +488,7 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
|
|||
runTransfer (Transfer Download u key)
|
||||
file stdRetry
|
||||
(\p -> copier object dest (combineMeterUpdate p meterupdate) checksuccess)
|
||||
| Git.repoIsSsh (repo r) = if forcersync
|
||||
| Git.repoIsSsh repo = if forcersync
|
||||
then fallback meterupdate
|
||||
else P2PHelper.retrieve
|
||||
(\p -> Ssh.runProto r connpool (False, UnVerified) (fallback p))
|
||||
|
|
@ -505,7 +524,7 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
|
|||
let fields = (Fields.remoteUUID, fromUUID u)
|
||||
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
|
||||
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
|
||||
(repo r) "transferinfo"
|
||||
repo "transferinfo"
|
||||
[Param $ key2file key] fields
|
||||
v <- liftIO (newEmptySV :: IO (MSampleVar Integer))
|
||||
pidv <- liftIO $ newEmptyMVar
|
||||
|
|
@ -541,10 +560,15 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
|
|||
bracketIO noop (const cleanup) (const $ a feeder)
|
||||
|
||||
copyFromRemoteCheap :: Remote -> State -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
copyFromRemoteCheap r st key af file = do
|
||||
repo <- getRepo r
|
||||
copyFromRemoteCheap' repo r st key af file
|
||||
|
||||
copyFromRemoteCheap' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
#ifndef mingw32_HOST_OS
|
||||
copyFromRemoteCheap r st key af file
|
||||
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ liftIO $ do
|
||||
loc <- gitAnnexLocation key (repo r) $
|
||||
copyFromRemoteCheap' repo r st key af file
|
||||
| not $ Git.repoIsUrl repo = guardUsable repo (return False) $ liftIO $ do
|
||||
loc <- gitAnnexLocation key repo $
|
||||
remoteGitConfig $ gitconfig r
|
||||
ifM (doesFileExist loc)
|
||||
( do
|
||||
|
|
@ -554,25 +578,30 @@ copyFromRemoteCheap r st key af file
|
|||
return True
|
||||
, return False
|
||||
)
|
||||
| Git.repoIsSsh (repo r) =
|
||||
| Git.repoIsSsh repo =
|
||||
ifM (Annex.Content.preseedTmp key file)
|
||||
( fst <$> copyFromRemote' True r st key af file nullMeterUpdate
|
||||
, return False
|
||||
)
|
||||
| otherwise = return False
|
||||
#else
|
||||
copyFromRemoteCheap _ _ _ _ _ = return False
|
||||
copyFromRemoteCheap' _ _ _ _ _ _ = return False
|
||||
#endif
|
||||
|
||||
{- Tries to copy a key's content to a remote's annex. -}
|
||||
copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
copyToRemote r (State connpool duc) key file meterupdate
|
||||
| not $ Git.repoIsUrl (repo r) = ifM duc
|
||||
( guardUsable (repo r) (return False) $ commitOnCleanup r $
|
||||
copyToRemote r st key file meterupdate = do
|
||||
repo <- getRepo r
|
||||
copyToRemote' repo r st key file meterupdate
|
||||
|
||||
copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
copyToRemote' repo r (State connpool duc) key file meterupdate
|
||||
| not $ Git.repoIsUrl repo = ifM duc
|
||||
( guardUsable repo (return False) $ commitOnCleanup repo r $
|
||||
copylocal =<< Annex.Content.prepSendAnnex key
|
||||
, return False
|
||||
)
|
||||
| Git.repoIsSsh (repo r) = commitOnCleanup r $
|
||||
| Git.repoIsSsh repo = commitOnCleanup repo r $
|
||||
P2PHelper.store
|
||||
(\p -> Ssh.runProto r connpool False (copyremotefallback p))
|
||||
key file meterupdate
|
||||
|
|
@ -589,7 +618,7 @@ copyToRemote r (State connpool duc) key file meterupdate
|
|||
u <- getUUID
|
||||
hardlink <- wantHardLink
|
||||
-- run copy from perspective of remote
|
||||
onLocalFast r $ ifM (Annex.Content.inAnnex key)
|
||||
onLocalFast repo r $ ifM (Annex.Content.inAnnex key)
|
||||
( return True
|
||||
, do
|
||||
ensureInitialized
|
||||
|
|
@ -642,11 +671,11 @@ repairRemote r a = return $ do
|
|||
- However, coprocesses are stopped after each call to avoid git
|
||||
- processes hanging around on removable media.
|
||||
-}
|
||||
onLocal :: Remote -> Annex a -> Annex a
|
||||
onLocal r a = do
|
||||
onLocal :: Git.Repo -> Remote -> Annex a -> Annex a
|
||||
onLocal repo r a = do
|
||||
m <- Annex.getState Annex.remoteannexstate
|
||||
go =<< maybe
|
||||
(liftIO $ Annex.new $ repo r)
|
||||
(liftIO $ Annex.new repo)
|
||||
return
|
||||
(M.lookup (uuid r) m)
|
||||
where
|
||||
|
|
@ -666,8 +695,8 @@ onLocal r a = do
|
|||
- it gets the most current value. Caller of onLocalFast can make changes
|
||||
- to the branch, however.
|
||||
-}
|
||||
onLocalFast :: Remote -> Annex a -> Annex a
|
||||
onLocalFast r a = onLocal r $ Annex.BranchState.disableUpdate >> a
|
||||
onLocalFast :: Git.Repo -> Remote -> Annex a -> Annex a
|
||||
onLocalFast repo r a = onLocal repo r $ Annex.BranchState.disableUpdate >> a
|
||||
|
||||
{- Copys a file with rsync unless both locations are on the same
|
||||
- filesystem. Then cp could be faster. -}
|
||||
|
|
@ -689,18 +718,18 @@ rsyncOrCopyFile rsyncparams src dest p =
|
|||
Ssh.rsyncHelper oh (Just p) $
|
||||
rsyncparams ++ [File src, File dest]
|
||||
|
||||
commitOnCleanup :: Remote -> Annex a -> Annex a
|
||||
commitOnCleanup r a = go `after` a
|
||||
commitOnCleanup :: Git.Repo -> Remote -> Annex a -> Annex a
|
||||
commitOnCleanup repo r a = go `after` a
|
||||
where
|
||||
go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup
|
||||
cleanup
|
||||
| not $ Git.repoIsUrl (repo r) = onLocalFast r $
|
||||
| not $ Git.repoIsUrl repo = onLocalFast repo r $
|
||||
doQuietSideAction $
|
||||
Annex.Branch.commit "update"
|
||||
| otherwise = void $ do
|
||||
Just (shellcmd, shellparams) <-
|
||||
Ssh.git_annex_shell NoConsumeStdin
|
||||
(repo r) "commit" [] []
|
||||
repo "commit" [] []
|
||||
|
||||
-- Throw away stderr, since the remote may not
|
||||
-- have a new enough git-annex shell to
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = Nothing
|
||||
, readonly = False
|
||||
|
|
|
|||
|
|
@ -42,7 +42,8 @@ gitRepoInfo r = do
|
|||
let lastsynctime = case mtimes of
|
||||
[] -> "never"
|
||||
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes
|
||||
repo <- Remote.getRepo r
|
||||
return
|
||||
[ ("repository location", Git.repoLocation (Remote.repo r))
|
||||
[ ("repository location", Git.repoLocation repo)
|
||||
, ("last synced", lastsynctime)
|
||||
]
|
||||
|
|
|
|||
|
|
@ -135,7 +135,8 @@ rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do
|
|||
-- compatability.
|
||||
: (Fields.direct, if unlocked then "1" else "")
|
||||
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
|
||||
Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin (repo r)
|
||||
repo <- getRepo r
|
||||
Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo
|
||||
(if direction == Download then "sendkey" else "recvkey")
|
||||
[ Param $ key2file key ]
|
||||
fields
|
||||
|
|
@ -237,13 +238,14 @@ openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshCon
|
|||
openP2PSshConnection r connpool = do
|
||||
u <- getUUID
|
||||
let ps = [Param (fromUUID u)]
|
||||
git_annex_shell ConsumeStdin (repo r) "p2pstdio" ps [] >>= \case
|
||||
repo <- getRepo r
|
||||
git_annex_shell ConsumeStdin repo "p2pstdio" ps [] >>= \case
|
||||
Nothing -> do
|
||||
liftIO $ rememberunsupported
|
||||
return Nothing
|
||||
Just (cmd, params) -> start cmd params
|
||||
Just (cmd, params) -> start cmd params =<< getRepo r
|
||||
where
|
||||
start cmd params = liftIO $ withNullHandle $ \nullh -> do
|
||||
start cmd params repo = liftIO $ withNullHandle $ \nullh -> do
|
||||
-- stderr is discarded because old versions of git-annex
|
||||
-- shell always error
|
||||
(Just from, Just to, Nothing, pid) <- createProcess $
|
||||
|
|
@ -253,7 +255,7 @@ openP2PSshConnection r connpool = do
|
|||
, std_err = UseHandle nullh
|
||||
}
|
||||
let conn = P2P.P2PConnection
|
||||
{ P2P.connRepo = repo r
|
||||
{ P2P.connRepo = repo
|
||||
, P2P.connCheckAuth = const False
|
||||
, P2P.connIhdl = to
|
||||
, P2P.connOhdl = from
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ gen r u c gc = do
|
|||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, localpath = Nothing
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, readonly = False
|
||||
, availability = GloballyAvailable
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ remoteGen m t r = do
|
|||
updateRemote :: Remote -> Annex (Maybe Remote)
|
||||
updateRemote remote = do
|
||||
m <- readRemoteLog
|
||||
remote' <- updaterepo $ repo remote
|
||||
remote' <- updaterepo =<< getRepo remote
|
||||
remoteGen m (remotetype remote) remote'
|
||||
where
|
||||
updaterepo r
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ chainGen addr r u c gc = do
|
|||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, localpath = Nothing
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc { remoteGitConfig = extractGitConfig r }
|
||||
, readonly = False
|
||||
, availability = GloballyAvailable
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ gen r u c gc = do
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = if islocal
|
||||
then Just $ rsyncUrl o
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ gen r u c gc = do
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = Nothing
|
||||
, readonly = False
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ gen r u c gc = do
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = Nothing
|
||||
, readonly = False
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ gen r _ c gc =
|
|||
, config = c
|
||||
, gitconfig = gc
|
||||
, localpath = Nothing
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, readonly = True
|
||||
, availability = GloballyAvailable
|
||||
, remotetype = remote
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
|||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, getRepo = return r
|
||||
, gitconfig = gc
|
||||
, localpath = Nothing
|
||||
, readonly = False
|
||||
|
|
|
|||
|
|
@ -111,8 +111,8 @@ data RemoteA a = Remote
|
|||
, repairRepo :: Maybe (a Bool -> a (IO Bool))
|
||||
-- a Remote has a persistent configuration store
|
||||
, config :: RemoteConfig
|
||||
-- git repo for the Remote
|
||||
, repo :: Git.Repo
|
||||
-- Get the git repo for the Remote.
|
||||
, getRepo :: a Git.Repo
|
||||
-- a Remote's configuration from git
|
||||
, gitconfig :: RemoteGitConfig
|
||||
-- a Remote can be assocated with a specific local filesystem path
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
[[!comment format=mdwn
|
||||
username="joey"
|
||||
subject="""comment 2"""
|
||||
date="2018-06-04T17:40:23Z"
|
||||
content="""
|
||||
Actually, Remote.gitconfig is not a problem; it contains
|
||||
the local repos's remote config settings, not the remote repo's
|
||||
own git config.
|
||||
"""]]
|
||||
Loading…
Reference in a new issue