summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-12-13 15:05:07 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-12-13 15:06:49 -0400
commit13fff71f2019ae098c3f8532ac2734cb1ab11498 (patch)
treef37714c4089df4afac9bf9724c80757e5fd29e6f
parent46588674b081cd4ea5820680d8fc15c81ed175ad (diff)
split out three modules from Git
Constructors and configuration make sense in separate modules. A separate Git.Types is needed to avoid cycles.
-rw-r--r--Annex.hs3
-rw-r--r--Annex/UUID.hs5
-rw-r--r--Annex/Version.hs4
-rw-r--r--Backend.hs3
-rw-r--r--Command/Map.hs10
-rw-r--r--Command/Sync.hs5
-rw-r--r--Config.hs9
-rw-r--r--Git.hs250
-rw-r--r--Git/Config.hs58
-rw-r--r--Git/Construct.hs198
-rw-r--r--Git/Types.hs36
-rw-r--r--GitAnnex.hs7
-rw-r--r--Remote/Bup.hs16
-rw-r--r--Remote/Git.hs8
-rw-r--r--Remote/Helper/Special.hs3
-rw-r--r--Remote/Web.hs3
-rw-r--r--git-annex-shell.hs4
-rw-r--r--git-annex.cabal2
-rw-r--r--git-union-merge.hs4
-rw-r--r--test.hs6
20 files changed, 349 insertions, 285 deletions
diff --git a/Annex.hs b/Annex.hs
index d8d9c63b4..acc38a5db 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -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
diff --git a/Config.hs b/Config.hs
index c6107fc8e..322dc8af8 100644
--- a/Config.hs
+++ b/Config.hs
@@ -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"
diff --git a/Git.hs b/Git.hs
index 9af68a194..cb7cc19c2 100644
--- a/Git.hs
+++ b/Git.hs
@@ -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
diff --git a/test.hs b/test.hs
index 91c11873d..14994865f 100644
--- a/test.hs
+++ b/test.hs
@@ -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