reorder repo parameters last

Many functions took the repo as their first parameter. Changing it
consistently to be the last parameter allows doing some useful things with
currying, that reduce boilerplate.

In particular, g <- gitRepo is almost never needed now, instead
use inRepo to run an IO action in the repo, and fromRepo to get
a value from the repo.

This also provides more opportunities to use monadic and applicative
combinators.
This commit is contained in:
Joey Hess 2011-11-08 15:34:10 -04:00
parent 2ff8915365
commit bf460a0a98
46 changed files with 338 additions and 390 deletions

View file

@ -17,7 +17,9 @@ module Annex (
eval, eval,
getState, getState,
changeState, changeState,
gitRepo gitRepo,
inRepo,
fromRepo,
) where ) where
import Control.Monad.IO.Control import Control.Monad.IO.Control
@ -114,6 +116,16 @@ getState = gets
changeState :: (AnnexState -> AnnexState) -> Annex () changeState :: (AnnexState -> AnnexState) -> Annex ()
changeState = modify changeState = modify
{- Returns the git repository being acted on -} {- Returns the annex's git repository. -}
gitRepo :: Annex Git.Repo gitRepo :: Annex Git.Repo
gitRepo = getState repo gitRepo = getState repo
{- Runs an IO action in the annex's git repository. -}
inRepo :: (Git.Repo -> IO a) -> Annex a
inRepo a = do
g <- gitRepo
liftIO $ a g
{- Extracts a value from the annex's git repisitory. -}
fromRepo :: (Git.Repo -> a) -> Annex a
fromRepo a = a <$> gitRepo

View file

@ -56,21 +56,19 @@ index g = gitAnnexDir g </> "index"
- and merge in changes from other branches. - and merge in changes from other branches.
-} -}
genIndex :: Git.Repo -> IO () genIndex :: Git.Repo -> IO ()
genIndex g = Git.UnionMerge.ls_tree g fullname >>= Git.UnionMerge.update_index g genIndex g = Git.UnionMerge.ls_tree fullname g >>= Git.UnionMerge.update_index g
{- Runs an action using the branch's index file. -} {- Runs an action using the branch's index file. -}
withIndex :: Annex a -> Annex a withIndex :: Annex a -> Annex a
withIndex = withIndex' False withIndex = withIndex' False
withIndex' :: Bool -> Annex a -> Annex a withIndex' :: Bool -> Annex a -> Annex a
withIndex' bootstrapping a = do withIndex' bootstrapping a = do
g <- gitRepo f <- fromRepo $ index
let f = index g
bracketIO (Git.useIndex f) id $ do bracketIO (Git.useIndex f) id $ do
unlessM (liftIO $ doesFileExist f) $ do unlessM (liftIO $ doesFileExist f) $ do
unless bootstrapping create unless bootstrapping create
liftIO $ createDirectoryIfMissing True $ takeDirectory f liftIO $ createDirectoryIfMissing True $ takeDirectory f
unless bootstrapping $ liftIO $ genIndex g unless bootstrapping $ inRepo genIndex
a a
withIndexUpdate :: Annex a -> Annex a withIndexUpdate :: Annex a -> Annex a
@ -103,19 +101,17 @@ getCache file = getState >>= go
{- Creates the branch, if it does not already exist. -} {- Creates the branch, if it does not already exist. -}
create :: Annex () create :: Annex ()
create = unlessM hasBranch $ do create = unlessM hasBranch $ do
g <- gitRepo
e <- hasOrigin e <- hasOrigin
if e if e
then liftIO $ Git.run g "branch" [Param name, Param originname] then inRepo $ Git.run "branch" [Param name, Param originname]
else withIndex' True $ else withIndex' True $
liftIO $ Git.commit g "branch created" fullname [] inRepo $ Git.commit "branch created" fullname []
{- Stages the journal, and commits staged changes to the branch. -} {- Stages the journal, and commits staged changes to the branch. -}
commit :: String -> Annex () commit :: String -> Annex ()
commit message = whenM journalDirty $ lockJournal $ do commit message = whenM journalDirty $ lockJournal $ do
stageJournalFiles stageJournalFiles
g <- gitRepo withIndex $ inRepo $ Git.commit message fullname [fullname]
withIndex $ liftIO $ Git.commit g message fullname [fullname]
{- Ensures that the branch is up-to-date; should be called before data is {- Ensures that the branch is up-to-date; should be called before data is
- read from it. Runs only once per git-annex run. - read from it. Runs only once per git-annex run.
@ -134,7 +130,6 @@ commit message = whenM journalDirty $ lockJournal $ do
-} -}
update :: Annex () update :: Annex ()
update = onceonly $ do update = onceonly $ do
g <- gitRepo
-- check what needs updating before taking the lock -- check what needs updating before taking the lock
dirty <- journalDirty dirty <- journalDirty
c <- filterM (changedBranch name . snd) =<< siblingBranches c <- filterM (changedBranch name . snd) =<< siblingBranches
@ -151,10 +146,10 @@ update = onceonly $ do
- documentation advises users not to directly - documentation advises users not to directly
- modify the branch. - modify the branch.
-} -}
liftIO $ Git.UnionMerge.merge_index g branches inRepo $ \g -> Git.UnionMerge.merge_index g branches
ff <- if dirty then return False else tryFastForwardTo refs ff <- if dirty then return False else tryFastForwardTo refs
unless ff $ unless ff $ inRepo $
liftIO $ Git.commit g "update" fullname (nub $ fullname:refs) Git.commit "update" fullname (nub $ fullname:refs)
invalidateCache invalidateCache
where where
onceonly a = unlessM (branchUpdated <$> getState) $ do onceonly a = unlessM (branchUpdated <$> getState) $ do
@ -165,14 +160,13 @@ update = onceonly $ do
{- Checks if the second branch has any commits not present on the first {- Checks if the second branch has any commits not present on the first
- branch. -} - branch. -}
changedBranch :: String -> String -> Annex Bool changedBranch :: String -> String -> Annex Bool
changedBranch origbranch newbranch = do changedBranch origbranch newbranch = not . L.null <$> diffs
g <- gitRepo where
diffs <- liftIO $ Git.pipeRead g [ diffs = inRepo $ Git.pipeRead
Param "log", [ Param "log"
Param (origbranch ++ ".." ++ newbranch), , Param (origbranch ++ ".." ++ newbranch)
Params "--oneline -n1" , Params "--oneline -n1"
] ]
return $ not $ L.null diffs
{- Given a set of refs that are all known to have commits not {- Given a set of refs that are all known to have commits not
- on the git-annex branch, tries to update the branch by a - on the git-annex branch, tries to update the branch by a
@ -195,8 +189,7 @@ tryFastForwardTo (first:rest) = do
where where
no_ff = return False no_ff = return False
do_ff branch = do do_ff branch = do
g <- gitRepo inRepo $ Git.run "update-ref" [Param fullname, Param branch]
liftIO $ Git.run g "update-ref" [Param fullname, Param branch]
return True return True
findbest c [] = return $ Just c findbest c [] = return $ Just c
findbest c (r:rs) findbest c (r:rs)
@ -223,10 +216,8 @@ disableUpdate = Annex.changeState setupdated
{- Checks if a git ref exists. -} {- Checks if a git ref exists. -}
refExists :: GitRef -> Annex Bool refExists :: GitRef -> Annex Bool
refExists ref = do refExists ref = inRepo $ Git.runBool "show-ref"
g <- gitRepo [Param "--verify", Param "-q", Param ref]
liftIO $ Git.runBool g "show-ref"
[Param "--verify", Param "-q", Param ref]
{- Does the main git-annex branch exist? -} {- Does the main git-annex branch exist? -}
hasBranch :: Annex Bool hasBranch :: Annex Bool
@ -244,8 +235,7 @@ hasSomeBranch = not . null <$> siblingBranches
- from remotes. Duplicate refs are filtered out. -} - from remotes. Duplicate refs are filtered out. -}
siblingBranches :: Annex [(String, String)] siblingBranches :: Annex [(String, String)]
siblingBranches = do siblingBranches = do
g <- gitRepo r <- inRepo $ Git.pipeRead [Param "show-ref", Param name]
r <- liftIO $ Git.pipeRead g [Param "show-ref", Param name]
return $ nubBy uref $ map (pair . words . L.unpack) (L.lines r) return $ nubBy uref $ map (pair . words . L.unpack) (L.lines r)
where where
pair l = (head l, last l) pair l = (head l, last l)
@ -280,8 +270,7 @@ get file = fromcache =<< getCache file
{- Lists all files on the branch. There may be duplicates in the list. -} {- Lists all files on the branch. There may be duplicates in the list. -}
files :: Annex [FilePath] files :: Annex [FilePath]
files = withIndexUpdate $ do files = withIndexUpdate $ do
g <- gitRepo bfiles <- inRepo $ Git.pipeNullSplit
bfiles <- liftIO $ Git.pipeNullSplit g
[Params "ls-tree --name-only -r -z", Param fullname] [Params "ls-tree --name-only -r -z", Param fullname]
jfiles <- getJournalledFiles jfiles <- getJournalledFiles
return $ jfiles ++ bfiles return $ jfiles ++ bfiles
@ -349,8 +338,8 @@ stageJournalFiles = do
where where
index_lines shas = map genline . zip shas index_lines shas = map genline . zip shas
genline (sha, file) = Git.UnionMerge.update_index_line sha file genline (sha, file) = Git.UnionMerge.update_index_line sha file
git_hash_object g = Git.gitCommandLine g git_hash_object g = Git.gitCommandLine
[Param "hash-object", Param "-w", Param "--stdin-paths"] [Param "hash-object", Param "-w", Param "--stdin-paths"] g
{- Checks if there are changes in the journal. -} {- Checks if there are changes in the journal. -}
@ -379,8 +368,7 @@ fileJournal = replace "//" "_" . replace "_" "/"
- contention with other git-annex processes. -} - contention with other git-annex processes. -}
lockJournal :: Annex a -> Annex a lockJournal :: Annex a -> Annex a
lockJournal a = do lockJournal a = do
g <- gitRepo file <- fromRepo $ gitAnnexJournalLock
let file = gitAnnexJournalLock g
bracketIO (lock file) unlock a bracketIO (lock file) unlock a
where where
lock file = do lock file = do

View file

@ -17,8 +17,7 @@ catFile :: String -> FilePath -> Annex String
catFile branch file = maybe startup go =<< Annex.getState Annex.catfilehandle catFile branch file = maybe startup go =<< Annex.getState Annex.catfilehandle
where where
startup = do startup = do
g <- gitRepo h <- inRepo $ Git.CatFile.catFileStart
h <- liftIO $ Git.CatFile.catFileStart g
Annex.changeState $ \s -> s { Annex.catfilehandle = Just h } Annex.changeState $ \s -> s { Annex.catfilehandle = Just h }
go h go h
go h = liftIO $ Git.CatFile.catFile h branch file go h = liftIO $ Git.CatFile.catFile h branch file

View file

@ -37,18 +37,18 @@ import Config
{- Checks if a given key is currently present in the gitAnnexLocation. -} {- Checks if a given key is currently present in the gitAnnexLocation. -}
inAnnex :: Key -> Annex Bool inAnnex :: Key -> Annex Bool
inAnnex key = do inAnnex key = do
g <- gitRepo whenM (fromRepo Git.repoIsUrl) $
when (Git.repoIsUrl g) $ error "inAnnex cannot check remote repo" error "inAnnex cannot check remote repo"
liftIO $ doesFileExist $ gitAnnexLocation g key inRepo $ doesFileExist . gitAnnexLocation key
{- Calculates the relative path to use to link a file to a key. -} {- Calculates the relative path to use to link a file to a key. -}
calcGitLink :: FilePath -> Key -> Annex FilePath calcGitLink :: FilePath -> Key -> Annex FilePath
calcGitLink file key = do calcGitLink file key = do
g <- gitRepo
cwd <- liftIO getCurrentDirectory cwd <- liftIO getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPath cwd file let absfile = fromMaybe whoops $ absNormPath cwd file
top <- fromRepo Git.workTree
return $ relPathDirToFile (parentDir absfile) return $ relPathDirToFile (parentDir absfile)
(Git.workTree g) </> ".git" </> annexLocation key top </> ".git" </> annexLocation key
where where
whoops = error $ "unable to normalize " ++ file whoops = error $ "unable to normalize " ++ file
@ -65,8 +65,7 @@ logStatus key status = do
- the annex as a key's content. -} - the annex as a key's content. -}
getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmp key action = do getViaTmp key action = do
g <- gitRepo tmp <- fromRepo $ gitAnnexTmpLocation key
let tmp = gitAnnexTmpLocation g key
-- Check that there is enough free disk space. -- Check that there is enough free disk space.
-- When the temp file already exists, count the space -- When the temp file already exists, count the space
@ -84,8 +83,7 @@ getViaTmp key action = do
prepTmp :: Key -> Annex FilePath prepTmp :: Key -> Annex FilePath
prepTmp key = do prepTmp key = do
g <- gitRepo tmp <- fromRepo $ gitAnnexTmpLocation key
let tmp = gitAnnexTmpLocation g key
liftIO $ createDirectoryIfMissing True (parentDir tmp) liftIO $ createDirectoryIfMissing True (parentDir tmp)
return tmp return tmp
@ -162,8 +160,7 @@ checkDiskSpace' adjustment key = do
-} -}
moveAnnex :: Key -> FilePath -> Annex () moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do moveAnnex key src = do
g <- gitRepo dest <- fromRepo $ gitAnnexLocation key
let dest = gitAnnexLocation g key
let dir = parentDir dest let dir = parentDir dest
e <- liftIO $ doesFileExist dest e <- liftIO $ doesFileExist dest
if e if e
@ -177,8 +174,7 @@ moveAnnex key src = do
withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
withObjectLoc key a = do withObjectLoc key a = do
g <- gitRepo file <- fromRepo $gitAnnexLocation key
let file = gitAnnexLocation g key
let dir = parentDir file let dir = parentDir file
a (dir, file) a (dir, file)
@ -201,9 +197,9 @@ fromAnnex key dest = withObjectLoc key $ \(dir, file) -> liftIO $ do
- returns the file it was moved to. -} - returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath moveBad :: Key -> Annex FilePath
moveBad key = do moveBad key = do
g <- gitRepo src <- fromRepo $ gitAnnexLocation key
let src = gitAnnexLocation g key bad <- fromRepo $ gitAnnexBadDir
let dest = gitAnnexBadDir g </> takeFileName src let dest = bad </> takeFileName src
liftIO $ do liftIO $ do
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (parentDir dest)
allowWrite (parentDir src) allowWrite (parentDir src)
@ -214,9 +210,7 @@ moveBad key = do
{- List of keys whose content exists in .git/annex/objects/ -} {- List of keys whose content exists in .git/annex/objects/ -}
getKeysPresent :: Annex [Key] getKeysPresent :: Annex [Key]
getKeysPresent = do getKeysPresent = getKeysPresent' =<< fromRepo gitAnnexObjectDir
g <- gitRepo
getKeysPresent' $ gitAnnexObjectDir g
getKeysPresent' :: FilePath -> Annex [Key] getKeysPresent' :: FilePath -> Annex [Key]
getKeysPresent' dir = do getKeysPresent' dir = do
exists <- liftIO $ doesDirectoryExist dir exists <- liftIO $ doesDirectoryExist dir

View file

@ -34,8 +34,7 @@ flush silent = do
unless (0 == Git.Queue.size q) $ do unless (0 == Git.Queue.size q) $ do
unless silent $ unless silent $
showSideAction "Recording state in git" showSideAction "Recording state in git"
g <- gitRepo q' <- inRepo $ Git.Queue.flush q
q' <- liftIO $ Git.Queue.flush g q
store q' store q'
store :: Git.Queue.Queue -> Annex () store :: Git.Queue.Queue -> Annex ()

View file

@ -45,23 +45,23 @@ getUUID = getRepoUUID =<< gitRepo
{- Looks up a repo's UUID. May return "" if none is known. -} {- Looks up a repo's UUID. May return "" if none is known. -}
getRepoUUID :: Git.Repo -> Annex UUID getRepoUUID :: Git.Repo -> Annex UUID
getRepoUUID r = do getRepoUUID r = do
g <- gitRepo c <- fromRepo cached
let c = cached g
let u = getUncachedUUID r let u = getUncachedUUID r
if c /= u && u /= NoUUID if c /= u && u /= NoUUID
then do then do
updatecache g u updatecache u
return u return u
else return c else return c
where where
cached g = toUUID $ Git.configGet g cachekey "" cached g = toUUID $ Git.configGet cachekey "" g
updatecache g u = when (g /= r) $ storeUUID cachekey u updatecache u = do
g <- gitRepo
when (g /= r) $ storeUUID cachekey u
cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid" cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid"
getUncachedUUID :: Git.Repo -> UUID getUncachedUUID :: Git.Repo -> UUID
getUncachedUUID r = toUUID $ Git.configGet r configkey "" getUncachedUUID = toUUID . Git.configGet configkey ""
{- Make sure that the repo has an annex.uuid setting. -} {- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex () prepUUID :: Annex ()

View file

@ -26,12 +26,10 @@ versionField :: String
versionField = "annex.version" versionField = "annex.version"
getVersion :: Annex (Maybe Version) getVersion :: Annex (Maybe Version)
getVersion = do getVersion = handle <$> fromRepo (Git.configGet versionField "")
g <- gitRepo where
let v = Git.configGet g versionField "" handle [] = Nothing
if not $ null v handle v = Just v
then return $ Just v
else return Nothing
setVersion :: Annex () setVersion :: Annex ()
setVersion = setConfig versionField defaultVersion setVersion = setConfig versionField defaultVersion

View file

@ -47,10 +47,7 @@ orderedList = do
l' <- (lookupBackendName name :) <$> standard l' <- (lookupBackendName name :) <$> standard
Annex.changeState $ \s -> s { Annex.backends = l' } Annex.changeState $ \s -> s { Annex.backends = l' }
return l' return l'
standard = do standard = fromRepo $ parseBackendList . Git.configGet "annex.backends" ""
g <- gitRepo
return $ parseBackendList $
Git.configGet g "annex.backends" ""
parseBackendList [] = list parseBackendList [] = list
parseBackendList s = map lookupBackendName $ words s parseBackendList s = map lookupBackendName $ words s
@ -96,16 +93,14 @@ type BackendFile = (Maybe (Backend Annex), FilePath)
- That can be configured on a per-file basis in the gitattributes file. - That can be configured on a per-file basis in the gitattributes file.
-} -}
chooseBackends :: [FilePath] -> Annex [BackendFile] chooseBackends :: [FilePath] -> Annex [BackendFile]
chooseBackends fs = do chooseBackends fs = Annex.getState Annex.forcebackend >>= go
g <- gitRepo where
forced <- Annex.getState Annex.forcebackend go Nothing = do
if isJust forced pairs <- inRepo $ Git.checkAttr "annex.backend" fs
then do return $ map (\(f,b) -> (maybeLookupBackendName b, f)) pairs
go (Just _) = do
l <- orderedList l <- orderedList
return $ map (\f -> (Just $ head l, f)) fs return $ map (\f -> (Just $ head l, f)) fs
else do
pairs <- liftIO $ Git.checkAttr g "annex.backend" fs
return $ map (\(f,b) -> (maybeLookupBackendName b, f)) pairs
{- Looks up a backend by name. May fail if unknown. -} {- Looks up a backend by name. May fail if unknown. -}
lookupBackendName :: String -> Backend Annex lookupBackendName :: String -> Backend Annex

View file

@ -98,9 +98,8 @@ keyValueE size file = keyValue size file >>= maybe (return Nothing) addE
{- A key's checksum is checked during fsck. -} {- A key's checksum is checked during fsck. -}
checkKeyChecksum :: SHASize -> Key -> Annex Bool checkKeyChecksum :: SHASize -> Key -> Annex Bool
checkKeyChecksum size key = do checkKeyChecksum size key = do
g <- gitRepo
fast <- Annex.getState Annex.fast fast <- Annex.getState Annex.fast
let file = gitAnnexLocation g key file <- fromRepo $ gitAnnexLocation key
present <- liftIO $ doesFileExist file present <- liftIO $ doesFileExist file
if not present || fast if not present || fast
then return True then return True

View file

@ -78,7 +78,7 @@ notBareRepo a = do
a a
isBareRepo :: Annex Bool isBareRepo :: Annex Bool
isBareRepo = Git.repoIsLocalBare <$> gitRepo isBareRepo = fromRepo Git.repoIsLocalBare
{- Used for commands that have an auto mode that checks the number of known {- Used for commands that have an auto mode that checks the number of known
- copies of a key. - copies of a key.

View file

@ -60,8 +60,8 @@ undo file key e = do
-- fromAnnex could fail if the file ownership is weird -- fromAnnex could fail if the file ownership is weird
tryharder :: IOException -> Annex () tryharder :: IOException -> Annex ()
tryharder _ = do tryharder _ = do
g <- gitRepo src <- fromRepo $ gitAnnexLocation key
liftIO $ renameFile (gitAnnexLocation g key) file liftIO $ renameFile src file
cleanup :: FilePath -> Key -> Bool -> CommandCleanup cleanup :: FilePath -> Key -> Bool -> CommandCleanup
cleanup file key hascontent = do cleanup file key hascontent = do

View file

@ -41,10 +41,9 @@ perform url file = do
download :: String -> FilePath -> CommandPerform download :: String -> FilePath -> CommandPerform
download url file = do download url file = do
g <- gitRepo
showAction $ "downloading " ++ url ++ " " showAction $ "downloading " ++ url ++ " "
let dummykey = Backend.URL.fromUrl url let dummykey = Backend.URL.fromUrl url
let tmp = gitAnnexTmpLocation g dummykey tmp <- fromRepo $ gitAnnexTmpLocation dummykey
liftIO $ createDirectoryIfMissing True (parentDir tmp) liftIO $ createDirectoryIfMissing True (parentDir tmp)
ok <- liftIO $ Url.download url tmp ok <- liftIO $ Url.download url tmp
if ok if ok

View file

@ -58,17 +58,15 @@ perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote
next $ Command.Drop.cleanupRemote key r next $ Command.Drop.cleanupRemote key r
droplocal = Command.Drop.performLocal key (Just 0) -- force drop droplocal = Command.Drop.performLocal key (Just 0) -- force drop
performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
performOther filespec key = do performOther filespec key = do
g <- gitRepo f <- fromRepo $ filespec key
let f = filespec g key
liftIO $ whenM (doesFileExist f) $ removeFile f liftIO $ whenM (doesFileExist f) $ removeFile f
next $ return True next $ return True
readUnusedLog :: FilePath -> Annex UnusedMap readUnusedLog :: FilePath -> Annex UnusedMap
readUnusedLog prefix = do readUnusedLog prefix = do
g <- gitRepo f <- fromRepo $ gitAnnexUnusedLog prefix
let f = gitAnnexUnusedLog prefix g
e <- liftIO $ doesFileExist f e <- liftIO $ doesFileExist f
if e if e
then M.fromList . map parse . lines <$> liftIO (readFile f) then M.fromList . map parse . lines <$> liftIO (readFile f)

View file

@ -79,26 +79,26 @@ check = sequence >=> dispatch
in this repository only. -} in this repository only. -}
verifyLocationLog :: Key -> String -> Annex Bool verifyLocationLog :: Key -> String -> Annex Bool
verifyLocationLog key desc = do verifyLocationLog key desc = do
g <- gitRepo
present <- inAnnex key present <- inAnnex key
-- Since we're checking that a key's file is present, throw -- Since we're checking that a key's file is present, throw
-- in a permission fixup here too. -- in a permission fixup here too.
when present $ liftIO $ do when present $ do
let f = gitAnnexLocation g key f <- fromRepo $ gitAnnexLocation key
preventWrite f liftIO $ do
preventWrite (parentDir f) preventWrite f
preventWrite (parentDir f)
u <- getUUID u <- getUUID
uuids <- keyLocations key uuids <- keyLocations key
case (present, u `elem` uuids) of case (present, u `elem` uuids) of
(True, False) -> do (True, False) -> do
fix g u InfoPresent fix u InfoPresent
-- There is no data loss, so do not fail. -- There is no data loss, so do not fail.
return True return True
(False, True) -> do (False, True) -> do
fix g u InfoMissing fix u InfoMissing
warning $ warning $
"** Based on the location log, " ++ desc "** Based on the location log, " ++ desc
++ "\n** was expected to be present, " ++ ++ "\n** was expected to be present, " ++
@ -107,16 +107,16 @@ verifyLocationLog key desc = do
_ -> return True _ -> return True
where where
fix g u s = do fix u s = do
showNote "fixing location log" showNote "fixing location log"
g <- gitRepo
logChange g key u s logChange g key u s
{- The size of the data for a key is checked against the size encoded in {- The size of the data for a key is checked against the size encoded in
- the key's metadata, if available. -} - the key's metadata, if available. -}
checkKeySize :: Key -> Annex Bool checkKeySize :: Key -> Annex Bool
checkKeySize key = do checkKeySize key = do
g <- gitRepo file <- fromRepo $ gitAnnexLocation key
let file = gitAnnexLocation g key
present <- liftIO $ doesFileExist file present <- liftIO $ doesFileExist file
case (present, Types.Key.keySize key) of case (present, Types.Key.keySize key) of
(_, Nothing) -> return True (_, Nothing) -> return True

View file

@ -31,8 +31,7 @@ seek = [withNothing start]
start :: CommandStart start :: CommandStart
start = do start = do
g <- gitRepo rs <- spider =<< gitRepo
rs <- spider g
umap <- uuidMap umap <- uuidMap
trusted <- trustGet Trusted trusted <- trustGet Trusted

View file

@ -42,14 +42,13 @@ upgradableKey key = isNothing $ Types.Key.keySize key
perform :: FilePath -> Key -> Backend Annex -> CommandPerform perform :: FilePath -> Key -> Backend Annex -> CommandPerform
perform file oldkey newbackend = do perform file oldkey newbackend = do
g <- gitRepo
-- Store the old backend's cached key in the new backend -- Store the old backend's cached key in the new backend
-- (the file can't be stored as usual, because it's already a symlink). -- (the file can't be stored as usual, because it's already a symlink).
-- The old backend's key is not dropped from it, because there may -- The old backend's key is not dropped from it, because there may
-- be other files still pointing at that key. -- be other files still pointing at that key.
let src = gitAnnexLocation g oldkey src <- fromRepo $ gitAnnexLocation oldkey
let tmpfile = gitAnnexTmpDir g </> takeFileName file tmp <- fromRepo $ gitAnnexTmpDir
let tmpfile = tmp </> takeFileName file
liftIO $ createLink src tmpfile liftIO $ createLink src tmpfile
k <- Backend.genKey tmpfile $ Just newbackend k <- Backend.genKey tmpfile $ Just newbackend
liftIO $ cleantmp tmpfile liftIO $ cleantmp tmpfile

View file

@ -21,8 +21,7 @@ seek = [withKeys start]
start :: Key -> CommandStart start :: Key -> CommandStart
start key = do start key = do
g <- gitRepo file <- fromRepo $ gitAnnexLocation key
let file = gitAnnexLocation g key
whenM (inAnnex key) $ whenM (inAnnex key) $
liftIO $ rsyncServerSend file -- does not return liftIO $ rsyncServerSend file -- does not return
warning "requested key is not present" warning "requested key is not present"

View file

@ -31,8 +31,8 @@ start file = isAnnexed file $ \(key, _) -> do
then do then do
force <- Annex.getState Annex.force force <- Annex.getState Annex.force
unless force $ do unless force $ do
g <- gitRepo top <- fromRepo Git.workTree
staged <- liftIO $ LsFiles.staged g [Git.workTree g] staged <- inRepo $ LsFiles.staged [top]
unless (null staged) $ unless (null staged) $
error "This command cannot be run when there are already files staged for commit." error "This command cannot be run when there are already files staged for commit."
Annex.changeState $ \s -> s { Annex.force = True } Annex.changeState $ \s -> s { Annex.force = True }
@ -46,19 +46,19 @@ perform file key = next $ cleanup file key
cleanup :: FilePath -> Key -> CommandCleanup cleanup :: FilePath -> Key -> CommandCleanup
cleanup file key = do cleanup file key = do
g <- gitRepo
liftIO $ removeFile file liftIO $ removeFile file
liftIO $ Git.run g "rm" [Params "--quiet --", File file] inRepo $ Git.run "rm" [Params "--quiet --", File file]
-- git rm deletes empty directories; put them back -- git rm deletes empty directories; put them back
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (parentDir file)
fast <- Annex.getState Annex.fast fast <- Annex.getState Annex.fast
if fast if fast
then liftIO $ do then do
-- fast mode: hard link to content in annex -- fast mode: hard link to content in annex
createLink (gitAnnexLocation g key) file src <- fromRepo $ gitAnnexLocation key
allowWrite file liftIO $ do
createLink src file
allowWrite file
else do else do
fromAnnex key file fromAnnex key file
logStatus key InfoMissing logStatus key InfoMissing

View file

@ -28,11 +28,9 @@ check = do
when (b == Annex.Branch.name) $ error $ when (b == Annex.Branch.name) $ error $
"cannot uninit when the " ++ b ++ " branch is checked out" "cannot uninit when the " ++ b ++ " branch is checked out"
where where
current_branch = do current_branch = head . lines . B.unpack <$> revhead
g <- gitRepo revhead = inRepo $ Git.pipeRead
b <- liftIO $ [Params "rev-parse --abbrev-ref HEAD"]
Git.pipeRead g [Params "rev-parse --abbrev-ref HEAD"]
return $ head $ lines $ B.unpack b
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit startUnannex, withNothing start] seek = [withFilesInGit startUnannex, withNothing start]
@ -53,12 +51,11 @@ perform = next cleanup
cleanup :: CommandCleanup cleanup :: CommandCleanup
cleanup = do cleanup = do
g <- gitRepo annexdir <- fromRepo $ gitAnnexDir
uninitialize uninitialize
mapM_ removeAnnex =<< getKeysPresent mapM_ removeAnnex =<< getKeysPresent
liftIO $ removeDirectoryRecursive (gitAnnexDir g) liftIO $ removeDirectoryRecursive annexdir
-- avoid normal shutdown -- avoid normal shutdown
saveState saveState
liftIO $ do inRepo $ Git.run "branch" [Param "-D", Param Annex.Branch.name]
Git.run g "branch" [Param "-D", Param Annex.Branch.name] liftIO $ exitSuccess
exitSuccess

View file

@ -37,9 +37,8 @@ perform dest key = do
checkDiskSpace key checkDiskSpace key
g <- gitRepo src <- fromRepo $ gitAnnexLocation key
let src = gitAnnexLocation g key tmpdest <- fromRepo $ gitAnnexTmpLocation key
let tmpdest = gitAnnexTmpLocation g key
liftIO $ createDirectoryIfMissing True (parentDir tmpdest) liftIO $ createDirectoryIfMissing True (parentDir tmpdest)
showAction "copying" showAction "copying"
ok <- liftIO $ copyFileExternal src tmpdest ok <- liftIO $ copyFileExternal src tmpdest

View file

@ -75,8 +75,8 @@ checkRemoteUnused' r = do
writeUnusedFile :: FilePath -> [(Int, Key)] -> Annex () writeUnusedFile :: FilePath -> [(Int, Key)] -> Annex ()
writeUnusedFile prefix l = do writeUnusedFile prefix l = do
g <- gitRepo logfile <- fromRepo $ gitAnnexUnusedLog prefix
liftIO $ viaTmp writeFile (gitAnnexUnusedLog prefix g) $ liftIO $ viaTmp writeFile logfile $
unlines $ map (\(n, k) -> show n ++ " " ++ show k) l unlines $ map (\(n, k) -> show n ++ " " ++ show k) l
table :: [(Int, Key)] -> [String] table :: [(Int, Key)] -> [String]
@ -147,8 +147,7 @@ unusedKeys = do
excludeReferenced :: [Key] -> Annex [Key] excludeReferenced :: [Key] -> Annex [Key]
excludeReferenced [] = return [] -- optimisation excludeReferenced [] = return [] -- optimisation
excludeReferenced l = do excludeReferenced l = do
g <- gitRepo c <- inRepo $ Git.pipeRead [Param "show-ref"]
c <- liftIO $ Git.pipeRead g [Param "show-ref"]
removewith (getKeysReferenced : map getKeysReferencedInGit (refs c)) removewith (getKeysReferenced : map getKeysReferencedInGit (refs c))
(S.fromList l) (S.fromList l)
where where
@ -183,8 +182,8 @@ exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
{- List of keys referenced by symlinks in the git repo. -} {- List of keys referenced by symlinks in the git repo. -}
getKeysReferenced :: Annex [Key] getKeysReferenced :: Annex [Key]
getKeysReferenced = do getKeysReferenced = do
g <- gitRepo top <- fromRepo Git.workTree
files <- liftIO $ LsFiles.inRepo g [Git.workTree g] files <- inRepo $ LsFiles.inRepo [top]
keypairs <- mapM Backend.lookupFile files keypairs <- mapM Backend.lookupFile files
return $ map fst $ catMaybes keypairs return $ map fst $ catMaybes keypairs
@ -192,8 +191,7 @@ getKeysReferenced = do
getKeysReferencedInGit :: String -> Annex [Key] getKeysReferencedInGit :: String -> Annex [Key]
getKeysReferencedInGit ref = do getKeysReferencedInGit ref = do
showAction $ "checking " ++ Git.refDescribe ref showAction $ "checking " ++ Git.refDescribe ref
g <- gitRepo findkeys [] =<< inRepo (LsTree.lsTree ref)
findkeys [] =<< liftIO (LsTree.lsTree g ref)
where where
findkeys c [] = return c findkeys c [] = return c
findkeys c (l:ls) findkeys c (l:ls)
@ -217,16 +215,14 @@ staleKeysPrune dirspec present = do
let stale = contents `exclude` present let stale = contents `exclude` present
let dups = contents `exclude` stale let dups = contents `exclude` stale
g <- gitRepo dir <- fromRepo dirspec
let dir = dirspec g
liftIO $ forM_ dups $ \t -> removeFile $ dir </> keyFile t liftIO $ forM_ dups $ \t -> removeFile $ dir </> keyFile t
return stale return stale
staleKeys :: (Git.Repo -> FilePath) -> Annex [Key] staleKeys :: (Git.Repo -> FilePath) -> Annex [Key]
staleKeys dirspec = do staleKeys dirspec = do
g <- gitRepo dir <- fromRepo dirspec
let dir = dirspec g
exists <- liftIO $ doesDirectoryExist dir exists <- liftIO $ doesDirectoryExist dir
if not exists if not exists
then return [] then return []

View file

@ -10,6 +10,6 @@ module Common.Annex (
import Common import Common
import Types import Types
import Types.UUID (toUUID, fromUUID) import Types.UUID (toUUID, fromUUID)
import Annex (gitRepo) import Annex (gitRepo, inRepo, fromRepo)
import Locations import Locations
import Messages import Messages

View file

@ -16,19 +16,17 @@ type ConfigKey = String
{- Changes a git config setting in both internal state and .git/config -} {- Changes a git config setting in both internal state and .git/config -}
setConfig :: ConfigKey -> String -> Annex () setConfig :: ConfigKey -> String -> Annex ()
setConfig k value = do setConfig k value = do
g <- gitRepo inRepo $ Git.run "config" [Param k, Param value]
liftIO $ Git.run g "config" [Param k, Param value]
-- re-read git config and update the repo's state -- re-read git config and update the repo's state
g' <- liftIO $ Git.configRead g newg <- inRepo $ Git.configRead
Annex.changeState $ \s -> s { Annex.repo = g' } Annex.changeState $ \s -> s { Annex.repo = newg }
{- Looks up a per-remote config setting in git config. {- Looks up a per-remote config setting in git config.
- Failing that, tries looking for a global config option. -} - Failing that, tries looking for a global config option. -}
getConfig :: Git.Repo -> ConfigKey -> String -> Annex String getConfig :: Git.Repo -> ConfigKey -> String -> Annex String
getConfig r key def = do getConfig r key def = do
g <- gitRepo def' <- fromRepo $ Git.configGet ("annex." ++ key) def
let def' = Git.configGet g ("annex." ++ key) def fromRepo $ Git.configGet (remoteConfig r key) def'
return $ Git.configGet g (remoteConfig r key) def'
remoteConfig :: Git.Repo -> ConfigKey -> String remoteConfig :: Git.Repo -> ConfigKey -> String
remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key
@ -87,7 +85,5 @@ getNumCopies v =
Annex.getState Annex.forcenumcopies >>= maybe (use v) (return . id) Annex.getState Annex.forcenumcopies >>= maybe (use v) (return . id)
where where
use (Just n) = return n use (Just n) = return n
use Nothing = do use Nothing = read <$> fromRepo (Git.configGet config "1")
g <- gitRepo
return $ read $ Git.configGet g config "1"
config = "annex.numcopies" config = "annex.numcopies"

100
Git.hs
View file

@ -188,13 +188,13 @@ repoRemoteName Repo { remoteName = Just name } = Just name
repoRemoteName _ = Nothing repoRemoteName _ = Nothing
{- Sets the name of a remote. -} {- Sets the name of a remote. -}
repoRemoteNameSet :: Repo -> String -> Repo repoRemoteNameSet :: String -> Repo -> Repo
repoRemoteNameSet r n = r { remoteName = Just n } repoRemoteNameSet n r = r { remoteName = Just n }
{- Sets the name of a remote based on the git config key, such as {- Sets the name of a remote based on the git config key, such as
"remote.foo.url". -} "remote.foo.url". -}
repoRemoteNameFromKey :: Repo -> String -> Repo repoRemoteNameFromKey :: String -> Repo -> Repo
repoRemoteNameFromKey r k = repoRemoteNameSet r basename repoRemoteNameFromKey k = repoRemoteNameSet basename
where where
basename = join "." $ reverse $ drop 1 $ basename = join "." $ reverse $ drop 1 $
reverse $ drop 1 $ split "." k reverse $ drop 1 $ split "." k
@ -280,8 +280,8 @@ workTree Repo { location = Unknown } = undefined
- is itself a symlink). But, if the cwd is "/tmp/repo/subdir", - is itself a symlink). But, if the cwd is "/tmp/repo/subdir",
- it's best to refer to "../foo". - it's best to refer to "../foo".
-} -}
workTreeFile :: Repo -> FilePath -> IO FilePath workTreeFile :: FilePath -> Repo -> IO FilePath
workTreeFile repo@(Repo { location = Dir d }) file = do workTreeFile file repo@(Repo { location = Dir d }) = do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
let file' = absfile cwd let file' = absfile cwd
unless (inrepo file') $ unless (inrepo file') $
@ -296,7 +296,7 @@ workTreeFile repo@(Repo { location = Dir d }) file = do
absfile c = fromMaybe file $ secureAbsNormPath c file absfile c = fromMaybe file $ secureAbsNormPath c file
inrepo f = absrepo `isPrefixOf` f inrepo f = absrepo `isPrefixOf` f
bad = error $ "bad repo" ++ repoDescribe repo bad = error $ "bad repo" ++ repoDescribe repo
workTreeFile repo _ = assertLocal repo $ error "internal" workTreeFile _ repo = assertLocal repo $ error "internal"
{- Path of an URL repo. -} {- Path of an URL repo. -}
urlPath :: Repo -> String urlPath :: Repo -> String
@ -350,23 +350,23 @@ urlAuthPart a Repo { location = Url u } = a auth
urlAuthPart _ repo = assertUrl repo $ error "internal" urlAuthPart _ repo = assertUrl repo $ error "internal"
{- Constructs a git command line operating on the specified repo. -} {- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: Repo -> [CommandParam] -> [CommandParam] gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine repo@(Repo { location = Dir _ } ) params = gitCommandLine params repo@(Repo { location = Dir _ } ) =
-- force use of specified repo via --git-dir and --work-tree -- force use of specified repo via --git-dir and --work-tree
[ Param ("--git-dir=" ++ gitDir repo) [ Param ("--git-dir=" ++ gitDir repo)
, Param ("--work-tree=" ++ workTree repo) , Param ("--work-tree=" ++ workTree repo)
] ++ params ] ++ params
gitCommandLine repo _ = assertLocal repo $ error "internal" gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -} {- Runs git in the specified repo. -}
runBool :: Repo -> String -> [CommandParam] -> IO Bool runBool :: String -> [CommandParam] -> Repo -> IO Bool
runBool repo subcommand params = assertLocal repo $ runBool subcommand params repo = assertLocal repo $
boolSystem "git" $ gitCommandLine repo $ Param subcommand : params boolSystem "git" $ gitCommandLine (Param subcommand : params) repo
{- Runs git in the specified repo, throwing an error if it fails. -} {- Runs git in the specified repo, throwing an error if it fails. -}
run :: Repo -> String -> [CommandParam] -> IO () run :: String -> [CommandParam] -> Repo -> IO ()
run repo subcommand params = assertLocal repo $ run subcommand params repo = assertLocal repo $
runBool repo subcommand params runBool subcommand params repo
>>! error $ "git " ++ show params ++ " failed" >>! error $ "git " ++ show params ++ " failed"
{- Runs a git subcommand and returns its output, lazily. {- Runs a git subcommand and returns its output, lazily.
@ -374,26 +374,26 @@ run repo subcommand params = assertLocal repo $
- Note that this leaves the git process running, and so zombies will - Note that this leaves the git process running, and so zombies will
- result unless reap is called. - result unless reap is called.
-} -}
pipeRead :: Repo -> [CommandParam] -> IO L.ByteString pipeRead :: [CommandParam] -> Repo -> IO L.ByteString
pipeRead repo params = assertLocal repo $ do pipeRead params repo = assertLocal repo $ do
(_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine repo params (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo
hSetBinaryMode h True hSetBinaryMode h True
L.hGetContents h L.hGetContents h
{- Runs a git subcommand, feeding it input. {- Runs a git subcommand, feeding it input.
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -} - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
pipeWrite :: Repo -> [CommandParam] -> L.ByteString -> IO PipeHandle pipeWrite :: [CommandParam] -> L.ByteString -> Repo -> IO PipeHandle
pipeWrite repo params s = assertLocal repo $ do pipeWrite params s repo = assertLocal repo $ do
(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine repo params) (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
L.hPut h s L.hPut h s
hClose h hClose h
return p return p
{- Runs a git subcommand, feeding it input, and returning its output. {- Runs a git subcommand, feeding it input, and returning its output.
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -} - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
pipeWriteRead :: Repo -> [CommandParam] -> L.ByteString -> IO (PipeHandle, L.ByteString) pipeWriteRead :: [CommandParam] -> L.ByteString -> Repo -> IO (PipeHandle, L.ByteString)
pipeWriteRead repo params s = assertLocal repo $ do pipeWriteRead params s repo = assertLocal repo $ do
(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine repo params) (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)
hSetBinaryMode from True hSetBinaryMode from True
L.hPut to s L.hPut to s
hClose to hClose to
@ -402,13 +402,13 @@ pipeWriteRead repo params s = assertLocal repo $ do
{- Reads null terminated output of a git command (as enabled by the -z {- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -} - parameter), and splits it. -}
pipeNullSplit :: Repo -> [CommandParam] -> IO [String] pipeNullSplit :: [CommandParam] -> Repo -> IO [String]
pipeNullSplit repo params = map L.unpack <$> pipeNullSplitB repo params pipeNullSplit params repo = map L.unpack <$> pipeNullSplitB params repo
{- For when Strings are not needed. -} {- For when Strings are not needed. -}
pipeNullSplitB :: Repo -> [CommandParam] -> IO [L.ByteString] pipeNullSplitB ::[CommandParam] -> Repo -> IO [L.ByteString]
pipeNullSplitB repo params = filter (not . L.null) . L.split '\0' <$> pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$>
pipeRead repo params pipeRead params repo
{- Reaps any zombie git processes. -} {- Reaps any zombie git processes. -}
reap :: IO () reap :: IO ()
@ -448,15 +448,15 @@ shaSize = 40
{- Commits the index into the specified branch, {- Commits the index into the specified branch,
- with the specified parent refs. -} - with the specified parent refs. -}
commit :: Repo -> String -> String -> [String] -> IO () commit :: String -> String -> [String] -> Repo -> IO ()
commit g message newref parentrefs = do commit message newref parentrefs repo = do
tree <- getSha "write-tree" $ asString $ tree <- getSha "write-tree" $ asString $
pipeRead g [Param "write-tree"] pipeRead [Param "write-tree"] repo
sha <- getSha "commit-tree" $ asString $ sha <- getSha "commit-tree" $ asString $
ignorehandle $ pipeWriteRead g ignorehandle $ pipeWriteRead
(map Param $ ["commit-tree", tree] ++ ps) (map Param $ ["commit-tree", tree] ++ ps)
(L.pack message) (L.pack message) repo
run g "update-ref" [Param newref, Param sha] run "update-ref" [Param newref, Param sha] repo
where where
ignorehandle a = snd <$> a ignorehandle a = snd <$> a
asString a = L.unpack <$> a asString a = L.unpack <$> a
@ -478,13 +478,13 @@ configRead r = assertLocal r $ error "internal"
hConfigRead :: Repo -> Handle -> IO Repo hConfigRead :: Repo -> Handle -> IO Repo
hConfigRead repo h = do hConfigRead repo h = do
val <- hGetContentsStrict h val <- hGetContentsStrict h
configStore repo val configStore val repo
{- Stores a git config into a repo, returning the new version of the repo. {- Stores a git config into a repo, returning the new version of the repo.
- The git config may be multiple lines, or a single line. Config settings - The git config may be multiple lines, or a single line. Config settings
- can be updated inrementally. -} - can be updated inrementally. -}
configStore :: Repo -> String -> IO Repo configStore :: String -> Repo -> IO Repo
configStore repo s = do configStore s repo = do
let repo' = repo { config = configParse s `M.union` config repo } let repo' = repo { config = configParse s `M.union` config repo }
rs <- configRemotes repo' rs <- configRemotes repo'
return $ repo' { remotes = rs } return $ repo' { remotes = rs }
@ -507,13 +507,11 @@ configRemotes repo = mapM construct remotepairs
filterkeys f = filterconfig (\(k,_) -> f k) filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isremote remotepairs = filterkeys isremote
isremote k = startswith "remote." k && endswith ".url" k isremote k = startswith "remote." k && endswith ".url" k
construct (k,v) = do construct (k,v) = repoRemoteNameFromKey k <$> genRemote v repo
r <- genRemote repo v
return $ repoRemoteNameFromKey r k
{- Generates one of a repo's remotes using a given location (ie, an url). -} {- Generates one of a repo's remotes using a given location (ie, an url). -}
genRemote :: Repo -> String -> IO Repo genRemote :: String -> Repo -> IO Repo
genRemote repo = gen . calcloc genRemote s repo = gen $ calcloc s
where where
filterconfig f = filter f $ M.toList $ config repo filterconfig f = filter f $ M.toList $ config repo
gen v gen v
@ -549,8 +547,8 @@ configTrue :: String -> Bool
configTrue s = map toLower s == "true" configTrue s = map toLower s == "true"
{- Returns a single git config setting, or a default value if not set. -} {- Returns a single git config setting, or a default value if not set. -}
configGet :: Repo -> String -> String -> String configGet :: String -> String -> Repo -> String
configGet repo key defaultValue = configGet key defaultValue repo =
M.findWithDefault defaultValue key (config repo) M.findWithDefault defaultValue key (config repo)
{- Access to raw config Map -} {- Access to raw config Map -}
@ -558,8 +556,8 @@ configMap :: Repo -> M.Map String String
configMap = config configMap = config
{- Efficiently looks up a gitattributes value for each file in a list. -} {- Efficiently looks up a gitattributes value for each file in a list. -}
checkAttr :: Repo -> String -> [FilePath] -> IO [(FilePath, String)] checkAttr :: String -> [FilePath] -> Repo -> IO [(FilePath, String)]
checkAttr repo attr files = do checkAttr attr files repo = do
-- git check-attr needs relative filenames input; it will choke -- git check-attr needs relative filenames input; it will choke
-- on some absolute filenames. This also means it will output -- on some absolute filenames. This also means it will output
-- all relative filenames. -- all relative filenames.
@ -574,7 +572,11 @@ checkAttr repo attr files = do
hClose toh hClose toh
(map topair . lines) <$> hGetContents fromh (map topair . lines) <$> hGetContents fromh
where where
params = gitCommandLine repo [Param "check-attr", Param attr, Params "-z --stdin"] params = gitCommandLine
[ Param "check-attr"
, Param attr
, Params "-z --stdin"
] repo
topair l = (file, value) topair l = (file, value)
where where
file = decodeGitFile $ join sep $ take end bits file = decodeGitFile $ join sep $ take end bits

View file

@ -25,7 +25,7 @@ type CatFileHandle = (PipeHandle, Handle, Handle)
{- Starts git cat-file running in batch mode in a repo and returns a handle. -} {- Starts git cat-file running in batch mode in a repo and returns a handle. -}
catFileStart :: Repo -> IO CatFileHandle catFileStart :: Repo -> IO CatFileHandle
catFileStart repo = hPipeBoth "git" $ toCommand $ catFileStart repo = hPipeBoth "git" $ toCommand $
Git.gitCommandLine repo [Param "cat-file", Param "--batch"] Git.gitCommandLine [Param "cat-file", Param "--batch"] repo
{- Stops git cat-file. -} {- Stops git cat-file. -}
catFileStop :: CatFileHandle -> IO () catFileStop :: CatFileHandle -> IO ()

View file

@ -19,51 +19,52 @@ import Git
import Utility.SafeCommand import Utility.SafeCommand
{- Scans for files that are checked into git at the specified locations. -} {- Scans for files that are checked into git at the specified locations. -}
inRepo :: Repo -> [FilePath] -> IO [FilePath] inRepo :: [FilePath] -> Repo -> IO [FilePath]
inRepo repo l = pipeNullSplit repo $ Params "ls-files --cached -z --" : map File l inRepo l repo = pipeNullSplit (Params "ls-files --cached -z --" : map File l) repo
{- Scans for files at the specified locations that are not checked into git. -} {- Scans for files at the specified locations that are not checked into git. -}
notInRepo :: Repo -> Bool -> [FilePath] -> IO [FilePath] notInRepo :: Bool -> [FilePath] -> Repo -> IO [FilePath]
notInRepo repo include_ignored l = pipeNullSplit repo $ notInRepo include_ignored l repo = pipeNullSplit params repo
[Params "ls-files --others"] ++ exclude ++
[Params "-z --"] ++ map File l
where where
params = [Params "ls-files --others"] ++ exclude ++
[Params "-z --"] ++ map File l
exclude exclude
| include_ignored = [] | include_ignored = []
| otherwise = [Param "--exclude-standard"] | otherwise = [Param "--exclude-standard"]
{- Returns a list of all files that are staged for commit. -} {- Returns a list of all files that are staged for commit. -}
staged :: Repo -> [FilePath] -> IO [FilePath] staged :: [FilePath] -> Repo -> IO [FilePath]
staged repo l = staged' repo l [] staged = staged' []
{- Returns a list of the files, staged for commit, that are being added, {- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -} - moved, or changed (but not deleted), from the specified locations. -}
stagedNotDeleted :: Repo -> [FilePath] -> IO [FilePath] stagedNotDeleted :: [FilePath] -> Repo -> IO [FilePath]
stagedNotDeleted repo l = staged' repo l [Param "--diff-filter=ACMRT"] stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
staged' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath] staged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]
staged' repo l middle = pipeNullSplit repo $ start ++ middle ++ end staged' middle l = pipeNullSplit $ start ++ middle ++ end
where where
start = [Params "diff --cached --name-only -z"] start = [Params "diff --cached --name-only -z"]
end = Param "--" : map File l end = Param "--" : map File l
{- Returns a list of files that have unstaged changes. -} {- Returns a list of files that have unstaged changes. -}
changedUnstaged :: Repo -> [FilePath] -> IO [FilePath] changedUnstaged :: [FilePath] -> Repo -> IO [FilePath]
changedUnstaged repo l = pipeNullSplit repo $ changedUnstaged l = pipeNullSplit params
Params "diff --name-only -z --" : map File l where
params = Params "diff --name-only -z --" : map File l
{- Returns a list of the files in the specified locations that are staged {- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -} - for commit, and whose type has changed. -}
typeChangedStaged :: Repo -> [FilePath] -> IO [FilePath] typeChangedStaged :: [FilePath] -> Repo -> IO [FilePath]
typeChangedStaged repo l = typeChanged' repo l [Param "--cached"] typeChangedStaged = typeChanged' [Param "--cached"]
{- Returns a list of the files in the specified locations whose type has {- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -} - changed. Files only staged for commit will not be included. -}
typeChanged :: Repo -> [FilePath] -> IO [FilePath] typeChanged :: [FilePath] -> Repo -> IO [FilePath]
typeChanged repo l = typeChanged' repo l [] typeChanged = typeChanged' []
typeChanged' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath] typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]
typeChanged' repo l middle = pipeNullSplit repo $ start ++ middle ++ end typeChanged' middle l = pipeNullSplit $ start ++ middle ++ end
where where
start = [Params "diff --name-only --diff-filter=T -z"] start = [Params "diff --name-only --diff-filter=T -z"]
end = Param "--" : map File l end = Param "--" : map File l

View file

@ -29,9 +29,9 @@ data TreeItem = TreeItem
} deriving Show } deriving Show
{- Lists the contents of a Treeish -} {- Lists the contents of a Treeish -}
lsTree :: Repo -> Treeish -> IO [TreeItem] lsTree :: Treeish -> Repo -> IO [TreeItem]
lsTree repo t = map parseLsTree <$> lsTree t repo = map parseLsTree <$>
pipeNullSplitB repo [Params "ls-tree --full-tree -z -r --", File t] pipeNullSplitB [Params "ls-tree --full-tree -z -r --", File t] repo
{- Parses a line of ls-tree output. {- Parses a line of ls-tree output.
- (The --long format is not currently supported.) -} - (The --long format is not currently supported.) -}

View file

@ -72,8 +72,8 @@ full :: Queue -> Bool
full (Queue n _) = n > maxSize full (Queue n _) = n > maxSize
{- Runs a queue on a git repository. -} {- Runs a queue on a git repository. -}
flush :: Repo -> Queue -> IO Queue flush :: Queue -> Repo -> IO Queue
flush repo (Queue _ m) = do flush (Queue _ m) repo = do
forM_ (M.toList m) $ uncurry $ runAction repo forM_ (M.toList m) $ uncurry $ runAction repo
return empty return empty
@ -87,6 +87,6 @@ runAction :: Repo -> Action -> [FilePath] -> IO ()
runAction repo action files = runAction repo action files =
pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
where where
params = toCommand $ gitCommandLine repo params = toCommand $ gitCommandLine
(Param (getSubcommand action):getParams action) (Param (getSubcommand action):getParams action) repo
feedxargs h = hPutStr h $ join "\0" files feedxargs h = hPutStr h $ join "\0" files

View file

@ -27,24 +27,25 @@ import Git
- -
- Should be run with a temporary index file configured by Git.useIndex. - Should be run with a temporary index file configured by Git.useIndex.
-} -}
merge :: Repo -> String -> String -> IO () merge :: String -> String -> Repo -> IO ()
merge g x y = do merge x y repo = do
a <- ls_tree g x a <- ls_tree x repo
b <- merge_trees g x y b <- merge_trees x y repo
update_index g (a++b) update_index repo (a++b)
{- Merges a list of branches into the index. Previously staged changed in {- Merges a list of branches into the index. Previously staged changed in
- the index are preserved (and participate in the merge). -} - the index are preserved (and participate in the merge). -}
merge_index :: Repo -> [String] -> IO () merge_index :: Repo -> [String] -> IO ()
merge_index g bs = update_index g =<< concat <$> mapM (merge_tree_index g) bs merge_index repo bs =
update_index repo =<< concat <$> mapM (\b -> merge_tree_index b repo) bs
{- Feeds a list into update-index. Later items in the list can override {- Feeds a list into update-index. Later items in the list can override
- earlier ones, so the list can be generated from any combination of - earlier ones, so the list can be generated from any combination of
- ls_tree, merge_trees, and merge_tree_index. -} - ls_tree, merge_trees, and merge_tree_index. -}
update_index :: Repo -> [String] -> IO () update_index :: Repo -> [String] -> IO ()
update_index g l = togit ["update-index", "-z", "--index-info"] (join "\0" l) update_index repo l = togit ["update-index", "-z", "--index-info"] (join "\0" l)
where where
togit ps content = pipeWrite g (map Param ps) (L.pack content) togit ps content = pipeWrite (map Param ps) (L.pack content) repo
>>= forceSuccess >>= forceSuccess
{- Generates a line suitable to be fed into update-index, to add {- Generates a line suitable to be fed into update-index, to add
@ -53,27 +54,28 @@ update_index_line :: String -> FilePath -> String
update_index_line sha file = "100644 blob " ++ sha ++ "\t" ++ file update_index_line sha file = "100644 blob " ++ sha ++ "\t" ++ file
{- Gets the contents of a tree in a format suitable for update_index. -} {- Gets the contents of a tree in a format suitable for update_index. -}
ls_tree :: Repo -> String -> IO [String] ls_tree :: String -> Repo -> IO [String]
ls_tree g x = pipeNullSplit g $ ls_tree x = pipeNullSplit params
map Param ["ls-tree", "-z", "-r", "--full-tree", x] where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
{- For merging two trees. -} {- For merging two trees. -}
merge_trees :: Repo -> String -> String -> IO [String] merge_trees :: String -> String -> Repo -> IO [String]
merge_trees g x y = calc_merge g $ "diff-tree":diff_opts ++ [x, y] merge_trees x y = calc_merge $ "diff-tree":diff_opts ++ [x, y]
{- For merging a single tree into the index. -} {- For merging a single tree into the index. -}
merge_tree_index :: Repo -> String -> IO [String] merge_tree_index :: String -> Repo -> IO [String]
merge_tree_index g x = calc_merge g $ "diff-index":diff_opts ++ ["--cached", x] merge_tree_index x = calc_merge $ "diff-index":diff_opts ++ ["--cached", x]
diff_opts :: [String] diff_opts :: [String]
diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"] diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
{- Calculates how to perform a merge, using git to get a raw diff, {- Calculates how to perform a merge, using git to get a raw diff,
- and returning a list suitable for update_index. -} - and returning a list suitable for update_index. -}
calc_merge :: Repo -> [String] -> IO [String] calc_merge :: [String] -> Repo -> IO [String]
calc_merge g differ = do calc_merge differ repo = do
diff <- pipeNullSplit g $ map Param differ diff <- pipeNullSplit (map Param differ) repo
l <- mapM (mergeFile g) (pairs diff) l <- mapM (\p -> mergeFile p repo) (pairs diff)
return $ catMaybes l return $ catMaybes l
where where
pairs [] = [] pairs [] = []
@ -81,9 +83,9 @@ calc_merge g differ = do
pairs (a:b:rest) = (a,b):pairs rest pairs (a:b:rest) = (a,b):pairs rest
{- Injects some content into git, returning its hash. -} {- Injects some content into git, returning its hash. -}
hashObject :: Repo -> L.ByteString -> IO String hashObject :: L.ByteString -> Repo -> IO String
hashObject repo content = getSha subcmd $ do hashObject content repo = getSha subcmd $ do
(h, s) <- pipeWriteRead repo (map Param params) content (h, s) <- pipeWriteRead (map Param params) content repo
L.length s `seq` do L.length s `seq` do
forceSuccess h forceSuccess h
reap -- XXX unsure why this is needed reap -- XXX unsure why this is needed
@ -95,13 +97,13 @@ hashObject repo content = getSha subcmd $ do
{- Given an info line from a git raw diff, and the filename, generates {- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update_index that union merges the two sides of the - a line suitable for update_index that union merges the two sides of the
- diff. -} - diff. -}
mergeFile :: Repo -> (String, FilePath) -> IO (Maybe String) mergeFile :: (String, FilePath) -> Repo -> IO (Maybe String)
mergeFile g (info, file) = case filter (/= nullsha) [asha, bsha] of mergeFile (info, file) repo = case filter (/= nullsha) [asha, bsha] of
[] -> return Nothing [] -> return Nothing
(sha:[]) -> return $ Just $ update_index_line sha file (sha:[]) -> return $ Just $ update_index_line sha file
shas -> do shas -> do
content <- pipeRead g $ map Param ("show":shas) content <- pipeRead (map Param ("show":shas)) repo
sha <- hashObject g $ unionmerge content sha <- hashObject (unionmerge content) repo
return $ Just $ update_index_line sha file return $ Just $ update_index_line sha file
where where
[_colonamode, _bmode, asha, bsha, _status] = words info [_colonamode, _bmode, asha, bsha, _status] = words info

View file

@ -116,9 +116,8 @@ options = commonOptions ++
setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v } setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v }
setgitconfig :: String -> Annex () setgitconfig :: String -> Annex ()
setgitconfig v = do setgitconfig v = do
g <- gitRepo newg <- inRepo $ Git.configStore v
g' <- liftIO $ Git.configStore g v Annex.changeState $ \s -> s { Annex.repo = newg }
Annex.changeState $ \s -> s { Annex.repo = g' }
header :: String header :: String
header = "Usage: git-annex command [option ..]" header = "Usage: git-annex command [option ..]"

View file

@ -68,12 +68,10 @@ gitPreCommitHookUnWrite = unlessBare $ do
" Edit it to remove call to git annex." " Edit it to remove call to git annex."
unlessBare :: Annex () -> Annex () unlessBare :: Annex () -> Annex ()
unlessBare = unlessM $ Git.repoIsLocalBare <$> gitRepo unlessBare = unlessM $ fromRepo $ Git.repoIsLocalBare
preCommitHook :: Annex FilePath preCommitHook :: Annex FilePath
preCommitHook = do preCommitHook = (</>) <$> fromRepo Git.gitDir <*> pure "hooks/pre-commit"
g <- gitRepo
return $ Git.gitDir g ++ "/hooks/pre-commit"
preCommitScript :: String preCommitScript :: String
preCommitScript = preCommitScript =

View file

@ -65,8 +65,8 @@ annexLocation key = objectDir </> hashDirMixed key </> f </> f
f = keyFile key f = keyFile key
{- Annexed file's absolute location in a repository. -} {- Annexed file's absolute location in a repository. -}
gitAnnexLocation :: Git.Repo -> Key -> FilePath gitAnnexLocation :: Key -> Git.Repo -> FilePath
gitAnnexLocation r key gitAnnexLocation key r
| Git.repoIsLocalBare r = Git.workTree r </> annexLocation key | Git.repoIsLocalBare r = Git.workTree r </> annexLocation key
| otherwise = Git.workTree r </> ".git" </> annexLocation key | otherwise = Git.workTree r </> ".git" </> annexLocation key
@ -88,16 +88,16 @@ gitAnnexTmpDir :: Git.Repo -> FilePath
gitAnnexTmpDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp" gitAnnexTmpDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp"
{- The temp file to use for a given key. -} {- The temp file to use for a given key. -}
gitAnnexTmpLocation :: Git.Repo -> Key -> FilePath gitAnnexTmpLocation :: Key -> Git.Repo -> FilePath
gitAnnexTmpLocation r key = gitAnnexTmpDir r </> keyFile key gitAnnexTmpLocation key r = gitAnnexTmpDir r </> keyFile key
{- .git/annex/bad/ is used for bad files found during fsck -} {- .git/annex/bad/ is used for bad files found during fsck -}
gitAnnexBadDir :: Git.Repo -> FilePath gitAnnexBadDir :: Git.Repo -> FilePath
gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r </> "bad" gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r </> "bad"
{- The bad file to use for a given key. -} {- The bad file to use for a given key. -}
gitAnnexBadLocation :: Git.Repo -> Key -> FilePath gitAnnexBadLocation :: Key -> Git.Repo -> FilePath
gitAnnexBadLocation r key = gitAnnexBadDir r </> keyFile key gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key
{- .git/annex/*unused is used to number possibly unused keys -} {- .git/annex/*unused is used to number possibly unused keys -}
gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath

View file

@ -130,10 +130,10 @@ nameToUUID n = byName' n >>= go
- of the UUIDs. -} - of the UUIDs. -}
prettyPrintUUIDs :: String -> [UUID] -> Annex String prettyPrintUUIDs :: String -> [UUID] -> Annex String
prettyPrintUUIDs desc uuids = do prettyPrintUUIDs desc uuids = do
here <- getUUID hereu <- getUUID
m <- M.unionWith addname <$> uuidMap <*> remoteMap m <- M.unionWith addname <$> uuidMap <*> remoteMap
maybeShowJSON [(desc, map (jsonify m here) uuids)] maybeShowJSON [(desc, map (jsonify m hereu) uuids)]
return $ unwords $ map (\u -> "\t" ++ prettify m here u ++ "\n") uuids return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids
where where
addname d n addname d n
| d == n = d | d == n = d
@ -141,20 +141,20 @@ prettyPrintUUIDs desc uuids = do
| otherwise = n ++ " (" ++ d ++ ")" | otherwise = n ++ " (" ++ d ++ ")"
remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> genList remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> genList
findlog m u = M.findWithDefault "" u m findlog m u = M.findWithDefault "" u m
prettify m here u prettify m hereu u
| not (null d) = fromUUID u ++ " -- " ++ d | not (null d) = fromUUID u ++ " -- " ++ d
| otherwise = fromUUID u | otherwise = fromUUID u
where where
ishere = here == u ishere = hereu == u
n = findlog m u n = findlog m u
d d
| null n && ishere = "here" | null n && ishere = "here"
| ishere = addname n "here" | ishere = addname n "here"
| otherwise = n | otherwise = n
jsonify m here u = toJSObject jsonify m hereu u = toJSObject
[ ("uuid", toJSON $ fromUUID u) [ ("uuid", toJSON $ fromUUID u)
, ("description", toJSON $ findlog m u) , ("description", toJSON $ findlog m u)
, ("here", toJSON $ here == u) , ("here", toJSON $ hereu == u)
] ]
{- Filters a list of remotes to ones that have the listed uuids. -} {- Filters a list of remotes to ones that have the listed uuids. -}

View file

@ -102,15 +102,13 @@ bupSplitParams r buprepo k src = do
store :: Git.Repo -> BupRepo -> Key -> Annex Bool store :: Git.Repo -> BupRepo -> Key -> Annex Bool
store r buprepo k = do store r buprepo k = do
g <- gitRepo src <- fromRepo $ gitAnnexLocation k
let src = gitAnnexLocation g k
params <- bupSplitParams r buprepo k (File src) params <- bupSplitParams r buprepo k (File src)
liftIO $ boolSystem "bup" params liftIO $ boolSystem "bup" params
storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool
storeEncrypted r buprepo (cipher, enck) k = do storeEncrypted r buprepo (cipher, enck) k = do
g <- gitRepo src <- fromRepo $ gitAnnexLocation k
let src = gitAnnexLocation g k
params <- bupSplitParams r buprepo enck (Param "-") params <- bupSplitParams r buprepo enck (Param "-")
liftIO $ catchBool $ liftIO $ catchBool $
withEncryptedHandle cipher (L.readFile src) $ \h -> withEncryptedHandle cipher (L.readFile src) $ \h ->
@ -147,7 +145,7 @@ checkPresent r bupr k
showAction $ "checking " ++ Git.repoDescribe r showAction $ "checking " ++ Git.repoDescribe r
ok <- onBupRemote bupr boolSystem "git" params ok <- onBupRemote bupr boolSystem "git" params
return $ Right ok return $ Right ok
| otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine bupr params | otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine params bupr
where where
params = params =
[ Params "show-ref --quiet --verify" [ Params "show-ref --quiet --verify"
@ -165,9 +163,10 @@ storeBupUUID u buprepo = do
>>! error "ssh failed" >>! error "ssh failed"
else liftIO $ do else liftIO $ do
r' <- Git.configRead r r' <- Git.configRead r
let olduuid = Git.configGet r' "annex.uuid" "" let olduuid = Git.configGet "annex.uuid" "" r'
when (olduuid == "") $ Git.run r' "config" when (olduuid == "") $
[Param "annex.uuid", Param v] Git.run "config"
[Param "annex.uuid", Param v] r'
where where
v = fromUUID u v = fromUUID u
@ -194,7 +193,7 @@ getBupUUID r u
| otherwise = liftIO $ do | otherwise = liftIO $ do
ret <- try $ Git.configRead r ret <- try $ Git.configRead r
case ret of case ret of
Right r' -> return (toUUID $ Git.configGet r' "annex.uuid" "", r') Right r' -> return (toUUID $ Git.configGet "annex.uuid" "" r', r')
Left _ -> return (NoUUID, r) Left _ -> return (NoUUID, r)
{- Converts a bup remote path spec into a Git.Repo. There are some {- Converts a bup remote path spec into a Git.Repo. There are some

View file

@ -70,15 +70,13 @@ dirKey d k = d </> hashDirMixed k </> f </> f
store :: FilePath -> Key -> Annex Bool store :: FilePath -> Key -> Annex Bool
store d k = do store d k = do
g <- gitRepo src <- fromRepo $ gitAnnexLocation k
let src = gitAnnexLocation g k
let dest = dirKey d k let dest = dirKey d k
liftIO $ catchBool $ storeHelper dest $ copyFileExternal src dest liftIO $ catchBool $ storeHelper dest $ copyFileExternal src dest
storeEncrypted :: FilePath -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted :: FilePath -> (Cipher, Key) -> Key -> Annex Bool
storeEncrypted d (cipher, enck) k = do storeEncrypted d (cipher, enck) k = do
g <- gitRepo src <- fromRepo $ gitAnnexLocation k
let src = gitAnnexLocation g k
let dest = dirKey d enck let dest = dirKey d enck
liftIO $ catchBool $ storeHelper dest $ encrypt src dest liftIO $ catchBool $ storeHelper dest $ encrypt src dest
where where

View file

@ -35,19 +35,16 @@ remote = RemoteType {
list :: Annex [Git.Repo] list :: Annex [Git.Repo]
list = do list = do
g <- gitRepo c <- fromRepo Git.configMap
let c = Git.configMap g mapM (tweakurl c) =<< fromRepo Git.remotes
mapM (tweakurl c) $ Git.remotes g
where where
annexurl n = "remote." ++ n ++ ".annexurl" annexurl n = "remote." ++ n ++ ".annexurl"
tweakurl c r = do tweakurl c r = do
let n = fromJust $ Git.repoRemoteName r let n = fromJust $ Git.repoRemoteName r
case M.lookup (annexurl n) c of case M.lookup (annexurl n) c of
Nothing -> return r Nothing -> return r
Just url -> do Just url -> Git.repoRemoteNameSet n <$>
g <- gitRepo inRepo (Git.genRemote url)
r' <- liftIO $ Git.genRemote g url
return $ Git.repoRemoteNameSet r' n
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r u _ = do gen r u _ = do
@ -178,7 +175,7 @@ copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
copyFromRemote r key file copyFromRemote r key file
| not $ Git.repoIsUrl r = do | not $ Git.repoIsUrl r = do
params <- rsyncParams r params <- rsyncParams r
rsyncOrCopyFile params (gitAnnexLocation r key) file rsyncOrCopyFile params (gitAnnexLocation key r) file
| Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file | Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file
| Git.repoIsHttp r = liftIO $ Url.download (keyUrl r key) file | Git.repoIsHttp r = liftIO $ Url.download (keyUrl r key) file
| otherwise = error "copying from non-ssh, non-http repo not supported" | otherwise = error "copying from non-ssh, non-http repo not supported"
@ -187,8 +184,7 @@ copyFromRemote r key file
copyToRemote :: Git.Repo -> Key -> Annex Bool copyToRemote :: Git.Repo -> Key -> Annex Bool
copyToRemote r key copyToRemote r key
| not $ Git.repoIsUrl r = do | not $ Git.repoIsUrl r = do
g <- gitRepo keysrc <- fromRepo $ gitAnnexLocation key
let keysrc = gitAnnexLocation g key
params <- rsyncParams r params <- rsyncParams r
-- run copy from perspective of remote -- run copy from perspective of remote
liftIO $ onLocal r $ do liftIO $ onLocal r $ do
@ -197,8 +193,7 @@ copyToRemote r key
Annex.Content.saveState Annex.Content.saveState
return ok return ok
| Git.repoIsSsh r = do | Git.repoIsSsh r = do
g <- gitRepo keysrc <- fromRepo $ gitAnnexLocation key
let keysrc = gitAnnexLocation g key
rsyncHelper =<< rsyncParamsRemote r False key keysrc rsyncHelper =<< rsyncParamsRemote r False key keysrc
| otherwise = error "copying to non-ssh repo not supported" | otherwise = error "copying to non-ssh repo not supported"

View file

@ -23,16 +23,16 @@ findSpecialRemotes s = do
return $ map construct $ remotepairs g return $ map construct $ remotepairs g
where where
remotepairs r = M.toList $ M.filterWithKey match $ Git.configMap r remotepairs r = M.toList $ M.filterWithKey match $ Git.configMap r
construct (k,_) = Git.repoRemoteNameFromKey Git.repoFromUnknown k construct (k,_) = Git.repoRemoteNameFromKey k Git.repoFromUnknown
match k _ = startswith "remote." k && endswith (".annex-"++s) k match k _ = startswith "remote." k && endswith (".annex-"++s) k
{- Sets up configuration for a special remote in .git/config. -} {- Sets up configuration for a special remote in .git/config. -}
gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex () gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex ()
gitConfigSpecialRemote u c k v = do gitConfigSpecialRemote u c k v = do
g <- gitRepo set ("annex-"++k) v
liftIO $ do set ("annex-uuid") (fromUUID u)
Git.run g "config" [Param (configsetting $ "annex-"++k), Param v]
Git.run g "config" [Param (configsetting "annex-uuid"), Param $ fromUUID u]
where where
set a b = inRepo $ Git.run "config"
[Param (configsetting a), Param b]
remotename = fromJust (M.lookup "name" c) remotename = fromJust (M.lookup "name" c)
configsetting s = "remote." ++ remotename ++ "." ++ s configsetting s = "remote." ++ remotename ++ "." ++ s

View file

@ -98,14 +98,13 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
store :: String -> Key -> Annex Bool store :: String -> Key -> Annex Bool
store h k = do store h k = do
g <- gitRepo src <- fromRepo $ gitAnnexLocation k
runHook h "store" k (Just $ gitAnnexLocation g k) $ return True runHook h "store" k (Just src) $ return True
storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool
storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do
g <- gitRepo src <- fromRepo $ gitAnnexLocation k
let f = gitAnnexLocation g k liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
runHook h "store" enck (Just tmp) $ return True runHook h "store" enck (Just tmp) $ return True
retrieve :: String -> Key -> FilePath -> Annex Bool retrieve :: String -> Key -> FilePath -> Annex Bool

View file

@ -90,15 +90,12 @@ rsyncKeyDir :: RsyncOpts -> Key -> String
rsyncKeyDir o k = rsyncUrl o </> hashDirMixed k </> shellEscape (keyFile k) rsyncKeyDir o k = rsyncUrl o </> hashDirMixed k </> shellEscape (keyFile k)
store :: RsyncOpts -> Key -> Annex Bool store :: RsyncOpts -> Key -> Annex Bool
store o k = do store o k = rsyncSend o k =<< fromRepo (gitAnnexLocation k)
g <- gitRepo
rsyncSend o k (gitAnnexLocation g k)
storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool
storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
g <- gitRepo src <- fromRepo $ gitAnnexLocation k
let f = gitAnnexLocation g k liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
rsyncSend o enck tmp rsyncSend o enck tmp
retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool
@ -151,9 +148,9 @@ partialParams = Params "--no-inplace --partial --partial-dir=.rsync-partial"
- up trees for rsync. -} - up trees for rsync. -}
withRsyncScratchDir :: (FilePath -> Annex Bool) -> Annex Bool withRsyncScratchDir :: (FilePath -> Annex Bool) -> Annex Bool
withRsyncScratchDir a = do withRsyncScratchDir a = do
g <- gitRepo
pid <- liftIO getProcessID pid <- liftIO getProcessID
let tmp = gitAnnexTmpDir g </> "rsynctmp" </> show pid t <- fromRepo gitAnnexTmpDir
let tmp = t </> "rsynctmp" </> show pid
nuke tmp nuke tmp
liftIO $ createDirectoryIfMissing True tmp liftIO $ createDirectoryIfMissing True tmp
res <- a tmp res <- a tmp

View file

@ -112,8 +112,8 @@ s3Setup u c = handlehost $ M.lookup "host" c
store :: Remote Annex -> Key -> Annex Bool store :: Remote Annex -> Key -> Annex Bool
store r k = s3Action r False $ \(conn, bucket) -> do store r k = s3Action r False $ \(conn, bucket) -> do
g <- gitRepo dest <- fromRepo $ gitAnnexLocation k
res <- liftIO $ storeHelper (conn, bucket) r k $ gitAnnexLocation g k res <- liftIO $ storeHelper (conn, bucket) r k dest
s3Bool res s3Bool res
storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool
@ -121,8 +121,7 @@ storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
-- To get file size of the encrypted content, have to use a temp file. -- To get file size of the encrypted content, have to use a temp file.
-- (An alternative would be chunking to to a constant size.) -- (An alternative would be chunking to to a constant size.)
withTmp enck $ \tmp -> do withTmp enck $ \tmp -> do
g <- gitRepo f <- fromRepo $ gitAnnexLocation k
let f = gitAnnexLocation g k
liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
res <- liftIO $ storeHelper (conn, bucket) r enck tmp res <- liftIO $ storeHelper (conn, bucket) r enck tmp
s3Bool res s3Bool res

View file

@ -27,7 +27,7 @@ remote = RemoteType {
-- (If the web should cease to exist, remove this module and redistribute -- (If the web should cease to exist, remove this module and redistribute
-- a new release to the survivors by carrier pigeon.) -- a new release to the survivors by carrier pigeon.)
list :: Annex [Git.Repo] list :: Annex [Git.Repo]
list = return [Git.repoRemoteNameSet Git.repoFromUnknown "web"] list = return [Git.repoRemoteNameSet "web" Git.repoFromUnknown]
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r _ _ = gen r _ _ =

34
Seek.hs
View file

@ -20,16 +20,18 @@ import qualified Git
import qualified Git.LsFiles as LsFiles import qualified Git.LsFiles as LsFiles
import qualified Limit import qualified Limit
seekHelper :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> [FilePath] -> Annex [FilePath]
seekHelper a params = do
g <- gitRepo
liftIO $ runPreserveOrder (\p -> a p g) params
withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
withFilesInGit a params = do withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params
repo <- gitRepo
prepFiltered a $ liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek
withAttrFilesInGit attr a params = do withAttrFilesInGit attr a params = do
repo <- gitRepo files <- seekHelper LsFiles.inRepo params
files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params prepFilteredGen a fst $ inRepo $ Git.checkAttr attr files
prepFilteredGen a fst $ liftIO $ Git.checkAttr repo attr files
withNumCopies :: (FilePath -> Maybe Int -> CommandStart) -> CommandSeek withNumCopies :: (FilePath -> Maybe Int -> CommandStart) -> CommandSeek
withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params
@ -38,8 +40,7 @@ withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params
withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek
withBackendFilesInGit a params = do withBackendFilesInGit a params = do
repo <- gitRepo files <- seekHelper LsFiles.inRepo params
files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
prepBackendPairs a files prepBackendPairs a files
withFilesMissing :: (String -> CommandStart) -> CommandSeek withFilesMissing :: (String -> CommandStart) -> CommandSeek
@ -49,9 +50,8 @@ withFilesMissing a params = prepFiltered a $ liftIO $ filterM missing params
withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek
withFilesNotInGit a params = do withFilesNotInGit a params = do
repo <- gitRepo
force <- Annex.getState Annex.force force <- Annex.getState Annex.force
newfiles <- liftIO $ runPreserveOrder (LsFiles.notInRepo repo force) params newfiles <- seekHelper (LsFiles.notInRepo force) params
prepBackendPairs a newfiles prepBackendPairs a newfiles
withWords :: ([String] -> CommandStart) -> CommandSeek withWords :: ([String] -> CommandStart) -> CommandSeek
@ -61,10 +61,8 @@ withStrings :: (String -> CommandStart) -> CommandSeek
withStrings a params = return $ map a params withStrings a params = return $ map a params
withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
withFilesToBeCommitted a params = do withFilesToBeCommitted a params = prepFiltered a $
repo <- gitRepo seekHelper LsFiles.stagedNotDeleted params
prepFiltered a $
liftIO $ runPreserveOrder (LsFiles.stagedNotDeleted repo) params
withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek
withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
@ -72,13 +70,13 @@ withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek
withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek
withFilesUnlocked' typechanged a params = do withFilesUnlocked' typechanged a params = do
-- unlocked files have changed type from a symlink to a regular file -- unlocked files have changed type from a symlink to a regular file
repo <- gitRepo top <- fromRepo $ Git.workTree
typechangedfiles <- liftIO $ runPreserveOrder (typechanged repo) params typechangedfiles <- seekHelper typechanged params
unlockedfiles <- liftIO $ filterM notSymlink $ unlockedfiles <- liftIO $ filterM notSymlink $
map (\f -> Git.workTree repo ++ "/" ++ f) typechangedfiles map (\f -> top ++ "/" ++ f) typechangedfiles
prepBackendPairs a unlockedfiles prepBackendPairs a unlockedfiles
withKeys :: (Key -> CommandStart) -> CommandSeek withKeys :: (Key -> CommandStart) -> CommandSeek

View file

@ -16,10 +16,9 @@ import qualified Upgrade.V1
upgrade :: Annex Bool upgrade :: Annex Bool
upgrade = do upgrade = do
showAction "v0 to v1" showAction "v0 to v1"
g <- gitRepo
-- do the reorganisation of the key files -- do the reorganisation of the key files
let olddir = gitAnnexDir g olddir <- fromRepo gitAnnexDir
keys <- getKeysPresent0 olddir keys <- getKeysPresent0 olddir
forM_ keys $ \k -> moveAnnex k $ olddir </> keyFile0 k forM_ keys $ \k -> moveAnnex k $ olddir </> keyFile0 k

View file

@ -50,9 +50,9 @@ import qualified Upgrade.V2
upgrade :: Annex Bool upgrade :: Annex Bool
upgrade = do upgrade = do
showAction "v1 to v2" showAction "v1 to v2"
g <- gitRepo bare <- fromRepo $ Git.repoIsLocalBare
if Git.repoIsLocalBare g if bare
then do then do
moveContent moveContent
setVersion setVersion
@ -83,8 +83,8 @@ moveContent = do
updateSymlinks :: Annex () updateSymlinks :: Annex ()
updateSymlinks = do updateSymlinks = do
showAction "updating symlinks" showAction "updating symlinks"
g <- gitRepo top <- fromRepo Git.workTree
files <- liftIO $ LsFiles.inRepo g [Git.workTree g] files <- inRepo $ LsFiles.inRepo [top]
forM_ files fixlink forM_ files fixlink
where where
fixlink f = do fixlink f = do
@ -104,8 +104,7 @@ moveLocationLogs = do
forM_ logkeys move forM_ logkeys move
where where
oldlocationlogs = do oldlocationlogs = do
g <- gitRepo dir <- fromRepo Upgrade.V2.gitStateDir
let dir = Upgrade.V2.gitStateDir g
exists <- liftIO $ doesDirectoryExist dir exists <- liftIO $ doesDirectoryExist dir
if exists if exists
then do then do
@ -113,9 +112,8 @@ moveLocationLogs = do
return $ mapMaybe oldlog2key contents return $ mapMaybe oldlog2key contents
else return [] else return []
move (l, k) = do move (l, k) = do
g <- gitRepo dest <- fromRepo $ logFile2 k
let dest = logFile2 g k dir <- fromRepo $ Upgrade.V2.gitStateDir
let dir = Upgrade.V2.gitStateDir g
let f = dir </> l let f = dir </> l
liftIO $ createDirectoryIfMissing True (parentDir dest) liftIO $ createDirectoryIfMissing True (parentDir dest)
-- could just git mv, but this way deals with -- could just git mv, but this way deals with
@ -206,9 +204,7 @@ lookupFile1 file = do
" (unknown backend " ++ bname ++ ")" " (unknown backend " ++ bname ++ ")"
getKeyFilesPresent1 :: Annex [FilePath] getKeyFilesPresent1 :: Annex [FilePath]
getKeyFilesPresent1 = do getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir
g <- gitRepo
getKeyFilesPresent1' $ gitAnnexObjectDir g
getKeyFilesPresent1' :: FilePath -> Annex [FilePath] getKeyFilesPresent1' :: FilePath -> Annex [FilePath]
getKeyFilesPresent1' dir = do getKeyFilesPresent1' dir = do
exists <- liftIO $ doesDirectoryExist dir exists <- liftIO $ doesDirectoryExist dir
@ -228,11 +224,11 @@ getKeyFilesPresent1' dir = do
logFile1 :: Git.Repo -> Key -> String logFile1 :: Git.Repo -> Key -> String
logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log" logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
logFile2 :: Git.Repo -> Key -> String logFile2 :: Key -> Git.Repo -> String
logFile2 = logFile' hashDirLower logFile2 = logFile' hashDirLower
logFile' :: (Key -> FilePath) -> Git.Repo -> Key -> String logFile' :: (Key -> FilePath) -> Key -> Git.Repo -> String
logFile' hasher repo key = logFile' hasher key repo =
gitStateDir repo ++ hasher key ++ keyFile key ++ ".log" gitStateDir repo ++ hasher key ++ keyFile key ++ ".log"
stateDir :: FilePath stateDir :: FilePath

View file

@ -37,45 +37,46 @@ olddir g
upgrade :: Annex Bool upgrade :: Annex Bool
upgrade = do upgrade = do
showAction "v2 to v3" showAction "v2 to v3"
g <- gitRepo bare <- fromRepo Git.repoIsLocalBare
let bare = Git.repoIsLocalBare g old <- fromRepo olddir
Annex.Branch.create Annex.Branch.create
showProgress showProgress
e <- liftIO $ doesDirectoryExist (olddir g) e <- liftIO $ doesDirectoryExist old
when e $ do when e $ do
mapM_ (\(k, f) -> inject f $ logFile k) =<< locationLogs g mapM_ (\(k, f) -> inject f $ logFile k) =<< locationLogs
mapM_ (\f -> inject f f) =<< logFiles (olddir g) mapM_ (\f -> inject f f) =<< logFiles old
saveState saveState
showProgress showProgress
when e $ liftIO $ do when e $ do
Git.run g "rm" [Param "-r", Param "-f", Param "-q", File (olddir g)] inRepo $ Git.run "rm" [Param "-r", Param "-f", Param "-q", File old]
unless bare $ gitAttributesUnWrite g unless bare $ inRepo $ gitAttributesUnWrite
showProgress showProgress
unless bare push unless bare push
return True return True
locationLogs :: Git.Repo -> Annex [(Key, FilePath)] locationLogs :: Annex [(Key, FilePath)]
locationLogs repo = liftIO $ do locationLogs = do
levela <- dirContents dir dir <- fromRepo gitStateDir
levelb <- mapM tryDirContents levela liftIO $ do
files <- mapM tryDirContents (concat levelb) levela <- dirContents dir
return $ mapMaybe islogfile (concat files) levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb)
return $ mapMaybe islogfile (concat files)
where where
tryDirContents d = catch (dirContents d) (return . const []) tryDirContents d = catch (dirContents d) (return . const [])
dir = gitStateDir repo
islogfile f = maybe Nothing (\k -> Just (k, f)) $ islogfile f = maybe Nothing (\k -> Just (k, f)) $
logFileKey $ takeFileName f logFileKey $ takeFileName f
inject :: FilePath -> FilePath -> Annex () inject :: FilePath -> FilePath -> Annex ()
inject source dest = do inject source dest = do
g <- gitRepo old <- fromRepo olddir
new <- liftIO (readFile $ olddir g </> source) new <- liftIO (readFile $ old </> source)
Annex.Branch.change dest $ \prev -> Annex.Branch.change dest $ \prev ->
unlines $ nub $ lines prev ++ lines new unlines $ nub $ lines prev ++ lines new
@ -102,8 +103,7 @@ push = do
Annex.Branch.update -- just in case Annex.Branch.update -- just in case
showAction "pushing new git-annex branch to origin" showAction "pushing new git-annex branch to origin"
showOutput showOutput
g <- gitRepo inRepo $ Git.run "push" [Param "origin", Param Annex.Branch.name]
liftIO $ Git.run g "push" [Param "origin", Param Annex.Branch.name]
_ -> do _ -> do
-- no origin exists, so just let the user -- no origin exists, so just let the user
-- know about the new branch -- know about the new branch
@ -126,7 +126,7 @@ gitAttributesUnWrite repo = do
c <- readFileStrict attributes c <- readFileStrict attributes
liftIO $ viaTmp writeFile attributes $ unlines $ liftIO $ viaTmp writeFile attributes $ unlines $
filter (`notElem` attrLines) $ lines c filter (`notElem` attrLines) $ lines c
Git.run repo "add" [File attributes] Git.run "add" [File attributes] repo
stateDir :: FilePath stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex" stateDir = addTrailingPathSeparator ".git-annex"

View file

@ -41,6 +41,6 @@ main = do
g <- Git.configRead =<< Git.repoFromCwd g <- Git.configRead =<< Git.repoFromCwd
_ <- Git.useIndex (tmpIndex g) _ <- Git.useIndex (tmpIndex g)
setup g setup g
Git.UnionMerge.merge g aref bref Git.UnionMerge.merge aref bref g
Git.commit g "union merge" newref [aref, bref] Git.commit "union merge" newref [aref, bref] g
cleanup g cleanup g