finish v6 git-annex lock

This was a doozy!

Annex/Content.hs

@@ -27,6 +27,7 @@ module Annex.Content (
 	linkAnnex,
 	linkAnnex',
 	LinkAnnexResult(..),
+	checkedCopyFile,
 	sendAnnex,
 	prepSendAnnex,
 	removeAnnex,
@@ -549,16 +550,25 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
 linkAnnex'' :: Key -> FilePath -> FilePath -> Annex Bool
 linkAnnex'' key src dest = catchBoolIO $ do
 	s <- liftIO $ getFileStatus src
+	let copy = checkedCopyFile' key src dest s
 #ifndef mingw32_HOST_OS
 	if linkCount s > 1
-		then copy s
+		then copy
 		else liftIO (createLink src dest >> return True)
-			`catchIO` const (copy s)
+			`catchIO` const copy
 #else
-	copy s
+	copy
 #endif
-  where
+
-	copy s = ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)
+{- Checks disk space before copying. -}
+checkedCopyFile :: Key -> FilePath -> FilePath -> Annex Bool
+checkedCopyFile key src dest = catchBoolIO $
+	checkedCopyFile' key src dest
+		=<< liftIO (getFileStatus src)
+
+checkedCopyFile' :: Key -> FilePath -> FilePath -> FileStatus -> Annex Bool
+checkedCopyFile' key src dest s = catchBoolIO $
+	ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)
 		( liftIO $ copyFileExternal CopyAllMetaData src dest
 		, return False
 		)

Command/Lock.hs

@@ -15,9 +15,12 @@ import Annex.Version
 import Annex.Content
 import Annex.Link
 import Annex.InodeSentinal
+import Annex.Perms
+import Annex.ReplaceFile
 import Utility.InodeCache
 import qualified Database.Keys
 import qualified Command.Add
+import Logs.Location
 	
 cmd :: Command
 cmd = notDirect $ withGlobalOptions annexedMatchingOptions $
@@ -34,9 +37,12 @@ seek ps = ifM versionSupportsUnlockedPointers
 	)
 
 startNew :: FilePath -> Key -> CommandStart
-startNew file key = do
+startNew file key = ifM (isJust <$> isAnnexLink file)
-	showStart "lock" file
+	( stop
-	go =<< isPointerFile file
+	, do
+		showStart "lock" file
+		go =<< isPointerFile file
+	)
   where
 	go (Just key')
 		| key' == key = cont False
@@ -53,33 +59,42 @@ startNew file key = do
 
 performNew :: FilePath -> Key -> Bool -> CommandPerform
 performNew file key filemodified = do
-	-- If other files use this same key, and are unlocked, 
+	lockdown =<< calcRepo (gitAnnexLocation key)
-	-- the annex object file might be hard linked to those files.
-	-- It's also possible that the annex object file was
-	-- modified while the file was unlocked. 
-	--
-	-- So, in order to lock the file's content, we need to break all
-	-- hard links to the annex object file, and if it's modified,
-	-- replace it with a copy of the content of one of the associated
-	-- files.
-	--
-	-- When the file being locked is unmodified, the annex object file
-	-- can just be linked to it. (Which might already be the case, but
-	-- do it again to be sure.)
-	--
-	-- When the file being locked is modified, find another associated
-	-- file that is unmodified, and copy it to the annex object file.
-	-- If there are no unmodified associated files, the content of
-	-- the key is lost.
-	--
-	-- If the filesystem doesn't support hard links, none of this
-	-- is a concern.
-	obj <- calcRepo (gitAnnexLocation key)
-
-	freezeContent obj
 	Command.Add.addLink file key
 		=<< withTSDelta (liftIO . genInodeCache file)
 	next $ cleanupNew file key
+  where
+	lockdown obj = do
+		ifM (sameInodeCache obj =<< Database.Keys.getInodeCaches key)
+			( breakhardlink obj
+			, repopulate obj
+			)
+		freezeContent obj
+
+	-- It's ok if the file is hard linked to obj, but if some other
+	-- associated file is, we need to break that link to lock down obj.
+	breakhardlink obj = whenM ((> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do
+		mfc <- withTSDelta (liftIO . genInodeCache file)
+		unlessM (sameInodeCache obj (maybeToList mfc)) $ do
+			modifyContent obj $ replaceFile obj $ \tmp -> do
+				unlessM (checkedCopyFile key obj tmp) $
+					error "unable to lock file; need more free disk space"
+			Database.Keys.storeInodeCaches key [obj]
+
+	-- Try to repopulate obj from an unmodified associated file.
+	repopulate obj
+		| filemodified = modifyContent obj $ do
+			fs <- Database.Keys.getAssociatedFiles key
+			mfile <- firstM (isUnmodified key) fs
+			liftIO $ nukeFile obj
+			case mfile of
+				Just unmodified ->
+					unlessM (checkedCopyFile key unmodified obj)
+						lostcontent
+				Nothing -> lostcontent
+		| otherwise = modifyContent obj $ 
+			liftIO $ renameFile file obj
+	lostcontent = logStatus key InfoMissing
 
 cleanupNew :: FilePath -> Key -> CommandCleanup
 cleanupNew file key = do

doc/todo/smudge.mdwn

@@ -236,11 +236,8 @@ git annex lock/unlock:
   unlock will stage a pointer file, and will link the content of the object
   from .git/annex/objects to the work tree file.
   
-  lock will replace the current work tree file with the symlink, and stage it.
+  lock will replace the current work tree file with the symlink, and stage it,
-  Note that multiple work tree files could point to the same object.
+  and lock down the permissions of the annex object.
-  So, if the link count is > 1, replace the annex object with a copy of
-  itself to break such a hard link. Always finish by locking down the
-  permissions of the annex object.
 
 #### file map
 
@@ -337,13 +334,6 @@ files to be unlocked, while the indirect upgrades don't touch the files.
   (when not in direct mode).
   However, beware over-optimisation breaking the assistant or perhaps other
   long-lived processes.
-* Convert `git annex lock` to verify that worktree file is not modified
-  (same check used when updating pointer files to the content of a key),
-  and then delete the worktree file and replace with an annex symlink.
-  - Allow --force to override the check and throw away modified content.
-  - Also needs to update associated files db.
-  - Also should check associated files db, and if there are no other
-    unlocked files for the key, freeze its object file.
 * Make v6 upgrade convert direct mode repo to repo with all unlocked
   files.
 * fsck will need some fixes to handle unlocked files.
@@ -356,6 +346,7 @@ files to be unlocked, while the indirect upgrades don't touch the files.
   when pushing changes committed in such a repo. Ideally, should avoid
   committing implicit unlocks, or should prevent such commits leaking out
   in pushes.
+* getKeysPresent needs to check if object file is modified
 
 ----