add dropkey subcommand and --quiet

Needed for better git annex move --from

Commands.hs

@@ -61,7 +61,8 @@ doSubCmd cmdname start param = do
 
 {- A subcommand can broadly want one of several kinds of input parameters.
  - This allows a first stage of filtering before starting a subcommand. -}
-data SubCmdWants = FilesInGit | FilesNotInGit | FilesMissing | Description
+data SubCmdWants = FilesInGit | FilesNotInGit | FilesMissing
+	| Description | Keys
 
 data SubCommand = Command {
 	subcmdname :: String,
@@ -87,6 +88,8 @@ subCmds =  [
 		"fix up files' symlinks to point to annexed content")
 	, (Command "fromkey"	fromKeyStart	FilesMissing
 		"adds a file using a specific key")
+	, (Command "dropkey"	fromKeyStart	Keys
+		"drops cached content for specified keys")
 	]
 
 -- Each dashed command-line option results in generation of an action
@@ -95,6 +98,8 @@ options :: [OptDescr (Annex ())]
 options = [
 	    Option ['f'] ["force"] (NoArg (storebool "force" True))
 		"allow actions that may lose annexed data"
+	  , Option ['q'] ["quiet"] (NoArg (storebool "quiet" True))
+		"avoid verbose output"
 	  , Option ['b'] ["backend"] (ReqArg (storestring "backend") "NAME")
 		"specify default key-value backend to use"
 	  , Option ['k'] ["key"] (ReqArg (storestring "key") "KEY")
@@ -127,6 +132,7 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
 {- Generate descriptions of wanted parameters for subcommands. -}
 descWanted :: SubCmdWants -> String
 descWanted Description = "DESCRIPTION"
+descWanted Keys = "KEY ..."
 descWanted _ = "PATH ..."
 
 {- Finds the type of parameters a subcommand wants, from among the passed
@@ -147,6 +153,7 @@ findWanted FilesMissing params repo = do
 			if (e) then return False else return True
 findWanted Description params _ = do
 	return $ [unwords params]
+findWanted Keys params _ = return params
 
 {- Parses command line and returns two lists of actions to be 
  - run in the Annex monad. The first actions configure it
@@ -243,9 +250,9 @@ dropStart file = isAnnexed file $ \(key, backend) -> do
 	inbackend <- Backend.hasKey key
 	if (not inbackend)
 		then return Nothing
-		else return $ Just $ dropPerform file key backend
+		else return $ Just $ dropPerform key backend
-dropPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
+dropPerform :: Key -> Backend -> Annex (Maybe SubCmdCleanup)
-dropPerform file key backend = do
+dropPerform key backend = do
 	success <- Backend.removeKey backend key
 	if (success)
 		then return $ Just $ dropCleanup key
@@ -262,6 +269,29 @@ dropCleanup key = do
 			return True
 		else return True
 
+{- Drops cached content for a key. -}
+dropKeyStart :: String -> Annex (Maybe SubCmdPerform)
+dropKeyStart keyname = do
+	backends <- Backend.list
+	let key = genKey (backends !! 0) keyname
+	present <- inAnnex key
+	force <- Annex.flagIsSet "force"
+	if (not present)
+		then return Nothing
+		else if (not force)
+			then error "dropkey is can cause data loss; use --force if you're sure you want to do this"
+			else return $ Just $ dropKeyPerform key
+dropKeyPerform :: Key -> Annex (Maybe SubCmdCleanup)
+dropKeyPerform key = do
+	g <- Annex.gitRepo
+	let loc = annexLocation g key
+	liftIO $ removeFile loc
+	return $ Just $ dropKeyCleanup key
+dropKeyCleanup :: Key -> Annex Bool
+dropKeyCleanup key = do
+	logStatus key ValueMissing
+	return True
+
 {- Fixes the symlink to an annexed file. -}
 fixStart :: FilePath -> Annex (Maybe SubCmdPerform)
 fixStart file = isAnnexed file $ \(key, backend) -> do
@@ -423,11 +453,14 @@ moveFromPerform file key = do
 			return $ Just $ moveFromCleanup remote key
 moveFromCleanup :: Git.Repo -> Key -> Annex Bool
 moveFromCleanup remote key = do
-	Remotes.removeRemoteFile remote $ annexLocation remote key
+	-- Force drop content from the remote.
-	-- Record that the key is not on the remote.
+	Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
-	u <- getUUID remote
+		"--backend=" ++ (backendName key),
-	liftIO $ logChange remote key u ValueMissing
+		keyName key]
-	Remotes.updateRemoteLogStatus remote key
+	-- Record locally that the key is not on the remote.
+	remoteuuid <- getUUID remote
+	g <- Annex.gitRepo
+	liftIO $ logChange g key remoteuuid ValueMissing
 	return True
 
 -- helpers

Core.hs

@@ -115,22 +115,26 @@ getViaTmp key action = do
 			return False
 
 {- Output logging -}
+verbose :: Annex () -> Annex ()
+verbose a = do
+	q <- Annex.flagIsSet "quiet"
+	if (q) then return () else a
 showStart :: String -> String -> Annex ()
-showStart command file = do
+showStart command file = verbose $ do
 	liftIO $ putStr $ command ++ " " ++ file ++ " "
 	liftIO $ hFlush stdout
 showNote :: String -> Annex ()
-showNote s = do
+showNote s = verbose $ do
 	liftIO $ putStr $ "(" ++ s ++ ") "
 	liftIO $ hFlush stdout
 showLongNote :: String -> Annex ()
-showLongNote s = do
+showLongNote s = verbose $ do
 	liftIO $ putStr $ "\n" ++ (indent s)
 	where
 		indent s = join "\n" $ map (\l -> "  " ++ l) $ lines s 
 showEndOk :: Annex ()
-showEndOk = do
+showEndOk = verbose $ do
 	liftIO $ putStrLn "ok"
 showEndFail :: Annex ()
-showEndFail = do
+showEndFail = verbose $ do
 	liftIO $ putStrLn "\nfailed"

GitRepo.hs

@@ -156,7 +156,7 @@ workTree repo =
  - name to use to refer to the file relative to a git repository's top.
  - This is the same form displayed and used by git. -}
 relative :: Repo -> String -> String
-relative repo file = drop (length absrepo) absfile
+relative repo file = assertLocal repo $ drop (length absrepo) absfile
 	where
 		-- normalize both repo and file, so that repo
 		-- will be substring of file

Remotes.hs

@@ -8,11 +8,11 @@ module Remotes (
 	commandLineRemote,
 	copyFromRemote,
 	copyToRemote,
-	removeRemoteFile,
+	runCmd
-	updateRemoteLogStatus
 ) where
 
-import Control.Exception
+import IO (bracket_)
+import Control.Exception hiding (bracket_)
 import Control.Monad.State (liftIO)
 import Control.Monad (filterM)
 import qualified Data.Map as Map
@@ -20,9 +20,9 @@ import Data.String.Utils
 import Data.Either.Utils
 import System.Cmd.Utils
 import System.Directory
+import System.Posix.Directory
 import List
 import Maybe
-import IO (hPutStrLn)
 
 import Types
 import qualified GitRepo as Git
@@ -221,39 +221,19 @@ copyToRemote r key = do
 		sshlocation = (Git.urlHost r) ++ ":" ++ file
 		file = error "TODO"
 
-{- Removes a file from a remote. -}
+{- Runs a command in a remote. -}
-removeRemoteFile :: Git.Repo -> FilePath -> Annex ()
+runCmd :: Git.Repo -> String -> [String] -> Annex Bool
-removeRemoteFile r file = do
+runCmd r command params = do
 	if (not $ Git.repoIsUrl r)
-		then liftIO $ removeFile file
+		then do
+			cwd <- liftIO $ getCurrentDirectory
+			liftIO $ bracket_ (changeWorkingDirectory (Git.workTree r))
+				(\_ -> changeWorkingDirectory cwd) $
+					boolSystem command params
 		else if (Git.repoIsSsh r)
 			then do
-				ok <- liftIO $ boolSystem "ssh"
+				liftIO $ boolSystem "ssh" [Git.urlHost r,
-					[Git.urlHost r, "rm -f " ++
+					"cd " ++ (shellEscape $ Git.workTree r) ++
-					(shellEscape file)]
+					" && " ++ command ++ " " ++
-				if (ok)
+					unwords params]
-					then return ()
+			else error "running command in non-ssh repo not supported"
-					else error "failed to remove file from remote"
-			else error "removing file from non-ssh repo not supported"
-
-{- Update's a remote's location log for a key, by merging the local
- - location log into it. -}
-updateRemoteLogStatus :: Git.Repo -> Key -> Annex ()
-updateRemoteLogStatus r key = do
-	-- To merge, just append data to the remote's
-	-- log. Since the log is timestamped, the presumably newer
-	-- information from the local will superscede the older
-	-- information in the remote's log.
-	-- TODO: remote log locking
-	let mergecmd = "cat >> " ++ (shellEscape $ logFile r key) ++ " && " ++
-		"cd " ++ (shellEscape $ Git.workTree r) ++ " && " ++
-		"git add " ++ (shellEscape $ stateLoc)
-	let shellcmd = if (not $ Git.repoIsUrl r)
-		then pOpen WriteToPipe "sh" ["-c", mergecmd]
-		else if (Git.repoIsSsh r)
-			then pOpen WriteToPipe "ssh" [Git.urlHost r, mergecmd]
-			else error "updating non-ssh repo not supported"
-	g <- Annex.gitRepo
-	liftIO $ shellcmd $ \h -> do
-		lines <- readLog $ logFile g key
-		hPutStrLn h $ unlines $ map show lines

TypeInternals.hs

@@ -31,12 +31,12 @@ data AnnexState = AnnexState {
 type Annex = StateT AnnexState IO
 
 -- annexed filenames are mapped through a backend into keys
-type KeyFrag = String
+type KeyName = String
 type BackendName = String
-data Key = Key (BackendName, KeyFrag) deriving (Eq)
+data Key = Key (BackendName, KeyName) deriving (Eq)
 
 -- constructs a key in a backend
-genKey :: Backend -> KeyFrag -> Key
+genKey :: Backend -> KeyName -> Key
 genKey b f = Key (name b,f)
 
 -- show a key to convert it to a string; the string includes the
@@ -51,9 +51,10 @@ instance Read Key where
 			b = l !! 0
 			k = join ":" $ drop 1 l
 
--- pulls the backend name out
 backendName :: Key -> BackendName
 backendName (Key (b,k)) = b
+keyName :: Key -> KeyName
+keyName (Key (b,k)) = k
 
 -- this structure represents a key-value backend
 data Backend = Backend {

Types.hs

@@ -7,6 +7,7 @@ module Types (
 	Key,
 	genKey,
 	backendName,
+	keyName,
 	FlagName,
 	Flag(..)
 ) where

doc/git-annex.mdwn

@@ -116,6 +116,13 @@ Many git-annex subcommands will stage changes for later `git commit` by you.
 
 	git annex fromkey --backend=URL --key=http://www.archive.org/somefile somefile
 
+* dropkey [key ...]
+
+  Drops the cached data for the specified keys from this repository.
+
+  This can be used to drop content for arbitrary keys, which do not need
+  to have a file in the git repository pointing at them.
+
 # OPTIONS
 
 * --force
@@ -123,6 +130,11 @@ Many git-annex subcommands will stage changes for later `git commit` by you.
   Force unsafe actions, such as dropping a file's content when no other
   source of it can be verified to still exist. Use with care.
 
+* --quiet
+
+  Avoid the default verbose logging of what is done; only show errors
+  and progress displays.
+
 * --backend=name
 
   Specify the default key-value backend to use, adding it to the front