basic clean filter working

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 289a4f1b377fdb4e81fd55b0895debb693ef66a9..74fae381b742e5d413d27f28d8baa1ab147346cf 100644 (file)
--- a/Annex/Content.hs
+++ b/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.

diff --git a/Command/Clean.hs b/Command/Clean.hs
index 9af862fb07c7a98c6b288a52125e6c82629c0b09..0a8e438d1deb2b5508d949fc92dcd2edee1b8c73 100644 (file)
--- a/Command/Clean.hs
+++ b/Command/Clean.hs
@@ -10,8 +10,12 @@ module Command.Clean where
 import Common.Annex
 import Command
 import Annex.Content
-import Annex.Link
-import Git.Types
+import Annex.MetaData
+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