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

change Remote.repo to Remote.getRepo

Browse source 
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 2018-06-04 14:31:55 -04:00
parent dc5550a54e
commit 67e46229a5
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
36 changed files with 266 additions and 191 deletions
Download patch file Download diff file Expand all files Collapse all files

3
Assistant/DaemonStatus.hs
View file

@ -55,8 +55,7 @@ calcSyncRemotes = do
let good r = Remote.uuid r `elem` alive let good r = Remote.uuid r `elem` alive
let syncable = filter good rs let syncable = filter good rs
contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $ contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $
filter (\r -> Remote.uuid r /= NoUUID) $ filter (\r -> Remote.uuid r /= NoUUID) syncable
filter (not . Remote.isXMPPRemote) syncable
let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes
return $ \dstatus -> dstatus return $ \dstatus -> dstatus

3
Assistant/Pairing/MakeRemote.hs
View file

@ -47,7 +47,8 @@ finishedLocalPairing msg keypair = do
("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)) ("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata))
Nothing Nothing
r <- liftAnnex $ addRemote $ makeSshRemote sshdata r <- liftAnnex $ addRemote $ makeSshRemote sshdata
liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost repo <- liftAnnex $ Remote.getRepo r
liftAnnex $ setRemoteCost repo semiExpensiveRemoteCost
syncRemote r syncRemote r
{- Mostly a straightforward conversion. Except: {- Mostly a straightforward conversion. Except:

37
Assistant/Sync.hs
View file

@ -64,26 +64,25 @@ reconnectRemotes rs = void $ do
mapM_ signal $ filter (`notElem` failedrs) rs' mapM_ signal $ filter (`notElem` failedrs) rs'
recordExportCommit recordExportCommit
where where
gitremotes = filter (notspecialremote . Remote.repo) rs gitremotes = liftAnnex $
(_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs filterM (notspecialremote <$$> Remote.getRepo) rs
notspecialremote r notspecialremote r
| Git.repoIsUrl r = True | Git.repoIsUrl r = True
| Git.repoIsLocal r = True | Git.repoIsLocal r = True
| Git.repoIsLocalUnknown r = True | Git.repoIsLocalUnknown r = True
| otherwise = False | otherwise = False
sync currentbranch@(Just _, _) = do sync currentbranch@(Just _, _) = do
(failedpull, diverged) <- manualPull currentbranch gitremotes (failedpull, diverged) <- manualPull currentbranch =<< gitremotes
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
failedpush <- pushToRemotes' now gitremotes failedpush <- pushToRemotes' now =<< gitremotes
return (nub $ failedpull ++ failedpush, diverged) return (nub $ failedpull ++ failedpush, diverged)
{- No local branch exists yet, but we can try pulling. -} {- No local branch exists yet, but we can try pulling. -}
sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes
go = do go = do
(failed, diverged) <- sync (failed, diverged) <- sync
=<< liftAnnex (join Command.Sync.getCurrBranch) =<< liftAnnex (join Command.Sync.getCurrBranch)
addScanRemotes diverged =<< addScanRemotes diverged =<<
filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs
nonxmppremotes
return failed return failed
signal r = liftIO . mapM_ (flip tryPutMVar ()) signal r = liftIO . mapM_ (flip tryPutMVar ())
=<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers =<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers
@ -130,8 +129,7 @@ pushToRemotes' now remotes = do
<$> gitRepo <$> gitRepo
<*> join Command.Sync.getCurrBranch <*> join Command.Sync.getCurrBranch
<*> getUUID <*> getUUID
let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes ret <- go True branch g u remotes
ret <- go True branch g u normalremotes
return ret return ret
where where
go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
@ -174,7 +172,8 @@ parallelPush g rs a = do
where where
topush r = (,) topush r = (,)
<$> pure 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, {- Displays an alert while running an action that syncs with some remotes,
- and returns any remotes that it failed to sync with. - and returns any remotes that it failed to sync with.
@ -187,7 +186,7 @@ syncAction rs a
| otherwise = do | otherwise = do
i <- addAlert $ syncAlert visibleremotes i <- addAlert $ syncAlert visibleremotes
failed <- a rs 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 let succeeded = filter (`notElem` failed) visibleremotes
if null succeeded && null failed' if null succeeded && null failed'
then removeAlert i then removeAlert i
@ -195,8 +194,7 @@ syncAction rs a
syncResultAlert succeeded failed' syncResultAlert succeeded failed'
return failed return failed
where where
visibleremotes = filter (not . Remote.readonly) $ visibleremotes = filter (not . Remote.readonly) rs
filter (not . Remote.isXMPPRemote) rs
{- Manually pull from remotes and merge their branches. Returns any {- Manually pull from remotes and merge their branches. Returns any
- remotes that it failed to pull from, and a Bool indicating - 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 :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do manualPull currentbranch remotes = do
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes failed <- forM remotes $ \r -> if wantpull $ Remote.gitconfig r
failed <- forM normalremotes $ \r -> if wantpull $ Remote.gitconfig r
then do 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') ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g')
( return Nothing ( return Nothing
, return $ Just r , return $ Just r
) )
else return Nothing else return Nothing
haddiverged <- liftAnnex Annex.Branch.forceUpdate haddiverged <- liftAnnex Annex.Branch.forceUpdate
forM_ normalremotes $ \r -> forM_ remotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r liftAnnex $ Command.Sync.mergeRemote r
currentbranch Command.Sync.mergeConfig def currentbranch Command.Sync.mergeConfig def
when haddiverged $ when haddiverged $
@ -263,10 +262,10 @@ changeSyncable (Just r) False = do
changeSyncFlag :: Remote -> Bool -> Annex () changeSyncFlag :: Remote -> Bool -> Annex ()
changeSyncFlag r enabled = do changeSyncFlag r enabled = do
repo <- Remote.getRepo r
let key = Config.remoteConfig repo "sync"
Config.setConfig key (boolConfig enabled) Config.setConfig key (boolConfig enabled)
void Remote.remoteListRefresh void Remote.remoteListRefresh
where
key = Config.remoteConfig (Remote.repo r) "sync"
updateExportTreeFromLogAll :: Assistant () updateExportTreeFromLogAll :: Assistant ()
updateExportTreeFromLogAll = do updateExportTreeFromLogAll = do

6
Assistant/Threads/Cronner.hs
View file

@ -210,11 +210,11 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (r
- Annex monad. -} - Annex monad. -}
go rmt =<< liftAnnex (mkfscker (annexFsckParams d)) go rmt =<< liftAnnex (mkfscker (annexFsckParams d))
go rmt annexfscker = do go rmt annexfscker = do
repo <- liftAnnex $ Remote.getRepo rmt
fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do
void annexfscker void annexfscker
let r = Remote.repo rmt if Git.repoIsLocal repo && not (Git.repoIsLocalUnknown repo)
if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) then Just <$> Git.Fsck.findBroken True repo
then Just <$> Git.Fsck.findBroken True r
else pure Nothing else pure Nothing
maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults

3
Assistant/Threads/MountWatcher.hs
View file

@ -144,7 +144,8 @@ handleMounts urlrenderer wasmounted nowmounted =
handleMount :: UrlRenderer -> FilePath -> Assistant () handleMount :: UrlRenderer -> FilePath -> Assistant ()
handleMount urlrenderer dir = do handleMount urlrenderer dir = do
debug ["detected mount of", dir] 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 mapM_ (fsckNudge urlrenderer . Just) rs
reconnectRemotes rs reconnectRemotes rs

15
Assistant/Threads/ProblemFixer.hs
View file

@ -49,20 +49,23 @@ handleProblem urlrenderer repoproblem = do
liftIO $ afterFix repoproblem liftIO $ afterFix repoproblem
handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool
handleRemoteProblem urlrenderer rmt handleRemoteProblem urlrenderer rmt = do
| Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) = 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) ifM (liftIO $ checkAvailable True rmt)
( do ( do
fixedlocks <- repairStaleGitLocks r fixedlocks <- repairStaleGitLocks repo
fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ 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 repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults
return $ fixedlocks || repaired return $ fixedlocks || repaired
, return False , return False
) )
| otherwise = return False | otherwise = return False
where
r = Remote.repo rmt
{- This is not yet used, and should probably do a fsck. -} {- This is not yet used, and should probably do a fsck. -}
handleLocalRepoProblem :: UrlRenderer -> Assistant Bool handleLocalRepoProblem :: UrlRenderer -> Assistant Bool

2
Assistant/Threads/RemoteControl.hs
View file

@ -99,7 +99,7 @@ remoteResponderThread fromh urimap = go M.empty
cont cont
getURIMap :: Annex (M.Map URI Remote) 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 where
mkk (Git.Url u) = Just u mkk (Git.Url u) = Just u
mkk _ = Nothing mkk _ = Nothing

12
Assistant/TransferSlots.hs
View file

@ -106,13 +106,13 @@ runTransferThread' program batchmaker d run = go
- already have been updated to include the transfer. -} - already have been updated to include the transfer. -}
genTransfer :: Transfer -> TransferInfo -> TransferGenerator genTransfer :: Transfer -> TransferInfo -> TransferGenerator
genTransfer t info = case transferRemote info of genTransfer t info = case transferRemote info of
Just remote Just remote -> ifM (unpluggedremovabledrive remote)
| Git.repoIsLocalUnknown (Remote.repo remote) -> do ( do
-- optimisation for removable drives not plugged in -- optimisation, since the transfer would fail
liftAnnex $ recordFailedTransfer t info liftAnnex $ recordFailedTransfer t info
void $ removeTransfer t void $ removeTransfer t
return Nothing return Nothing
| otherwise -> ifM (liftAnnex $ shouldTransfer t info) , ifM (liftAnnex $ shouldTransfer t info)
( do ( do
debug [ "Transferring:" , describeTransfer t info ] debug [ "Transferring:" , describeTransfer t info ]
notifyTransfer notifyTransfer
@ -124,11 +124,15 @@ genTransfer t info = case transferRemote info of
finishedTransfer t (Just info) finishedTransfer t (Just info)
return Nothing return Nothing
) )
)
_ -> return Nothing _ -> return Nothing
where where
direction = transferDirection t direction = transferDirection t
isdownload = direction == Download isdownload = direction == Download
unpluggedremovabledrive remote = Git.repoIsLocalUnknown
<$> liftAnnex (Remote.getRepo remote)
{- Alerts are only shown for successful transfers. {- Alerts are only shown for successful transfers.
- Transfers can temporarily fail for many reasons, - Transfers can temporarily fail for many reasons,
- so there's no point in bothering the user about - so there's no point in bothering the user about

25
Assistant/WebApp/Configurators/Edit.hs
View file

@ -146,8 +146,8 @@ setRepoConfig uuid mremote oldc newc = do
legalName = makeLegalName . T.unpack . repoName legalName = makeLegalName . T.unpack . repoName
editRepositoryAForm :: Maybe Remote -> RepoConfig -> MkAForm RepoConfig editRepositoryAForm :: Maybe Git.Repo -> Maybe Remote -> RepoConfig -> MkAForm RepoConfig
editRepositoryAForm mremote d = RepoConfig editRepositoryAForm mrepo mremote d = RepoConfig
<$> areq (if ishere then readonlyTextField else textField) <$> areq (if ishere then readonlyTextField else textField)
(bfs "Name") (Just $ repoName d) (bfs "Name") (Just $ repoName d)
<*> aopt textField (bfs "Description") (Just $ repoDescription d) <*> aopt textField (bfs "Description") (Just $ repoDescription d)
@ -156,8 +156,7 @@ editRepositoryAForm mremote d = RepoConfig
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable d) <*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable d)
where where
ishere = isNothing mremote ishere = isNothing mremote
isspecial = fromMaybe False $ isspecial = maybe False ((== Git.Unknown) . Git.location) mrepo
(== Git.Unknown) . Git.location . Remote.repo <$> mremote
groups = customgroups ++ standardgroups groups = customgroups ++ standardgroups
standardgroups :: [(Text, RepoGroup)] standardgroups :: [(Text, RepoGroup)]
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) $ standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) $
@ -204,8 +203,11 @@ editForm new (RepoUUID uuid)
error "unknown remote" error "unknown remote"
curr <- liftAnnex $ getRepoConfig uuid mremote curr <- liftAnnex $ getRepoConfig uuid mremote
liftAnnex $ checkAssociatedDirectory curr mremote liftAnnex $ checkAssociatedDirectory curr mremote
mrepo <- liftAnnex $
maybe (pure Nothing) (Just <$$> Remote.getRepo) mremote
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ editRepositoryAForm mremote curr runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
editRepositoryAForm mrepo mremote curr
case result of case result of
FormSuccess input -> liftH $ do FormSuccess input -> liftH $ do
setRepoConfig uuid mremote curr input setRepoConfig uuid mremote curr input
@ -221,7 +223,8 @@ editForm _new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do
mr <- liftAnnex (repoIdRemote r) mr <- liftAnnex (repoIdRemote r)
let repoInfo = getRepoInfo mr Nothing let repoInfo = getRepoInfo mr Nothing
g <- liftAnnex gitRepo 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") $(widgetFile "configurators/edit/nonannexremote")
{- Makes any directory associated with the repository. -} {- 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 | otherwise -> AWS.getRepoInfo c
Just t Just t
| t /= "git" -> [whamlet|#{t} remote|] | 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 (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r)
getRepoInfo _ _ = [whamlet|git repository|] getRepoInfo _ _ = [whamlet|git repository|]
@ -283,9 +286,11 @@ getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
go Nothing = redirect DashboardR go Nothing = redirect DashboardR
go (Just rmt) = do go (Just rmt) = do
liftIO fixSshKeyPairIdentitiesOnly liftIO fixSshKeyPairIdentitiesOnly
liftAnnex $ setConfig liftAnnex $ do
(remoteConfig (Remote.repo rmt) "ignore") repo <- Remote.getRepo rmt
(Git.Config.boolConfig False) setConfig
(remoteConfig repo "ignore")
(Git.Config.boolConfig False)
liftAnnex $ void Remote.remoteListRefresh liftAnnex $ void Remote.remoteListRefresh
liftAssistant updateSyncRemotes liftAssistant updateSyncRemotes
liftAssistant $ syncRemote rmt liftAssistant $ syncRemote rmt

3
Assistant/WebApp/MakeRemote.hs
View file

@ -38,8 +38,9 @@ setupCloudRemote = setupRemote postsetup . Just
setupRemote :: (Remote -> Handler a) -> Maybe StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a setupRemote :: (Remote -> Handler a) -> Maybe StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
setupRemote postsetup mgroup mcost getname = do setupRemote postsetup mgroup mcost getname = do
r <- liftAnnex $ addRemote getname r <- liftAnnex $ addRemote getname
repo <- liftAnnex $ Remote.getRepo r
liftAnnex $ do liftAnnex $ do
maybe noop (defaultStandardGroup (Remote.uuid r)) mgroup maybe noop (defaultStandardGroup (Remote.uuid r)) mgroup
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost maybe noop (Config.setRemoteCost repo) mcost
liftAssistant $ syncRemote r liftAssistant $ syncRemote r
postsetup r postsetup r

17
Assistant/WebApp/RepoList.hs
View file

@ -139,10 +139,11 @@ repoList reposelector
unwanted <- S.fromList unwanted <- S.fromList
<$> filterM inUnwantedGroup (map Remote.uuid syncremotes) <$> filterM inUnwantedGroup (map Remote.uuid syncremotes)
trustmap <- trustMap trustmap <- trustMap
allrs <- concat . Remote.byCost <$> Remote.remoteList
rs <- filter (\r -> M.lookup (Remote.uuid r) trustmap /= Just DeadTrusted) rs <- filter (\r -> M.lookup (Remote.uuid r) trustmap /= Just DeadTrusted)
. filter selectedrepo . map fst
. concat . Remote.byCost . filter selectedrepo
<$> Remote.remoteList <$> forM allrs (\r -> (,) <$> pure r <*> Remote.getRepo r)
let l = flip map (map mkRepoId rs) $ \r -> case r of let l = flip map (map mkRepoId rs) $ \r -> case r of
(RepoUUID u) (RepoUUID u)
| u `S.member` unwanted -> (r, mkUnwantedRepoActions r) | u `S.member` unwanted -> (r, mkUnwantedRepoActions r)
@ -165,11 +166,10 @@ repoList reposelector
map snd . catMaybes . filter selectedremote map snd . catMaybes . filter selectedremote
. map (findinfo m g) . map (findinfo m g)
<$> trustExclude DeadTrusted (M.keys m) <$> trustExclude DeadTrusted (M.keys m)
selectedrepo r selectedrepo (r, repo)
| Remote.readonly r = False | Remote.readonly r = False
| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) | onlyCloud reposelector = Git.repoIsUrl repo
&& Remote.uuid r /= NoUUID && Remote.uuid r /= NoUUID
&& not (Remote.isXMPPRemote r)
| otherwise = True | otherwise = True
selectedremote Nothing = False selectedremote Nothing = False
selectedremote (Just (iscloud, _)) selectedremote (Just (iscloud, _))
@ -238,8 +238,9 @@ getRepositoriesReorderR = do
go list (Just remote) = do go list (Just remote) = do
rs <- catMaybes <$> mapM repoIdRemote list rs <- catMaybes <$> mapM repoIdRemote list
forM_ (reorderCosts remote rs) $ \(r, newcost) -> forM_ (reorderCosts remote rs) $ \(r, newcost) ->
when (Remote.cost r /= newcost) $ when (Remote.cost r /= newcost) $ do
setRemoteCost (Remote.repo r) newcost repo <- Remote.getRepo r
setRemoteCost repo newcost
void remoteListRefresh void remoteListRefresh
fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack

4
Command/EnableRemote.hs
View file

@ -92,7 +92,9 @@ cleanupSpecialRemote u c = do
Logs.Remote.configSet u c Logs.Remote.configSet u c
Remote.byUUID u >>= \case Remote.byUUID u >>= \case
Nothing -> noop Nothing -> noop
Just r -> setRemoteIgnore (R.repo r) False Just r -> do
repo <- R.getRepo r
setRemoteIgnore repo False
return True return True
unknownNameError :: String -> Annex a unknownNameError :: String -> Annex a

27
Command/Sync.hs
View file

@ -275,8 +275,7 @@ remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
syncRemotes :: [String] -> Annex [Remote] syncRemotes :: [String] -> Annex [Remote]
syncRemotes ps = do syncRemotes ps = do
remotelist <- Remote.remoteList' True remotelist <- Remote.remoteList' True
available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig) available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig) remotelist
(filter (not . Remote.isXMPPRemote) remotelist)
syncRemotes' ps available syncRemotes' ps available
syncRemotes' :: [String] -> [Remote] -> Annex [Remote] syncRemotes' :: [String] -> [Remote] -> Annex [Remote]
@ -292,7 +291,8 @@ syncRemotes' ps available =
listed = concat <$> mapM Remote.byNameOrGroup ps listed = concat <$> mapM Remote.byNameOrGroup ps
good r good r
| Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r | Remote.gitSyncableRemote r =
Remote.Git.repoAvail =<< Remote.getRepo r
| otherwise = return True | otherwise = return True
fastest = fromMaybe [] . headMaybe . Remote.byCost fastest = fromMaybe [] . headMaybe . Remote.byCost
@ -408,9 +408,11 @@ pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && want
stopUnless fetch $ stopUnless fetch $
next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o) next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
where where
fetch = inRepoWithSshOptionsTo (Remote.repo remote) (Remote.gitconfig remote) $ fetch = do
Git.Command.runBool repo <- Remote.getRepo remote
[Param "fetch", Param $ Remote.name remote] inRepoWithSshOptionsTo repo (Remote.gitconfig remote) $
Git.Command.runBool
[Param "fetch", Param $ Remote.name remote]
wantpull = remoteAnnexPull (Remote.gitconfig remote) wantpull = remoteAnnexPull (Remote.gitconfig remote)
{- The remote probably has both a master and a synced/master branch. {- 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 pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do
showStart' "push" (Just (Remote.name remote)) showStart' "push" (Just (Remote.name remote))
next $ next $ do next $ next $ do
repo <- Remote.getRepo remote
showOutput showOutput
ok <- inRepoWithSshOptionsTo (Remote.repo remote) gc $ ok <- inRepoWithSshOptionsTo repo gc $
pushBranch remote branch pushBranch remote branch
if ok if ok
then postpushupdate then postpushupdate repo
else do else do
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] 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)" 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] | otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
-- Do updateInstead emulation for remotes on eg removable drives -- Do updateInstead emulation for remotes on eg removable drives
-- formatted FAT, where the post-update hook won't run. -- formatted FAT, where the post-update hook won't run.
postpushupdate postpushupdate repo
| annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) = | annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) =
case Git.repoWorkTree (Remote.repo remote) of case Git.repoWorkTree repo of
Nothing -> return True Nothing -> return True
Just wt -> ifM (Remote.Git.onLocal remote needUpdateInsteadEmulation) Just wt -> ifM (Remote.Git.onLocal repo remote needUpdateInsteadEmulation)
( liftIO $ do ( liftIO $ do
p <- readProgramFile p <- readProgramFile
boolSystem' p [Param "post-receive"] boolSystem' p [Param "post-receive"]

12
Command/TestRemote.hs
View file

@ -123,11 +123,13 @@ exportTreeVariant r = ifM (Remote.isExportSupported r)
-- Regenerate a remote with a modified config. -- Regenerate a remote with a modified config.
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote) adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
adjustRemoteConfig r adjustconfig = Remote.generate (Remote.remotetype r) adjustRemoteConfig r adjustconfig = do
(Remote.repo r) repo <- Remote.getRepo r
(Remote.uuid r) Remote.generate (Remote.remotetype r)
(adjustconfig (Remote.config r)) repo
(Remote.gitconfig r) (Remote.uuid r)
(adjustconfig (Remote.config r))
(Remote.gitconfig r)
test :: Annex.AnnexState -> Remote -> Key -> [TestTree] test :: Annex.AnnexState -> Remote -> Key -> [TestTree]
test st r k = test st r k =

21
Remote.hs
View file

@ -51,7 +51,6 @@ module Remote (
forceTrust, forceTrust,
logStatus, logStatus,
checkAvailable, checkAvailable,
isXMPPRemote,
claimingUrl, claimingUrl,
isExportSupported, isExportSupported,
) where ) where
@ -72,21 +71,20 @@ import Remote.List
import Config import Config
import Config.DynamicConfig import Config.DynamicConfig
import Git.Types (RemoteName) import Git.Types (RemoteName)
import qualified Git
import Utility.Aeson import Utility.Aeson
{- Map from UUIDs of Remotes to a calculated value. -} {- Map from UUIDs of Remotes to a calculated value. -}
remoteMap :: (Remote -> v) -> Annex (M.Map UUID v) remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
remoteMap mkv = remoteMap' mkv mkk remoteMap mkv = remoteMap' mkv (pure . mkk)
where where
mkk r = case uuid r of mkk r = case uuid r of
NoUUID -> Nothing NoUUID -> Nothing
u -> Just u u -> Just u
remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Maybe k) -> Annex (M.Map k v) remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Annex (Maybe k)) -> Annex (M.Map k v)
remoteMap' mkv mkk = M.fromList . mapMaybe mk <$> remoteList remoteMap' mkv mkk = M.fromList . catMaybes <$> (mapM mk =<< remoteList)
where where
mk r = case mkk r of mk r = mkk r >>= return . \case
Nothing -> Nothing Nothing -> Nothing
Just k -> Just (k, mkv r) Just k -> Just (k, mkv r)
@ -122,10 +120,11 @@ byNameWithUUID = checkuuid <=< byName
where where
checkuuid Nothing = return Nothing checkuuid Nothing = return Nothing
checkuuid (Just r) checkuuid (Just r)
| uuid r == NoUUID = | uuid r == NoUUID = do
repo <- getRepo r
ifM (liftIO $ getDynamicConfig $ remoteAnnexIgnore (gitconfig r)) ifM (liftIO $ getDynamicConfig $ remoteAnnexIgnore (gitconfig r))
( giveup $ noRemoteUUIDMsg r ++ ( giveup $ noRemoteUUIDMsg r ++
" (" ++ show (remoteConfig (repo r) "ignore") ++ " (" ++ show (remoteConfig repo "ignore") ++
" is set)" " is set)"
, giveup $ noRemoteUUIDMsg r , giveup $ noRemoteUUIDMsg r
) )
@ -357,12 +356,6 @@ checkAvailable :: Bool -> Remote -> IO Bool
checkAvailable assumenetworkavailable = checkAvailable assumenetworkavailable =
maybe (return assumenetworkavailable) doesDirectoryExist . localpath 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 :: Remote -> Key -> Annex (Either String Bool)
hasKey r k = either (Left . show) Right <$> tryNonAsync (checkPresent r k) hasKey r k = either (Left . show) Right <$> tryNonAsync (checkPresent r k)

2
Remote/Adb.hs
View file

@ -64,7 +64,7 @@ gen r u c gc = do
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Nothing , localpath = Nothing
, remotetype = remote , remotetype = remote

2
Remote/BitTorrent.hs
View file

@ -70,7 +70,7 @@ gen r _ c gc =
, config = c , config = c
, gitconfig = gc , gitconfig = gc
, localpath = Nothing , localpath = Nothing
, repo = r , getRepo = return r
, readonly = True , readonly = True
, availability = GloballyAvailable , availability = GloballyAvailable
, remotetype = remote , remotetype = remote

2
Remote/Bup.hs
View file

@ -68,7 +68,7 @@ gen r u c gc = do
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = if bupLocal buprepo && not (null buprepo) , localpath = if bupLocal buprepo && not (null buprepo)
then Just buprepo then Just buprepo

2
Remote/Ddar.hs
View file

@ -67,7 +67,7 @@ gen r u c gc = do
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = if ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo) , localpath = if ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo)
then Just $ ddarRepoLocation ddarrepo then Just $ ddarRepoLocation ddarrepo

2
Remote/Directory.hs
View file

@ -76,7 +76,7 @@ gen r u c gc = do
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Just dir , localpath = Just dir
, readonly = False , readonly = False

2
Remote/External.hs
View file

@ -117,7 +117,7 @@ gen r u c gc
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, localpath = Nothing , localpath = Nothing
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, readonly = False , readonly = False
, availability = avail , availability = avail

72
Remote/GCrypt.hs
View file

@ -123,7 +123,7 @@ gen' r u c gc = do
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, localpath = localpathCalc r , localpath = localpathCalc r
, repo = r , getRepo = return r
, gitconfig = gc { remoteGitConfig = extractGitConfig r } , gitconfig = gc { remoteGitConfig = extractGitConfig r }
, readonly = Git.repoIsHttp r , readonly = Git.repoIsHttp r
, availability = availabilityCalc r , availability = availabilityCalc r
@ -328,17 +328,22 @@ setGcryptEncryption c remotename = do
remoteconfig n = ConfigKey $ n remotename remoteconfig n = ConfigKey $ n remotename
store :: Remote -> Remote.Rsync.RsyncOpts -> Storer store :: Remote -> Remote.Rsync.RsyncOpts -> Storer
store r rsyncopts store r rsyncopts k s p = do
| not $ Git.repoIsUrl (repo r) = repo <- getRepo r
byteStorer $ \k b p -> guardUsable (repo r) (return False) $ liftIO $ do store' repo r rsyncopts k s p
let tmpdir = Git.repoLocation (repo r) </> "tmp" </> keyFile k
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 void $ tryIO $ createDirectoryIfMissing True tmpdir
let tmpf = tmpdir </> keyFile k let tmpf = tmpdir </> keyFile k
meteredWriteFile p tmpf b meteredWriteFile p tmpf b
let destdir = parentDir $ gCryptLocation r k let destdir = parentDir $ gCryptLocation repo k
Remote.Directory.finalizeStoreGeneric tmpdir destdir Remote.Directory.finalizeStoreGeneric tmpdir destdir
return True return True
| Git.repoIsSsh (repo r) = if accessShell r | Git.repoIsSsh repo = if accessShell r
then fileStorer $ \k f p -> do then fileStorer $ \k f p -> do
oh <- mkOutputHandler oh <- mkOutputHandler
Ssh.rsyncHelper oh (Just p) Ssh.rsyncHelper oh (Just p)
@ -348,11 +353,16 @@ store r rsyncopts
| otherwise = unsupportedUrl | otherwise = unsupportedUrl
retrieve :: Remote -> Remote.Rsync.RsyncOpts -> Retriever retrieve :: Remote -> Remote.Rsync.RsyncOpts -> Retriever
retrieve r rsyncopts retrieve r rsyncopts k p sink = do
| not $ Git.repoIsUrl (repo r) = byteRetriever $ \k sink -> repo <- getRepo r
guardUsable (repo r) (return False) $ retrieve' repo r rsyncopts k p sink
sink =<< liftIO (L.readFile $ gCryptLocation r k)
| Git.repoIsSsh (repo r) = if accessShell r 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 then fileRetriever $ \f k p -> do
ps <- Ssh.rsyncParamsRemote False r Download k f ps <- Ssh.rsyncParamsRemote False r Download k f
(AssociatedFile Nothing) (AssociatedFile Nothing)
@ -364,30 +374,40 @@ retrieve r rsyncopts
where where
remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover
remove r rsyncopts k remove r rsyncopts k = do
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ repo <- getRepo r
liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k)) remove' repo r rsyncopts k
| Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
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 | otherwise = unsupportedUrl
where where
removersync = Remote.Rsync.remove rsyncopts k removersync = Remote.Rsync.remove rsyncopts k
removeshell = Ssh.dropKey (repo r) k removeshell = Ssh.dropKey repo k
checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent
checkKey r rsyncopts k checkKey r rsyncopts k = do
| not $ Git.repoIsUrl (repo r) = repo <- getRepo r
guardUsable (repo r) (cantCheck $ repo r) $ checkKey' repo r rsyncopts k
liftIO $ doesFileExist (gCryptLocation r k)
| Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync 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 | otherwise = unsupportedUrl
where where
checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k checkrsync = Remote.Rsync.checkKey repo rsyncopts k
checkshell = Ssh.inAnnex (repo r) k checkshell = Ssh.inAnnex repo k
{- Annexed objects are hashed using lower-case directories for max {- Annexed objects are hashed using lower-case directories for max
- portability. -} - portability. -}
gCryptLocation :: Remote -> Key -> FilePath gCryptLocation :: Git.Repo -> Key -> FilePath
gCryptLocation r key = Git.repoLocation (repo r) </> objectDir </> keyPath key (hashDirLower def) gCryptLocation repo key = Git.repoLocation repo </> objectDir </> keyPath key (hashDirLower def)
data AccessMethod = AccessDirect | AccessShell data AccessMethod = AccessDirect | AccessShell

137
Remote/Git.hs
View file

@ -175,7 +175,7 @@ gen r u c gc
else Just $ repairRemote r else Just $ repairRemote r
, config = c , config = c
, localpath = localpathCalc r , localpath = localpathCalc r
, repo = r , getRepo = return r
, gitconfig = gc { remoteGitConfig = extractGitConfig r } , gitconfig = gc { remoteGitConfig = extractGitConfig r }
, readonly = Git.repoIsHttp r , readonly = Git.repoIsHttp r
, availability = availabilityCalc 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. -} {- Checks if a given remote has the content for a key in its annex. -}
inAnnex :: Remote -> State -> Key -> Annex Bool inAnnex :: Remote -> State -> Key -> Annex Bool
inAnnex rmt (State connpool duc) key inAnnex rmt st key = do
| Git.repoIsHttp r = checkhttp repo <- getRepo rmt
| Git.repoIsUrl r = checkremote 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 | otherwise = checklocal
where where
r = repo rmt
checkhttp = do checkhttp = do
showChecking r showChecking repo
ifM (Url.withUrlOptions $ \uo -> liftIO $ 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 ( return True
, giveup "not found" , giveup "not found"
) )
checkremote = checkremote =
let fallback = Ssh.inAnnex r key let fallback = Ssh.inAnnex repo key
in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key
checklocal = ifM duc checklocal = ifM duc
( guardUsable r (cantCheck r) $ ( guardUsable repo (cantCheck repo) $
maybe (cantCheck r) return maybe (cantCheck repo) return
=<< onLocalFast rmt (Annex.Content.inAnnexSafe key) =<< onLocalFast repo rmt (Annex.Content.inAnnexSafe key)
, cantCheck r , cantCheck repo
) )
keyUrls :: Remote -> Key -> [String] keyUrls :: Git.Repo -> Remote -> Key -> [String]
keyUrls r key = map tourl locs' keyUrls repo r key = map tourl locs'
where 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 -- If the remote is known to not be bare, try the hash locations
-- used for non-bare repos first, as an optimisation. -- used for non-bare repos first, as an optimisation.
locs locs
@ -369,10 +373,15 @@ keyUrls r key = map tourl locs'
cfg = remoteGitConfig remoteconfig cfg = remoteGitConfig remoteconfig
dropKey :: Remote -> State -> Key -> Annex Bool dropKey :: Remote -> State -> Key -> Annex Bool
dropKey r (State connpool duc) key dropKey r st key = do
| not $ Git.repoIsUrl (repo r) = ifM duc repo <- getRepo r
( guardUsable (repo r) (return False) $ dropKey' repo r st key
commitOnCleanup r $ onLocalFast r $ do
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 ensureInitialized
whenM (Annex.Content.inAnnex key) $ do whenM (Annex.Content.inAnnex key) $ do
Annex.Content.lockContentForRemoval key $ \lock -> do Annex.Content.lockContentForRemoval key $ \lock -> do
@ -382,25 +391,30 @@ dropKey r (State connpool duc) key
return True return True
, return False , return False
) )
| Git.repoIsHttp (repo r) = giveup "dropping from http remote not supported" | Git.repoIsHttp repo = giveup "dropping from http remote not supported"
| otherwise = commitOnCleanup r $ do | otherwise = commitOnCleanup repo r $ do
let fallback = Ssh.dropKey (repo r) key let fallback = Ssh.dropKey repo key
P2PHelper.remove (Ssh.runProto r connpool False fallback) key P2PHelper.remove (Ssh.runProto r connpool False fallback) key
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
lockKey r (State connpool duc) key callback lockKey r st key callback = do
| not $ Git.repoIsUrl (repo r) = ifM duc repo <- getRepo r
( guardUsable (repo r) failedlock $ do 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 inorigrepo <- Annex.makeRunner
-- Lock content from perspective of remote, -- Lock content from perspective of remote,
-- and then run the callback in the original -- and then run the callback in the original
-- annex monad, not the remote's. -- annex monad, not the remote's.
onLocalFast r $ onLocalFast repo r $
Annex.Content.lockContentShared key $ Annex.Content.lockContentShared key $
liftIO . inorigrepo . callback liftIO . inorigrepo . callback
, failedlock , failedlock
) )
| Git.repoIsSsh (repo r) = do | Git.repoIsSsh repo = do
showLocking r showLocking r
let withconn = Ssh.withP2PSshConnection r connpool fallback let withconn = Ssh.withP2PSshConnection r connpool fallback
P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback
@ -408,7 +422,7 @@ lockKey r (State connpool duc) key callback
where where
fallback = do fallback = do
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
(repo r) "lockcontent" repo "lockcontent"
[Param $ key2file key] [] [Param $ key2file key] []
(Just hin, Just hout, Nothing, p) <- liftIO $ (Just hin, Just hout, Nothing, p) <- liftIO $
withFile devNull WriteMode $ \nullh -> withFile devNull WriteMode $ \nullh ->
@ -451,15 +465,20 @@ copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterU
copyFromRemote = copyFromRemote' False copyFromRemote = copyFromRemote' False
copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
copyFromRemote' forcersync r (State connpool _) key file dest meterupdate copyFromRemote' forcersync r st key file dest meterupdate = do
| Git.repoIsHttp (repo r) = unVerified $ repo <- getRepo r
Annex.Content.downloadUrl key meterupdate (keyUrls r key) dest copyFromRemote'' repo forcersync r st key file dest meterupdate
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (unVerified (return False)) $ do
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 params <- Ssh.rsyncParams r Download
u <- getUUID u <- getUUID
hardlink <- wantHardLink hardlink <- wantHardLink
-- run copy from perspective of remote -- run copy from perspective of remote
onLocalFast r $ do onLocalFast repo r $ do
ensureInitialized ensureInitialized
v <- Annex.Content.prepSendAnnex key v <- Annex.Content.prepSendAnnex key
case v of case v of
@ -469,7 +488,7 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
runTransfer (Transfer Download u key) runTransfer (Transfer Download u key)
file stdRetry file stdRetry
(\p -> copier object dest (combineMeterUpdate p meterupdate) checksuccess) (\p -> copier object dest (combineMeterUpdate p meterupdate) checksuccess)
| Git.repoIsSsh (repo r) = if forcersync | Git.repoIsSsh repo = if forcersync
then fallback meterupdate then fallback meterupdate
else P2PHelper.retrieve else P2PHelper.retrieve
(\p -> Ssh.runProto r connpool (False, UnVerified) (fallback p)) (\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) let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile : maybe [] (\f -> [(Fields.associatedFile, f)]) afile
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
(repo r) "transferinfo" repo "transferinfo"
[Param $ key2file key] fields [Param $ key2file key] fields
v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) v <- liftIO (newEmptySV :: IO (MSampleVar Integer))
pidv <- liftIO $ newEmptyMVar pidv <- liftIO $ newEmptyMVar
@ -541,10 +560,15 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
bracketIO noop (const cleanup) (const $ a feeder) bracketIO noop (const cleanup) (const $ a feeder)
copyFromRemoteCheap :: Remote -> State -> Key -> AssociatedFile -> FilePath -> Annex Bool 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 #ifndef mingw32_HOST_OS
copyFromRemoteCheap r st key af file copyFromRemoteCheap' repo r st key af file
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ liftIO $ do | not $ Git.repoIsUrl repo = guardUsable repo (return False) $ liftIO $ do
loc <- gitAnnexLocation key (repo r) $ loc <- gitAnnexLocation key repo $
remoteGitConfig $ gitconfig r remoteGitConfig $ gitconfig r
ifM (doesFileExist loc) ifM (doesFileExist loc)
( do ( do
@ -554,25 +578,30 @@ copyFromRemoteCheap r st key af file
return True return True
, return False , return False
) )
| Git.repoIsSsh (repo r) = | Git.repoIsSsh repo =
ifM (Annex.Content.preseedTmp key file) ifM (Annex.Content.preseedTmp key file)
( fst <$> copyFromRemote' True r st key af file nullMeterUpdate ( fst <$> copyFromRemote' True r st key af file nullMeterUpdate
, return False , return False
) )
| otherwise = return False | otherwise = return False
#else #else
copyFromRemoteCheap _ _ _ _ _ = return False copyFromRemoteCheap' _ _ _ _ _ _ = return False
#endif #endif
{- Tries to copy a key's content to a remote's annex. -} {- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote r (State connpool duc) key file meterupdate copyToRemote r st key file meterupdate = do
| not $ Git.repoIsUrl (repo r) = ifM duc repo <- getRepo r
( guardUsable (repo r) (return False) $ commitOnCleanup 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 copylocal =<< Annex.Content.prepSendAnnex key
, return False , return False
) )
| Git.repoIsSsh (repo r) = commitOnCleanup r $ | Git.repoIsSsh repo = commitOnCleanup repo r $
P2PHelper.store P2PHelper.store
(\p -> Ssh.runProto r connpool False (copyremotefallback p)) (\p -> Ssh.runProto r connpool False (copyremotefallback p))
key file meterupdate key file meterupdate
@ -589,7 +618,7 @@ copyToRemote r (State connpool duc) key file meterupdate
u <- getUUID u <- getUUID
hardlink <- wantHardLink hardlink <- wantHardLink
-- run copy from perspective of remote -- run copy from perspective of remote
onLocalFast r $ ifM (Annex.Content.inAnnex key) onLocalFast repo r $ ifM (Annex.Content.inAnnex key)
( return True ( return True
, do , do
ensureInitialized ensureInitialized
@ -642,11 +671,11 @@ repairRemote r a = return $ do
- However, coprocesses are stopped after each call to avoid git - However, coprocesses are stopped after each call to avoid git
- processes hanging around on removable media. - processes hanging around on removable media.
-} -}
onLocal :: Remote -> Annex a -> Annex a onLocal :: Git.Repo -> Remote -> Annex a -> Annex a
onLocal r a = do onLocal repo r a = do
m <- Annex.getState Annex.remoteannexstate m <- Annex.getState Annex.remoteannexstate
go =<< maybe go =<< maybe
(liftIO $ Annex.new $ repo r) (liftIO $ Annex.new repo)
return return
(M.lookup (uuid r) m) (M.lookup (uuid r) m)
where where
@ -666,8 +695,8 @@ onLocal r a = do
- it gets the most current value. Caller of onLocalFast can make changes - it gets the most current value. Caller of onLocalFast can make changes
- to the branch, however. - to the branch, however.
-} -}
onLocalFast :: Remote -> Annex a -> Annex a onLocalFast :: Git.Repo -> Remote -> Annex a -> Annex a
onLocalFast r a = onLocal r $ Annex.BranchState.disableUpdate >> a onLocalFast repo r a = onLocal repo r $ Annex.BranchState.disableUpdate >> a
{- Copys a file with rsync unless both locations are on the same {- Copys a file with rsync unless both locations are on the same
- filesystem. Then cp could be faster. -} - filesystem. Then cp could be faster. -}
@ -689,18 +718,18 @@ rsyncOrCopyFile rsyncparams src dest p =
Ssh.rsyncHelper oh (Just p) $ Ssh.rsyncHelper oh (Just p) $
rsyncparams ++ [File src, File dest] rsyncparams ++ [File src, File dest]
commitOnCleanup :: Remote -> Annex a -> Annex a commitOnCleanup :: Git.Repo -> Remote -> Annex a -> Annex a
commitOnCleanup r a = go `after` a commitOnCleanup repo r a = go `after` a
where where
go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup
cleanup cleanup
| not $ Git.repoIsUrl (repo r) = onLocalFast r $ | not $ Git.repoIsUrl repo = onLocalFast repo r $
doQuietSideAction $ doQuietSideAction $
Annex.Branch.commit "update" Annex.Branch.commit "update"
| otherwise = void $ do | otherwise = void $ do
Just (shellcmd, shellparams) <- Just (shellcmd, shellparams) <-
Ssh.git_annex_shell NoConsumeStdin Ssh.git_annex_shell NoConsumeStdin
(repo r) "commit" [] [] repo "commit" [] []
-- Throw away stderr, since the remote may not -- Throw away stderr, since the remote may not
-- have a new enough git-annex shell to -- have a new enough git-annex shell to

2
Remote/Glacier.hs
View file

@ -64,7 +64,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Nothing , localpath = Nothing
, readonly = False , readonly = False

3
Remote/Helper/Git.hs
View file

@ -42,7 +42,8 @@ gitRepoInfo r = do
let lastsynctime = case mtimes of let lastsynctime = case mtimes of
[] -> "never" [] -> "never"
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes _ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes
repo <- Remote.getRepo r
return return
[ ("repository location", Git.repoLocation (Remote.repo r)) [ ("repository location", Git.repoLocation repo)
, ("last synced", lastsynctime) , ("last synced", lastsynctime)
] ]

12
Remote/Helper/Ssh.hs
View file

@ -135,7 +135,8 @@ rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do
-- compatability. -- compatability.
: (Fields.direct, if unlocked then "1" else "") : (Fields.direct, if unlocked then "1" else "")
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile : 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") (if direction == Download then "sendkey" else "recvkey")
[ Param $ key2file key ] [ Param $ key2file key ]
fields fields
@ -237,13 +238,14 @@ openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshCon
openP2PSshConnection r connpool = do openP2PSshConnection r connpool = do
u <- getUUID u <- getUUID
let ps = [Param (fromUUID u)] 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 Nothing -> do
liftIO $ rememberunsupported liftIO $ rememberunsupported
return Nothing return Nothing
Just (cmd, params) -> start cmd params Just (cmd, params) -> start cmd params =<< getRepo r
where 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 -- stderr is discarded because old versions of git-annex
-- shell always error -- shell always error
(Just from, Just to, Nothing, pid) <- createProcess $ (Just from, Just to, Nothing, pid) <- createProcess $
@ -253,7 +255,7 @@ openP2PSshConnection r connpool = do
, std_err = UseHandle nullh , std_err = UseHandle nullh
} }
let conn = P2P.P2PConnection let conn = P2P.P2PConnection
{ P2P.connRepo = repo r { P2P.connRepo = repo
, P2P.connCheckAuth = const False , P2P.connCheckAuth = const False
, P2P.connIhdl = to , P2P.connIhdl = to
, P2P.connOhdl = from , P2P.connOhdl = from

2
Remote/Hook.hs
View file

@ -59,7 +59,7 @@ gen r u c gc = do
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, localpath = Nothing , localpath = Nothing
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, readonly = False , readonly = False
, availability = GloballyAvailable , availability = GloballyAvailable

2
Remote/List.hs
View file

@ -111,7 +111,7 @@ remoteGen m t r = do
updateRemote :: Remote -> Annex (Maybe Remote) updateRemote :: Remote -> Annex (Maybe Remote)
updateRemote remote = do updateRemote remote = do
m <- readRemoteLog m <- readRemoteLog
remote' <- updaterepo $ repo remote remote' <- updaterepo =<< getRepo remote
remoteGen m (remotetype remote) remote' remoteGen m (remotetype remote) remote'
where where
updaterepo r updaterepo r

2
Remote/P2P.hs
View file

@ -64,7 +64,7 @@ chainGen addr r u c gc = do
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, localpath = Nothing , localpath = Nothing
, repo = r , getRepo = return r
, gitconfig = gc { remoteGitConfig = extractGitConfig r } , gitconfig = gc { remoteGitConfig = extractGitConfig r }
, readonly = False , readonly = False
, availability = GloballyAvailable , availability = GloballyAvailable

2
Remote/Rsync.hs
View file

@ -88,7 +88,7 @@ gen r u c gc = do
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = if islocal , localpath = if islocal
then Just $ rsyncUrl o then Just $ rsyncUrl o

2
Remote/S3.hs
View file

@ -102,7 +102,7 @@ gen r u c gc = do
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Nothing , localpath = Nothing
, readonly = False , readonly = False

2
Remote/Tahoe.hs
View file

@ -82,7 +82,7 @@ gen r u c gc = do
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Nothing , localpath = Nothing
, readonly = False , readonly = False

2
Remote/Web.hs
View file

@ -59,7 +59,7 @@ gen r _ c gc =
, config = c , config = c
, gitconfig = gc , gitconfig = gc
, localpath = Nothing , localpath = Nothing
, repo = r , getRepo = return r
, readonly = True , readonly = True
, availability = GloballyAvailable , availability = GloballyAvailable
, remotetype = remote , remotetype = remote

2
Remote/WebDAV.hs
View file

@ -89,7 +89,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
, repo = r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Nothing , localpath = Nothing
, readonly = False , readonly = False

4
Types/Remote.hs
View file

@ -111,8 +111,8 @@ data RemoteA a = Remote
, repairRepo :: Maybe (a Bool -> a (IO Bool)) , repairRepo :: Maybe (a Bool -> a (IO Bool))
-- a Remote has a persistent configuration store -- a Remote has a persistent configuration store
, config :: RemoteConfig , config :: RemoteConfig
-- git repo for the Remote -- Get the git repo for the Remote.
, repo :: Git.Repo , getRepo :: a Git.Repo
-- a Remote's configuration from git -- a Remote's configuration from git
, gitconfig :: RemoteGitConfig , gitconfig :: RemoteGitConfig
-- a Remote can be assocated with a specific local filesystem path -- a Remote can be assocated with a specific local filesystem path

9
doc/bugs/annex-checkuuid_renders_remotes_inaccessible/comment_2_298b1a8418380d932464962ca00fb2f3._comment Normal file
View file

@ -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.
"""]]