diff options
| -rw-r--r-- | Git/Config.hs | 15 | ||||
| -rw-r--r-- | Remote/GCrypt.hs | 14 | ||||
| -rw-r--r-- | Remote/Git.hs | 22 |
3 files changed, 38 insertions, 13 deletions
diff --git a/Git/Config.hs b/Git/Config.hs index adc75a208..513c3e5a6 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -10,6 +10,7 @@ module Git.Config where import qualified Data.Map as M import Data.Char import System.Process (cwd, env) +import Control.Exception.Extensible import Common import Git @@ -153,3 +154,17 @@ boolConfig False = "false" isBare :: Repo -> Bool isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r + +{- Runs a command to get the configuration of a repo, + - and returns a repo populated with the configuration, as well as the raw + - output of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) +fromPipe r cmd params = try $ + withHandle StdoutHandle createProcessSuccess p $ \h -> do + fileEncoding h + val <- hGetContentsStrict h + r' <- store val r + return (r', val) + where + p = proc cmd $ toCommand params + diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index e5e7e8d48..5e8102652 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -209,7 +209,14 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c -} setupRepo :: Git.GCrypt.GCryptId -> Git.Repo -> Annex AccessMethod setupRepo gcryptid r - | Git.repoIsUrl r = rsyncsetup + | Git.repoIsUrl r = do + accessmethod <- rsyncsetup + case accessmethod of + AccessDirect -> return AccessDirect + AccessShell -> ifM usablegitannexshell + ( return AccessShell + , return AccessDirect + ) | Git.repoIsLocalUnknown r = localsetup =<< liftIO (Git.Config.read r) | otherwise = localsetup r where @@ -245,6 +252,11 @@ setupRepo gcryptid r error "Failed to connect to remote to set it up." return accessmethod + {- Check if git-annex shell is installed, and is a new enough + - version to work in a gcrypt repo. -} + usablegitannexshell = either (const False) (const True) + <$> Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] [] + shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a shellOrRsync r ashell arsync = case method of AccessShell -> ashell diff --git a/Remote/Git.hs b/Remote/Git.hs index 2761995b2..6876ec4b4 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -165,18 +165,16 @@ tryGitConfigRead r safely a = either (const $ return r) return =<< liftIO (try a :: IO (Either SomeException Git.Repo)) - pipedconfig cmd params = try run :: IO (Either SomeException Git.Repo) - where - run = withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h - val <- hGetContentsStrict h - r' <- Git.Config.store val r - when (getUncachedUUID r' == NoUUID && not (null val)) $ do - warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r - warningIO $ "Instead, got: " ++ show val - warningIO $ "This is unexpected; please check the network transport!" - return r' - p = proc cmd $ toCommand params + pipedconfig cmd params = do + v <- Git.Config.fromPipe r cmd params + case v of + Right (r', val) -> do + when (getUncachedUUID r' == NoUUID && not (null val)) $ do + warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r + warningIO $ "Instead, got: " ++ show val + warningIO $ "This is unexpected; please check the network transport!" + return $ Right r' + Left l -> return $ Left l geturlconfig headers = do v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do |