blind enabling gcrypt repos on rsync.net
This pulls off quite a nice trick: When given a path on rsync.net, it determines if it is an encrypted git repository that the user has the key to decrypt, and merges with it. This is works even when the local repository had no idea that the gcrypt remote exists! (As previously done with local drives.) This commit sponsored by Pedro Côrte-Real
This commit is contained in:
Joey Hess
parent
8888e825fc
commit
e864c8d033
6 changed files with 111 additions and 58 deletions
|
|
@ -252,7 +252,7 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
|
|||
mu <- liftIO $ probeUUID dir
|
||||
case mu of
|
||||
Nothing -> maybe askcombine isknownuuid
|
||||
=<< liftIO (probeGCryptRemoteUUID dir)
|
||||
=<< liftAnnex (probeGCryptRemoteUUID dir)
|
||||
Just driveuuid -> isknownuuid driveuuid
|
||||
, newrepo
|
||||
)
|
||||
|
|
@ -295,19 +295,17 @@ getFinishAddDriveR drive = go
|
|||
makeGCryptRemote remotename dir keyid
|
||||
return (Types.Remote.uuid r, r)
|
||||
go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted $ do
|
||||
mu <- liftIO $ probeGCryptRemoteUUID dir
|
||||
mu <- liftAnnex $ probeGCryptRemoteUUID dir
|
||||
case mu of
|
||||
Just u -> enablegcryptremote u
|
||||
Just u -> enableexistinggcryptremote u
|
||||
Nothing -> error "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||||
enablegcryptremote u = do
|
||||
mname <- liftAnnex $ getGCryptRemoteName u dir
|
||||
case mname of
|
||||
Nothing -> error $ "Cannot find configuration for the gcrypt remote at " ++ dir
|
||||
Just name -> makewith $ const $ do
|
||||
r <- liftAnnex $ addRemote $
|
||||
enableSpecialRemote name GCrypt.remote $ M.fromList
|
||||
[("gitrepo", dir)]
|
||||
return (u, r)
|
||||
enableexistinggcryptremote u = do
|
||||
remotename' <- liftAnnex $ getGCryptRemoteName u dir
|
||||
makewith $ const $ do
|
||||
r <- liftAnnex $ addRemote $
|
||||
enableSpecialRemote remotename' 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)
|
||||
|
|
@ -471,9 +469,3 @@ 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
|
||||
GCrypt.getGCryptUUID =<< Git.Construct.fromAbsPath dir
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import Utility.Gpg
|
|||
import Types.Remote (RemoteConfigKey)
|
||||
import Git.Remote
|
||||
import Assistant.WebApp.Utility
|
||||
import qualified Remote.GCrypt as GCrypt
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
|
|
@ -344,7 +345,8 @@ postAddRsyncNetR = do
|
|||
$(widgetFile "configurators/rsync.net/add")
|
||||
case result of
|
||||
FormSuccess sshinput
|
||||
| isRsyncNet (inputHostname sshinput) -> prep sshinput
|
||||
| isRsyncNet (inputHostname sshinput) ->
|
||||
go sshinput
|
||||
| otherwise ->
|
||||
showform $ UnusableServer
|
||||
"That is not a rsync.net host name."
|
||||
|
|
@ -360,13 +362,28 @@ postAddRsyncNetR = do
|
|||
The host name will be something like "usw-s001.rsync.net", and the #
|
||||
user name something like "7491"
|
||||
|]
|
||||
prep sshinput = do
|
||||
go sshinput = do
|
||||
let reponame = genSshRepoName "rsync.net"
|
||||
(maybe "" T.unpack $ inputDirectory sshinput)
|
||||
prepRsyncNet sshinput reponame $ \sshdata -> inpage $ do
|
||||
secretkeys <- sortBy (comparing snd) . M.toList
|
||||
<$> liftIO secretKeys
|
||||
$(widgetFile "configurators/rsync.net/encrypt")
|
||||
prepRsyncNet sshinput reponame $ \sshdata -> inpage $
|
||||
checkexistinggcrypt sshdata $ do
|
||||
secretkeys <- sortBy (comparing snd) . M.toList
|
||||
<$> liftIO secretKeys
|
||||
$(widgetFile "configurators/rsync.net/encrypt")
|
||||
{- Detect if the user entered an existing gcrypt repository,
|
||||
- and enable it. -}
|
||||
checkexistinggcrypt sshdata a = ifM (liftIO isGcryptInstalled)
|
||||
( checkGCryptRepoEncryption repourl a $ do
|
||||
mu <- liftAnnex $ probeGCryptRemoteUUID repourl
|
||||
case mu of
|
||||
Just u -> do
|
||||
reponame <- liftAnnex $ getGCryptRemoteName u repourl
|
||||
void $ liftH $ enableRsyncNetGCrypt' sshdata reponame
|
||||
Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||||
, a
|
||||
)
|
||||
where
|
||||
repourl = sshUrl True sshdata
|
||||
|
||||
getMakeRsyncNetSharedR :: SshData -> Handler Html
|
||||
getMakeRsyncNetSharedR sshdata = makeSshRepo True sshdata
|
||||
|
|
@ -387,16 +404,18 @@ enableRsyncNet :: SshInput -> String -> Handler Html
|
|||
enableRsyncNet sshinput reponame =
|
||||
prepRsyncNet sshinput reponame $ makeSshRepo True
|
||||
|
||||
enableRsyncNetGCrypt :: SshInput -> String -> Handler Html
|
||||
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
|
||||
enableRsyncNetGCrypt sshinput reponame =
|
||||
prepRsyncNet sshinput reponame $ \sshdata -> do
|
||||
let repourl = sshUrl True sshdata
|
||||
checkGCryptRepoEncryption repourl notencrypted $
|
||||
setupCloudRemote TransferGroup $
|
||||
enableSpecialRemote reponame GCrypt.remote $ M.fromList
|
||||
[("gitrepo", repourl)]
|
||||
prepRsyncNet sshinput reponame $ \sshdata ->
|
||||
checkGCryptRepoEncryption (sshUrl True sshdata) notencrypted $
|
||||
enableRsyncNetGCrypt' sshdata reponame
|
||||
where
|
||||
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
|
||||
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
|
||||
enableRsyncNetGCrypt' :: SshData -> RemoteName -> Handler Html
|
||||
enableRsyncNetGCrypt' sshdata reponame =
|
||||
setupCloudRemote TransferGroup $
|
||||
enableSpecialRemote reponame GCrypt.remote $ M.fromList
|
||||
[("gitrepo", sshUrl True sshdata)]
|
||||
|
||||
{- Prepares rsync.net ssh key, and if successful, runs an action with
|
||||
- its SshData. -}
|
||||
|
|
|
|||
|
|
@ -14,8 +14,10 @@ import Assistant.Gpg
|
|||
import Utility.Gpg
|
||||
import qualified Git.Command
|
||||
import qualified Git.Remote
|
||||
import qualified Git.Construct
|
||||
import qualified Annex.Branch
|
||||
import qualified Git.GCrypt
|
||||
import qualified Remote.GCrypt as GCrypt
|
||||
import Assistant.MakeRemote
|
||||
import Logs.Remote
|
||||
|
||||
|
|
@ -34,8 +36,11 @@ gpgKeyDisplay keyid userid = [whamlet|
|
|||
genKeyModal :: Widget
|
||||
genKeyModal = $(widgetFile "configurators/genkeymodal")
|
||||
|
||||
isGcryptInstalled :: IO Bool
|
||||
isGcryptInstalled = inPath "git-remote-gcrypt"
|
||||
|
||||
whenGcryptInstalled :: Handler Html -> Handler Html
|
||||
whenGcryptInstalled a = ifM (liftIO $ inPath "git-remote-gcrypt")
|
||||
whenGcryptInstalled a = ifM (liftIO isGcryptInstalled)
|
||||
( a
|
||||
, page "Need git-remote-gcrypt" (Just Configuration) $
|
||||
$(widgetFile "configurators/needgcrypt")
|
||||
|
|
@ -58,7 +63,7 @@ withNewSecretKey use = do
|
|||
- branch from the gcrypt remote and merges it in, and then looks up
|
||||
- the name.
|
||||
-}
|
||||
getGCryptRemoteName :: UUID -> String -> Annex (Maybe Git.Remote.RemoteName)
|
||||
getGCryptRemoteName :: UUID -> String -> Annex Git.Remote.RemoteName
|
||||
getGCryptRemoteName u repoloc = do
|
||||
tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> gitRepo
|
||||
void $ inRepo $ Git.Command.runBool
|
||||
|
|
@ -70,9 +75,11 @@ getGCryptRemoteName u repoloc = do
|
|||
, return Nothing
|
||||
)
|
||||
void $ inRepo $ Git.Remote.remove tmpremote
|
||||
return mname
|
||||
maybe missing return mname
|
||||
where
|
||||
missing = error $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
|
||||
|
||||
checkGCryptRepoEncryption :: String -> Handler Html -> Handler Html -> Handler Html
|
||||
checkGCryptRepoEncryption :: (Monad m, LiftAnnex m) => String -> m a -> m a -> m a
|
||||
checkGCryptRepoEncryption location notencrypted encrypted =
|
||||
dispatch =<< liftAnnex (inRepo $ Git.GCrypt.probeRepo location)
|
||||
where
|
||||
|
|
@ -80,3 +87,10 @@ checkGCryptRepoEncryption location notencrypted encrypted =
|
|||
dispatch Git.GCrypt.NotEncrypted = notencrypted
|
||||
dispatch Git.GCrypt.NotDecryptable =
|
||||
error "This git repository is encrypted with a GnuPG key that you do not have."
|
||||
|
||||
{- 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 :: String -> Annex (Maybe UUID)
|
||||
probeGCryptRemoteUUID repolocation = do
|
||||
r <- inRepo $ Git.Construct.fromRemoteLocation repolocation
|
||||
GCrypt.getGCryptUUID False r
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue