merge clean into smudge command

The git filter config can be used to map the single git-annex command to
the 2 actions, and this avoids "git annex clean" being used for this thing,
it might have a better use for that name later.

1 files changed, 63 insertions, 8 deletions

diff --git a/Command/Smudge.hs b/Command/Smudge.hs
index 6c4b9604a..07a3e1805 100644
--- a/Command/Smudge.hs
+++ b/Command/Smudge.hs
@@ -10,20 +10,37 @@ module Command.Smudge where
 import Common.Annex
 import Command
 import Types.Key
+import Annex.Content
+import Annex.MetaData
+import Annex.FileMatcher
+import Types.KeySource
+import Backend
+import Logs.Location
 
 import qualified Data.ByteString.Lazy as B
 
 cmd :: Command
-cmd = noCommit $ noMessages $ dontCheck repoExists $
+cmd = noCommit $ noMessages $
 	command "smudge" SectionPlumbing 
 		"git smudge filter"
-		paramFile (withParams seek)
+		paramFile (seek <$$> optParser)
 
-seek :: CmdParams -> CommandSeek
-seek = withWords start
+data SmudgeOptions = SmudgeOptions
+	{ smudgeFile :: FilePath
+	, cleanOption :: Bool
+	}
 
-start :: [String] -> CommandStart
-start [_file] = do
+optParser :: CmdParamsDesc -> Parser SmudgeOptions
+optParser desc = SmudgeOptions
+	<$> argument str ( metavar desc )
+	<*> switch ( long "clean" <> help "clean filter" )
+
+seek :: SmudgeOptions -> CommandSeek
+seek o = commandAction $
+	(if cleanOption o then clean else smudge) (smudgeFile o)
+
+smudge :: FilePath -> CommandStart
+smudge _file = do
 	liftIO $ fileEncoding stdin
 	s <- liftIO $ hGetContents stdin
 	case parsePointer s of
@@ -35,8 +52,46 @@ start [_file] = do
 				(B.hPut stdout)
 				=<< catchMaybeIO (B.readFile content)
 	stop
-start [] = error "smudge filter run without filename; upgrade git"
-start _ = error "smudge filter passed multiple filenames"
+
+clean :: FilePath -> CommandStart
+clean file = do
+	ifM (shouldAnnex file)
+		( do
+			k <- ingest file
+			liftIO $ emitPointer k
+		, liftIO $ B.hGetContents stdin >>= B.hPut stdout -- cat file
+		)
+	stop
+
+shouldAnnex :: FilePath -> Annex Bool
+shouldAnnex file = do
+	matcher <- largeFilesMatcher
+	checkFileMatcher matcher file
+
+ingest :: FilePath -> Annex Key
+ingest file = do
+	backend <- chooseBackend file
+	let source = KeySource
+		{ keyFilename = file
+		, contentLocation = file
+		, inodeCache = Nothing
+		}
+	k <- fst . fromMaybe (error "failed to generate a key")
+		<$> genKey source backend
+	-- Hard link (or copy) file content to annex
+	-- to prevent it from being lost when git checks out
+	-- a branch not containing this file.
+	r <- linkAnnex k file
+	case r of
+		LinkAnnexFailed -> error "Problem adding file to the annex"
+		LinkAnnexOk -> logStatus k InfoPresent
+		LinkAnnexNoop -> noop
+	genMetaData k file
+		=<< liftIO (getFileStatus file)
+	return k
+
+emitPointer :: Key -> IO ()
+emitPointer = putStrLn . key2file
 
 parsePointer :: String -> Maybe Key
 parsePointer s