diff options
Diffstat (limited to 'Remote/Git.hs')
| -rw-r--r-- | Remote/Git.hs | 84 |
1 files changed, 48 insertions, 36 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs index d80f580fc..49f040cc8 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -5,7 +5,11 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Remote.Git (remote, repoAvail) where +module Remote.Git ( + remote, + configRead, + repoAvail, +) where import qualified Data.Map as M import Control.Exception.Extensible @@ -45,7 +49,7 @@ list :: Annex [Git.Repo] list = do c <- fromRepo Git.config rs <- mapM (tweakurl c) =<< fromRepo Git.remotes - mapM configread rs + mapM configRead rs where annexurl n = "remote." ++ n ++ ".annexurl" tweakurl c r = do @@ -55,19 +59,21 @@ list = do Just url -> inRepo $ \g -> Git.Construct.remoteNamed n $ Git.Construct.fromRemoteLocation url g - {- It's assumed to be cheap to read the config of non-URL - - remotes, so this is done each time git-annex is run - - in a way that uses remotes. - - Conversely, the config of an URL remote is only read - - when there is no cached UUID value. -} - configread r = do - notignored <- repoNotIgnored r - u <- getRepoUUID r - case (repoCheap r, notignored, u) of - (_, False, _) -> return r - (True, _, _) -> tryGitConfigRead r - (False, _, NoUUID) -> tryGitConfigRead r - _ -> return r + +{- It's assumed to be cheap to read the config of non-URL remotes, so this is + - done each time git-annex is run in a way that uses remotes. + - + - Conversely, the config of an URL remote is only read when there is no + - cached UUID value. -} +configRead :: Git.Repo -> Annex Git.Repo +configRead r = do + notignored <- repoNotIgnored r + u <- getRepoUUID r + case (repoCheap r, notignored, u) of + (_, False, _) -> return r + (True, _, _) -> tryGitConfigRead r + (False, _, NoUUID) -> tryGitConfigRead r + _ -> return r repoCheap :: Git.Repo -> Bool repoCheap = not . Git.repoIsUrl @@ -76,21 +82,26 @@ gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote gen r u _ = new <$> remoteCost r defcst where defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost - new cst = Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = copyToRemote r, - retrieveKeyFile = copyFromRemote r, - retrieveKeyFileCheap = copyFromRemoteCheap r, - removeKey = dropKey r, - hasKey = inAnnex r, - hasKeyCheap = repoCheap r, - whereisKey = Nothing, - config = Nothing, - repo = r, - remotetype = remote - } + new cst = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = copyToRemote r + , retrieveKeyFile = copyFromRemote r + , retrieveKeyFileCheap = copyFromRemoteCheap r + , removeKey = dropKey r + , hasKey = inAnnex r + , hasKeyCheap = repoCheap r + , whereisKey = Nothing + , config = Nothing + , localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r + then Just $ Git.repoPath r + else Nothing + , repo = r + , readonly = Git.repoIsHttp r + , remotetype = remote + } + {- Checks relatively inexpensively if a repository is available for use. -} repoAvail :: Git.Repo -> Annex Bool @@ -127,16 +138,17 @@ tryGitConfigRead r =<< liftIO (try a :: IO (Either SomeException Git.Repo)) pipedconfig cmd params = safely $ - pOpen ReadFromPipe cmd (toCommand params) $ + withHandle StdoutHandle createProcessSuccess p $ Git.Config.hRead r + where + p = proc cmd $ toCommand params geturlconfig headers = do s <- Url.get (Git.repoLocation r ++ "/config") headers withTempFile "git-annex.tmp" $ \tmpfile h -> do hPutStr h s hClose h - pOpen ReadFromPipe "git" ["config", "--null", "--list", "--file", tmpfile] $ - Git.Config.hRead r + pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] store = observe $ \r' -> do g <- gitRepo @@ -172,7 +184,7 @@ inAnnex r key v -> return v checkremote = do showAction $ "checking " ++ Git.repoDescribe r - onRemote r (check, unknown) "inannex" [Param (show key)] [] + onRemote r (check, unknown) "inannex" [Param (key2file key)] [] where check c p = dispatch <$> safeSystem c p dispatch ExitSuccess = Right True @@ -217,7 +229,7 @@ dropKey r key | Git.repoIsHttp r = error "dropping from http repo not supported" | otherwise = commitOnCleanup r $ onRemote r (boolSystem, False) "dropkey" [ Params "--quiet --force" - , Param $ show key + , Param $ key2file key ] [] @@ -299,7 +311,7 @@ rsyncParamsRemote r sending key file afile = do : maybe [] (\f -> [(Fields.associatedFile, f)]) afile Just (shellcmd, shellparams) <- git_annex_shell r (if sending then "sendkey" else "recvkey") - [ Param $ show key ] + [ Param $ key2file key ] fields -- Convert the ssh command into rsync command line. let eparam = rsyncShell (Param shellcmd:shellparams) |