summaryrefslogtreecommitdiff
path: root/Command/Proxy.hs
blob: d38a94b46b4a173dff45c9ef1e490c980e593d22 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
{- git-annex command
 -
 - Copyright 2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Proxy where

import Common.Annex
import Command
import Config
import Utility.Tmp
import Utility.Env
import Annex.Direct
import qualified Git
import qualified Git.Sha
import qualified Git.Ref
import qualified Git.Branch
import qualified Git.LsFiles
import Git.FilePath
import Utility.CopyFile

cmd :: Command
cmd = notBareRepo $
	command "proxy" SectionPlumbing 
		"safely bypass direct mode guard"
		("-- git command") (withParams seek)

seek :: CmdParams -> CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start [] = error "Did not specify command to run."
start (c:ps) = liftIO . exitWith =<< ifM isDirect
	( do
		tmp <- gitAnnexTmpMiscDir <$> gitRepo
		withTmpDirIn tmp "proxy" go
	, liftIO $ safeSystem c (map Param ps)
	)
  where
	go tmp = do
		oldref <- fromMaybe Git.Sha.emptyTree
			<$> (inRepo . maybe Git.Ref.headSha Git.Ref.sha
				=<< inRepo Git.Branch.currentUnsafe)
		
		setuptmpworktree tmp
		exitcode <- proxy tmp
		cleanupproxy tmp oldref

		return exitcode
	
	proxy tmp = do
		usetmp <- liftIO $ Just . addEntry "GIT_WORK_TREE" tmp  <$> getEnvironment
		unlessM (isNothing <$> inRepo Git.Branch.current) $
			unlessM (liftIO $ boolSystemEnv "git" [Param "checkout", Param "--", Param "."] usetmp) $
				error "Failed to set up proxy work tree."
		liftIO $ safeSystemEnv c (map Param ps) usetmp

	-- Commands like git revert will fail if there's a file
	-- in the work tree, or index, that would be overwritten
	-- by the revert. We want that to also happen when such a command
	-- is proxied.
	--
	-- It suffices to find any files in the real work tree that
	-- are not in the index, and hard link (or copy) them
	-- into the tmp work tree. This assumes that files that are in the
	-- index don't need to appear in the tmp work tree.
	setuptmpworktree tmp = do
		top <- fromRepo Git.repoPath
		(fs, cleanup) <- inRepo $ Git.LsFiles.notInRepo True [top]
		forM_ fs $ \f -> do
			tf <- inRepo $ toTopFilePath f
			let tmpf = tmp </> getTopFilePath tf
			liftIO $ do
				createDirectoryIfMissing True (takeDirectory tmpf)
				createLinkOrCopy f tmpf
		liftIO $ void cleanup
		
	-- To merge the changes made by the proxied command into
	-- the work tree is similar to cleaning up after a
	-- direct mode merge. But, here we force updates of any
	-- non-annxed files that were changed by the proxied
	-- command.
	cleanupproxy tmp oldref = do
		updateWorkTree tmp oldref True
		liftIO $ removeDirectoryRecursive tmp