basic clean filter working

Annex/Content.hs

@@ -24,6 +24,7 @@ module Annex.Content (
 	withTmp,
 	checkDiskSpace,
 	moveAnnex,
+	linkAnnex,
 	sendAnnex,
 	prepSendAnnex,
 	removeAnnex,
@@ -470,6 +471,23 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
 	
 	alreadyhave = liftIO $ removeFile src
 
+{- Hard links a file into .git/annex/objects/, falling back to a copy
+ - if necessary.
+ -
+ - Does not lock down the hard linked object, so that the user can modify
+ - the source file. So, adding an object to the annex this way can
+ - prevent losing the content if the source file is deleted, but does not
+ - guard against modifications.
+ -}
+linkAnnex :: Key -> FilePath -> Annex Bool
+linkAnnex key src = do
+	dest <- calcRepo (gitAnnexLocation key)
+	ifM (liftIO $ doesFileExist dest)
+		( return True
+		, modifyContent dest $
+			liftIO $ createLinkOrCopy src dest
+		)
+
 {- Runs an action to transfer an object's content.
  -
  - In direct mode, it's possible for the file to change as it's being sent.

Command/Clean.hs

@@ -10,8 +10,12 @@ module Command.Clean where
 import Common.Annex
 import Command
 import Annex.Content
-import Annex.Link
+import Annex.MetaData
-import Git.Types
+import Types.KeySource
+import Types.Key
+import Backend
+
+import qualified Data.ByteString.Lazy as B
 
 cmd :: Command
 cmd = dontCheck repoExists $
@@ -24,6 +28,35 @@ seek = withWords start
 
 start :: [String] -> CommandStart
 start [file] = do
-	error ("clean " ++ file)
+	ifM (shouldAnnex file)
+		( do
+			k <- ingest file
+			liftIO $ putStrLn (key2file k)
+		, liftIO $ B.hGetContents stdin >>= B.hPut stdout -- cat file
+		)
+	stop
 start [] = error "clean filter run without filename; upgrade git"
 start _ = error "clean filter passed multiple filenames"
+
+shouldAnnex :: FilePath -> Annex Bool
+shouldAnnex _ = return True
+-- TODO check annex.largefiles
+
+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 contaning this file.
+	unlessM (linkAnnex k file) $
+		error "Problem adding file to the annex"
+	genMetaData k file
+		=<< liftIO (getFileStatus file)
+	return k