This commit is contained in:
Joey Hess 2010-10-12 00:53:42 -04:00
parent 107074d662
commit 92bf408c66
3 changed files with 72 additions and 33 deletions

View file

@ -86,7 +86,7 @@ gitPrep :: GitRepo -> IO ()
gitPrep repo = do gitPrep repo = do
-- configure git to use union merge driver on state files -- configure git to use union merge driver on state files
let attrLine = stateLoc ++ "/*.log merge=union" let attrLine = stateLoc ++ "/*.log merge=union"
attributes <- gitAttributes repo let attributes = gitAttributes repo
exists <- doesFileExist attributes exists <- doesFileExist attributes
if (not exists) if (not exists)
then do then do

View file

@ -7,9 +7,10 @@
module GitRepo ( module GitRepo (
GitRepo, GitRepo,
gitRepoFromPath,
gitRepoCurrent, gitRepoCurrent,
gitRepoTop, gitRepoFromPath,
gitRepoFromUrl,
gitWorkTree,
gitDir, gitDir,
gitRelative, gitRelative,
gitConfig, gitConfig,
@ -26,21 +27,28 @@ import System.IO
import System.Posix.Process import System.Posix.Process
import Data.String.Utils import Data.String.Utils
import Data.Map as Map (fromList, empty, lookup, Map) import Data.Map as Map (fromList, empty, lookup, Map)
import Network.URI
import Maybe
import Utility import Utility
-- a git repository {- A git repository can be local or remote. -}
data GitRepo = GitRepo { data GitRepo =
LocalGitRepo {
top :: FilePath, top :: FilePath,
bare :: Bool, bare :: Bool,
config :: Map String String config :: Map String String
} | RemoteGitRepo {
url :: String,
top :: FilePath,
config :: Map String String
} deriving (Show, Read, Eq) } deriving (Show, Read, Eq)
{- GitRepo constructor -} {- Local GitRepo constructor. -}
gitRepoFromPath :: FilePath -> IO GitRepo gitRepoFromPath :: FilePath -> IO GitRepo
gitRepoFromPath dir = do gitRepoFromPath dir = do
b <- isBareRepo dir b <- isBareRepo dir
let r = GitRepo { let r = LocalGitRepo {
top = dir, top = dir,
bare = b, bare = b,
config = Map.empty config = Map.empty
@ -49,28 +57,49 @@ gitRepoFromPath dir = do
return r' return r'
{- Field accessor. -} {- Remote GitRepo constructor. Note that remote repo config is not read.
gitRepoTop :: GitRepo -> FilePath - Throws exception on invalid url. -}
gitRepoTop repo = top repo gitRepoFromUrl :: String -> IO GitRepo
gitRepoFromUrl url = do
return RemoteGitRepo {
url = url,
top = path url,
config = Map.empty
}
where path url = uriPath $ fromJust $ parseURI url
{- Some code needs to vary between remote and local repos. -}
local repo = case (repo) of
LocalGitRepo {} -> True
RemoteGitRepo {} -> False
remote repo = not $ local repo
assertlocal repo action =
if (local repo)
then action
else error "acting on remote git repo not supported"
{- Path to a repository's gitattributes file. -} {- Path to a repository's gitattributes file. -}
gitAttributes :: GitRepo -> IO String gitAttributes :: GitRepo -> String
gitAttributes repo = do gitAttributes repo = assertlocal repo $ do
if (bare repo) if (bare repo)
then return $ (top repo) ++ "/info/.gitattributes" then (top repo) ++ "/info/.gitattributes"
else return $ (top repo) ++ "/.gitattributes" else (top repo) ++ "/.gitattributes"
{- Path to a repository's .git directory. {- Path to a repository's .git directory.
- (For a bare repository, that is the root of the repository.) - (For a bare repository, that is the root of the repository.)
- TODO: support GIT_DIR -} - TODO: support GIT_DIR -}
gitDir :: GitRepo -> String gitDir :: GitRepo -> String
gitDir repo = gitDir repo = assertlocal repo $
if (bare repo) if (bare repo)
then top repo then top repo
else top repo ++ "/.git" else top repo ++ "/.git"
{- Given a relative or absolute filename, calculates the name to use {- Path to a repository's --work-tree. -}
- to refer to the file relative to a git repository directory. gitWorkTree :: GitRepo -> FilePath
gitWorkTree repo = top repo
{- Given a relative or absolute filename in a repository, calculates the
- name to use to refer to the file relative to a git repository's top.
- This is the same form displayed and used by git. -} - This is the same form displayed and used by git. -}
gitRelative :: GitRepo -> String -> String gitRelative :: GitRepo -> String -> String
gitRelative repo file = drop (length absrepo) absfile gitRelative repo file = drop (length absrepo) absfile
@ -92,26 +121,36 @@ gitAdd repo file = runGit repo ["add", file]
gitCommandLine :: GitRepo -> [String] -> [String] gitCommandLine :: GitRepo -> [String] -> [String]
gitCommandLine repo params = gitCommandLine repo params =
-- force use of specified repo via --git-dir and --work-tree -- force use of specified repo via --git-dir and --work-tree
["--git-dir="++(gitDir repo), "--work-tree="++(top repo)] ++ params if (local repo)
then ["--git-dir="++(gitDir repo), "--work-tree="++(top repo)] ++ params
else error "gitCommandLine not implemented for remote repo"
{- Runs git in the specified repo. -} {- Runs git in the specified repo. -}
runGit :: GitRepo -> [String] -> IO () runGit :: GitRepo -> [String] -> IO ()
runGit repo params = do runGit repo params =
if (local repo)
then do
r <- executeFile "git" True (gitCommandLine repo params) Nothing r <- executeFile "git" True (gitCommandLine repo params) Nothing
return () return ()
else error "runGit not implemented for remote repo"
{- Runs a git subcommand and returns its output. -} {- Runs a git subcommand and returns its output. -}
gitPipeRead :: GitRepo -> [String] -> IO String gitPipeRead :: GitRepo -> [String] -> IO String
gitPipeRead repo params = gitPipeRead repo params =
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do if (local repo)
then pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
ret <- hGetContentsStrict h ret <- hGetContentsStrict h
return ret return ret
else error "gitPipeRead not implemented for remote repo"
{- Runs git config and populates a repo with its settings. -} {- Runs git config and populates a repo with its settings. -}
gitConfigRead :: GitRepo -> IO GitRepo gitConfigRead :: GitRepo -> IO GitRepo
gitConfigRead repo = do gitConfigRead repo =
if (local repo)
then do
c <- gitPipeRead repo ["config", "--list"] c <- gitPipeRead repo ["config", "--list"]
return repo { config = gitConfigParse c } return repo { config = gitConfigParse c }
else error "gitConfigRead not implemented for remote repo"
{- Parses git config --list output into a config map. -} {- Parses git config --list output into a config map. -}
gitConfigParse :: String -> Map.Map String String gitConfigParse :: String -> Map.Map String String

View file

@ -9,7 +9,7 @@ module Locations (
import GitRepo import GitRepo
{- Long-term, cross-repo state is stored in files inside the .git-annex {- Long-term, cross-repo state is stored in files inside the .git-annex
- directory, in the git repository. -} - directory, in the git repository's working tree. -}
stateLoc = ".git-annex" stateLoc = ".git-annex"
gitStateDir :: GitRepo -> FilePath gitStateDir :: GitRepo -> FilePath
gitStateDir repo = (gitRepoTop repo) ++ "/" ++ stateLoc ++ "/" gitStateDir repo = (gitWorkTree repo) ++ "/" ++ stateLoc ++ "/"