From 02f1bd2bf47d3ff49a222e9428ec27708ef55f64 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 Dec 2011 15:30:14 -0400 Subject: [PATCH] split more stuff out of Git.hs --- Annex/Branch.hs | 3 +- Annex/Ssh.hs | 5 +- Backend.hs | 1 - Command/Map.hs | 13 ++-- Config.hs | 2 +- Git.hs | 148 +++------------------------------------ Git/Branch.hs | 5 +- Git/CatFile.hs | 5 +- Git/Construct.hs | 27 +++++-- Git/HashObject.hs | 4 +- Git/Index.hs | 24 +++++++ Git/Ref.hs | 6 +- Git/Sha.hs | 27 +++++++ Git/UnionMerge.hs | 5 +- Git/Url.hs | 70 ++++++++++++++++++ Remote/Git.hs | 17 ++--- Remote/Helper/Special.hs | 6 +- Remote/Web.hs | 4 +- git-union-merge.hs | 3 +- test.hs | 1 - 20 files changed, 197 insertions(+), 179 deletions(-) create mode 100644 Git/Index.hs create mode 100644 Git/Sha.hs create mode 100644 Git/Url.hs diff --git a/Annex/Branch.hs b/Annex/Branch.hs index a2ecd50a70..a22a4adcfe 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -28,6 +28,7 @@ import qualified Git.Ref import qualified Git.Branch import qualified Git.UnionMerge import qualified Git.HashObject +import qualified Git.Index import Annex.CatFile {- Name of the branch that is used to store git-annex's information. -} @@ -249,7 +250,7 @@ withIndex = withIndex' False withIndex' :: Bool -> Annex a -> Annex a withIndex' bootstrapping a = do f <- fromRepo gitAnnexIndex - bracketIO (Git.useIndex f) id $ do + bracketIO (Git.Index.override f) id $ do unlessM (liftIO $ doesFileExist f) $ do unless bootstrapping create liftIO $ createDirectoryIfMissing True $ takeDirectory f diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 6893f94ef4..fe83aad001 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -10,6 +10,7 @@ module Annex.Ssh where import Control.Monad.State (liftIO) import qualified Git +import qualified Git.Url import Utility.SafeCommand import Types import Config @@ -22,10 +23,10 @@ sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam] sshToRepo repo sshcmd = do s <- getConfig repo "ssh-options" "" let sshoptions = map Param (words s) - let sshport = case Git.urlPort repo of + let sshport = case Git.Url.port repo of Nothing -> [] Just p -> [Param "-p", Param (show p)] - let sshhost = Param $ Git.urlHostUser repo + let sshhost = Param $ Git.Url.hostuser repo return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd {- Generates parameters to run a git-annex-shell command on a remote diff --git a/Backend.hs b/Backend.hs index 38f0629f48..4743bb202e 100644 --- a/Backend.hs +++ b/Backend.hs @@ -20,7 +20,6 @@ import System.IO.Error (try) import System.Posix.Files import Common.Annex -import qualified Git import qualified Git.Config import qualified Git.CheckAttr import qualified Annex diff --git a/Command/Map.hs b/Command/Map.hs index 815b142e72..ae8a694043 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -13,6 +13,7 @@ import qualified Data.Map as M import Common.Annex import Command import qualified Git +import qualified Git.Url import qualified Git.Config import qualified Git.Construct import Annex.UUID @@ -68,7 +69,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others hostname :: Git.Repo -> String hostname r - | Git.repoIsUrl r = Git.urlHost r + | Git.repoIsUrl r = Git.Url.host r | otherwise = "localhost" basehostname :: Git.Repo -> String @@ -82,7 +83,7 @@ repoName umap r | otherwise = M.findWithDefault fallback repouuid umap where repouuid = getUncachedUUID r - fallback = fromMaybe "unknown" $ Git.repoRemoteName r + fallback = fromMaybe "unknown" $ Git.remoteName r {- A unique id for the node for a repo. Uses the annex.uuid if available. -} nodeId :: Git.Repo -> String @@ -99,7 +100,7 @@ node umap fullinfo r = unlines $ n:edges decorate $ Dot.graphNode (nodeId r) (repoName umap r) edges = map (edge umap fullinfo r) (Git.remotes r) decorate - | Git.configMap r == M.empty = unreachable + | Git.config r == M.empty = unreachable | otherwise = reachable {- An edge between two repos. The second repo is a remote of the first. -} @@ -116,7 +117,7 @@ edge umap fullinfo from to = {- Only name an edge if the name is different than the name - that will be used for the destination node, and is - different from its hostname. (This reduces visual clutter.) -} - edgename = maybe Nothing calcname $ Git.repoRemoteName to + edgename = maybe Nothing calcname $ Git.remoteName to calcname n | n `elem` [repoName umap fullto, hostname fullto] = Nothing | otherwise = Just n @@ -141,7 +142,7 @@ spider' (r:rs) known -- The remotes will be relative to r', and need to be -- made absolute for later use. remotes <- mapM (absRepo r') (Git.remotes r') - let r'' = Git.remotesAdd r' remotes + let r'' = r' { Git.remotes = remotes } spider' (rs ++ remotes) (r'':known) @@ -154,7 +155,7 @@ absRepo reference r {- Checks if two repos are the same. -} same :: Git.Repo -> Git.Repo -> Bool same a b - | both Git.repoIsSsh = matching Git.urlAuthority && matching Git.workTree + | both Git.repoIsSsh = matching Git.Url.authority && matching Git.workTree | both Git.repoIsUrl && neither Git.repoIsSsh = matching show | neither Git.repoIsSsh = matching Git.workTree | otherwise = False diff --git a/Config.hs b/Config.hs index 322dc8af82..07c9eedad7 100644 --- a/Config.hs +++ b/Config.hs @@ -31,7 +31,7 @@ getConfig r key def = do {- Looks up a per-remote config setting in git config. -} remoteConfig :: Git.Repo -> ConfigKey -> String -remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key +remoteConfig r key = "remote." ++ fromMaybe "" (Git.remoteName r) ++ ".annex-" ++ key {- Calculates cost for a remote. Either the default, or as configured - by remote..annex-cost, or if remote..annex-cost-command diff --git a/Git.hs b/Git.hs index b4cbd91aa0..a3f2ad74cb 100644 --- a/Git.hs +++ b/Git.hs @@ -9,7 +9,7 @@ -} module Git ( - Repo, + Repo(..), Ref(..), Branch, Sha, @@ -22,13 +22,6 @@ module Git ( repoLocation, workTree, gitDir, - urlPath, - urlHost, - urlPort, - urlHostUser, - urlAuthority, - urlScheme, - configMap, configTrue, gitCommandLine, run, @@ -39,23 +32,14 @@ module Git ( pipeNullSplit, pipeNullSplitB, attributes, - remotes, - remotesAdd, - repoRemoteName, - repoRemoteNameSet, - repoRemoteNameFromKey, reap, - useIndex, - getSha, - shaSize, assertLocal, ) where import qualified Data.Map as M -import Network.URI import Data.Char -import System.Posix.Env (setEnv, unsetEnv, getEnv) import qualified Data.ByteString.Lazy.Char8 as L +import Network.URI (uriPath, uriScheme) import Common import Git.Types @@ -73,29 +57,6 @@ repoLocation Repo { location = Url url } = show url repoLocation Repo { location = Dir dir } = dir repoLocation Repo { location = Unknown } = undefined -{- Constructs and returns an updated version of a repo with - - different remotes list. -} -remotesAdd :: Repo -> [Repo] -> Repo -remotesAdd repo rs = repo { remotes = rs } - -{- Returns the name of the remote that corresponds to the repo, if - - it is a remote. -} -repoRemoteName :: Repo -> Maybe String -repoRemoteName Repo { remoteName = Just name } = Just name -repoRemoteName _ = Nothing - -{- Sets the name of a remote. -} -repoRemoteNameSet :: String -> Repo -> Repo -repoRemoteNameSet n r = r { remoteName = Just n } - -{- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -repoRemoteNameFromKey :: String -> Repo -> Repo -repoRemoteNameFromKey k = repoRemoteNameSet basename - where - basename = join "." $ reverse $ drop 1 $ - reverse $ drop 1 $ split "." k - {- Some code needs to vary between URL and normal repos, - or bare and non-bare, these functions help with that. -} repoIsUrl :: Repo -> Bool @@ -104,11 +65,13 @@ repoIsUrl _ = False repoIsSsh :: Repo -> Bool repoIsSsh Repo { location = Url url } - | uriScheme url == "ssh:" = True + | scheme == "ssh:" = True -- git treats these the same as ssh - | uriScheme url == "git+ssh:" = True - | uriScheme url == "ssh+git:" = True + | scheme == "git+ssh:" = True + | scheme == "ssh+git:" = True | otherwise = False + where + scheme = uriScheme url repoIsSsh _ = False repoIsHttp :: Repo -> Bool @@ -129,15 +92,8 @@ assertLocal :: Repo -> a -> a assertLocal repo action = if not $ repoIsUrl repo then action - else error $ "acting on URL git repo " ++ repoDescribe repo ++ + else error $ "acting on non-local git repo " ++ repoDescribe repo ++ " not supported" -assertUrl :: Repo -> a -> a -assertUrl repo action = - if repoIsUrl repo - then action - else error $ "acting on local git repo " ++ repoDescribe repo ++ - " not supported" - configBare :: Repo -> Bool configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo where @@ -161,61 +117,10 @@ gitDir repo - - Note that for URL repositories, this is the path on the remote host. -} workTree :: Repo -> FilePath -workTree r@(Repo { location = Url _ }) = urlPath r -workTree (Repo { location = Dir d }) = d +workTree Repo { location = Url u } = uriPath u +workTree Repo { location = Dir d } = d workTree Repo { location = Unknown } = undefined -{- Path of an URL repo. -} -urlPath :: Repo -> String -urlPath Repo { location = Url u } = uriPath u -urlPath repo = assertUrl repo $ error "internal" - -{- Scheme of an URL repo. -} -urlScheme :: Repo -> String -urlScheme Repo { location = Url u } = uriScheme u -urlScheme repo = assertUrl repo $ error "internal" - -{- Work around a bug in the real uriRegName - - -} -uriRegName' :: URIAuth -> String -uriRegName' a = fixup $ uriRegName a - where - fixup x@('[':rest) - | rest !! len == ']' = take len rest - | otherwise = x - where - len = length rest - 1 - fixup x = x - -{- Hostname of an URL repo. -} -urlHost :: Repo -> String -urlHost = urlAuthPart uriRegName' - -{- Port of an URL repo, if it has a nonstandard one. -} -urlPort :: Repo -> Maybe Integer -urlPort r = - case urlAuthPart uriPort r of - ":" -> Nothing - (':':p) -> readMaybe p - _ -> Nothing - -{- Hostname of an URL repo, including any username (ie, "user@host") -} -urlHostUser :: Repo -> String -urlHostUser r = urlAuthPart uriUserInfo r ++ urlAuthPart uriRegName' r - -{- The full authority portion an URL repo. (ie, "user@host:port") -} -urlAuthority :: Repo -> String -urlAuthority = urlAuthPart assemble - where - assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a - -{- Applies a function to extract part of the uriAuthority of an URL repo. -} -urlAuthPart :: (URIAuth -> a) -> Repo -> a -urlAuthPart a Repo { location = Url u } = a auth - where - auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u) -urlAuthPart _ repo = assertUrl repo $ error "internal" - {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params repo@(Repo { location = Dir _ } ) = @@ -284,39 +189,6 @@ reap = do r <- catchDefaultIO (getAnyProcessStatus False True) Nothing maybe (return ()) (const reap) r -{- Forces git to use the specified index file. - - Returns an action that will reset back to the default - - index file. -} -useIndex :: FilePath -> IO (IO ()) -useIndex index = do - res <- getEnv var - setEnv var index True - return $ reset res - where - var = "GIT_INDEX_FILE" - reset (Just v) = setEnv var v True - reset _ = unsetEnv var - -{- Runs an action that causes a git subcommand to emit a sha, and strips - any trailing newline, returning the sha. -} -getSha :: String -> IO String -> IO Sha -getSha subcommand a = do - t <- a - let t' = if last t == '\n' - then init t - else t - when (length t' /= shaSize) $ - error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")" - return $ Ref t' - -{- Size of a git sha. -} -shaSize :: Int -shaSize = 40 - {- Checks if a string from git config is a true value. -} configTrue :: String -> Bool configTrue s = map toLower s == "true" - -{- Access to raw config Map -} -configMap :: Repo -> M.Map String String -configMap = config diff --git a/Git/Branch.hs b/Git/Branch.hs index 8b0d1e5afc..3e08e19c28 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as L import Common import Git +import Git.Sha {- Checks if the second branch has any commits not present on the first - branch. -} @@ -19,7 +20,7 @@ changed origbranch newbranch repo | origbranch == newbranch = return False | otherwise = not . L.null <$> diffs where - diffs = Git.pipeRead + diffs = pipeRead [ Param "log" , Param (show origbranch ++ ".." ++ show newbranch) , Params "--oneline -n1" @@ -44,7 +45,7 @@ fastForward branch (first:rest) repo = do where no_ff = return False do_ff to = do - Git.run "update-ref" + run "update-ref" [Param $ show branch, Param $ show to] repo return True findbest c [] = return $ Just c diff --git a/Git/CatFile.hs b/Git/CatFile.hs index c1cafb8ba8..44c2a9f5ef 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -20,6 +20,7 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Git +import Git.Sha import Utility.SafeCommand type CatFileHandle = (PipeHandle, Handle, Handle) @@ -27,7 +28,7 @@ type CatFileHandle = (PipeHandle, Handle, Handle) {- Starts git cat-file running in batch mode in a repo and returns a handle. -} catFileStart :: Repo -> IO CatFileHandle catFileStart repo = hPipeBoth "git" $ toCommand $ - Git.gitCommandLine [Param "cat-file", Param "--batch"] repo + gitCommandLine [Param "cat-file", Param "--batch"] repo {- Stops git cat-file. -} catFileStop :: CatFileHandle -> IO () @@ -49,7 +50,7 @@ catObject (_, from, to) object = do header <- hGetLine from case words header of [sha, objtype, size] - | length sha == Git.shaSize && + | length sha == shaSize && validobjtype objtype -> handle size | otherwise -> empty _ diff --git a/Git/Construct.hs b/Git/Construct.hs index 9149ab9ec0..a35a87cc77 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -11,6 +11,8 @@ module Git.Construct ( fromUrl, fromUnknown, localToUrl, + remoteNamed, + remoteNamedFromKey, fromRemotes, fromRemoteLocation, repoAbsPath, @@ -23,6 +25,7 @@ import Network.URI import Common import Git.Types import Git +import qualified Git.Url as Url {- Finds the current git repository, which may be in a parent directory. -} fromCwd :: IO Repo @@ -67,8 +70,8 @@ fromUrl url bad = error $ "bad url " ++ url {- Creates a repo that has an unknown location. -} -fromUnknown :: Repo -fromUnknown = newFrom Unknown +fromUnknown :: IO Repo +fromUnknown = return $ newFrom Unknown {- Converts a local Repo into a remote repo, using the reference repo - which is assumed to be on the same host. -} @@ -79,8 +82,8 @@ localToUrl reference r | otherwise = r { location = Url $ fromJust $ parseURI absurl } where absurl = - urlScheme reference ++ "//" ++ - urlAuthority reference ++ + Url.scheme reference ++ "//" ++ + Url.authority reference ++ workTree r {- Calculates a list of a repo's configured remotes, by parsing its config. -} @@ -91,7 +94,21 @@ fromRemotes repo = mapM construct remotepairs filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isremote isremote k = startswith "remote." k && endswith ".url" k - construct (k,v) = repoRemoteNameFromKey k <$> fromRemoteLocation v repo + construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + +{- Sets the name of a remote when constructing the Repo to represent it. -} +remoteNamed :: String -> IO Repo -> IO Repo +remoteNamed n constructor = do + r <- constructor + return $ r { remoteName = Just n } + +{- Sets the name of a remote based on the git config key, such as + "remote.foo.url". -} +remoteNamedFromKey :: String -> IO Repo -> IO Repo +remoteNamedFromKey k = remoteNamed basename + where + basename = join "." $ reverse $ drop 1 $ + reverse $ drop 1 $ split "." k {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 99b96afcb9..60822f3f07 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -17,10 +17,10 @@ hashFiles paths repo = do (pid, fromh, toh) <- hPipeBoth "git" $ toCommand $ git_hash_object repo _ <- forkProcess (feeder toh) hClose toh - shas <- map Git.Ref . lines <$> hGetContentsStrict fromh + shas <- map Ref . lines <$> hGetContentsStrict fromh return (shas, ender fromh pid) where - git_hash_object = Git.gitCommandLine + git_hash_object = gitCommandLine [Param "hash-object", Param "-w", Param "--stdin-paths"] feeder toh = do hPutStr toh $ unlines paths diff --git a/Git/Index.hs b/Git/Index.hs new file mode 100644 index 0000000000..aaf54e032e --- /dev/null +++ b/Git/Index.hs @@ -0,0 +1,24 @@ +{- git index file stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Index where + +import System.Posix.Env (setEnv, unsetEnv, getEnv) + +{- Forces git to use the specified index file. + - + - Returns an action that will reset back to the default + - index file. -} +override :: FilePath -> IO (IO ()) +override index = do + res <- getEnv var + setEnv var index True + return $ reset res + where + var = "GIT_INDEX_FILE" + reset (Just v) = setEnv var v True + reset _ = unsetEnv var diff --git a/Git/Ref.hs b/Git/Ref.hs index 723bea6817..3b550cf5b9 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -37,11 +37,11 @@ sha branch repo = process . L.unpack <$> showref repo {- List of (refs, branches) matching a given ref spec. - Duplicate refs are filtered out. -} -matching :: Ref -> Repo -> IO [(Git.Ref, Git.Branch)] +matching :: Ref -> Repo -> IO [(Ref, Branch)] matching ref repo = do - r <- Git.pipeRead [Param "show-ref", Param $ show ref] repo + r <- pipeRead [Param "show-ref", Param $ show ref] repo return $ nubBy uref $ map (gen . words . L.unpack) (L.lines r) where - gen l = (Git.Ref $ head l, Git.Ref $ last l) + gen l = (Ref $ head l, Ref $ last l) uref (a, _) (b, _) = a == b diff --git a/Git/Sha.hs b/Git/Sha.hs new file mode 100644 index 0000000000..475c2ba5f3 --- /dev/null +++ b/Git/Sha.hs @@ -0,0 +1,27 @@ +{- git SHA stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Sha where + +import Common +import Git.Types + +{- Runs an action that causes a git subcommand to emit a sha, and strips + any trailing newline, returning the sha. -} +getSha :: String -> IO String -> IO Sha +getSha subcommand a = do + t <- a + let t' = if last t == '\n' + then init t + else t + when (length t' /= shaSize) $ + error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")" + return $ Ref t' + +{- Size of a git sha. -} +shaSize :: Int +shaSize = 40 diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 0345af3994..a623e1cebb 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -20,6 +20,7 @@ import qualified Data.Set as S import Common import Git +import Git.Sha import Git.CatFile type Streamer = (String -> IO ()) -> IO () @@ -27,7 +28,7 @@ type Streamer = (String -> IO ()) -> IO () {- Performs a union merge between two branches, staging it in the index. - Any previously staged changes in the index will be lost. - - - Should be run with a temporary index file configured by Git.useIndex. + - Should be run with a temporary index file configured by useIndex. -} merge :: Ref -> Ref -> Repo -> IO () merge x y repo = do @@ -53,7 +54,7 @@ update_index repo ls = stream_update_index repo [(`mapM_` ls)] {- Streams content into update-index. -} stream_update_index :: Repo -> [Streamer] -> IO () stream_update_index repo as = do - (p, h) <- hPipeTo "git" (toCommand $ Git.gitCommandLine params repo) + (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) forM_ as (stream h) hClose h forceSuccess p diff --git a/Git/Url.hs b/Git/Url.hs new file mode 100644 index 0000000000..6a893d92fe --- /dev/null +++ b/Git/Url.hs @@ -0,0 +1,70 @@ +{- git repository urls + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Url ( + scheme, + host, + port, + hostuser, + authority, +) where + +import Network.URI hiding (scheme, authority) + +import Common +import Git.Types +import Git + +{- Scheme of an URL repo. -} +scheme :: Repo -> String +scheme Repo { location = Url u } = uriScheme u +scheme repo = notUrl repo + +{- Work around a bug in the real uriRegName + - -} +uriRegName' :: URIAuth -> String +uriRegName' a = fixup $ uriRegName a + where + fixup x@('[':rest) + | rest !! len == ']' = take len rest + | otherwise = x + where + len = length rest - 1 + fixup x = x + +{- Hostname of an URL repo. -} +host :: Repo -> String +host = authpart uriRegName' + +{- Port of an URL repo, if it has a nonstandard one. -} +port :: Repo -> Maybe Integer +port r = + case authpart uriPort r of + ":" -> Nothing + (':':p) -> readMaybe p + _ -> Nothing + +{- Hostname of an URL repo, including any username (ie, "user@host") -} +hostuser :: Repo -> String +hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r + +{- The full authority portion an URL repo. (ie, "user@host:port") -} +authority :: Repo -> String +authority = authpart assemble + where + assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a + +{- Applies a function to extract part of the uriAuthority of an URL repo. -} +authpart :: (URIAuth -> a) -> Repo -> a +authpart a Repo { location = Url u } = a auth + where + auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u) +authpart _ repo = notUrl repo + +notUrl :: Repo -> a +notUrl repo = error $ + "acting on local git repo " ++ repoDescribe repo ++ " not supported" diff --git a/Remote/Git.hs b/Remote/Git.hs index 9d80f4c1cb..d848a21b33 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -37,16 +37,17 @@ remote = RemoteType { list :: Annex [Git.Repo] list = do - c <- fromRepo Git.configMap + c <- fromRepo Git.config mapM (tweakurl c) =<< fromRepo Git.remotes where annexurl n = "remote." ++ n ++ ".annexurl" tweakurl c r = do - let n = fromJust $ Git.repoRemoteName r + let n = fromJust $ Git.remoteName r case M.lookup (annexurl n) c of Nothing -> return r - Just url -> Git.repoRemoteNameSet n <$> - inRepo (Git.Construct.fromRemoteLocation url) + Just url -> inRepo $ \g -> + Git.Construct.remoteNamed n $ + Git.Construct.fromRemoteLocation url g gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen r u _ = do @@ -84,7 +85,7 @@ gen r u _ = do - returns the updated repo. -} tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead r - | not $ M.null $ Git.configMap r = return r -- already read + | not $ M.null $ Git.config r = return r -- already read | Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" [] | Git.repoIsHttp r = store $ safely geturlconfig | Git.repoIsUrl r = return r @@ -116,13 +117,13 @@ tryGitConfigRead r r' <- a g <- gitRepo let l = Git.remotes g - let g' = Git.remotesAdd g $ exchange l r' + let g' = g { Git.remotes = exchange l r' } Annex.changeState $ \s -> s { Annex.repo = g' } return r' exchange [] _ = [] exchange (old:ls) new = - if Git.repoRemoteName old == Git.repoRemoteName new + if Git.remoteName old == Git.remoteName new then new : exchange ls new else old : exchange ls new @@ -167,7 +168,7 @@ onLocal :: Git.Repo -> Annex a -> IO a onLocal r a = do -- Avoid re-reading the repository's configuration if it was -- already read. - state <- if M.null $ Git.configMap r + state <- if M.null $ Git.config r then Annex.new r else return $ Annex.newState r Annex.eval state $ do diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 72c4842d88..c374a16aaf 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -20,11 +20,11 @@ import qualified Git.Construct -} findSpecialRemotes :: String -> Annex [Git.Repo] findSpecialRemotes s = do - m <- fromRepo Git.configMap - return $ map construct $ remotepairs m + m <- fromRepo Git.config + liftIO $ mapM construct $ remotepairs m where remotepairs = M.toList . M.filterWithKey match - construct (k,_) = Git.repoRemoteNameFromKey k Git.Construct.fromUnknown + construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown match k _ = startswith "remote." k && endswith (".annex-"++s) k {- Sets up configuration for a special remote in .git/config. -} diff --git a/Remote/Web.hs b/Remote/Web.hs index c4e9f8bd69..e31539f885 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -27,7 +27,9 @@ remote = RemoteType { -- (If the web should cease to exist, remove this module and redistribute -- a new release to the survivors by carrier pigeon.) list :: Annex [Git.Repo] -list = return [Git.repoRemoteNameSet "web" Git.Construct.fromUnknown] +list = do + r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown + return [r] gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen r _ _ = diff --git a/git-union-merge.hs b/git-union-merge.hs index f67414bdd3..6fd19c8dae 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -12,6 +12,7 @@ import qualified Git.UnionMerge import qualified Git.Config import qualified Git.Construct import qualified Git.Branch +import qualified Git.Index import qualified Git header :: String @@ -42,7 +43,7 @@ main :: IO () main = do [aref, bref, newref] <- map Git.Ref <$> parseArgs g <- Git.Config.read =<< Git.Construct.fromCwd - _ <- Git.useIndex (tmpIndex g) + _ <- Git.Index.override (tmpIndex g) setup g Git.UnionMerge.merge aref bref g _ <- Git.Branch.commit "union merge" newref [aref, bref] g diff --git a/test.hs b/test.hs index 1ce9d103d1..daa2661b6e 100644 --- a/test.hs +++ b/test.hs @@ -24,7 +24,6 @@ import qualified Utility.SafeCommand import qualified Annex import qualified Annex.UUID import qualified Backend -import qualified Git import qualified Git.Config import qualified Git.Construct import qualified Git.Filename