fromkey unlocked files support

fromkey: Create an unlocked file when used in an adjusted branch where the
file should be unlocked, or when configured by annex.addunlocked.

There is some overlap with code in Annex.Ingest, however it's not quite the
same because ingesting has a temp file with the content, where here the
content, if any, is in the annex object file. So it eg, makes sense for
Annex.Ingest to copy the execute mode of the content file, but it does not make
sense for fromkey to do that.

Also changed in passing to stage the file in git directly, rather than
using git add. One consequence of that is that if the file is gitignored,
it will still get added, rather than the old behavior:

The following paths are ignored by one of your .gitignore files:
ignored
hint: Use -f if you really want to add them.
hint: Turn this message off by running
hint: "git config advice.addIgnoredFile false"
git-annex: user error (xargs ["-0","git","--git-dir=.git","--work-tree=.","--literal-pathspecs","add","--"] exited 123)

That old behavior was a surprise to me, and so I consider it a bug, and doubt
anyone would have relied on it.

Note that, when on an --hide-missing branch, it is possible to fromkey a key
that is not present (needs --force). The annex link or pointer file still gets
written in this case. It doesn't seem to make any sense not to write it,
because then fromkey would not do anything useful in this case, and this way
the file can be committed and synced to master, and the branch re-adjusted to
hide the new missing file.

This commit was sponsored by Noam Kremen on Patreon.

Annex/Ingest.hs

@@ -387,19 +387,10 @@ addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mt
 			, matchFile = file
 			, matchKey = Just key
 			}
-		-- Provide as much info as we can without access to the
-		-- file's content.
-		Nothing -> MatchingInfo $ ProvidedInfo
-			{ providedFilePath = Just file
-			, providedKey = Just key
-			, providedFileSize = Nothing
-			, providedMimeType = Nothing
-			, providedMimeEncoding = Nothing
-			, providedLinkType = Nothing
-			}
+		Nothing -> keyMatchInfoWithoutContent key file
 	
 	linkunlocked mode = linkFromAnnex key file mode >>= \case
-		LinkAnnexFailed -> liftIO $ writepointer mode
+		LinkAnnexFailed -> writepointer mode
 		_ -> return ()
 	
 	writepointer mode = liftIO $ writePointerFile file key mode

CHANGELOG

@@ -1,3 +1,10 @@
+git-annex (8.20210429) UNRELEASED; urgency=medium
+
+  * fromkey: Create an unlocked file when used in an adjusted branch
+    where the file should be unlocked, or when configured by annex.addunlocked.
+
+ -- Joey Hess <id@joeyh.name>  Mon, 03 May 2021 10:33:10 -0400
+
 git-annex (8.20210428) upstream; urgency=medium
 
   * New annex.private and remote.name.annex-private configs that can

Command/FromKey.hs

@@ -1,22 +1,23 @@
 {- git-annex command
  -
- - Copyright 2010-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE BangPatterns #-}
-
 module Command.FromKey where
 
 import Command
-import qualified Annex.Queue
+import qualified Annex
+import qualified Database.Keys
+import qualified Backend.URL
 import Annex.Content
 import Annex.WorkTree
 import Annex.Perms
-import qualified Annex
-import qualified Backend.URL
-import qualified Utility.RawFilePath as R
+import Annex.Link
+import Annex.FileMatcher
+import Annex.Ingest
+import Git.FilePath
 
 import Network.URI
 
@@ -37,16 +38,18 @@ optParser desc = FromKeyOptions
 	<*> parseBatchOption
 
 seek :: FromKeyOptions -> CommandSeek
-seek o = case (batchOption o, keyFilePairs o) of
-	(Batch fmt, _) -> seekBatch fmt
-	-- older way of enabling batch input, does not support BatchNull
-	(NoBatch, []) -> seekBatch BatchLine
-	(NoBatch, ps) -> do
-		force <- Annex.getState Annex.force
-		withPairs (commandAction . start force) ps
+seek o = do
+	matcher <- addUnlockedMatcher
+	case (batchOption o, keyFilePairs o) of
+		(Batch fmt, _) -> seekBatch matcher fmt
+		-- older way of enabling batch input, does not support BatchNull
+		(NoBatch, []) -> seekBatch matcher BatchLine
+		(NoBatch, ps) -> do
+			force <- Annex.getState Annex.force
+			withPairs (commandAction . start matcher force) ps
 
-seekBatch :: BatchFormat -> CommandSeek
-seekBatch fmt = batchInput fmt parse (commandAction . go)
+seekBatch :: AddUnlockedMatcher -> BatchFormat -> CommandSeek
+seekBatch matcher fmt = batchInput fmt parse (commandAction . go)
   where
 	parse s = do
 		let (keyname, file) = separate (== ' ') s
@@ -59,10 +62,10 @@ seekBatch fmt = batchInput fmt parse (commandAction . go)
 	go (si, (file, key)) = 
 		let ai = mkActionItem (key, file)
 		in starting "fromkey" ai si $
-			perform key file
+			perform matcher key file
 
-start :: Bool -> (SeekInput, (String, FilePath)) -> CommandStart
-start force (si, (keyname, file)) = do
+start :: AddUnlockedMatcher -> Bool -> (SeekInput, (String, FilePath)) -> CommandStart
+start matcher force (si, (keyname, file)) = do
 	let key = keyOpt keyname
 	unless force $ do
 		inbackend <- inAnnex key
@@ -70,7 +73,7 @@ start force (si, (keyname, file)) = do
 			"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
 	let ai = mkActionItem (key, file')
 	starting "fromkey" ai si $
-		perform key file'
+		perform matcher key file'
   where
 	file' = toRawFilePath file
 
@@ -89,16 +92,32 @@ keyOpt s = case parseURI s of
 		Just k -> k
 		Nothing -> giveup $ "bad key/url " ++ s
 
-perform :: Key -> RawFilePath -> CommandPerform
-perform key file = lookupKeyNotHidden file >>= \case
+perform :: AddUnlockedMatcher -> Key -> RawFilePath -> CommandPerform
+perform matcher key file = lookupKeyNotHidden file >>= \case
 	Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file))
 		( hasothercontent
 		, do
-			link <- calcRepo $ gitAnnexLink file key
-			createWorkTreeDirectory (parentDir file)
-			liftIO $ R.createSymbolicLink link file
-			Annex.Queue.addCommand [] "add" [Param "--"]
-				[fromRawFilePath file]
+			contentpresent <- inAnnex key
+			objectloc <- calcRepo (gitAnnexLocation key)
+			let mi = if contentpresent
+				then MatchingFile $ FileInfo
+					{ contentFile = objectloc
+					, matchFile = file
+					, matchKey = Just key
+					}
+				else keyMatchInfoWithoutContent key file
+			ifM (addUnlocked matcher mi contentpresent)
+				( do
+					stagePointerFile file Nothing =<< hashPointerFile key
+					Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
+					if contentpresent
+						then linkunlocked
+						else writepointer
+				, do
+					link <- calcRepo $ gitAnnexLink file key
+					createWorkTreeDirectory (parentDir file)
+					addAnnexLink link file
+				)
 			next $ return True
 		)
 	Just k
@@ -108,3 +127,9 @@ perform key file = lookupKeyNotHidden file >>= \case
 	hasothercontent = do
 		warning $ fromRawFilePath file ++ " already exists with different content"
 		next $ return False
+	
+	linkunlocked = linkFromAnnex key file Nothing >>= \case
+		LinkAnnexFailed -> writepointer
+		_ -> return ()
+	
+	writepointer = liftIO $ writePointerFile file key Nothing

Types/FileMatcher.hs

@@ -47,6 +47,16 @@ data ProvidedInfo = ProvidedInfo
 	, providedLinkType :: Maybe LinkType
 	}
 
+keyMatchInfoWithoutContent :: Key -> RawFilePath -> MatchInfo
+keyMatchInfoWithoutContent key file = MatchingInfo $ ProvidedInfo
+	{ providedFilePath = Just file
+	, providedKey = Just key
+	, providedFileSize = Nothing
+	, providedMimeType = Nothing
+	, providedMimeEncoding = Nothing
+	, providedLinkType = Nothing
+	}
+
 -- This is used when testing a matcher, with values to match against
 -- provided by the user.
 data UserProvidedInfo = UserProvidedInfo

doc/bugs/git-annex-fromkey_broken_on_Windows.mdwn

@@ -25,3 +25,5 @@ Windows 10 Pro 1903 <br>
 ### Have you had any luck using git-annex before? (Sometimes we get tired of reading bug reports all day and a lil' positive end note does wonders)
 Yes! git-annex is really great and there is nothing else like it. 
 
+> [[fixed|done]] by making it create an unlocked file when used on an
+> unlocked adjusted branch. --[[Joey]]