basic clean filter working

This commit is contained in:
Joey Hess 2015-12-04 13:39:14 -04:00
parent 20ca89dfa3
commit 2c6454a2e2
Failed to extract signature
2 changed files with 54 additions and 3 deletions

View file

@ -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.

View file

@ -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