New annex.hardlink setting. Closes: #758593

* New annex.hardlink setting. Closes: #758593
* init: Automatically detect when a repository was cloned with --shared,
  and set annex.hardlink=true, as well as marking the repository as
  untrusted.

Had to reorganize Logs.Trust a bit to avoid a cycle between it and
Annex.Init.

Annex/Content.hs

@@ -377,7 +377,7 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex key
 			)
 
 {- Returns a file that contains an object's content,
- - and an check to run after the transfer is complete.
+ - and a check to run after the transfer is complete.
  -
  - In direct mode, it's possible for the file to change as it's being sent,
  - and the check detects this case and returns False.

Annex/Init.hs

@@ -23,8 +23,11 @@ import qualified Git.LsFiles
 import qualified Git.Config
 import qualified Git.Construct
 import qualified Git.Types as Git
+import qualified Git.Objects
 import qualified Annex.Branch
 import Logs.UUID
+import Logs.Trust.Basic
+import Types.TrustLevel
 import Annex.Version
 import Annex.UUID
 import Config
@@ -70,6 +73,7 @@ initialize mdescription = do
 		Annex.Branch.create
 		describeUUID u =<< genDescription mdescription
 
+-- Everything except for uuid setup.
 initialize' :: Annex ()
 initialize' = do
 	checkFifoSupport
@@ -87,6 +91,7 @@ initialize' = do
 			switchHEADBack
 		)
 	createInodeSentinalFile
+	checkSharedClone
 
 uninitialize :: Annex ()
 uninitialize = do
@@ -242,3 +247,10 @@ checkBadBare = allM (not <$>)
   where
 	hasPreCommitHook = inRepo $ doesFileExist . hookFile preCommitHook
 	hasDotGitHEAD = inRepo $ \r -> doesFileExist $ Git.localGitDir r </> "HEAD"
+
+checkSharedClone :: Annex ()
+checkSharedClone = whenM (inRepo Git.Objects.isSharedClone) $ do
+	showSideAction "Repository was cloned with --shared; setting annex.hardlink=true and making repository untrusted."
+	u <- getUUID
+	trustSet u UnTrusted
+	setConfig (annexConfig "hardlink") (Git.Config.boolConfig True)

Git/Objects.hs

@@ -33,3 +33,17 @@ looseObjectFile :: Repo -> Sha -> FilePath
 looseObjectFile r sha = objectsDir r </> prefix </> rest
   where
 	(prefix, rest) = splitAt 2 (fromRef sha)
+
+listAlternates :: Repo -> IO [FilePath]
+listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile)
+  where
+	alternatesfile = objectsDir r </> "info" </> "alternates"
+
+{- A repository recently cloned with --shared will have one or more
+ - alternates listed, and contain no loose objects or packs. -}
+isSharedClone :: Repo -> IO Bool
+isSharedClone r = allM id
+	[ not . null <$> listAlternates r
+	, null <$> listLooseObjectShas r
+	, null <$> listPackFiles r
+	]

Logs/Trust.hs

@@ -11,7 +11,6 @@ module Logs.Trust (
 	TrustLevel(..),
 	trustGet,
 	trustMap,
-	trustSet,
 	trustPartition,
 	trustExclude,
 	lookupTrust,
@@ -20,17 +19,15 @@ module Logs.Trust (
 ) where
 
 import qualified Data.Map as M
-import Data.Time.Clock.POSIX
 
 import Common.Annex
 import Types.TrustLevel
 import qualified Annex.Branch
 import qualified Annex
 import Logs
-import Logs.UUIDBased
 import Remote.List
 import qualified Types.Remote
-import Logs.Trust.Pure as X
+import Logs.Trust.Basic as X
 
 {- Returns a list of UUIDs that the trustLog indicates have the
  - specified trust level.
@@ -39,17 +36,6 @@ import Logs.Trust.Pure as X
 trustGet :: TrustLevel -> Annex [UUID]
 trustGet level = M.keys . M.filter (== level) <$> trustMap
 
-{- Changes the trust level for a uuid in the trustLog. -}
-trustSet :: UUID -> TrustLevel -> Annex ()
-trustSet uuid@(UUID _) level = do
-	ts <- liftIO getPOSIXTime
-	Annex.Branch.change trustLog $
-		showLog showTrustLog .
-			changeLog ts uuid level .
-				parseLog (Just . parseTrustLog)
-	Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
-trustSet NoUUID _ = error "unknown UUID; cannot modify"
-
 {- Returns the TrustLevel of a given repo UUID. -}
 lookupTrust :: UUID -> Annex TrustLevel
 lookupTrust u = (fromMaybe SemiTrusted . M.lookup u) <$> trustMap

Logs/Trust/Basic.hs

@@ -0,0 +1,32 @@
+{- git-annex trust log, basics
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Trust.Basic (
+	module X,
+	trustSet,
+) where
+
+import Data.Time.Clock.POSIX
+
+import Common.Annex
+import Types.TrustLevel
+import qualified Annex.Branch
+import qualified Annex
+import Logs
+import Logs.UUIDBased
+import Logs.Trust.Pure as X
+
+{- Changes the trust level for a uuid in the trustLog. -}
+trustSet :: UUID -> TrustLevel -> Annex ()
+trustSet uuid@(UUID _) level = do
+	ts <- liftIO getPOSIXTime
+	Annex.Branch.change trustLog $
+		showLog showTrustLog .
+			changeLog ts uuid level .
+				parseLog (Just . parseTrustLog)
+	Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
+trustSet NoUUID _ = error "unknown UUID; cannot modify"

Remote/Git.hs

@@ -355,15 +355,27 @@ copyFromRemote' r key file dest
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do
 		params <- Ssh.rsyncParams r Download
 		u <- getUUID
+		hardlink <- annexHardLink <$> Annex.getGitConfig
 		-- run copy from perspective of remote
 		onLocal r $ do
 			ensureInitialized
 			v <- Annex.Content.prepSendAnnex key
 			case v of
 				Nothing -> return False
-				Just (object, checksuccess) ->
-					runTransfer (Transfer Download u key) file noRetry
-						(rsyncOrCopyFile params object dest)
+				Just (object, checksuccess) -> do
+					let copier = rsyncOrCopyFile params object dest
+#ifndef mingw32_HOST_OS
+					let linker = createLink object dest >> return True
+					go <- ifM (pure hardlink <&&> not <$> isDirect)
+						( return $ \m -> liftIO (catchBoolIO linker)
+							<||> copier m
+						, return copier
+						)
+#else
+					let go = copier
+#endif
+					runTransfer (Transfer Download u key)
+						file noRetry go
 						<&&> checksuccess
 	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do
 		direct <- isDirect

Types/GitConfig.hs

@@ -52,6 +52,7 @@ data GitConfig = GitConfig
 	, annexGenMetaData :: Bool
 	, annexListen :: Maybe String
 	, annexStartupScan :: Bool
+	, annexHardLink :: Bool
 	, coreSymlinks :: Bool
 	, gcryptId :: Maybe String
 	}
@@ -87,6 +88,7 @@ extractGitConfig r = GitConfig
 	, annexGenMetaData = getbool (annex "genmetadata") False
 	, annexListen = getmaybe (annex "listen")
 	, annexStartupScan = getbool (annex "startupscan") True
+	, annexHardLink = getbool (annex "hardlink") False
 	, coreSymlinks = getbool "core.symlinks" True
 	, gcryptId = getmaybe "core.gcrypt-id"
 	}

debian/changelog

@@ -1,6 +1,10 @@
 git-annex (5.20140832) UNRELEASED; urgency=medium
 
   * webapp: Fixed visual glitch in xmpp pairing.
+  * New annex.hardlink setting. Closes: #758593
+  * init: Automatically detect when a repository was cloned with --shared,
+    and set annex.hardlink=true, as well as marking the repository as
+    untrusted.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 04 Sep 2014 16:17:22 -0400
 

doc/git-annex.mdwn

@@ -1433,6 +1433,19 @@ Here are all the supported configuration settings.
   commit the data by running `git annex merge` (or by automatic merges)
   or `git annex sync`.
 
+* `annex.hardlink`
+
+  Set this to `true` to make file contents be hard linked into the
+  repository when possible, instead of a more expensive copy.
+
+  Use with caution -- This can invalidate numcopies counting, since
+  with hard links, fewer copies of a file can exist. So, it is a good
+  idea to mark a repository using this setting as untrusted.
+
+  When a repository is set up using `git clone --shared`, git-annex init
+  will automatically set annex.hardlink and mark the repository as
+  untrusted.
+
 * `annex.delayadd`
 
   Makes the watch and assistant commands delay for the specified number of