moved config reading into GitRepo

Annex.hs

@@ -20,49 +20,41 @@ import LocationLog
 -- git-annex's runtime state
 data State = State {
 	repo :: GitRepo,
-	config :: Config
-}
-
-data Config = Config {
-	annex_name :: String,
-	annex_numcopies :: Int,
-	annex_backends :: [Backend]
+	backends :: [Backend]
 }
 
 {- An annexed file's content is stored somewhere under .git/annex/ -}
-annexDir :: GitRepo -> Key -> IO FilePath
-annexDir repo key = do
-	dir <- gitDir repo
-	return $ dir ++ "/annex/" ++ key
+annexDir :: GitRepo -> Key -> FilePath
+annexDir repo key = gitDir repo ++ "/annex/" ++ key
 
 {- On startup, examine the git repo, prepare it, and record state for
  - later. -}
 startAnnex :: IO State
 startAnnex = do
 	r <- gitRepoCurrent
-	config <- queryConfig r
 	gitPrep r
+
 	return State {
 		repo = r,
-		config = config
+		backends = parseBackendList $ gitConfig r "annex.backends" ""
 	}
 
 {- Annexes a file, storing it in a backend, and then moving it into
  - the annex directory and setting up the symlink pointing to its content. -}
 annexFile :: State -> FilePath -> IO ()
 annexFile state file = do
-	alreadyannexed <- lookupBackend backends (repo state) file
+	alreadyannexed <- lookupBackend (backends state) (repo state) file
 	case (alreadyannexed) of
 		Just _ -> error $ "already annexed: " ++ file
 		Nothing -> do
 			checkLegal file
-			stored <- storeFile backends (repo state) file
+			stored <- storeFile (backends state) (repo state) file
 			case (stored) of
 				Nothing -> error $ "no backend could store: " ++ file
 				Just key -> symlink key
 	where
 		symlink key = do
-			dest <- annexDir (repo state) key
+			let dest = annexDir (repo state) key
 			createDirectoryIfMissing True (parentDir dest)
 			renameFile file dest
 			createSymbolicLink dest file
@@ -72,40 +64,22 @@ annexFile state file = do
 			if ((isSymbolicLink s) || (not $ isRegularFile s))
 				then error $ "not a regular file: " ++ file
 				else return ()
-		backends = getConfig state annex_backends
 
 {- Inverse of annexFile. -}
 unannexFile :: State -> FilePath -> IO ()
 unannexFile state file = do
-	alreadyannexed <- lookupBackend backends (repo state) file
+	alreadyannexed <- lookupBackend (backends state) (repo state) file
 	case (alreadyannexed) of
 		Nothing -> error $ "not annexed " ++ file
 		Just _ -> do
-			mkey <- dropFile backends (repo state) file
+			mkey <- dropFile (backends state) (repo state) file
 			case (mkey) of
 				Nothing -> return ()
 				Just key -> do
-					src <- annexDir (repo state) key
+					let src = annexDir (repo state) key
 					removeFile file
 					renameFile src file
 					return ()
-	where
-		backends = getConfig state annex_backends
-
-{- Query the git repo for relevant configuration settings. -}
-queryConfig :: GitRepo -> IO Config
-queryConfig repo = do
-	-- a name can be configured, if none is, use the repository path
-	name <- gitConfigGet "annex.name" (gitRepoTop repo)
-	-- default number of copies to keep of file contents is 1
-	numcopies <- gitConfigGet "annex.numcopies" "1"
-	backends <- gitConfigGet "annex.backends" ""
-	
-	return Config {
-		annex_name = name,
-		annex_numcopies = read numcopies,
-		annex_backends = parseBackendList backends
-	}
 
 {- Sets up a git repo for git-annex. May be called repeatedly. -}
 gitPrep :: GitRepo -> IO ()
@@ -125,7 +99,3 @@ gitPrep repo = do
 					appendFile attributes $ attrLine ++ "\n"
 					gitAdd repo attributes
 				else return ()
-
-{- Looks up a key in a State's Config -}
-getConfig :: State -> (Config -> b) -> b
-getConfig state key = key $ config state

GitRepo.hs

@@ -1,4 +1,9 @@
-{- git repository handling -}
+{- git repository handling 
+ -
+ - This is written to be completely independant of git-annex and should be
+ - suitable for other uses.
+ -
+ - -}
 
 module GitRepo (
 	GitRepo,
@@ -6,38 +11,46 @@ module GitRepo (
 	gitRepoTop,
 	gitDir,
 	gitRelative,
-	gitConfigGet,
+	gitConfig,
 	gitAdd,
 	gitAttributes
 ) where
 
 import Directory
+import System
 import System.Directory
 import System.Path
 import System.Cmd.Utils
 import System.IO
-import System.IO.Error
+import System.Posix.Process
 import Data.String.Utils
+import Data.Map as Map (fromList, empty, lookup, Map)
 import Utility
 
 -- a git repository
 data GitRepo = GitRepo {
-	gitRepoTop :: FilePath,
-	bare :: Bool
-}
+	top :: FilePath,
+	bare :: Bool,
+	config :: Map String String
+} deriving (Show, Read, Eq)
 
 {- GitRepo constructor -}
 gitRepo :: FilePath -> IO GitRepo
 gitRepo dir = do
 	b <- isBareRepo dir
 
-	return GitRepo {
-		gitRepoTop = dir,
-		bare = b
+	let r = GitRepo {
+		top = dir,
+		bare = b,
+		config = Map.empty
 	}
+	r' <- gitConfigRead r
 
-{- Short name used in here for top of repo. -}
-top = gitRepoTop
+	return r'
+
+{- Field accessor. -}
+gitRepoTop :: GitRepo -> FilePath
+gitRepoTop repo = top repo
 
 {- Path to a repository's gitattributes file. -}
 gitAttributes :: GitRepo -> IO String
@@ -49,11 +62,11 @@ gitAttributes repo = do
 {- Path to a repository's .git directory.
  - (For a bare repository, that is the root of the repository.)
  - TODO: support GIT_DIR -}
-gitDir :: GitRepo -> IO String
-gitDir repo = do
+gitDir :: GitRepo -> String
+gitDir repo = 
 	if (bare repo)
-		then return $ (top repo)
-		else return $ (top repo) ++ "/.git"
+		then top repo
+		else top repo ++ "/.git"
 
 {- Given a relative or absolute filename, calculates the name to use
  - to refer to the file relative to a git repository directory.
@@ -72,17 +85,45 @@ gitRelative repo file = drop (length absrepo) absfile
 
 {- Stages a changed file in git's index. -}
 gitAdd :: GitRepo -> FilePath -> IO ()
-gitAdd repo file = do
-	-- TODO
+gitAdd repo file = runGit repo ["add", file]
+
+{- Constructs a git command line operating on the specified repo. -}
+gitCommandLine :: GitRepo -> [String] -> [String]
+gitCommandLine repo params =
+	-- force use of specified repo via --git-dir and --work-tree
+	["--git-dir="++(gitDir repo), "--work-tree="++(top repo)] ++ params
+
+{- Runs git in the specified repo. -}
+runGit :: GitRepo -> [String] -> IO ()
+runGit repo params = do
+	r <- executeFile "git" True (gitCommandLine repo params) Nothing
 	return ()
 
-{- Queries git-config. -}
-gitConfigGet :: String -> String -> IO String
-gitConfigGet name defaultValue = 
-	flip catch (\_ -> return defaultValue) $
-		pOpen ReadFromPipe "git" ["config", "--get", name] $ \h -> do
-			ret <- hGetLine h
-			return ret
+{- Runs a git subcommand and returns its output. -}
+gitPipeRead :: GitRepo -> [String] -> IO String
+gitPipeRead repo params =
+	pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
+		ret <- hGetContentsStrict h
+		return ret
+
+{- Runs git config and populates a repo with its settings. -}
+gitConfigRead :: GitRepo -> IO GitRepo
+gitConfigRead repo = do
+	c <- gitPipeRead repo ["config", "--list"]
+	return repo { config = Map.fromList $ parse c }
+		where
+			parse s = map ( \l -> (key l, val l) ) $ lines s
+			keyval l = split sep l :: [String]
+			key l = (keyval l) !! 0
+			val l = join sep $ drop 1 $ keyval l
+			sep = "="
+
+{- Returns a single git config setting, or a default value if not set. -}
+gitConfig :: GitRepo -> String -> String -> String
+gitConfig repo key defaultValue = 
+	case (Map.lookup key $ config repo) of
+		Just value -> value
+		Nothing -> defaultValue
 
 {- Finds the current git repository, which may be in a parent directory. -}
 gitRepoCurrent :: IO GitRepo