Merge branch 'forget'
Conflicts: debian/changelog
This commit is contained in:
commit
db83cc82d6
26 changed files with 685 additions and 214 deletions
52
Command/Forget.hs
Normal file
52
Command/Forget.hs
Normal file
|
@ -0,0 +1,52 @@
|
|||
{- git-annex command
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Command.Forget where
|
||||
|
||||
import Common.Annex
|
||||
import Command
|
||||
import qualified Annex.Branch as Branch
|
||||
import Logs.Transitions
|
||||
import qualified Annex
|
||||
import qualified Option
|
||||
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
def :: [Command]
|
||||
def = [withOptions forgetOptions $ command "forget" paramNothing seek
|
||||
SectionMaintenance "prune git-annex branch history"]
|
||||
|
||||
forgetOptions :: [Option]
|
||||
forgetOptions = [dropDeadOption]
|
||||
|
||||
dropDeadOption :: Option
|
||||
dropDeadOption = Option.flag [] "drop-dead" "drop references to dead repositories"
|
||||
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFlag dropDeadOption $ \dropdead ->
|
||||
withNothing $ start dropdead]
|
||||
|
||||
start :: Bool -> CommandStart
|
||||
start dropdead = do
|
||||
showStart "forget" "git-annex"
|
||||
now <- liftIO getPOSIXTime
|
||||
let basets = addTransition now ForgetGitHistory noTransitions
|
||||
let ts = if dropdead
|
||||
then addTransition now ForgetDeadRemotes basets
|
||||
else basets
|
||||
next $ perform ts =<< Annex.getState Annex.force
|
||||
|
||||
perform :: Transitions -> Bool -> CommandPerform
|
||||
perform ts True = do
|
||||
recordTransitions Branch.change ts
|
||||
-- get branch committed before contining with the transition
|
||||
Branch.update
|
||||
void $ Branch.performTransitions ts True
|
||||
next $ return True
|
||||
perform _ False = do
|
||||
showLongNote "To forget git-annex branch history, you must specify --force. This deletes metadata!"
|
||||
stop
|
|
@ -17,7 +17,7 @@ import Data.Char
|
|||
|
||||
import Common.Annex
|
||||
import Command
|
||||
import qualified Logs.Location
|
||||
import Logs
|
||||
import qualified Logs.Presence
|
||||
import Annex.CatFile
|
||||
import qualified Annex.Branch
|
||||
|
@ -135,7 +135,7 @@ getLog :: Key -> [CommandParam] -> Annex [String]
|
|||
getLog key os = do
|
||||
top <- fromRepo Git.repoPath
|
||||
p <- liftIO $ relPathCwdToFile top
|
||||
let logfile = p </> Logs.Location.logFile key
|
||||
let logfile = p </> locationLogFile key
|
||||
inRepo $ pipeNullSplitZombie $
|
||||
[ Params "log -z --pretty=format:%ct --raw --abbrev=40"
|
||||
, Param "--remove-empty"
|
||||
|
|
|
@ -167,29 +167,45 @@ pushRemote remote branch = go =<< needpush
|
|||
showOutput
|
||||
inRepo $ pushBranch remote branch
|
||||
|
||||
{- If the remote is a bare git repository, it's best to push the branch
|
||||
- directly to it. On the other hand, if it's not bare, pushing to the
|
||||
- checked out branch will fail, and this is why we use the syncBranch.
|
||||
{- Pushes a regular branch like master to a remote. Also pushes the git-annex
|
||||
- branch.
|
||||
-
|
||||
- If the remote is a bare git repository, it's best to push the regular
|
||||
- branch directly to it, so that cloning/pulling will get it.
|
||||
- On the other hand, if it's not bare, pushing to the checked out branch
|
||||
- will fail, and this is why we push to its syncBranch.
|
||||
-
|
||||
- Git offers no way to tell if a remote is bare or not, so both methods
|
||||
- are tried.
|
||||
-
|
||||
- The direct push is likely to spew an ugly error message, so stderr is
|
||||
- elided. Since progress is output to stderr too, the sync push is done
|
||||
- first, and actually sends the data. Then the direct push is tried,
|
||||
- with stderr discarded, to update the branch ref on the remote.
|
||||
- elided. Since git progress display goes to stderr too, the sync push
|
||||
- is done first, and actually sends the data. Then the direct push is
|
||||
- tried, with stderr discarded, to update the branch ref on the remote.
|
||||
-
|
||||
- The sync push forces the update of the remote synced/git-annex branch.
|
||||
- This is necessary if a transition has rewritten the git-annex branch.
|
||||
- Normally any changes to the git-annex branch get pulled and merged before
|
||||
- this push, so this forcing is unlikely to overwrite new data pushed
|
||||
- in from another repository that is also syncing.
|
||||
-
|
||||
- But overwriting of data on synced/git-annex can happen, in a race.
|
||||
- The only difference caused by using a forced push in that case is that
|
||||
- the last repository to push wins the race, rather than the first to push.
|
||||
-}
|
||||
pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
|
||||
pushBranch remote branch g = tryIO directpush `after` syncpush
|
||||
pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
|
||||
where
|
||||
syncpush = Git.Command.runBool (pushparams (refspec branch)) g
|
||||
directpush = Git.Command.runQuiet (pushparams (show $ Git.Ref.base branch)) g
|
||||
pushparams b =
|
||||
syncpush = Git.Command.runBool $ pushparams
|
||||
[ Git.Branch.forcePush $ refspec Annex.Branch.name
|
||||
, refspec branch
|
||||
]
|
||||
directpush = Git.Command.runQuiet $ pushparams
|
||||
[show $ Git.Ref.base branch]
|
||||
pushparams branches =
|
||||
[ Param "push"
|
||||
, Param $ Remote.name remote
|
||||
, Param $ refspec Annex.Branch.name
|
||||
, Param b
|
||||
]
|
||||
] ++ map Param branches
|
||||
refspec b = concat
|
||||
[ show $ Git.Ref.base b
|
||||
, ":"
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue