webapp: support adding existing gcrypt special remotes from removable drives
When adding a removable drive, it's now detected if the drive contains a gcrypt special remote, and that's all handled nicely. This includes fetching the git-annex branch from the gcrypt repo in order to find out how to set up the special remote. Note that gcrypt repos that are not git-annex special remotes are not supported. It will attempt to detect such a gcrypt repo and refuse to use it. (But this is hard to do any may fail; see https://github.com/blake2-ppc/git-remote-gcrypt/issues/6) The problem with supporting regular gcrypt repos is that we don't know what the gcrypt.participants setting is intended to be for the repo. So even if we can decrypt it, if we push changes to it they might not be visible to other participants. Anyway, encrypted sneakernet (or mailnet) is now fully possible with the git-annex assistant! Assuming that the gpg key distribution is handled somehow, which the assistant doesn't yet help with. This commit was sponsored by Navishkar Rao.
This commit is contained in:
parent
c6559e5d86
commit
8062f6337f
7 changed files with 140 additions and 35 deletions
|
@ -17,8 +17,7 @@ import Logs.Location
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Remote.List
|
import Remote.List
|
||||||
import qualified Git.Command
|
import qualified Git.Remote
|
||||||
import qualified Git.BuildVersion
|
|
||||||
import Logs.Trust
|
import Logs.Trust
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
|
||||||
|
@ -35,15 +34,7 @@ disableRemote uuid = do
|
||||||
remote <- fromMaybe (error "unknown remote")
|
remote <- fromMaybe (error "unknown remote")
|
||||||
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
||||||
liftAnnex $ do
|
liftAnnex $ do
|
||||||
inRepo $ Git.Command.run
|
inRepo $ Git.Remote.remove (Remote.name remote)
|
||||||
[ Param "remote"
|
|
||||||
-- name of this subcommand changed
|
|
||||||
, Param $
|
|
||||||
if Git.BuildVersion.older "1.8.0"
|
|
||||||
then "rm"
|
|
||||||
else "remove"
|
|
||||||
, Param (Remote.name remote)
|
|
||||||
]
|
|
||||||
void $ remoteListRefresh
|
void $ remoteListRefresh
|
||||||
updateSyncRemotes
|
updateSyncRemotes
|
||||||
return remote
|
return remote
|
||||||
|
|
|
@ -27,8 +27,6 @@ import Creds
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
|
||||||
type RemoteName = String
|
|
||||||
|
|
||||||
{- Sets up and begins syncing with a new ssh or rsync remote. -}
|
{- Sets up and begins syncing with a new ssh or rsync remote. -}
|
||||||
makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
|
makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
|
||||||
makeSshRemote forcersync sshdata mcost = do
|
makeSshRemote forcersync sshdata mcost = do
|
||||||
|
|
|
@ -38,6 +38,7 @@ import Config
|
||||||
import Utility.Gpg
|
import Utility.Gpg
|
||||||
import qualified Annex.Branch
|
import qualified Annex.Branch
|
||||||
import qualified Remote.GCrypt as GCrypt
|
import qualified Remote.GCrypt as GCrypt
|
||||||
|
import qualified Git.GCrypt
|
||||||
import qualified Types.Remote
|
import qualified Types.Remote
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
@ -247,16 +248,13 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
|
||||||
- If the repo does not already exist on the drive, prompt about
|
- If the repo does not already exist on the drive, prompt about
|
||||||
- encryption. -}
|
- encryption. -}
|
||||||
getConfirmAddDriveR :: RemovableDrive -> Handler Html
|
getConfirmAddDriveR :: RemovableDrive -> Handler Html
|
||||||
getConfirmAddDriveR drive = ifM (liftIO $ doesDirectoryExist dir)
|
getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
|
||||||
( do
|
( do
|
||||||
mu <- liftIO $ catchMaybeIO $ inDir dir $ getUUID
|
mu <- liftIO $ probeUUID dir
|
||||||
case mu of
|
case mu of
|
||||||
Nothing -> knownrepo
|
Nothing -> maybe askcombine isknownuuid
|
||||||
Just driveuuid ->
|
=<< liftIO (probeGCryptRemoteUUID dir)
|
||||||
ifM (M.member driveuuid <$> liftAnnex uuidMap)
|
Just driveuuid -> isknownuuid driveuuid
|
||||||
( knownrepo
|
|
||||||
, askcombine
|
|
||||||
)
|
|
||||||
, newrepo
|
, newrepo
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
@ -269,6 +267,11 @@ getConfirmAddDriveR drive = ifM (liftIO $ doesDirectoryExist dir)
|
||||||
knownrepo = getFinishAddDriveR drive NoRepoKey
|
knownrepo = getFinishAddDriveR drive NoRepoKey
|
||||||
askcombine = page "Combine repositories?" (Just Configuration) $
|
askcombine = page "Combine repositories?" (Just Configuration) $
|
||||||
$(widgetFile "configurators/adddrive/combine")
|
$(widgetFile "configurators/adddrive/combine")
|
||||||
|
isknownuuid driveuuid =
|
||||||
|
ifM (M.member driveuuid <$> liftAnnex uuidMap)
|
||||||
|
( knownrepo
|
||||||
|
, askcombine
|
||||||
|
)
|
||||||
|
|
||||||
setupDriveModal :: Widget
|
setupDriveModal :: Widget
|
||||||
setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal")
|
setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal")
|
||||||
|
@ -290,9 +293,7 @@ getGenKeyForDriveR drive = withNewSecretKey $ \key -> do
|
||||||
getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
|
getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
|
||||||
getFinishAddDriveR drive = go
|
getFinishAddDriveR drive = go
|
||||||
where
|
where
|
||||||
go NoRepoKey = makewith $ \isnew -> (,)
|
{- Set up new gcrypt special remote. -}
|
||||||
<$> liftIO (initRepo isnew False dir $ Just remotename)
|
|
||||||
<*> combineRepos dir remotename
|
|
||||||
go (RepoKey keyid) = ifM (liftIO $ inPath "git-remote-gcrypt")
|
go (RepoKey keyid) = ifM (liftIO $ inPath "git-remote-gcrypt")
|
||||||
( makewith $ \_ -> do
|
( makewith $ \_ -> do
|
||||||
r <- liftAnnex $ addRemote $
|
r <- liftAnnex $ addRemote $
|
||||||
|
@ -306,6 +307,33 @@ getFinishAddDriveR drive = go
|
||||||
, page "Encrypt repository" (Just Configuration) $
|
, page "Encrypt repository" (Just Configuration) $
|
||||||
$(widgetFile "configurators/needgcrypt")
|
$(widgetFile "configurators/needgcrypt")
|
||||||
)
|
)
|
||||||
|
{- Either making a new unencrypted repo, or combining with
|
||||||
|
- an existing unencrypted repo, or combining with an existing
|
||||||
|
- gcrypt special remot, or some other existing gcrypt repo. -}
|
||||||
|
go NoRepoKey = do
|
||||||
|
mu <- liftIO $ probeGCryptRemoteUUID dir
|
||||||
|
case mu of
|
||||||
|
Just u -> enablegcryptremote u
|
||||||
|
Nothing ->
|
||||||
|
ifM (liftAnnex $ inRepo $ Git.GCrypt.probeGCryptRepo dir)
|
||||||
|
( error "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||||||
|
, makeunencrypted
|
||||||
|
)
|
||||||
|
{- Sync the git-annex branch from the gcrypt repo, in order to
|
||||||
|
- make sure we know how the special remote should be set up. -}
|
||||||
|
enablegcryptremote u = do
|
||||||
|
mname <- liftAnnex $ getGCryptRemoteName u dir
|
||||||
|
case mname of
|
||||||
|
Nothing -> error $ "Unable to use the gcrypt remote at " ++ dir ++ ". Perhaps it is encrypted using a GnuPG key that you do not have?"
|
||||||
|
Just name -> makewith $ const $ do
|
||||||
|
r <- liftAnnex $ addRemote $
|
||||||
|
enableSpecialRemote name GCrypt.remote $ M.fromList
|
||||||
|
[("gitrepo", dir)]
|
||||||
|
return (u, r)
|
||||||
|
{- Making a new unencrypted repo, or combining with an existing one. -}
|
||||||
|
makeunencrypted = makewith $ \isnew -> (,)
|
||||||
|
<$> liftIO (initRepo isnew False dir $ Just remotename)
|
||||||
|
<*> combineRepos dir remotename
|
||||||
makewith a = do
|
makewith a = do
|
||||||
liftIO $ createDirectoryIfMissing True dir
|
liftIO $ createDirectoryIfMissing True dir
|
||||||
isnew <- liftIO $ makeRepo dir True
|
isnew <- liftIO $ makeRepo dir True
|
||||||
|
@ -385,7 +413,7 @@ startFullAssistant path repogroup setup = do
|
||||||
{- Makes a new git repository. Or, if a git repository already
|
{- Makes a new git repository. Or, if a git repository already
|
||||||
- exists, returns False. -}
|
- exists, returns False. -}
|
||||||
makeRepo :: FilePath -> Bool -> IO Bool
|
makeRepo :: FilePath -> Bool -> IO Bool
|
||||||
makeRepo path bare = ifM alreadyexists
|
makeRepo path bare = ifM (probeRepoExists path)
|
||||||
( return False
|
( return False
|
||||||
, do
|
, do
|
||||||
(transcript, ok) <-
|
(transcript, ok) <-
|
||||||
|
@ -395,8 +423,6 @@ makeRepo path bare = ifM alreadyexists
|
||||||
return True
|
return True
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
alreadyexists = isJust <$>
|
|
||||||
catchDefaultIO Nothing (Git.Construct.checkForRepo path)
|
|
||||||
baseparams = [Param "init", Param "--quiet"]
|
baseparams = [Param "init", Param "--quiet"]
|
||||||
params
|
params
|
||||||
| bare = baseparams ++ [Param "--bare", File path]
|
| bare = baseparams ++ [Param "--bare", File path]
|
||||||
|
@ -455,3 +481,23 @@ canWrite dir = do
|
||||||
tocheck <- ifM (doesDirectoryExist dir)
|
tocheck <- ifM (doesDirectoryExist dir)
|
||||||
(return dir, return $ parentDir dir)
|
(return dir, return $ parentDir dir)
|
||||||
catchBoolIO $ fileAccess tocheck False True False
|
catchBoolIO $ fileAccess tocheck False True False
|
||||||
|
|
||||||
|
{- Checks if a git repo exists at a location. -}
|
||||||
|
probeRepoExists :: FilePath -> IO Bool
|
||||||
|
probeRepoExists dir = isJust <$>
|
||||||
|
catchDefaultIO Nothing (Git.Construct.checkForRepo dir)
|
||||||
|
|
||||||
|
{- Gets the UUID of the git repo at a location, which may not exist, or
|
||||||
|
- not be a git-annex repo. -}
|
||||||
|
probeUUID :: FilePath -> IO (Maybe UUID)
|
||||||
|
probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
|
||||||
|
u <- getUUID
|
||||||
|
return $ if u == NoUUID then Nothing else Just u
|
||||||
|
|
||||||
|
{- Gets the UUID of the gcrypt repo at a location, which may not exist.
|
||||||
|
- Only works if the gcrypt repo was created as a git-annex remote. -}
|
||||||
|
probeGCryptRemoteUUID :: FilePath -> IO (Maybe UUID)
|
||||||
|
probeGCryptRemoteUUID dir = catchDefaultIO Nothing $ do
|
||||||
|
r <- Git.Construct.fromAbsPath dir
|
||||||
|
(genUUIDInNameSpace gCryptNameSpace <$>) . fst
|
||||||
|
<$> GCrypt.getGCryptId r
|
||||||
|
|
|
@ -12,6 +12,12 @@ module Assistant.WebApp.Gpg where
|
||||||
import Assistant.WebApp.Common
|
import Assistant.WebApp.Common
|
||||||
import Utility.Gpg
|
import Utility.Gpg
|
||||||
import Utility.UserInfo
|
import Utility.UserInfo
|
||||||
|
import qualified Git.Command
|
||||||
|
import qualified Git.Remote
|
||||||
|
import qualified Annex.Branch
|
||||||
|
import qualified Git.GCrypt
|
||||||
|
import Assistant.MakeRemote
|
||||||
|
import Logs.Remote
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
@ -45,3 +51,25 @@ withNewSecretKey use = do
|
||||||
case results of
|
case results of
|
||||||
[] -> error "Failed to generate gpg key!"
|
[] -> error "Failed to generate gpg key!"
|
||||||
(key:_) -> use key
|
(key:_) -> use key
|
||||||
|
|
||||||
|
{- Tries to find the name used in remote.log for a gcrypt repository
|
||||||
|
- with a given uuid.
|
||||||
|
-
|
||||||
|
- The gcrypt remote may not be on that is listed in the local remote.log
|
||||||
|
- (or the info may be out of date), so this actually fetches the git-annex
|
||||||
|
- branch from the gcrypt remote and merges it in, and then looks up
|
||||||
|
- the name.
|
||||||
|
-}
|
||||||
|
getGCryptRemoteName :: UUID -> String -> Annex (Maybe Git.Remote.RemoteName)
|
||||||
|
getGCryptRemoteName u repoloc = do
|
||||||
|
tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> gitRepo
|
||||||
|
void $ inRepo $ Git.Command.runBool
|
||||||
|
[Params "remote add", Param tmpremote, Param $ Git.GCrypt.urlPrefix ++ repoloc]
|
||||||
|
mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote])
|
||||||
|
( do
|
||||||
|
void $ Annex.Branch.forceUpdate
|
||||||
|
(M.lookup "name" <=< M.lookup u) <$> readRemoteLog
|
||||||
|
, return Nothing
|
||||||
|
)
|
||||||
|
void $ inRepo $ Git.Remote.remove tmpremote
|
||||||
|
return mname
|
||||||
|
|
|
@ -13,6 +13,7 @@ import Common
|
||||||
import Git.Types
|
import Git.Types
|
||||||
import Git.Construct
|
import Git.Construct
|
||||||
import qualified Git.Config as Config
|
import qualified Git.Config as Config
|
||||||
|
import qualified Git.Command as Command
|
||||||
import Utility.Gpg
|
import Utility.Gpg
|
||||||
|
|
||||||
urlPrefix :: String
|
urlPrefix :: String
|
||||||
|
@ -44,12 +45,28 @@ encryptedRepo baserepo = go
|
||||||
go _ = notencrypted
|
go _ = notencrypted
|
||||||
notencrypted = error "not a gcrypt encrypted repository"
|
notencrypted = error "not a gcrypt encrypted repository"
|
||||||
|
|
||||||
|
{- Checks if the git repo at a location is a gcrypt repo that
|
||||||
|
- we can decrypt. This works by trying to fetch from the repo
|
||||||
|
- at the location, into the baserepo.
|
||||||
|
-
|
||||||
|
- Returns false if the git repo is not using gcrypt, or if it is using
|
||||||
|
- gcrypt but cannot be decrypted. We do not try to detect gcrypt
|
||||||
|
- repos that cannot be decrypted, because gcrypt may change in the future
|
||||||
|
- to avoid easy fingerprinting of gcrypt repos.
|
||||||
|
-}
|
||||||
|
probeGCryptRepo :: FilePath -> Repo -> IO Bool
|
||||||
|
probeGCryptRepo dir baserepo = catchBoolIO $ Command.runBool
|
||||||
|
[ Param "fetch"
|
||||||
|
, Param $ urlPrefix ++ dir
|
||||||
|
] baserepo
|
||||||
|
|
||||||
type RemoteName = String
|
type RemoteName = String
|
||||||
|
type GCryptId = String
|
||||||
|
|
||||||
{- gcrypt gives each encrypted repository a uique gcrypt-id,
|
{- gcrypt gives each encrypted repository a uique gcrypt-id,
|
||||||
- which is stored in the repository (in encrypted form)
|
- which is stored in the repository (in encrypted form)
|
||||||
- and cached in a per-remote gcrypt-id configuration setting. -}
|
- and cached in a per-remote gcrypt-id configuration setting. -}
|
||||||
remoteRepoId :: Repo -> Maybe RemoteName -> Maybe String
|
remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId
|
||||||
remoteRepoId = getRemoteConfig "gcrypt-id"
|
remoteRepoId = getRemoteConfig "gcrypt-id"
|
||||||
|
|
||||||
getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String
|
getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String
|
||||||
|
|
|
@ -8,15 +8,21 @@
|
||||||
module Git.Remote where
|
module Git.Remote where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
|
import Git
|
||||||
|
import qualified Git.Command
|
||||||
|
import qualified Git.BuildVersion
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
|
||||||
|
type RemoteName = String
|
||||||
|
|
||||||
{- Construct a legal git remote name out of an arbitrary input string.
|
{- Construct a legal git remote name out of an arbitrary input string.
|
||||||
-
|
-
|
||||||
- There seems to be no formal definition of this in the git source,
|
- There seems to be no formal definition of this in the git source,
|
||||||
- just some ad-hoc checks, and some other things that fail with certian
|
- just some ad-hoc checks, and some other things that fail with certian
|
||||||
- types of names (like ones starting with '-').
|
- types of names (like ones starting with '-').
|
||||||
-}
|
-}
|
||||||
makeLegalName :: String -> String
|
makeLegalName :: String -> RemoteName
|
||||||
makeLegalName s = case filter legal $ replace "/" "_" s of
|
makeLegalName s = case filter legal $ replace "/" "_" s of
|
||||||
-- it can't be empty
|
-- it can't be empty
|
||||||
[] -> "unnamed"
|
[] -> "unnamed"
|
||||||
|
@ -31,3 +37,14 @@ makeLegalName s = case filter legal $ replace "/" "_" s of
|
||||||
legal '_' = True
|
legal '_' = True
|
||||||
legal '.' = True
|
legal '.' = True
|
||||||
legal c = isAlphaNum c
|
legal c = isAlphaNum c
|
||||||
|
|
||||||
|
remove :: RemoteName -> Repo -> IO ()
|
||||||
|
remove remotename = Git.Command.run
|
||||||
|
[ Param "remote"
|
||||||
|
-- name of this subcommand changed
|
||||||
|
, Param $
|
||||||
|
if Git.BuildVersion.older "1.8.0"
|
||||||
|
then "rm"
|
||||||
|
else "remove"
|
||||||
|
, Param remotename
|
||||||
|
]
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Remote.GCrypt (remote, gen) where
|
module Remote.GCrypt (remote, gen, getGCryptId) where
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
@ -52,13 +52,10 @@ gen gcryptr u c gc = do
|
||||||
-- get underlying git repo with real path, not gcrypt path
|
-- get underlying git repo with real path, not gcrypt path
|
||||||
r <- liftIO $ Git.GCrypt.encryptedRepo g gcryptr
|
r <- liftIO $ Git.GCrypt.encryptedRepo g gcryptr
|
||||||
let r' = r { Git.remoteName = Git.remoteName gcryptr }
|
let r' = r { Git.remoteName = Git.remoteName gcryptr }
|
||||||
-- read config of underlying repo if it's local
|
(mgcryptid, r'') <- liftIO $ getGCryptId r'
|
||||||
r'' <- if Git.repoIsLocalUnknown r'
|
|
||||||
then liftIO $ catchDefaultIO r' $ Git.Config.read r'
|
|
||||||
else return r'
|
|
||||||
-- doublecheck that local cache matches underlying repo's gcrypt-id
|
-- doublecheck that local cache matches underlying repo's gcrypt-id
|
||||||
-- (which might not be set)
|
-- (which might not be set)
|
||||||
case (Git.Config.getMaybe "core.gcrypt-id" r'', Git.GCrypt.remoteRepoId g (Git.remoteName gcryptr)) of
|
case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName gcryptr)) of
|
||||||
(Just gcryptid, Just cachedgcryptid)
|
(Just gcryptid, Just cachedgcryptid)
|
||||||
| gcryptid /= cachedgcryptid -> resetup gcryptid r''
|
| gcryptid /= cachedgcryptid -> resetup gcryptid r''
|
||||||
_ -> gen' r'' u c gc
|
_ -> gen' r'' u c gc
|
||||||
|
@ -81,6 +78,17 @@ gen gcryptr u c gc = do
|
||||||
warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r
|
warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r
|
||||||
return Nothing
|
return Nothing
|
||||||
|
|
||||||
|
{- gcrypt repos set up by git-annex as special remotes have a
|
||||||
|
- core.gcrypt-id setting in their config, which can be mapped back to
|
||||||
|
- the remote's UUID. This only works for local repos.
|
||||||
|
- (Also returns a version of input repo with its config read.) -}
|
||||||
|
getGCryptId :: Git.Repo -> IO (Maybe Git.GCrypt.GCryptId, Git.Repo)
|
||||||
|
getGCryptId r
|
||||||
|
| Git.repoIsLocalUnknown r = do
|
||||||
|
r' <- catchDefaultIO r $ Git.Config.read r
|
||||||
|
return (Git.Config.getMaybe "core.gcrypt-id" r', r')
|
||||||
|
| otherwise = return (Nothing, r)
|
||||||
|
|
||||||
gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||||
gen' r u c gc = do
|
gen' r u c gc = do
|
||||||
cst <- remoteCost gc $
|
cst <- remoteCost gc $
|
||||||
|
|
Loading…
Reference in a new issue