work around lack of receive.denyCurrentBranch in direct mode

Now that direct mode sets core.bare=true, git's normal prohibition about
pushing into the currently checked out branch doesn't work.

A simple fix for this would be an update hook which blocks the pushes..
but git hooks must be executable, and git-annex needs to be usable on eg,
FAT, which lacks x bits.

Instead, enabling direct mode switches the branch (eg master) to a special
purpose branch (eg annex/direct/master). This branch is not pushed when
syncing; instead any changes that git annex sync commits get written to
master, and it's pushed (along with synced/master) to the remote.

Note that initialization has been changed to always call setDirect,
even if it's just setDirect False for indirect mode. This is needed because
if the user has just cloned a direct mode repo, that nothing has synced
with before, it may have no master branch, and only a annex/direct/master.
Resulting in that branch being checked out locally too. Calling setDirect False
for indirect mode moves back out of this branch, to a new master branch,
and ensures that a manual "git push" doesn't push changes directly to
the annex/direct/master of the remote. (It's possible that the user
makes a commit w/o using git-annex and pushes it, but nothing I can do
about that really.)

This commit was sponsored by Jonathan Harrington.

6 files changed, 126 insertions, 48 deletions

diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index 7b0dbc1e0..d4b73860e 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -15,6 +15,7 @@ import qualified Git.Merge
 import qualified Git.DiffTree as DiffTree
 import qualified Git.Config
 import qualified Git.Ref
+import qualified Git.Branch
 import Git.Sha
 import Git.FilePath
 import Git.Types
@@ -236,28 +237,65 @@ changedDirect oldk f = do
 	whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
 		logStatus oldk InfoMissing
 
-{- Since direct mode repositories use core.bare=true, pushes are allowed
- - that overwrite the master branch (or whatever branch is currently
- - checked out) at any time. But committing when a change has been pushed
- - to the current branch and not merged into the work tree will have the
- - effect of reverting the pushed changes.
- -
- - To avoid this problem, when git annex commits in a direct mode
- - repository, it does not commit to HEAD, but instead to annexhead.
- - This ref always contains the last local commit.
- -}
-annexheadRef :: Ref
-annexheadRef = Ref $ "refs" </> "annexhead"
-
 {- Enable/disable direct mode. -}
 setDirect :: Bool -> Annex ()
 setDirect wantdirect = do
-	when wantdirect $ do
-		f <- fromRepo $ Git.Ref.file annexheadRef
-		v <- inRepo $ Git.Ref.sha Git.Ref.headRef
-		liftIO $ maybe (nukeFile f) (writeFile f . show) v
+	if wantdirect
+		then do
+			switchHEAD
+			setbare
+		else do
+			setbare
+			switchHEADBack
 	setConfig (annexConfig "direct") val
-	setConfig (ConfigKey Git.Config.coreBare) val
 	Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect }
   where
 	val = Git.Config.boolConfig wantdirect
+	setbare = setConfig (ConfigKey Git.Config.coreBare) val
+
+{- Since direct mode sets core.bare=true, incoming pushes could change
+ - the currently checked out branch. To avoid this problem, HEAD
+ - is changed to a internal ref that nothing is going to push to.
+ -
+ - For refs/heads/master, use refs/heads/annex/direct/master;
+ - this way things that show HEAD (eg shell prompts) will
+ - hopefully show just "master". -}
+directBranch :: Ref -> Ref
+directBranch orighead = case split "/" $ show orighead of
+	("refs":"heads":"annex":"direct":_) -> orighead
+	("refs":"heads":rest) ->
+		Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
+	_ -> Ref $ "refs/heads/" ++ show (Git.Ref.base orighead)
+
+{- Converts a directBranch back to the original branch.
+ -
+ - Any other ref is left unchanged.
+ -}
+fromDirectBranch :: Ref -> Ref
+fromDirectBranch directhead = case split "/" $ show directhead of
+	("refs":"heads":"annex":"direct":rest) -> 
+		Ref $ "refs/heads/" ++ intercalate "/" rest
+	_ -> directhead
+
+switchHEAD :: Annex ()
+switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+  where
+	switch orighead = do
+		let newhead = directBranch orighead
+		maybe noop (inRepo . Git.Branch.update newhead)
+			=<< inRepo (Git.Ref.sha orighead)
+		inRepo $ Git.Branch.checkout newhead
+
+switchHEADBack :: Annex ()
+switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+  where
+	switch currhead = do
+		let orighead = fromDirectBranch currhead
+		v <- inRepo $ Git.Ref.sha currhead
+		case v of
+			Just headsha
+				| orighead /= currhead -> do
+					inRepo $ Git.Branch.update orighead headsha
+					inRepo $ Git.Branch.checkout orighead
+					inRepo $ Git.Branch.delete currhead
+			_ -> inRepo $ Git.Branch.checkout orighead
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 2a6f340e7..a37fcab98 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -75,10 +75,10 @@ prepMerge :: Annex ()
 prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath
 
 syncBranch :: Git.Ref -> Git.Ref
-syncBranch = Git.Ref.under "refs/heads/synced/"
+syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch
 
 remoteBranch :: Remote -> Git.Ref -> Git.Ref
-remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
+remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
 
 syncRemotes :: [String] -> Annex [Remote]
 syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
@@ -138,7 +138,13 @@ mergeLocal (Just branch) = go =<< needmerge
 pushLocal :: Maybe Git.Ref -> CommandStart
 pushLocal Nothing = stop
 pushLocal (Just branch) = do
+	-- Update the sync branch to match the new state of the branch
 	inRepo $ updateBranch $ syncBranch branch
+	-- In direct mode, we're operating on some special direct mode
+	-- branch, rather than the intended branch, so update the indended
+	-- branch.
+	whenM isDirect $
+		inRepo $ updateBranch $ fromDirectBranch branch
 	stop
 
 updateBranch :: Git.Ref -> Git.Repo -> IO ()
@@ -232,7 +238,7 @@ pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
 		, refspec branch
 		]
 	directpush = Git.Command.runQuiet $ pushparams
-		[show $ Git.Ref.base branch]
+		[show $ Git.Ref.base $ fromDirectBranch branch]
 	pushparams branches =
 		[ Param "push"
 		, Param $ Remote.name remote
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 7b560246e..7b3297d74 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -13,7 +13,7 @@ import Common
 import Git
 import Git.Sha
 import Git.Command
-import Git.Ref (headRef)
+import qualified Git.Ref
 
 {- The currently checked out branch.
  -
@@ -36,7 +36,7 @@ current r = do
 {- The current branch, which may not really exist yet. -}
 currentUnsafe :: Repo -> IO (Maybe Git.Ref)
 currentUnsafe r = parse . firstLine
-	<$> pipeReadStrict [Param "symbolic-ref", Param $ show headRef] r
+	<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
   where
 	parse l
 		| null l = Nothing
@@ -113,3 +113,21 @@ update branch sha = run
 	, Param $ show branch
 	, Param $ show sha
 	]
+
+{- Checks out a branch, creating it if necessary. -}
+checkout :: Branch -> Repo -> IO ()
+checkout branch = run
+	[ Param "checkout"
+	, Param "-q"
+	, Param "-B"
+	, Param $ show $ Git.Ref.base branch
+	]
+
+{- Removes a branch. -}
+delete :: Branch -> Repo -> IO ()
+delete branch = run
+	[ Param "branch"
+	, Param "-q"
+	, Param "-D"
+	, Param $ show $ Git.Ref.base branch
+	]
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 9706f8b6c..5057180d1 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -29,11 +29,17 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
 		| prefix `isPrefixOf` s = drop (length prefix) s
 		| otherwise = s
 
+{- Given a directory and any ref, takes the basename of the ref and puts
+ - it under the directory. -}
+under :: String -> Ref -> Ref
+under dir r = Ref $ dir ++ "/" ++
+	(reverse $ takeWhile (/= '/') $ reverse $ show r)
+
 {- Given a directory such as "refs/remotes/origin", and a ref such as
  - refs/heads/master, yields a version of that ref under the directory,
  - such as refs/remotes/origin/master. -}
-under :: String -> Ref -> Ref
-under dir r = Ref $ dir </> show (base r)
+underBase :: String -> Ref -> Ref
+underBase dir r = Ref $ dir ++ "/" ++ show (base r)
 
 {- Checks if a ref exists. -}
 exists :: Ref -> Repo -> IO Bool
diff --git a/Init.hs b/Init.hs
index 991f7d31c..453ad5ae9 100644
--- a/Init.hs
+++ b/Init.hs
@@ -53,11 +53,19 @@ genDescription Nothing = do
 initialize :: Maybe String -> Annex ()
 initialize mdescription = do
 	prepUUID
-	setVersion defaultVersion
-	checkCrippledFileSystem
 	checkFifoSupport
-	unlessBare $
+	checkCrippledFileSystem
+	unlessM isBare $
 		hookWrite preCommitHook
+	ifM (crippledFileSystem <&&> not <$> isBare)
+		( do
+			enableDirectMode
+			setDirect True
+			setVersion directModeVersion
+		, do
+			setVersion defaultVersion
+			setDirect False
+		)
 	createInodeSentinalFile
 	u <- getUUID
 	{- This will make the first commit to git, so ensure git is set up
@@ -91,8 +99,8 @@ ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
 isInitialized :: Annex Bool
 isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion
 
-unlessBare :: Annex () -> Annex ()
-unlessBare = unlessM $ fromRepo Git.repoIsLocalBare
+isBare :: Annex Bool
+isBare = fromRepo Git.repoIsLocalBare
 
 {- A crippled filesystem is one that does not allow making symlinks,
  - or removing write access from files. -}
@@ -125,25 +133,15 @@ checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
 	warning "Detected a crippled filesystem."
 	setCrippledFileSystem True
 
-	{- Normally git disables core.symlinks itself when the filesystem does
- 	 - not support them, but in Cygwin, git does support symlinks, while
- 	 - git-annex, not linking with Cygwin, does not. -}
+	{- Normally git disables core.symlinks itself when the
+	 - filesystem does not support them, but in Cygwin, git
+	 - does support symlinks, while git-annex, not linking
+	 - with Cygwin, does not. -}
 	whenM (coreSymlinks <$> Annex.getGitConfig) $ do
 		warning "Disabling core.symlinks."
 		setConfig (ConfigKey "core.symlinks")
 			(Git.Config.boolConfig False)
 
-	unlessBare $ do
-		unlessM isDirect $ do
-			warning "Enabling direct mode."
-			top <- fromRepo Git.repoPath
-			(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
-			forM_ l $ \f ->
-				maybe noop (`toDirect` f) =<< isAnnexLink f
-			void $ liftIO clean
-			setDirect True
-		setVersion directModeVersion
-
 probeFifoSupport :: Annex Bool
 probeFifoSupport = do
 #ifdef mingw32_HOST_OS
@@ -166,3 +164,12 @@ checkFifoSupport = unlessM probeFifoSupport $ do
 	warning "Detected a filesystem without fifo support."
 	warning "Disabling ssh connection caching."
 	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)
+
+enableDirectMode :: Annex ()
+enableDirectMode = unlessM isDirect $ do
+	warning "Enabling direct mode."
+	top <- fromRepo Git.repoPath
+	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+	forM_ l $ \f ->
+		maybe noop (`toDirect` f) =<< isAnnexLink f
+	void $ liftIO clean
diff --git a/doc/todo/direct_mode_guard.mdwn b/doc/todo/direct_mode_guard.mdwn
index 9fbb21cd3..bb7f90897 100644
--- a/doc/todo/direct_mode_guard.mdwn
+++ b/doc/todo/direct_mode_guard.mdwn
@@ -96,7 +96,10 @@ even when `receive.denyCurrentBranch` is set.)
 > branch. However, won't work on crippled filesystems! (No +x bit)
 > 
 > Could make git annex sync detect this. It could reset the master
-> branch to the last one committed, before committing. Will work,
-> does have the minor oddity that eg `git log` will show commits
-> pushed to master before `git annex sync` has been run and so before
-> those commits are reflected in the tree.
+> branch to the last one committed, before committing. Seems very racy
+> and hard to get right!
+>
+> Could make direct mode operate on a different branch, like
+> `annex/direct/master` rather than `master`. Avoid pushing to that
+> branch (`git annex sync` can map back from it to `master` and push there
+> instead). A bit clumsy, but works.