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:
parent
2ff8915365
commit
bf460a0a98
46 changed files with 338 additions and 390 deletions
16
Annex.hs
16
Annex.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
|
19
Backend.hs
19
Backend.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 []
|
||||||
|
|
|
@ -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
|
||||||
|
|
16
Config.hs
16
Config.hs
|
@ -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
100
Git.hs
|
@ -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
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.) -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ..]"
|
||||||
|
|
6
Init.hs
6
Init.hs
|
@ -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 =
|
||||||
|
|
12
Locations.hs
12
Locations.hs
|
@ -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
|
||||||
|
|
14
Remote.hs
14
Remote.hs
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
34
Seek.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Add table
Reference in a new issue