85ed38a574
git annex add, git annex lock etc make multiple seek passes, and each seek pass checked that files existed. That was unncessary redundant work. Fixed by adding a new WorkTreeItem type, make seek actions use it, and check that the files exist when constructing it. This commit was supported by the NSF-funded DataLad project.
121 lines
3.8 KiB
Haskell
121 lines
3.8 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2010 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Uninit where
|
|
|
|
import Command
|
|
import qualified Annex
|
|
import qualified Git
|
|
import qualified Git.Command
|
|
import qualified Command.Unannex
|
|
import qualified Annex.Branch
|
|
import qualified Database.Keys
|
|
import Annex.Content
|
|
import Annex.Init
|
|
import Utility.FileMode
|
|
|
|
cmd :: Command
|
|
cmd = addCheck check $
|
|
command "uninit" SectionUtility
|
|
"de-initialize git-annex and clean out repository"
|
|
paramPaths (withParams seek)
|
|
|
|
check :: Annex ()
|
|
check = do
|
|
b <- current_branch
|
|
when (b == Annex.Branch.name) $ giveup $
|
|
"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
|
|
top <- fromRepo Git.repoPath
|
|
currdir <- liftIO getCurrentDirectory
|
|
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
|
|
giveup "can only run uninit from the top of the git repository"
|
|
where
|
|
current_branch = Git.Ref . Prelude.head . lines <$> revhead
|
|
revhead = inRepo $ Git.Command.pipeReadStrict
|
|
[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"]
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek ps = do
|
|
l <- workTreeItems ps
|
|
withFilesNotInGit False (whenAnnexed startCheckIncomplete) l
|
|
Annex.changeState $ \s -> s { Annex.fast = True }
|
|
withFilesInGit (whenAnnexed Command.Unannex.start) l
|
|
finish
|
|
|
|
{- git annex symlinks that are not checked into git could be left by an
|
|
- interrupted add. -}
|
|
startCheckIncomplete :: FilePath -> Key -> CommandStart
|
|
startCheckIncomplete file _ = giveup $ unlines
|
|
[ file ++ " points to annexed content, but is not checked into git."
|
|
, "Perhaps this was left behind by an interrupted git annex add?"
|
|
, "Not continuing with uninit; either delete or git annex add the file and retry."
|
|
]
|
|
|
|
finish :: Annex ()
|
|
finish = do
|
|
annexdir <- fromRepo gitAnnexDir
|
|
annexobjectdir <- fromRepo gitAnnexObjectDir
|
|
leftovers <- removeUnannexed =<< getKeysPresent InAnnex
|
|
prepareRemoveAnnexDir annexdir
|
|
if null leftovers
|
|
then liftIO $ removeDirectoryRecursive annexdir
|
|
else giveup $ unlines
|
|
[ "Not fully uninitialized"
|
|
, "Some annexed data is still left in " ++ annexobjectdir
|
|
, "This may include deleted files, or old versions of modified files."
|
|
, ""
|
|
, "If you don't care about preserving the data, just delete the"
|
|
, "directory."
|
|
, ""
|
|
, "Or, you can move it to another location, in case it turns out"
|
|
, "something in there is important."
|
|
, ""
|
|
, "Or, you can run `git annex unused` followed by `git annex dropunused`"
|
|
, "to remove data that is not used by any tag or branch, which might"
|
|
, "take care of all the data."
|
|
, ""
|
|
, "Then run `git annex uninit` again to finish."
|
|
]
|
|
uninitialize
|
|
-- avoid normal shutdown
|
|
saveState False
|
|
inRepo $ Git.Command.run
|
|
[Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]
|
|
liftIO exitSuccess
|
|
|
|
{- Turn on write bits in all remaining files in the annex directory, in
|
|
- preparation for removal.
|
|
-
|
|
- Also closes sqlite databases that might be in the directory,
|
|
- to avoid later failure to write any cached changes to them. -}
|
|
prepareRemoveAnnexDir :: FilePath -> Annex ()
|
|
prepareRemoveAnnexDir annexdir = do
|
|
Database.Keys.closeDb
|
|
liftIO $ prepareRemoveAnnexDir' annexdir
|
|
|
|
prepareRemoveAnnexDir' :: FilePath -> IO ()
|
|
prepareRemoveAnnexDir' annexdir =
|
|
dirTreeRecursiveSkipping (const False) annexdir
|
|
>>= mapM_ (void . tryIO . allowWrite)
|
|
|
|
{- Keys that were moved out of the annex have a hard link still in the
|
|
- annex, with > 1 link count, and those can be removed.
|
|
-
|
|
- Returns keys that cannot be removed. -}
|
|
removeUnannexed :: [Key] -> Annex [Key]
|
|
removeUnannexed = go []
|
|
where
|
|
go c [] = return c
|
|
go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks)
|
|
( do
|
|
lockContentForRemoval k removeAnnex
|
|
go c ks
|
|
, go (k:c) ks
|
|
)
|
|
enoughlinks f = catchBoolIO $ do
|
|
s <- getFileStatus f
|
|
return $ linkCount s > 1
|