3cd3757236
The git add behavior changes could be avoided if it turns out to be really annoying, but then it would need to behave the old way when annex.dotfiles=false and the new way when annex.dotfiles=true. I'd rather not have the config option result in such divergent behavior as `git annex add .` skipping a dotfile (old) vs adding to annex (new). Note that the assistant always adds dotfiles to the annex. This is surprising, but not new behavior. Might be worth making it also honor annex.dotfiles, but I wonder if perhaps some user somewhere uses it and keeps large files in a directory that happens to begin with a dot. Since dotfiles and dotdirs are a unix culture thing, and the assistant users may not be part of that culture, it seems best to keep its current behavior for now.
122 lines
4 KiB
Haskell
122 lines
4 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2010 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL 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
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
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 <- fromRawFilePath <$> 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 . decodeBS' <$> revhead
|
|
revhead = inRepo $ Git.Command.pipeReadStrict
|
|
[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"]
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek ps = do
|
|
l <- workTreeItems ps
|
|
withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l
|
|
Annex.changeState $ \s -> s { Annex.fast = True }
|
|
withFilesInGit (commandAction . 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 <- fromRawFilePath <$> fromRepo gitAnnexDir
|
|
annexobjectdir <- fromRepo gitAnnexObjectDir
|
|
leftovers <- removeUnannexed =<< listKeys 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 <- R.getFileStatus f
|
|
return $ linkCount s > 1
|