convert GitRepo to qualified import

This commit is contained in:
Joey Hess 2010-10-14 02:36:41 -04:00
parent eda80e44c5
commit 48643b68b3
11 changed files with 173 additions and 189 deletions

View file

@ -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

View file

@ -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

View file

@ -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 ()

View file

@ -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

View file

@ -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))

View file

@ -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)

View file

@ -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.
-

View file

@ -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)

View file

@ -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 }

16
UUID.hs
View file

@ -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

View file

@ -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