diff options
| -rw-r--r-- | Annex.hs | 3 | ||||
| -rw-r--r-- | Annex/UUID.hs | 5 | ||||
| -rw-r--r-- | Annex/Version.hs | 4 | ||||
| -rw-r--r-- | Backend.hs | 3 | ||||
| -rw-r--r-- | Command/Map.hs | 10 | ||||
| -rw-r--r-- | Command/Sync.hs | 5 | ||||
| -rw-r--r-- | Config.hs | 9 | ||||
| -rw-r--r-- | Git.hs | 250 | ||||
| -rw-r--r-- | Git/Config.hs | 58 | ||||
| -rw-r--r-- | Git/Construct.hs | 198 | ||||
| -rw-r--r-- | Git/Types.hs | 36 | ||||
| -rw-r--r-- | GitAnnex.hs | 7 | ||||
| -rw-r--r-- | Remote/Bup.hs | 16 | ||||
| -rw-r--r-- | Remote/Git.hs | 8 | ||||
| -rw-r--r-- | Remote/Helper/Special.hs | 3 | ||||
| -rw-r--r-- | Remote/Web.hs | 3 | ||||
| -rw-r--r-- | git-annex-shell.hs | 4 | ||||
| -rw-r--r-- | git-annex.cabal | 2 | ||||
| -rw-r--r-- | git-union-merge.hs | 4 | ||||
| -rw-r--r-- | test.hs | 6 |
20 files changed, 349 insertions, 285 deletions
@@ -27,6 +27,7 @@ import Control.Monad.State import Common import qualified Git +import qualified Git.Config import Git.CatFile import Git.Queue import Types.Backend @@ -99,7 +100,7 @@ newState gitrepo = AnnexState {- Create and returns an Annex state object for the specified git repo. -} new :: Git.Repo -> IO AnnexState -new gitrepo = newState <$> Git.configRead gitrepo +new gitrepo = newState <$> Git.Config.read gitrepo {- performs an action in the Annex monad -} run :: AnnexState -> Annex a -> IO (a, AnnexState) diff --git a/Annex/UUID.hs b/Annex/UUID.hs index e510a7ccd..48bf71f10 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -21,6 +21,7 @@ module Annex.UUID ( import Common.Annex import qualified Git +import qualified Git.Config import qualified Build.SysConfig as SysConfig import Config @@ -55,14 +56,14 @@ getRepoUUID r = do return u else return c where - cached = toUUID . Git.configGet cachekey "" + cached = toUUID . Git.Config.get cachekey "" updatecache u = do g <- gitRepo when (g /= r) $ storeUUID cachekey u cachekey = remoteConfig r "uuid" getUncachedUUID :: Git.Repo -> UUID -getUncachedUUID = toUUID . Git.configGet configkey "" +getUncachedUUID = toUUID . Git.Config.get configkey "" {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex () diff --git a/Annex/Version.hs b/Annex/Version.hs index 9e694faf1..917859eae 100644 --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -8,7 +8,7 @@ module Annex.Version where import Common.Annex -import qualified Git +import qualified Git.Config import Config type Version = String @@ -26,7 +26,7 @@ versionField :: String versionField = "annex.version" getVersion :: Annex (Maybe Version) -getVersion = handle <$> fromRepo (Git.configGet versionField "") +getVersion = handle <$> fromRepo (Git.Config.get versionField "") where handle [] = Nothing handle v = Just v diff --git a/Backend.hs b/Backend.hs index 136c2eb7a..c7cb57440 100644 --- a/Backend.hs +++ b/Backend.hs @@ -21,6 +21,7 @@ import System.Posix.Files import Common.Annex import qualified Git +import qualified Git.Config import qualified Annex import Types.Key import qualified Types.Backend as B @@ -47,7 +48,7 @@ orderedList = do l' <- (lookupBackendName name :) <$> standard Annex.changeState $ \s -> s { Annex.backends = l' } return l' - standard = fromRepo $ parseBackendList . Git.configGet "annex.backends" "" + standard = fromRepo $ parseBackendList . Git.Config.get "annex.backends" "" parseBackendList [] = list parseBackendList s = map lookupBackendName $ words s diff --git a/Command/Map.hs b/Command/Map.hs index 57b48d503..815b142e7 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -13,6 +13,8 @@ import qualified Data.Map as M import Common.Annex import Command import qualified Git +import qualified Git.Config +import qualified Git.Construct import Annex.UUID import Logs.UUID import Logs.Trust @@ -146,8 +148,8 @@ spider' (r:rs) known {- Converts repos to a common absolute form. -} absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo absRepo reference r - | Git.repoIsUrl reference = return $ Git.localToUrl reference r - | otherwise = liftIO $ Git.repoFromAbsPath =<< absPath (Git.workTree r) + | Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r + | otherwise = liftIO $ Git.Construct.fromAbsPath =<< absPath (Git.workTree r) {- Checks if two repos are the same. -} same :: Git.Repo -> Git.Repo -> Bool @@ -182,7 +184,7 @@ tryScan :: Git.Repo -> Annex (Maybe Git.Repo) tryScan r | Git.repoIsSsh r = sshscan | Git.repoIsUrl r = return Nothing - | otherwise = safely $ Git.configRead r + | otherwise = safely $ Git.Config.read r where safely a = do result <- liftIO (try a :: IO (Either SomeException Git.Repo)) @@ -191,7 +193,7 @@ tryScan r Right r' -> return $ Just r' pipedconfig cmd params = safely $ pOpen ReadFromPipe cmd (toCommand params) $ - Git.hConfigRead r + Git.Config.hRead r configlist = onRemote r (pipedconfig, Nothing) "configlist" [] diff --git a/Command/Sync.hs b/Command/Sync.hs index 7dc5f4d24..987eb6138 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -11,6 +11,7 @@ import Common.Annex import Command import qualified Annex.Branch import qualified Git +import qualified Git.Config import qualified Data.ByteString.Lazy.Char8 as L @@ -56,7 +57,7 @@ push = do defaultRemote :: Annex String defaultRemote = do branch <- currentBranch - fromRepo $ Git.configGet ("branch." ++ branch ++ ".remote") "origin" + fromRepo $ Git.Config.get ("branch." ++ branch ++ ".remote") "origin" currentBranch :: Annex String currentBranch = last . split "/" . L.unpack . head . L.lines <$> @@ -65,6 +66,6 @@ currentBranch = last . split "/" . L.unpack . head . L.lines <$> checkRemote :: String -> Annex () checkRemote remote = do remoteurl <- fromRepo $ - Git.configGet ("remote." ++ remote ++ ".url") "" + Git.Config.get ("remote." ++ remote ++ ".url") "" when (null remoteurl) $ do error $ "No url is configured for the remote: " ++ remote @@ -9,6 +9,7 @@ module Config where import Common.Annex import qualified Git +import qualified Git.Config import qualified Annex type ConfigKey = String @@ -18,15 +19,15 @@ setConfig :: ConfigKey -> String -> Annex () setConfig k value = do inRepo $ Git.run "config" [Param k, Param value] -- re-read git config and update the repo's state - newg <- inRepo Git.configRead + newg <- inRepo Git.Config.read Annex.changeState $ \s -> s { Annex.repo = newg } {- Looks up a per-remote config setting in git config. - Failing that, tries looking for a global config option. -} getConfig :: Git.Repo -> ConfigKey -> String -> Annex String getConfig r key def = do - def' <- fromRepo $ Git.configGet ("annex." ++ key) def - fromRepo $ Git.configGet (remoteConfig r key) def' + def' <- fromRepo $ Git.Config.get ("annex." ++ key) def + fromRepo $ Git.Config.get (remoteConfig r key) def' {- Looks up a per-remote config setting in git config. -} remoteConfig :: Git.Repo -> ConfigKey -> String @@ -83,6 +84,6 @@ getNumCopies v = perhaps (use v) =<< Annex.getState Annex.forcenumcopies where use (Just n) = return n use Nothing = perhaps (return 1) =<< - readMaybe <$> fromRepo (Git.configGet config "1") + readMaybe <$> fromRepo (Git.Config.get config "1") perhaps fallback = maybe fallback (return . id) config = "annex.numcopies" @@ -3,7 +3,7 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - Copyright 2010,2011 Joey Hess <joey@kitenet.net> + - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,11 +14,6 @@ module Git ( Branch, Sha, Tag, - repoFromCwd, - repoFromAbsPath, - repoFromUnknown, - repoFromUrl, - localToUrl, repoIsUrl, repoIsSsh, repoIsHttp, @@ -34,11 +29,7 @@ module Git ( urlHostUser, urlAuthority, urlScheme, - configGet, configMap, - configRead, - hConfigRead, - configStore, configTrue, gitCommandLine, run, @@ -51,14 +42,12 @@ module Git ( attributes, remotes, remotesAdd, - genRemote, repoRemoteName, repoRemoteNameSet, repoRemoteNameFromKey, checkAttr, decodeGitFile, encodeGitFile, - repoAbsPath, reap, useIndex, getSha, @@ -69,9 +58,6 @@ module Git ( prop_idempotent_deencode ) where -import System.Posix.Directory -import System.Posix.User -import Control.Exception (bracket_) import qualified Data.Map as M hiding (map, split) import Network.URI import Data.Char @@ -83,92 +69,7 @@ import System.Posix.Env (setEnv, unsetEnv, getEnv) import qualified Data.ByteString.Lazy.Char8 as L import Common - -{- There are two types of repositories; those on local disk and those - - accessed via an URL. -} -data RepoLocation = Dir FilePath | Url URI | Unknown - deriving (Show, Eq) - -data Repo = Repo { - location :: RepoLocation, - config :: M.Map String String, - remotes :: [Repo], - -- remoteName holds the name used for this repo in remotes - remoteName :: Maybe String -} deriving (Show, Eq) - -{- A git ref. Can be a sha1, or a branch or tag name. -} -newtype Ref = Ref String - deriving (Eq) - -instance Show Ref where - show (Ref v) = v - -{- Aliases for Ref. -} -type Branch = Ref -type Sha = Ref -type Tag = Ref - -newFrom :: RepoLocation -> Repo -newFrom l = - Repo { - location = l, - config = M.empty, - remotes = [], - remoteName = Nothing - } - -{- Local Repo constructor, requires an absolute path to the repo be - - specified. -} -repoFromAbsPath :: FilePath -> IO Repo -repoFromAbsPath dir - | "/" `isPrefixOf` dir = do - -- Git always looks for "dir.git" in preference to - -- to "dir", even if dir ends in a "/". - let canondir = dropTrailingPathSeparator dir - let dir' = canondir ++ ".git" - e <- doesDirectoryExist dir' - if e - then ret dir' - else if "/.git" `isSuffixOf` canondir - then do - -- When dir == "foo/.git", git looks - -- for "foo/.git/.git", and failing - -- that, uses "foo" as the repository. - e' <- doesDirectoryExist $ dir </> ".git" - if e' - then ret dir - else ret $ takeDirectory canondir - else ret dir - | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" - where - ret = return . newFrom . Dir - -{- Remote Repo constructor. Throws exception on invalid url. -} -repoFromUrl :: String -> IO Repo -repoFromUrl url - | startswith "file://" url = repoFromAbsPath $ uriPath u - | otherwise = return $ newFrom $ Url u - where - u = fromMaybe bad $ parseURI url - bad = error $ "bad url " ++ url - -{- Creates a repo that has an unknown location. -} -repoFromUnknown :: Repo -repoFromUnknown = newFrom Unknown - -{- Converts a Local Repo into a remote repo, using the reference repo - - which is assumed to be on the same host. -} -localToUrl :: Repo -> Repo -> Repo -localToUrl reference r - | not $ repoIsUrl reference = error "internal error; reference repo not url" - | repoIsUrl r = r - | otherwise = r { location = Url $ fromJust $ parseURI absurl } - where - absurl = - urlScheme reference ++ "//" ++ - urlAuthority reference ++ - workTree r +import Git.Types {- User-visible description of a git repo. -} repoDescribe :: Repo -> String @@ -470,89 +371,10 @@ commit message branch parentrefs repo = do asString a = L.unpack <$> a ps = concatMap (\r -> ["-p", show r]) parentrefs -{- Runs git config and populates a repo with its config. -} -configRead :: Repo -> IO Repo -configRead repo@(Repo { location = Dir d }) = do - {- Cannot use pipeRead because it relies on the config having - been already read. Instead, chdir to the repo. -} - cwd <- getCurrentDirectory - bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) $ - pOpen ReadFromPipe "git" ["config", "--list"] $ hConfigRead repo -configRead r = assertLocal r $ error "internal" - -{- Reads git config from a handle and populates a repo with it. -} -hConfigRead :: Repo -> Handle -> IO Repo -hConfigRead repo h = do - val <- hGetContentsStrict h - configStore val repo - -{- Stores a git config into a repo, returning the new version of the repo. - - The git config may be multiple lines, or a single line. Config settings - - can be updated inrementally. -} -configStore :: String -> Repo -> IO Repo -configStore s repo = do - let repo' = repo { config = configParse s `M.union` config repo } - rs <- configRemotes repo' - return $ repo' { remotes = rs } - -{- Parses git config --list output into a config map. -} -configParse :: String -> M.Map String String -configParse s = M.fromList $ map pair $ lines s - where - pair = separate (== '=') - -{- Calculates a list of a repo's configured remotes, by parsing its config. -} -configRemotes :: Repo -> IO [Repo] -configRemotes repo = mapM construct remotepairs - where - filterconfig f = filter f $ M.toList $ config repo - filterkeys f = filterconfig (\(k,_) -> f k) - remotepairs = filterkeys isremote - isremote k = startswith "remote." k && endswith ".url" k - construct (k,v) = repoRemoteNameFromKey k <$> genRemote v repo - -{- Generates one of a repo's remotes using a given location (ie, an url). -} -genRemote :: String -> Repo -> IO Repo -genRemote s repo = gen $ calcloc s - where - filterconfig f = filter f $ M.toList $ config repo - gen v - | scpstyle v = repoFromUrl $ scptourl v - | isURI v = repoFromUrl v - | otherwise = repoFromRemotePath v repo - -- insteadof config can rewrite remote location - calcloc l - | null insteadofs = l - | otherwise = replacement ++ drop (length bestvalue) l - where - replacement = drop (length prefix) $ - take (length bestkey - length suffix) bestkey - (bestkey, bestvalue) = maximumBy longestvalue insteadofs - longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(k, v) -> - startswith prefix k && - endswith suffix k && - startswith v l - (prefix, suffix) = ("url." , ".insteadof") - -- git remotes can be written scp style -- [user@]host:dir - scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v) - scptourl v = "ssh://" ++ host ++ slash dir - where - (host, dir) = separate (== ':') v - slash d | d == "" = "/~/" ++ d - | "/" `isPrefixOf` d = d - | "~" `isPrefixOf` d = '/':d - | otherwise = "/~/" ++ d - {- Checks if a string from git config is a true value. -} configTrue :: String -> Bool configTrue s = map toLower s == "true" -{- Returns a single git config setting, or a default value if not set. -} -configGet :: String -> String -> Repo -> String -configGet key defaultValue repo = - M.findWithDefault defaultValue key (config repo) - {- Access to raw config Map -} configMap :: Repo -> M.Map String String configMap = config @@ -658,71 +480,3 @@ encodeGitFile s = foldl (++) "\"" (map echar s) ++ "\"" {- for quickcheck -} prop_idempotent_deencode :: String -> Bool prop_idempotent_deencode s = s == decodeGitFile (encodeGitFile s) - -{- Constructs a Repo from the path specified in the git remotes of - - another Repo. -} -repoFromRemotePath :: FilePath -> Repo -> IO Repo -repoFromRemotePath dir repo = do - dir' <- expandTilde dir - repoFromAbsPath $ workTree repo </> dir' - -{- Git remotes can have a directory that is specified relative - - to the user's home directory, or that contains tilde expansions. - - This converts such a directory to an absolute path. - - Note that it has to run on the system where the remote is. - -} -repoAbsPath :: FilePath -> IO FilePath -repoAbsPath d = do - d' <- expandTilde d - h <- myHomeDir - return $ h </> d' - -expandTilde :: FilePath -> IO FilePath -expandTilde = expandt True - where - expandt _ [] = return "" - expandt _ ('/':cs) = do - v <- expandt True cs - return ('/':v) - expandt True ('~':'/':cs) = do - h <- myHomeDir - return $ h </> cs - expandt True ('~':cs) = do - let (name, rest) = findname "" cs - u <- getUserEntryForName name - return $ homeDirectory u </> rest - expandt _ (c:cs) = do - v <- expandt False cs - return (c:v) - findname n [] = (n, "") - findname n (c:cs) - | c == '/' = (n, cs) - | otherwise = findname (n++[c]) cs - -{- Finds the current git repository, which may be in a parent directory. -} -repoFromCwd :: IO Repo -repoFromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo - where - makerepo = return . newFrom . Dir - norepo = error "Not in a git repository." - -seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath) -seekUp want dir = do - ok <- want dir - if ok - then return $ Just dir - else case parentDir dir of - "" -> return Nothing - d -> seekUp want d - -isRepoTop :: FilePath -> IO Bool -isRepoTop dir = do - r <- isRepo - b <- isBareRepo - return (r || b) - where - isRepo = gitSignature ".git" ".git/config" - isBareRepo = gitSignature "objects" "config" - gitSignature subdir file = liftM2 (&&) - (doesDirectoryExist (dir ++ "/" ++ subdir)) - (doesFileExist (dir ++ "/" ++ file)) diff --git a/Git/Config.hs b/Git/Config.hs new file mode 100644 index 000000000..5f0e3fdc2 --- /dev/null +++ b/Git/Config.hs @@ -0,0 +1,58 @@ +{- git repository configuration handling + - + - Copyright 2010,2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Config ( + get, + read, + hRead, + store +) where + +import Prelude hiding (read) +import System.Posix.Directory +import Control.Exception (bracket_) +import qualified Data.Map as M + +import Common +import Git +import Git.Types +import qualified Git.Construct + +{- Returns a single git config setting, or a default value if not set. -} +get :: String -> String -> Repo -> String +get key defaultValue repo = M.findWithDefault defaultValue key (config repo) + +{- Runs git config and populates a repo with its config. -} +read :: Repo -> IO Repo +read repo@(Repo { location = Dir d }) = do + {- Cannot use pipeRead because it relies on the config having + been already read. Instead, chdir to the repo. -} + cwd <- getCurrentDirectory + bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) $ + pOpen ReadFromPipe "git" ["config", "--list"] $ hRead repo +read r = assertLocal r $ error "internal" + +{- Reads git config from a handle and populates a repo with it. -} +hRead :: Repo -> Handle -> IO Repo +hRead repo h = do + val <- hGetContentsStrict h + store val repo + +{- Stores a git config into a repo, returning the new version of the repo. + - The git config may be multiple lines, or a single line. Config settings + - can be updated inrementally. -} +store :: String -> Repo -> IO Repo +store s repo = do + let repo' = repo { config = parse s `M.union` config repo } + rs <- Git.Construct.fromRemotes repo' + return $ repo' { remotes = rs } + +{- Parses git config --list output into a config map. -} +parse :: String -> M.Map String String +parse s = M.fromList $ map pair $ lines s + where + pair = separate (== '=') diff --git a/Git/Construct.hs b/Git/Construct.hs new file mode 100644 index 000000000..9149ab9ec --- /dev/null +++ b/Git/Construct.hs @@ -0,0 +1,198 @@ +{- Construction of Git Repo objects + - + - Copyright 2010,2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Construct ( + fromCwd, + fromAbsPath, + fromUrl, + fromUnknown, + localToUrl, + fromRemotes, + fromRemoteLocation, + repoAbsPath, +) where + +import System.Posix.User +import qualified Data.Map as M hiding (map, split) +import Network.URI + +import Common +import Git.Types +import Git + +{- Finds the current git repository, which may be in a parent directory. -} +fromCwd :: IO Repo +fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo + where + makerepo = return . newFrom . Dir + norepo = error "Not in a git repository." + +{- Local Repo constructor, requires an absolute path to the repo be + - specified. -} +fromAbsPath :: FilePath -> IO Repo +fromAbsPath dir + | "/" `isPrefixOf` dir = do + -- Git always looks for "dir.git" in preference to + -- to "dir", even if dir ends in a "/". + let canondir = dropTrailingPathSeparator dir + let dir' = canondir ++ ".git" + e <- doesDirectoryExist dir' + if e + then ret dir' + else if "/.git" `isSuffixOf` canondir + then do + -- When dir == "foo/.git", git looks + -- for "foo/.git/.git", and failing + -- that, uses "foo" as the repository. + e' <- doesDirectoryExist $ dir </> ".git" + if e' + then ret dir + else ret $ takeDirectory canondir + else ret dir + | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" + where + ret = return . newFrom . Dir + +{- Remote Repo constructor. Throws exception on invalid url. -} +fromUrl :: String -> IO Repo +fromUrl url + | startswith "file://" url = fromAbsPath $ uriPath u + | otherwise = return $ newFrom $ Url u + where + u = fromMaybe bad $ parseURI url + bad = error $ "bad url " ++ url + +{- Creates a repo that has an unknown location. -} +fromUnknown :: Repo +fromUnknown = newFrom Unknown + +{- Converts a local Repo into a remote repo, using the reference repo + - which is assumed to be on the same host. -} +localToUrl :: Repo -> Repo -> Repo +localToUrl reference r + | not $ repoIsUrl reference = error "internal error; reference repo not url" + | repoIsUrl r = r + | otherwise = r { location = Url $ fromJust $ parseURI absurl } + where + absurl = + urlScheme reference ++ "//" ++ + urlAuthority reference ++ + workTree r + +{- Calculates a list of a repo's configured remotes, by parsing its config. -} +fromRemotes :: Repo -> IO [Repo] +fromRemotes repo = mapM construct remotepairs + where + filterconfig f = filter f $ M.toList $ config repo + 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 + +{- Constructs a new Repo for one of a Repo's remotes using a given + - location (ie, an url). -} +fromRemoteLocation :: String -> Repo -> IO Repo +fromRemoteLocation s repo = gen $ calcloc s + where + filterconfig f = filter f $ M.toList $ config repo + gen v + | scpstyle v = fromUrl $ scptourl v + | isURI v = fromUrl v + | otherwise = fromRemotePath v repo + -- insteadof config can rewrite remote location + calcloc l + | null insteadofs = l + | otherwise = replacement ++ drop (length bestvalue) l + where + replacement = drop (length prefix) $ + take (length bestkey - length suffix) bestkey + (bestkey, bestvalue) = maximumBy longestvalue insteadofs + longestvalue (_, a) (_, b) = compare b a + insteadofs = filterconfig $ \(k, v) -> + startswith prefix k && + endswith suffix k && + startswith v l + (prefix, suffix) = ("url." , ".insteadof") + -- git remotes can be written scp style -- [user@]host:dir + scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v) + scptourl v = "ssh://" ++ host ++ slash dir + where + (host, dir) = separate (== ':') v + slash d | d == "" = "/~/" ++ d + | "/" `isPrefixOf` d = d + | "~" `isPrefixOf` d = '/':d + | otherwise = "/~/" ++ d + +{- Constructs a Repo from the path specified in the git remotes of + - another Repo. -} +fromRemotePath :: FilePath -> Repo -> IO Repo +fromRemotePath dir repo = do + dir' <- expandTilde dir + fromAbsPath $ workTree repo </> dir' + +{- Git remotes can have a directory that is specified relative + - to the user's home directory, or that contains tilde expansions. + - This converts such a directory to an absolute path. + - Note that it has to run on the system where the remote is. + -} +repoAbsPath :: FilePath -> IO FilePath +repoAbsPath d = do + d' <- expandTilde d + h <- myHomeDir + return $ h </> d' + +expandTilde :: FilePath -> IO FilePath +expandTilde = expandt True + where + expandt _ [] = return "" + expandt _ ('/':cs) = do + v <- expandt True cs + return ('/':v) + expandt True ('~':'/':cs) = do + h <- myHomeDir + return $ h </> cs + expandt True ('~':cs) = do + let (name, rest) = findname "" cs + u <- getUserEntryForName name + return $ homeDirectory u </> rest + expandt _ (c:cs) = do + v <- expandt False cs + return (c:v) + findname n [] = (n, "") + findname n (c:cs) + | c == '/' = (n, cs) + | otherwise = findname (n++[c]) cs + +seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath) +seekUp want dir = do + ok <- want dir + if ok + then return $ Just dir + else case parentDir dir of + "" -> return Nothing + d -> seekUp want d + +isRepoTop :: FilePath -> IO Bool +isRepoTop dir = do + r <- isRepo + b <- isBareRepo + return (r || b) + where + isRepo = gitSignature ".git" ".git/config" + isBareRepo = gitSignature "objects" "config" + gitSignature subdir file = liftM2 (&&) + (doesDirectoryExist (dir ++ "/" ++ subdir)) + (doesFileExist (dir ++ "/" ++ file)) + +newFrom :: RepoLocation -> Repo +newFrom l = + Repo { + location = l, + config = M.empty, + remotes = [], + remoteName = Nothing + } diff --git a/Git/Types.hs b/Git/Types.hs new file mode 100644 index 000000000..250da5f5e --- /dev/null +++ b/Git/Types.hs @@ -0,0 +1,36 @@ +{- git data types + - + - Copyright 2010,2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Types where + +import Network.URI +import qualified Data.Map as M + +{- There are two types of repositories; those on local disk and those + - accessed via an URL. -} +data RepoLocation = Dir FilePath | Url URI | Unknown + deriving (Show, Eq) + +data Repo = Repo { + location :: RepoLocation, + config :: M.Map String String, + remotes :: [Repo], + -- remoteName holds the name used for this repo in remotes + remoteName :: Maybe String +} deriving (Show, Eq) + +{- A git ref. Can be a sha1, or a branch or tag name. -} +newtype Ref = Ref String + deriving (Eq) + +instance Show Ref where + show (Ref v) = v + +{- Aliases for Ref. -} +type Branch = Ref +type Sha = Ref +type Tag = Ref diff --git a/GitAnnex.hs b/GitAnnex.hs index 7871638e4..a5b9609b6 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -10,7 +10,8 @@ module GitAnnex where import System.Console.GetOpt import Common.Annex -import qualified Git +import qualified Git.Config +import qualified Git.Construct import CmdLine import Command import Types.TrustLevel @@ -125,11 +126,11 @@ options = commonOptions ++ setprint0 v = Annex.changeState $ \s -> s { Annex.print0 = v } setgitconfig :: String -> Annex () setgitconfig v = do - newg <- inRepo $ Git.configStore v + newg <- inRepo $ Git.Config.store v Annex.changeState $ \s -> s { Annex.repo = newg } header :: String header = "Usage: git-annex command [option ..]" run :: [String] -> IO () -run args = dispatch args cmds options header Git.repoFromCwd +run args = dispatch args cmds options header Git.Construct.fromCwd diff --git a/Remote/Bup.hs b/Remote/Bup.hs index e705bbb34..4d63d88e1 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -15,6 +15,8 @@ import System.Process import Common.Annex import Types.Remote import qualified Git +import qualified Git.Config +import qualified Git.Construct import Config import Annex.Ssh import Remote.Helper.Special @@ -163,8 +165,8 @@ storeBupUUID u buprepo = do [Params $ "config annex.uuid " ++ v] >>! error "ssh failed" else liftIO $ do - r' <- Git.configRead r - let olduuid = Git.configGet "annex.uuid" "" r' + r' <- Git.Config.read r + let olduuid = Git.Config.get "annex.uuid" "" r' when (olduuid == "") $ Git.run "config" [Param "annex.uuid", Param v] r' @@ -192,9 +194,9 @@ getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo) getBupUUID r u | Git.repoIsUrl r = return (u, r) | otherwise = liftIO $ do - ret <- try $ Git.configRead r + ret <- try $ Git.Config.read r case ret of - Right r' -> return (toUUID $ Git.configGet "annex.uuid" "" r', r') + Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r') Left _ -> return (NoUUID, r) {- Converts a bup remote path spec into a Git.Repo. There are some @@ -203,13 +205,13 @@ bup2GitRemote :: BupRepo -> IO Git.Repo bup2GitRemote "" = do -- bup -r "" operates on ~/.bup h <- myHomeDir - Git.repoFromAbsPath $ h </> ".bup" + Git.Construct.fromAbsPath $ h </> ".bup" bup2GitRemote r | bupLocal r = if head r == '/' - then Git.repoFromAbsPath r + then Git.Construct.fromAbsPath r else error "please specify an absolute path" - | otherwise = Git.repoFromUrl $ "ssh://" ++ host ++ slash dir + | otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir where bits = split ":" r host = head bits diff --git a/Remote/Git.hs b/Remote/Git.hs index 2f9288e1b..9d80f4c1c 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -16,6 +16,8 @@ import Utility.RsyncFile import Annex.Ssh import Types.Remote import qualified Git +import qualified Git.Config +import qualified Git.Construct import qualified Annex import Annex.UUID import qualified Annex.Content @@ -44,7 +46,7 @@ list = do case M.lookup (annexurl n) c of Nothing -> return r Just url -> Git.repoRemoteNameSet n <$> - inRepo (Git.genRemote url) + inRepo (Git.Construct.fromRemoteLocation url) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen r u _ = do @@ -100,7 +102,7 @@ tryGitConfigRead r pipedconfig cmd params = safely $ pOpen ReadFromPipe cmd (toCommand params) $ - Git.hConfigRead r + Git.Config.hRead r geturlconfig = do s <- Url.get (Git.repoLocation r ++ "/config") @@ -108,7 +110,7 @@ tryGitConfigRead r hPutStr h s hClose h pOpen ReadFromPipe "git" ["config", "--list", "--file", tmpfile] $ - Git.hConfigRead r + Git.Config.hRead r store a = do r' <- a diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 77478eb1d..72c4842d8 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -12,6 +12,7 @@ import qualified Data.Map as M import Common.Annex import Types.Remote import qualified Git +import qualified Git.Construct {- Special remotes don't have a configured url, so Git.Repo does not - automatically generate remotes for them. This looks for a different @@ -23,7 +24,7 @@ findSpecialRemotes s = do return $ map construct $ remotepairs m where remotepairs = M.toList . M.filterWithKey match - construct (k,_) = Git.repoRemoteNameFromKey k Git.repoFromUnknown + construct (k,_) = Git.repoRemoteNameFromKey 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 d5acd7d86..c4e9f8bd6 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -10,6 +10,7 @@ module Remote.Web (remote) where import Common.Annex import Types.Remote import qualified Git +import qualified Git.Construct import Config import Logs.Web import qualified Utility.Url as Url @@ -26,7 +27,7 @@ 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.repoFromUnknown] +list = return [Git.repoRemoteNameSet "web" Git.Construct.fromUnknown] gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen r _ _ = diff --git a/git-annex-shell.hs b/git-annex-shell.hs index 9a9d2f092..872dabc58 100644 --- a/git-annex-shell.hs +++ b/git-annex-shell.hs @@ -9,7 +9,7 @@ import System.Environment import System.Console.GetOpt import Common.Annex -import qualified Git +import qualified Git.Construct import CmdLine import Command import Annex.UUID @@ -80,7 +80,7 @@ builtin :: String -> String -> [String] -> IO () builtin cmd dir params = do checkNotReadOnly cmd dispatch (cmd : filterparams params) cmds options header $ - Git.repoAbsPath dir >>= Git.repoFromAbsPath + Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath external :: [String] -> IO () external params = do diff --git a/git-annex.cabal b/git-annex.cabal index 35b3e690f..ae6a129b3 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 3.20111211 +Version: 3.20111212 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net> diff --git a/git-union-merge.hs b/git-union-merge.hs index edd9330c8..eeb694401 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -9,6 +9,8 @@ import System.Environment import Common import qualified Git.UnionMerge +import qualified Git.Config +import qualified Git.Construct import qualified Git header :: String @@ -38,7 +40,7 @@ parseArgs = do main :: IO () main = do [aref, bref, newref] <- map Git.Ref <$> parseArgs - g <- Git.configRead =<< Git.repoFromCwd + g <- Git.Config.read =<< Git.Construct.fromCwd _ <- Git.useIndex (tmpIndex g) setup g Git.UnionMerge.merge aref bref g @@ -25,6 +25,8 @@ import qualified Annex import qualified Annex.UUID import qualified Backend import qualified Git +import qualified Git.Config +import qualified Git.Construct import qualified Locations import qualified Types.Backend import qualified Types @@ -496,8 +498,8 @@ git_annex command params = do -- are not run; this should only be used for actions that query state. annexeval :: Types.Annex a -> IO a annexeval a = do - g <- Git.repoFromCwd - g' <- Git.configRead g + g <- Git.Construct.fromCwd + g' <- Git.Config.read g s <- Annex.new g' Annex.eval s a |