diff options
| -rw-r--r-- | Annex.hs | 52 | ||||
| -rw-r--r-- | GitRepo.hs | 89 |
2 files changed, 76 insertions, 65 deletions
@@ -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 diff --git a/GitRepo.hs b/GitRepo.hs index de54f6dca..7ae6584dd 100644 --- a/GitRepo.hs +++ b/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 |