faddle
This commit is contained in:
parent
107074d662
commit
92bf408c66
3 changed files with 72 additions and 33 deletions
2
Annex.hs
2
Annex.hs
|
@ -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
|
||||||
|
|
79
GitRepo.hs
79
GitRepo.hs
|
@ -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
|
||||||
|
|
|
@ -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 ++ "/"
|
||||||
|
|
Loading…
Reference in a new issue