diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 4fd73d3b6b..d6c8db6625 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 7626da69c6..5ac24ab6e8 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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. -} diff --git a/Assistant/WebApp/Gpg.hs b/Assistant/WebApp/Gpg.hs index 7fd2551cd3..4a98d26c63 100644 --- a/Assistant/WebApp/Gpg.hs +++ b/Assistant/WebApp/Gpg.hs @@ -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 diff --git a/Git/Config.hs b/Git/Config.hs index 513c3e5a67..db795b7a78 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -168,3 +168,12 @@ fromPipe r cmd params = try $ where p = proc cmd $ toCommand params +{- Reads git config from a specified file and returns the repo populated + - with the configuration. -} +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile r f = fromPipe r "git" + [ Param "config" + , Param "--file" + , File f + , Param "--list" + ] diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index 4133d6211a..c34b3b3070 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -61,7 +61,7 @@ options = Option.common ++ check u | u == toUUID expected = noop check NoUUID = checkGCryptUUID expected check u = unexpectedUUID expected u - checkGCryptUUID expected = inRepo getGCryptUUID >>= check + checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo where check (Just u) | u == toUUID expected = noop check Nothing = unexpected expected "uninitialized repository" diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index fe0632943f..5a66cbdebf 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -40,6 +40,7 @@ import Annex.UUID import Annex.Ssh import qualified Remote.Rsync import Utility.Rsync +import Utility.Tmp import Logs.Remote import Logs.Transfer import Utility.Gpg @@ -61,9 +62,9 @@ gen gcryptr u c gc = do -- get underlying git repo with real path, not gcrypt path r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr let r' = r { Git.remoteName = Git.remoteName gcryptr } - (mgcryptid, r'') <- liftIO $ getGCryptId r' - -- doublecheck that local cache matches underlying repo's gcrypt-id - -- (which might not be set) + -- doublecheck that cache matches underlying repo's gcrypt-id + -- (which might not be set), only for local repos + (mgcryptid, r'') <- getGCryptId True r' case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName gcryptr)) of (Just gcryptid, Just cachedgcryptid) | gcryptid /= cachedgcryptid -> resetup gcryptid r'' @@ -87,24 +88,6 @@ gen gcryptr u c gc = do warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r return Nothing -getGCryptUUID :: Git.Repo -> IO (Maybe UUID) -getGCryptUUID r = (genUUIDInNameSpace gCryptNameSpace <$>) . fst - <$> getGCryptId r - -coreGCryptId :: String -coreGCryptId = "core.gcrypt-id" - -{- 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.repoIsLocal r = do - r' <- catchDefaultIO r $ Git.Config.read r - return (Git.Config.getMaybe coreGCryptId r', r') - | otherwise = return (Nothing, r) - gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen' r u c gc = do cst <- remoteCost gc $ @@ -374,3 +357,39 @@ toAccessMethod :: String -> AccessMethod toAccessMethod "shell" = AccessShell toAccessMethod _ = AccessDirect +getGCryptUUID :: Bool -> Git.Repo -> Annex (Maybe UUID) +getGCryptUUID fast r = (genUUIDInNameSpace gCryptNameSpace <$>) . fst + <$> getGCryptId fast r + +coreGCryptId :: String +coreGCryptId = "core.gcrypt-id" + +{- 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. + - + - In fast mode, only checks local repos. To check a remote repo, + - tries git-annex-shell and direct rsync of the git config file. + - + - (Also returns a version of input repo with its config read.) -} +getGCryptId :: Bool -> Git.Repo -> Annex (Maybe Git.GCrypt.GCryptId, Git.Repo) +getGCryptId fast r + | Git.repoIsLocal r = extract + =<< liftIO (catchDefaultIO r $ Git.Config.read r) + | not fast = do + fromshell <- Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] [] + case fromshell of + Right (r', _) -> extract r' + Left _ -> do + (rsynctransport, rsyncurl, _) <- rsyncTransport r + fromrsync <- liftIO $ do + withTmpFile "tmpconfig" $ \tmpconfig _ -> do + void $ rsync $ rsynctransport ++ + [ Param $ rsyncurl ++ "/config" + , Param tmpconfig + ] + Git.Config.fromFile r tmpconfig + extract $ either (const r) fst fromrsync + | otherwise = return (Nothing, r) + where + extract r' = return (Git.Config.getMaybe coreGCryptId r', r')