diff options
| -rw-r--r-- | Annex.hs | 78 | ||||
| -rw-r--r-- | Backend.hs | 4 | ||||
| -rw-r--r-- | BackendFile.hs | 8 | ||||
| -rw-r--r-- | CmdLine.hs | 14 | ||||
| -rw-r--r-- | GitRepo.hs | 158 | ||||
| -rw-r--r-- | LocationLog.hs | 10 | ||||
| -rw-r--r-- | Locations.hs | 14 | ||||
| -rw-r--r-- | Remotes.hs | 34 | ||||
| -rw-r--r-- | Types.hs | 24 | ||||
| -rw-r--r-- | UUID.hs | 16 | ||||
| -rw-r--r-- | git-annex.hs | 2 |
11 files changed, 173 insertions, 189 deletions
@@ -2,14 +2,14 @@ -} module Annex ( - startAnnex, - annexFile, - unannexFile, - annexGetFile, - annexWantFile, - annexDropFile, - annexPushRepo, - annexPullRepo + start, + annexCmd, + unannexCmd, + getCmd, + wantCmd, + dropCmd, + pushCmd, + pullCmd ) where import Control.Monad.State (liftIO) @@ -17,7 +17,7 @@ import System.Posix.Files import System.Directory import Data.String.Utils import List -import GitRepo +import qualified GitRepo as Git import Utility import Locations import Backend @@ -29,20 +29,20 @@ import AbstractTypes {- Create and returns an Annex state object. - Examines and prepares the git repo. -} -startAnnex :: IO AnnexState -startAnnex = do - g <- gitRepoFromCwd +start :: IO AnnexState +start = do + g <- Git.repoFromCwd let s = makeAnnexState g (_,s') <- runAnnexState s (prep g) return s' where prep g = do -- setup git and read its config; update state - g' <- liftIO $ gitConfigRead g + g' <- liftIO $ Git.configRead g gitAnnexChange g' liftIO $ gitSetup g' backendsAnnexChange $ parseBackendList $ - gitConfig g' "annex.backends" "" + Git.configGet g' "annex.backends" "" prepUUID inBackend file yes no = do @@ -54,8 +54,8 @@ notinBackend file yes no = inBackend file no yes {- 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 :: FilePath -> Annex () -annexFile file = inBackend file err $ do +annexCmd :: FilePath -> Annex () +annexCmd file = inBackend file err $ do liftIO $ checkLegal file stored <- storeFile file g <- gitAnnex @@ -77,8 +77,8 @@ annexFile file = inBackend file err $ do createDirectoryIfMissing True (parentDir dest) renameFile file dest createSymbolicLink ((linkTarget file) ++ reldest) file - gitRun g ["add", file] - gitRun g ["commit", "-m", + Git.run g ["add", file] + Git.run g ["commit", "-m", ("git-annex annexed " ++ file), file] linkTarget file = -- relies on file being relative to the top of the @@ -90,9 +90,9 @@ annexFile file = inBackend file err $ do subdirs = (length $ split "/" file) - 1 -{- Inverse of annexFile. -} -unannexFile :: FilePath -> Annex () -unannexFile file = notinBackend file err $ \(key, backend) -> do +{- Inverse of annexCmd. -} +unannexCmd :: FilePath -> Annex () +unannexCmd file = notinBackend file err $ \(key, backend) -> do dropFile backend key logStatus key ValueMissing g <- gitAnnex @@ -102,8 +102,8 @@ unannexFile file = notinBackend file err $ \(key, backend) -> do err = error $ "not annexed " ++ file moveout g src = do removeFile file - gitRun g ["rm", file] - gitRun g ["commit", "-m", + Git.run g ["rm", file] + Git.run g ["commit", "-m", ("git-annex unannexed " ++ file), file] -- git rm deletes empty directories; -- put them back @@ -112,8 +112,8 @@ unannexFile file = notinBackend file err $ \(key, backend) -> do return () {- Gets an annexed file from one of the backends. -} -annexGetFile :: FilePath -> Annex () -annexGetFile file = notinBackend file err $ \(key, backend) -> do +getCmd :: FilePath -> Annex () +getCmd file = notinBackend file err $ \(key, backend) -> do inannex <- inAnnex backend key if (inannex) then return () @@ -131,23 +131,23 @@ annexGetFile file = notinBackend file err $ \(key, backend) -> do err = error $ "not annexed " ++ file {- Indicates a file is wanted. -} -annexWantFile :: FilePath -> Annex () -annexWantFile file = do error "not implemented" -- TODO +wantCmd :: FilePath -> Annex () +wantCmd file = do error "not implemented" -- TODO {- Indicates a file is not wanted. -} -annexDropFile :: FilePath -> Annex () -annexDropFile file = do error "not implemented" -- TODO +dropCmd :: FilePath -> Annex () +dropCmd file = do error "not implemented" -- TODO {- Pushes all files to a remote repository. -} -annexPushRepo :: String -> Annex () -annexPushRepo reponame = do error "not implemented" -- TODO +pushCmd :: String -> Annex () +pushCmd reponame = do error "not implemented" -- TODO {- Pulls all files from a remote repository. -} -annexPullRepo :: String -> Annex () -annexPullRepo reponame = do error "not implemented" -- TODO +pullCmd :: String -> Annex () +pullCmd reponame = do error "not implemented" -- TODO {- Sets up a git repo for git-annex. May be called repeatedly. -} -gitSetup :: GitRepo -> IO () +gitSetup :: Git.Repo -> IO () gitSetup repo = do -- configure git to use union merge driver on state files exists <- doesFileExist attributes @@ -164,10 +164,10 @@ gitSetup repo = do else return () where attrLine = stateLoc ++ "/*.log merge=union" - attributes = gitAttributes repo + attributes = Git.attributes repo commit = do - gitRun repo ["add", attributes] - gitRun repo ["commit", "-m", "git-annex setup", + Git.run repo ["add", attributes] + Git.run repo ["commit", "-m", "git-annex setup", attributes] {- Updates the LocationLog when a key's presence changes. -} @@ -179,8 +179,8 @@ logStatus key status = do liftIO $ commit g f where commit g f = do - gitRun g ["add", f] - gitRun g ["commit", "-m", "git-annex log update", f] + Git.run g ["add", f] + Git.run g ["commit", "-m", "git-annex log update", f] {- Checks if a given key is currently present in the annexLocation -} inAnnex :: Backend -> Key -> Annex Bool diff --git a/Backend.hs b/Backend.hs index 775c4a02f..1bd4efc1e 100644 --- a/Backend.hs +++ b/Backend.hs @@ -28,7 +28,7 @@ import Data.String.Utils import System.Posix.Files import BackendList import Locations -import GitRepo +import qualified GitRepo as Git import Utility import Types @@ -36,7 +36,7 @@ import Types storeFile :: FilePath -> Annex (Maybe (Key, Backend)) storeFile file = do g <- gitAnnex - let relfile = gitRelative g file + let relfile = Git.relative g file b <- backendsAnnex storeFile' b file relfile storeFile' [] _ _ = return Nothing diff --git a/BackendFile.hs b/BackendFile.hs index e821ac22b..6c1dc0623 100644 --- a/BackendFile.hs +++ b/BackendFile.hs @@ -11,7 +11,7 @@ import Types import LocationLog import Locations import Remotes -import GitRepo +import qualified GitRepo as Git backend = Backend { name = "file", @@ -58,11 +58,11 @@ copyKeyFile key file = do Right succ -> return True {- Tries to copy a file from a remote, exception on error. -} -copyFromRemote :: GitRepo -> Key -> FilePath -> IO () +copyFromRemote :: Git.Repo -> Key -> FilePath -> IO () copyFromRemote r key file = do - putStrLn $ "copy from " ++ (gitRepoDescribe r ) ++ " " ++ file + putStrLn $ "copy from " ++ (Git.repoDescribe r ) ++ " " ++ file - if (gitRepoIsLocal r) + if (Git.repoIsLocal r) then getlocal else getremote return () diff --git a/CmdLine.hs b/CmdLine.hs index bb908a2e4..479be7e8b 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -43,10 +43,10 @@ argvToMode argv = do dispatch :: Mode -> FilePath -> Annex () dispatch mode item = do case (mode) of - Add -> annexFile item - Push -> annexPushRepo item - Pull -> annexPullRepo item - Want -> annexWantFile item - Get -> annexGetFile item - Drop -> annexDropFile item - Unannex -> unannexFile item + Add -> annexCmd item + Push -> pushCmd item + Pull -> pullCmd item + Want -> wantCmd item + Get -> getCmd item + Drop -> dropCmd item + Unannex -> unannexCmd item diff --git a/GitRepo.hs b/GitRepo.hs index d22218219..f3bb5427a 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -3,27 +3,27 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - -} + -} module GitRepo ( - GitRepo, - gitRepoFromCwd, - gitRepoFromPath, - gitRepoFromUrl, - gitRepoIsLocal, - gitRepoIsRemote, - gitRepoDescribe, - gitWorkTree, - gitDir, - gitRelative, - gitConfig, - gitConfigMap, - gitConfigRead, - gitRun, - gitAttributes, - gitRepoRemotes, - gitRepoRemotesAdd, - gitRepoRemoteName + Repo, + repoFromCwd, + repoFromPath, + repoFromUrl, + repoIsLocal, + repoIsRemote, + repoDescribe, + workTree, + dir, + relative, + configGet, + configMap, + configRead, + run, + attributes, + remotes, + remotesAdd, + repoRemoteName ) where import Directory @@ -44,35 +44,35 @@ import Utility {- A git repository can be on local disk or remote. Not to be confused - with a git repo's configured remotes, some of which may be on local - disk. -} -data GitRepo = - LocalGitRepo { +data Repo = + LocalRepo { top :: FilePath, config :: Map String String, - remotes :: [GitRepo], + remotes :: [Repo], -- remoteName holds the name used for this repo in remotes remoteName :: Maybe String - } | RemoteGitRepo { + } | RemoteRepo { url :: String, top :: FilePath, config :: Map String String, - remotes :: [GitRepo], + remotes :: [Repo], remoteName :: Maybe String } deriving (Show, Read, Eq) -{- Local GitRepo constructor. -} -gitRepoFromPath :: FilePath -> GitRepo -gitRepoFromPath dir = - LocalGitRepo { +{- Local Repo constructor. -} +repoFromPath :: FilePath -> Repo +repoFromPath dir = + LocalRepo { top = dir, config = Map.empty, remotes = [], remoteName = Nothing } -{- Remote GitRepo constructor. Throws exception on invalid url. -} -gitRepoFromUrl :: String -> GitRepo -gitRepoFromUrl url = - RemoteGitRepo { +{- Remote Repo constructor. Throws exception on invalid url. -} +repoFromUrl :: String -> Repo +repoFromUrl url = + RemoteRepo { url = url, top = path url, config = Map.empty, @@ -82,72 +82,68 @@ gitRepoFromUrl url = where path url = uriPath $ fromJust $ parseURI url {- User-visible description of a git repo. -} -gitRepoDescribe repo = +repoDescribe repo = if (isJust $ remoteName repo) then fromJust $ remoteName repo - else if (gitRepoIsLocal repo) + else if (repoIsLocal repo) then top repo else url repo -{- Returns the list of a repo's remotes. -} -gitRepoRemotes :: GitRepo -> [GitRepo] -gitRepoRemotes r = remotes r - {- Constructs and returns an updated version of a repo with - different remotes list. -} -gitRepoRemotesAdd :: GitRepo -> [GitRepo] -> GitRepo -gitRepoRemotesAdd repo rs = repo { remotes = rs } +remotesAdd :: Repo -> [Repo] -> Repo +remotesAdd repo rs = repo { remotes = rs } {- Returns the name of the remote that corresponds to the repo, if - it is a remote. Otherwise, "" -} -gitRepoRemoteName r = +repoRemoteName r = if (isJust $ remoteName r) then fromJust $ remoteName r else "" {- Some code needs to vary between remote and local repos, or bare and - non-bare, these functions help with that. -} -gitRepoIsLocal repo = case (repo) of - LocalGitRepo {} -> True - RemoteGitRepo {} -> False -gitRepoIsRemote repo = not $ gitRepoIsLocal repo +repoIsLocal repo = case (repo) of + LocalRepo {} -> True + RemoteRepo {} -> False +repoIsRemote repo = not $ repoIsLocal repo assertlocal repo action = - if (gitRepoIsLocal repo) + if (repoIsLocal repo) then action - else error $ "acting on remote git repo " ++ (gitRepoDescribe repo) ++ + else error $ "acting on remote git repo " ++ (repoDescribe repo) ++ " not supported" -bare :: GitRepo -> Bool +bare :: Repo -> Bool bare repo = if (member b (config repo)) then ("true" == fromJust (Map.lookup b (config repo))) - else error $ "it is not known if git repo " ++ (gitRepoDescribe repo) ++ + else error $ "it is not known if git repo " ++ (repoDescribe repo) ++ " is a bare repository; config not read" where b = "core.bare" {- Path to a repository's gitattributes file. -} -gitAttributes :: GitRepo -> String -gitAttributes repo = assertlocal repo $ do +attributes :: Repo -> String +attributes repo = assertlocal repo $ do if (bare repo) then (top repo) ++ "/info/.gitattributes" else (top repo) ++ "/.gitattributes" {- Path to a repository's .git directory, relative to its topdir. -} -gitDir :: GitRepo -> String -gitDir repo = assertlocal repo $ +dir :: Repo -> String +dir repo = assertlocal repo $ if (bare repo) then "" else ".git" {- Path to a repository's --work-tree. -} -gitWorkTree :: GitRepo -> FilePath -gitWorkTree repo = top repo +workTree :: Repo -> FilePath +workTree 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. -} -gitRelative :: GitRepo -> String -> String -gitRelative repo file = drop (length absrepo) absfile +relative :: Repo -> String -> String +relative repo file = drop (length absrepo) absfile where -- normalize both repo and file, so that repo -- will be substring of file @@ -159,27 +155,27 @@ gitRelative repo file = drop (length absrepo) absfile Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo {- Constructs a git command line operating on the specified repo. -} -gitCommandLine :: GitRepo -> [String] -> [String] +gitCommandLine :: Repo -> [String] -> [String] gitCommandLine repo params = assertlocal repo $ -- force use of specified repo via --git-dir and --work-tree - ["--git-dir="++(top repo)++"/"++(gitDir repo), "--work-tree="++(top repo)] ++ params + ["--git-dir="++(top repo)++"/"++(dir repo), "--work-tree="++(top repo)] ++ params {- Runs git in the specified repo. -} -gitRun :: GitRepo -> [String] -> IO () -gitRun repo params = assertlocal repo $ do +run :: Repo -> [String] -> IO () +run repo params = assertlocal repo $ do r <- rawSystem "git" (gitCommandLine repo params) return () {- Runs a git subcommand and returns its output. -} -gitPipeRead :: GitRepo -> [String] -> IO String +gitPipeRead :: Repo -> [String] -> IO String gitPipeRead repo params = assertlocal repo $ do pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do ret <- hGetContentsStrict h return ret {- Runs git config and populates a repo with its config. -} -gitConfigRead :: GitRepo -> IO GitRepo -gitConfigRead repo = assertlocal repo $ do +configRead :: Repo -> IO Repo +configRead repo = assertlocal repo $ do {- Cannot use gitPipeRead because it relies on the config having been already read. Instead, chdir to the repo. -} cwd <- getCurrentDirectory @@ -187,12 +183,12 @@ gitConfigRead repo = assertlocal repo $ do (\_ -> changeWorkingDirectory cwd) $ pOpen ReadFromPipe "git" ["config", "--list"] $ \h -> do val <- hGetContentsStrict h - let r = repo { config = gitConfigParse val } - return r { remotes = gitConfigRemotes r } + let r = repo { config = configParse val } + return r { remotes = configRemotes r } {- Calculates a list of a repo's configured remotes, by parsing its config. -} -gitConfigRemotes :: GitRepo -> [GitRepo] -gitConfigRemotes repo = map construct remotes +configRemotes :: Repo -> [Repo] +configRemotes repo = map construct remotes where remotes = toList $ filter $ config repo filter = filterWithKey (\k _ -> isremote k) @@ -200,12 +196,12 @@ gitConfigRemotes repo = map construct remotes remotename k = (split "." k) !! 1 construct (k,v) = (gen v) { remoteName = Just $ remotename k } gen v = if (isURI v) - then gitRepoFromUrl v - else gitRepoFromPath v + then repoFromUrl v + else repoFromPath v {- Parses git config --list output into a config map. -} -gitConfigParse :: String -> Map.Map String String -gitConfigParse s = Map.fromList $ map pair $ lines s +configParse :: String -> Map.Map String String +configParse s = Map.fromList $ map pair $ lines s where pair l = (key l, val l) key l = (keyval l) !! 0 @@ -214,21 +210,21 @@ gitConfigParse s = Map.fromList $ map pair $ lines s sep = "=" {- Returns a single git config setting, or a default value if not set. -} -gitConfig :: GitRepo -> String -> String -> String -gitConfig repo key defaultValue = +configGet :: Repo -> String -> String -> String +configGet repo key defaultValue = Map.findWithDefault defaultValue key (config repo) {- Access to raw config Map -} -gitConfigMap :: GitRepo -> Map String String -gitConfigMap repo = config repo +configMap :: Repo -> Map String String +configMap repo = config repo {- Finds the current git repository, which may be in a parent directory. -} -gitRepoFromCwd :: IO GitRepo -gitRepoFromCwd = do +repoFromCwd :: IO Repo +repoFromCwd = do cwd <- getCurrentDirectory top <- seekUp cwd isRepoTop case top of - (Just dir) -> return $ gitRepoFromPath dir + (Just dir) -> return $ repoFromPath dir Nothing -> error "Not in a git repository." seekUp :: String -> (String -> IO Bool) -> IO (Maybe String) @@ -241,11 +237,11 @@ seekUp dir want = do d -> seekUp d want isRepoTop dir = do - r <- isGitRepo dir + r <- isRepo dir b <- isBareRepo dir return (r || b) where - isGitRepo dir = gitSignature dir ".git" ".git/config" + isRepo dir = gitSignature dir ".git" ".git/config" isBareRepo dir = gitSignature dir "objects" "config" gitSignature dir subdir file = do s <- (doesDirectoryExist (dir ++ "/" ++ subdir)) diff --git a/LocationLog.hs b/LocationLog.hs index a6d998e0a..7953b345f 100644 --- a/LocationLog.hs +++ b/LocationLog.hs @@ -29,7 +29,7 @@ import qualified Data.Map as Map import System.IO import System.Directory import Data.Char -import GitRepo +import qualified GitRepo as Git import Utility import UUID import AbstractTypes @@ -81,7 +81,7 @@ instance Read LogLine where {- Log a change in the presence of a key's value in a repository, - and return the log filename. -} -logChange :: GitRepo -> Key -> UUID -> LogStatus -> IO FilePath +logChange :: Git.Repo -> Key -> UUID -> LogStatus -> IO FilePath logChange repo key uuid status = do log <- logNow status uuid ls <- readLog logfile @@ -127,13 +127,13 @@ logNow status uuid = do return $ LogLine now status uuid {- Returns the filename of the log file for a given key. -} -logFile :: GitRepo -> Key -> String +logFile :: Git.Repo -> Key -> String logFile repo key = - (gitStateDir repo) ++ (gitRelative repo (keyFile key)) ++ ".log" + (gitStateDir repo) ++ (Git.relative repo (keyFile key)) ++ ".log" {- Returns a list of repository UUIDs that, according to the log, have - the value of a key. -} -keyLocations :: GitRepo -> Key -> IO [UUID] +keyLocations :: Git.Repo -> Key -> IO [UUID] keyLocations thisrepo key = do lines <- readLog $ logFile thisrepo key return $ map uuid (filterPresent lines) diff --git a/Locations.hs b/Locations.hs index 68a958192..5d701681c 100644 --- a/Locations.hs +++ b/Locations.hs @@ -12,27 +12,27 @@ module Locations ( import Data.String.Utils import Types -import GitRepo +import qualified GitRepo as Git {- Long-term, cross-repo state is stored in files inside the .git-annex - directory, in the git repository's working tree. -} stateLoc = ".git-annex" -gitStateDir :: GitRepo -> FilePath -gitStateDir repo = (gitWorkTree repo) ++ "/" ++ stateLoc ++ "/" +gitStateDir :: Git.Repo -> FilePath +gitStateDir repo = (Git.workTree repo) ++ "/" ++ stateLoc ++ "/" {- An annexed file's content is stored in - /path/to/repo/.git/annex/<backend>/<key> - - (That allows deriving the key and backend by looking at the symlink to it.) -} -annexLocation :: GitRepo -> Backend -> Key -> FilePath +annexLocation :: Git.Repo -> Backend -> Key -> FilePath annexLocation r backend key = - (gitWorkTree r) ++ "/" ++ (annexLocationRelative r backend key) + (Git.workTree r) ++ "/" ++ (annexLocationRelative r backend key) {- Annexed file's location relative to the gitWorkTree -} -annexLocationRelative :: GitRepo -> Backend -> Key -> FilePath +annexLocationRelative :: Git.Repo -> Backend -> Key -> FilePath annexLocationRelative r backend key = - gitDir r ++ "/annex/" ++ (name backend) ++ "/" ++ (keyFile key) + Git.dir r ++ "/annex/" ++ (name backend) ++ "/" ++ (keyFile key) {- Converts a key into a filename fragment. - diff --git a/Remotes.hs b/Remotes.hs index 711cd6c83..39404bf19 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -10,18 +10,18 @@ import Control.Monad.State (liftIO) import qualified Data.Map as Map import Data.String.Utils import AbstractTypes -import GitRepo +import qualified GitRepo as Git import LocationLog import Locations import UUID import List {- Human visible list of remotes. -} -remotesList :: [GitRepo] -> String -remotesList remotes = join " " $ map gitRepoDescribe remotes +remotesList :: [Git.Repo] -> String +remotesList remotes = join " " $ map Git.repoDescribe remotes {- Cost ordered list of remotes that the LocationLog indicate may have a key. -} -remotesWithKey :: Key -> Annex [GitRepo] +remotesWithKey :: Key -> Annex [Git.Repo] remotesWithKey key = do g <- gitAnnex uuids <- liftIO $ keyLocations g key @@ -34,13 +34,13 @@ remotesWithKey key = do else return remotes {- Cost Ordered list of remotes. -} -remotesByCost :: Annex [GitRepo] +remotesByCost :: Annex [Git.Repo] remotesByCost = do g <- gitAnnex - reposByCost $ gitRepoRemotes g + reposByCost $ Git.remotes g {- Orders a list of git repos by cost. -} -reposByCost :: [GitRepo] -> Annex [GitRepo] +reposByCost :: [Git.Repo] -> Annex [Git.Repo] reposByCost l = do costpairs <- mapM costpair l return $ fst $ unzip $ sortBy bycost $ costpairs @@ -55,36 +55,36 @@ reposByCost l = do - The default cost is 100 for local repositories, and 200 for remote - repositories; it can also be configured by remote.<name>.annex-cost -} -repoCost :: GitRepo -> Annex Int +repoCost :: Git.Repo -> Annex Int repoCost r = do g <- gitAnnex if ((length $ config g r) > 0) then return $ read $ config g r - else if (gitRepoIsLocal r) + else if (Git.repoIsLocal r) then return 100 else return 200 where - config g r = gitConfig g (configkey r) "" - configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost" + config g r = Git.configGet g (configkey r) "" + configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-cost" {- The git configs for the git repo's remotes is not read on startup - because reading it may be expensive. This function ensures that it is - read for a specified remote, and updates state. It returns the - updated git repo also. -} -remoteEnsureGitConfigRead :: GitRepo -> Annex GitRepo +remoteEnsureGitConfigRead :: Git.Repo -> Annex Git.Repo remoteEnsureGitConfigRead r = do - if (Map.null $ gitConfigMap r) + if (Map.null $ Git.configMap r) then do - r' <- liftIO $ gitConfigRead r + r' <- liftIO $ Git.configRead r g <- gitAnnex - let l = gitRepoRemotes g - let g' = gitRepoRemotesAdd g $ exchange l r' + let l = Git.remotes g + let g' = Git.remotesAdd g $ exchange l r' gitAnnexChange g' return r' else return r where exchange [] new = [] exchange (old:ls) new = - if ((gitRepoRemoteName old) == (gitRepoRemoteName new)) + if ((Git.repoRemoteName old) == (Git.repoRemoteName new)) then new:(exchange ls new) else old:(exchange ls new) @@ -1,26 +1,14 @@ {- git-annex core data types -} -module Types ( - Annex, - AnnexState, - makeAnnexState, - runAnnexState, - gitAnnex, - gitAnnexChange, - backendsAnnex, - backendsAnnexChange, - - Key(..), - Backend(..) -) where +module Types where import Control.Monad.State import Data.String.Utils -import GitRepo +import qualified GitRepo as Git -- git-annex's runtime state data AnnexState = AnnexState { - repo :: GitRepo, + repo :: Git.Repo, backends :: [Backend] } deriving (Show) @@ -28,18 +16,18 @@ data AnnexState = AnnexState { type Annex = StateT AnnexState IO -- constructor -makeAnnexState :: GitRepo -> AnnexState +makeAnnexState :: Git.Repo -> AnnexState makeAnnexState g = AnnexState { repo = g, backends = [] } -- performs an action in the Annex monad runAnnexState state action = runStateT (action) state -- Annex monad state accessors -gitAnnex :: Annex GitRepo +gitAnnex :: Annex Git.Repo gitAnnex = do state <- get return (repo state) -gitAnnexChange :: GitRepo -> Annex () +gitAnnexChange :: Git.Repo -> Annex () gitAnnexChange r = do state <- get put state { repo = r } @@ -19,7 +19,7 @@ import Maybe import List import System.Cmd.Utils import System.IO -import GitRepo +import qualified GitRepo as Git import AbstractTypes type UUID = String @@ -37,17 +37,17 @@ genUUID = liftIO $ pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h - remote.<name>.annex-uuid - - -} -getUUID :: GitRepo -> Annex UUID +getUUID :: Git.Repo -> Annex UUID getUUID r = do if ("" /= configured r) then return $ configured r else cached r where - configured r = gitConfig r "annex.uuid" "" + configured r = Git.configGet r "annex.uuid" "" cached r = do g <- gitAnnex - return $ gitConfig g (configkey r) "" - configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-uuid" + return $ Git.configGet g (configkey r) "" + configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-uuid" {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex () @@ -57,15 +57,15 @@ prepUUID = do if ("" == u) then do uuid <- genUUID - liftIO $ gitRun g ["config", configkey, uuid] + liftIO $ Git.run g ["config", configkey, uuid] -- re-read git config and update the repo's state - u' <- liftIO $ gitConfigRead g + u' <- liftIO $ Git.configRead g gitAnnexChange u' return () else return () {- Filters a list of repos to ones that have listed UUIDs. -} -reposByUUID :: [GitRepo] -> [UUID] -> Annex [GitRepo] +reposByUUID :: [Git.Repo] -> [UUID] -> Annex [Git.Repo] reposByUUID repos uuids = do filterM match repos where diff --git a/git-annex.hs b/git-annex.hs index be5168755..2cf1c5305 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -12,7 +12,7 @@ import Annex main = do args <- getArgs (mode, params) <- argvToMode args - state <- startAnnex + state <- start tryRun state mode 0 0 params {- Processes each param in the list by dispatching the handler function |