partially complete gcrypt remote (local send done; rest not)

This is a git-remote-gcrypt encrypted special remote. Only sending files
in to the remote works, and only for local repositories.

Most of the work so far has involved making initremote work. A particular
problem is that remote setup in this case needs to generate its own uuid,
derivied from the gcrypt-id. That required some larger changes in the code
to support.

For ssh remotes, this will probably just reuse Remote.Rsync's code, so
should be easy enough. And for downloading from a web remote, I will need
to factor out the part of Remote.Git that does that.

One particular thing that will need work is supporting hot-swapping a local
gcrypt remote. I think it needs to store the gcrypt-id in the git config of the
local remote, so that it can check it every time, and compare with the
cached annex-uuid for the remote. If there is a mismatch, it can change
both the cached annex-uuid and the gcrypt-id. That should work, and I laid
some groundwork for it by already reading the remote's config when it's
local. (Also needed for other reasons.)

This commit was sponsored by Daniel Callahan.
This commit is contained in:
Joey Hess 2013-09-07 18:38:00 -04:00
parent 0ab6764fe9
commit 7c1a9cdeb9
17 changed files with 306 additions and 92 deletions

View file

@ -13,9 +13,6 @@ module Remote.Git (
repoAvail,
) where
import qualified Data.Map as M
import Control.Exception.Extensible
import Common.Annex
import Utility.Rsync
import Remote.Helper.Ssh
@ -47,10 +44,14 @@ import Utility.Metered
#ifndef mingw32_HOST_OS
import Utility.CopyFile
#endif
import Remote.Helper.Git
import qualified Remote.GCrypt
import Control.Concurrent
import Control.Concurrent.MSampleVar
import System.Process (std_in, std_err)
import qualified Data.Map as M
import Control.Exception.Extensible
remote :: RemoteType
remote = RemoteType {
@ -91,11 +92,10 @@ configRead r = do
(False, _, NoUUID) -> tryGitConfigRead r
_ -> return r
repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u _ gc = go <$> remoteCost gc defcst
gen r u c gc
| Git.GCrypt.isEncrypted r = Remote.GCrypt.gen r u c gc
| otherwise = go <$> remoteCost gc defcst
where
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
go cst = new
@ -112,14 +112,12 @@ gen r u _ gc = go <$> remoteCost gc defcst
, hasKeyCheap = repoCheap r
, whereisKey = Nothing
, config = M.empty
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
then Just $ Git.repoPath r
else Nothing
, localpath = localpathCalc r
, repo = r
, gitconfig = gc
{ remoteGitConfig = Just $ extractGitConfig r }
, readonly = Git.repoIsHttp r
, globallyAvailable = not $ Git.repoIsLocal r || Git.repoIsLocalUnknown r
, globallyAvailable = globallyAvailableCalc r
, remotetype = remote
}
@ -131,13 +129,6 @@ repoAvail r
| Git.repoIsLocalUnknown r = return False
| otherwise = liftIO $ catchBoolIO $ onLocal r $ return True
{- Avoids performing an action on a local repository that's not usable.
- Does not check that the repository is still available on disk. -}
guardUsable :: Git.Repo -> a -> Annex a -> Annex a
guardUsable r onerr a
| Git.repoIsLocalUnknown r = return onerr
| otherwise = a
{- Tries to read the config for a specified remote, updates state, and
- returns the updated repo. -}
tryGitConfigRead :: Git.Repo -> Annex Git.Repo
@ -154,8 +145,9 @@ tryGitConfigRead r
headers <- getHttpHeaders
store $ geturlconfig headers
| Git.GCrypt.isEncrypted r = do
-- Generate a UUID from the gcrypt-id
g <- gitRepo
case Git.GCrypt.remoteRepoId g r of
case Git.GCrypt.remoteRepoId g (Git.remoteName r) of
Nothing -> return r
Just v -> store $ liftIO $ setUUID r $
genUUIDInNameSpace gCryptNameSpace v
@ -261,17 +253,6 @@ inAnnex r key
unknown = Left $ "unable to check " ++ Git.repoDescribe r
showchecking = showAction $ "checking " ++ Git.repoDescribe r
{- Runs an action on a local repository inexpensively, by making an annex
- monad using that repository. -}
onLocal :: Git.Repo -> Annex a -> IO a
onLocal r a = do
s <- Annex.new r
Annex.eval s $ do
-- No need to update the branch; its data is not used
-- for anything onLocal is used to do.
Annex.BranchState.disableUpdate
a
keyUrls :: Git.Repo -> Key -> [String]
keyUrls r key = map tourl locs
where
@ -415,15 +396,16 @@ copyToRemote r key file p
(\d -> rsyncOrCopyFile params object d p)
)
rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool
rsyncHelper callback params = do
showOutput -- make way for progress bar
ifM (liftIO $ (maybe rsync rsyncProgress callback) params)
( return True
, do
showLongNote "rsync failed -- run git annex again to resume file transfer"
return False
)
{- Runs an action on a local repository inexpensively, by making an annex
- monad using that repository. -}
onLocal :: Git.Repo -> Annex a -> IO a
onLocal r a = do
s <- Annex.new r
Annex.eval s $ do
-- No need to update the branch; its data is not used
-- for anything onLocal is used to do.
Annex.BranchState.disableUpdate
a
{- Copys a file with rsync unless both locations are on the same
- filesystem. Then cp could be faster. -}
@ -456,6 +438,16 @@ rsyncOrCopyFile rsyncparams src dest p =
dorsync = rsyncHelper (Just p) $
rsyncparams ++ [File src, File dest]
rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool
rsyncHelper callback params = do
showOutput -- make way for progress bar
ifM (liftIO $ (maybe rsync rsyncProgress callback) params)
( return True
, do
showLongNote "rsync failed -- run git annex again to resume file transfer"
return False
)
{- Generates rsync parameters that ssh to the remote and asks it
- to either receive or send the key's content. -}
rsyncParamsRemote :: Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]