tagging package git-annex version 5.20140210

-----BEGIN PGP SIGNATURE-----
 Version: GnuPG v1
 
 iQIVAwUAUvkVDskQ2SIlEuPHAQho0Q//Y1+hSKqSUcbfuaV9nlU1puUi0VdYWouA
 SmSCpp1Kp44lPNERTrPPA66d8cQo12iCixAxnGt50Wl7n8VD8Py1kyqoNWgMe54W
 H3A7rC58mzXYXWEox1xgX6Sz/RbYMekx9NbALpgQZkVtnOsKO7lNClx1LUNpvXwh
 U52/D4ABpOLAjcb4HS2rs1Z4w0u6fFvFas313RXhIEIecuS2Iz1V/h4Wv6fPkJGR
 S38rG3OQfFXL0v6cU1l+jM2at7sEs+f7q2sujIam3/kgcdysgnyU7rV+p2xqv2+e
 LeOiHszGhjdlK6wnKOoXDZ0rvdNfUzUXbFGHIZfg5ACYR9Ps5hVqfDH6J9riCH8J
 F4WzuDBtKcdVJyBehB/yWw4/ABh5D4YoC2+rsWm6buu/pX5qU+Yshu8X5LRX6h4h
 Ex1jSE2QbTaXNkEa7+14Eb/NscRJqULzUhjBjCrd8JzOVe+jrK/2C2FLETv1ImfN
 G+8iOD/mQL71XwLhdMHA8jwqdSnJOtGXCgaVOcgBKe7E2qXqZAefVrjGvENHQUCb
 AxP2KjGDybYtrCSfHOdYiM8+IJvV/pgmDe9KFjNsUemG+20+a+D64+4b890HwpTT
 gLQpw8U5EwFXgLsYFqu4YBcuVck8T9bEzQhG1FKu2ZP9QJPqR6Z3W2T8jGRyYuC7
 pFh2EtFUKZQ=
 =ojkV
 -----END PGP SIGNATURE-----

Merge tag '5.20140210' into debian-wheezy-backport

tagging package git-annex version 5.20140210

Conflicts:
	debian/control
	git-annex.cabal

.gitignore

@@ -28,3 +28,4 @@ cabal-dev
 # OSX related
 .DS_Store
 .virthualenv
+.tasty-rerun-log

.mailmap

@@ -0,0 +1,6 @@
+Joey Hess <joey@kitenet.net> http://joey.kitenet.net/ <joey@web>
+Joey Hess <joey@kitenet.net> http://joeyh.name/ <joey@web>
+Joey Hess <joey@kitenet.net> http://joeyh.name/ <http://joeyh.name/@web>
+Yaroslav Halchenko <debian@onerussian.com>
+Yaroslav Halchenko <debian@onerussian.com> http://yarikoptic.myopenid.com/ <site-myopenid@web>
+Yaroslav Halchenko <debian@onerussian.com> https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY <Yaroslav@web>

Annex.hs

@@ -34,7 +34,6 @@ module Annex (
 
 import "mtl" Control.Monad.Reader
 import "MonadCatchIO-transformers" Control.Monad.CatchIO
-import System.Posix.Types (Fd)
 import Control.Concurrent
 
 import Common
@@ -46,6 +45,7 @@ import Git.CheckAttr
 import Git.CheckIgnore
 import Git.SharedRepository
 import qualified Git.Queue
+import Types.Key
 import Types.Backend
 import Types.GitConfig
 import qualified Types.Remote
@@ -56,6 +56,8 @@ import Types.Group
 import Types.Messages
 import Types.UUID
 import Types.FileMatcher
+import Types.NumCopies
+import Types.LockPool
 import qualified Utility.Matcher
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -75,7 +77,7 @@ newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }
 	)
 
 type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
-type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FileInfo -> Annex Bool))
+type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> MatchInfo -> Annex Bool))
 
 -- internal state storage
 data AnnexState = AnnexState
@@ -94,8 +96,9 @@ data AnnexState = AnnexState
 	, checkattrhandle :: Maybe CheckAttrHandle
 	, checkignorehandle :: Maybe (Maybe CheckIgnoreHandle)
 	, forcebackend :: Maybe String
-	, forcenumcopies :: Maybe Int
+	, globalnumcopies :: Maybe NumCopies
-	, limit :: Matcher (FileInfo -> Annex Bool)
+	, forcenumcopies :: Maybe NumCopies
+	, limit :: Matcher (MatchInfo -> Annex Bool)
 	, uuidmap :: Maybe UUIDMap
 	, preferredcontentmap :: Maybe PreferredContentMap
 	, shared :: Maybe SharedRepository
@@ -103,12 +106,14 @@ data AnnexState = AnnexState
 	, trustmap :: Maybe TrustMap
 	, groupmap :: Maybe GroupMap
 	, ciphers :: M.Map StorableCipher Cipher
-	, lockpool :: M.Map FilePath Fd
+	, lockpool :: LockPool
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
 	, cleanup :: M.Map String (Annex ())
 	, inodeschanged :: Maybe Bool
 	, useragent :: Maybe String
+	, errcounter :: Integer
+	, unusedkeys :: Maybe (S.Set Key)
 	}
 
 newState :: GitConfig -> Git.Repo -> AnnexState
@@ -128,6 +133,7 @@ newState c r = AnnexState
 	, checkattrhandle = Nothing
 	, checkignorehandle = Nothing
 	, forcebackend = Nothing
+	, globalnumcopies = Nothing
 	, forcenumcopies = Nothing
 	, limit = Left []
 	, uuidmap = Nothing
@@ -143,6 +149,8 @@ newState c r = AnnexState
 	, cleanup = M.empty
 	, inodeschanged = Nothing
 	, useragent = Nothing
+	, errcounter = 0
+	, unusedkeys = Nothing
 	}
 
 {- Makes an Annex state object for the specified git repo.

Annex/Branch.hs

@@ -18,6 +18,7 @@ module Annex.Branch (
 	forceUpdate,
 	updateTo,
 	get,
+	getHistorical,
 	change,
 	commit,
 	forceCommit,
@@ -197,7 +198,13 @@ getLocal file = go =<< getJournalFileStale file
 	go Nothing = getRaw file
 
 getRaw :: FilePath -> Annex String
-getRaw file = withIndex $ L.unpack <$> catFile fullname file
+getRaw = getRef fullname
+
+getHistorical :: RefDate -> FilePath -> Annex String
+getHistorical date = getRef (Git.Ref.dateRef fullname date)
+
+getRef :: Ref -> FilePath -> Annex String
+getRef ref file = withIndex $ L.unpack <$> catFile ref file
 
 {- Applies a function to modifiy the content of a file.
  -
@@ -252,8 +259,7 @@ commitIndex' jl branchref message parents = do
 	committedref <- inRepo $ Git.Branch.commitAlways message fullname parents
 	setIndexSha committedref
 	parentrefs <- commitparents <$> catObject committedref
-	when (racedetected branchref parentrefs) $ do
+	when (racedetected branchref parentrefs) $
-		liftIO $ print ("race detected", branchref, parentrefs, "committing", (branchref, parents))
 		fixrace committedref parentrefs
   where
 	-- look for "parent ref" lines and return the refs

Annex/Branch/Transitions.hs

@@ -41,6 +41,7 @@ dropDead f content trustmap = case getLogVariety f of
 		in if null newlog
 			then RemoveFile
 			else ChangeFile $ Presence.showLog newlog
+	Just SingleValueLog -> PreserveFile
 	Nothing -> PreserveFile
 
 dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String

Annex/Content.hs

@@ -1,6 +1,6 @@
 {- git-annex file content managing
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -35,7 +35,6 @@ module Annex.Content (
 ) where
 
 import System.IO.Unsafe (unsafeInterleaveIO)
-import System.PosixCompat.Files
 
 import Common.Annex
 import Logs.Location
@@ -57,6 +56,10 @@ import Annex.Content.Direct
 import Annex.ReplaceFile
 import Annex.Exception
 
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
 inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
@@ -90,60 +93,105 @@ inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
 {- A safer check; the key's content must not only be present, but
  - is not in the process of being removed. -}
 inAnnexSafe :: Key -> Annex (Maybe Bool)
-inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go
+inAnnexSafe key = inAnnex' (fromMaybe False) (Just False) go key
   where
-	go f = liftIO $ openforlock f >>= check
+	is_locked = Nothing
+	is_unlocked = Just True
+	is_missing = Just False
+
+	go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile)
+		=<< contentLockFile key
+
 #ifndef mingw32_HOST_OS
+	checkindirect f = liftIO $ openforlock f >>= check is_missing
+	{- In direct mode, the content file must exist, but
+	 - the lock file often generally won't exist unless a removal is in
+	 - process. This does not create the lock file, it only checks for
+	 - it. -}
+	checkdirect contentfile lockfile = liftIO $
+		ifM (doesFileExist contentfile)
+			( openforlock lockfile >>= check is_unlocked
+			, return is_missing
+			)
 	openforlock f = catchMaybeIO $
 		openFd f ReadOnly Nothing defaultFileFlags
-#else
+	check _ (Just h) = do
-	openforlock _ = return $ Just ()
-#endif
-	check Nothing = return is_missing
-#ifndef mingw32_HOST_OS
-	check (Just h) = do
 		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
 		closeFd h
 		return $ case v of
 			Just _ -> is_locked
 			Nothing -> is_unlocked
+	check def Nothing = return def
 #else
-	check (Just _) = return is_unlocked
+	checkindirect _ = return is_missing
+	{- In Windows, see if we can take a shared lock. If so, 
+	 - remove the lock file to clean up after ourselves. -}
+	checkdirect contentfile lockfile =
+		ifM (liftIO $ doesFileExist contentfile)
+			( modifyContent lockfile $ liftIO $ do
+				v <- lockShared lockfile
+				case v of
+					Nothing -> return is_locked
+					Just lockhandle -> do
+						dropLock lockhandle
+						void $ tryIO $ nukeFile lockfile
+						return is_unlocked
+			, return is_missing
+			)
 #endif
-#ifndef mingw32_HOST_OS
+
-	is_locked = Nothing
+{- Direct mode and especially Windows has to use a separate lock
-#endif
+ - file from the content, since locking the actual content file
-	is_unlocked = Just True
+ - would interfere with the user's use of it. -}
-	is_missing = Just False
+contentLockFile :: Key -> Annex (Maybe FilePath)
+contentLockFile key = ifM isDirect
+	( Just <$> calcRepo (gitAnnexContentLock key)
+	, return Nothing
+	)
 
 {- Content is exclusively locked while running an action that might remove
  - it. (If the content is not present, no locking is done.) -}
 lockContent :: Key -> Annex a -> Annex a
-#ifndef mingw32_HOST_OS
 lockContent key a = do
-	file <- calcRepo $ gitAnnexLocation key
+	contentfile <- calcRepo $ gitAnnexLocation key
-	bracketIO (openforlock file >>= lock) unlock (const a)
+	lockfile <- contentLockFile key
+	maybe noop setuplockfile lockfile
+	bracketAnnex (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a)
   where
-	{- Since files are stored with the write bit disabled, have
+	alreadylocked = error "content is locked"
+	setuplockfile lockfile = modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			writeFile lockfile ""
+	cleanuplockfile lockfile = modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			nukeFile lockfile
+#ifndef mingw32_HOST_OS
+	lock contentfile Nothing = opencontentforlock contentfile >>= dolock
+	lock _ (Just lockfile) = openforlock lockfile >>= dolock . Just
+	{- Since content files are stored with the write bit disabled, have
 	 - to fiddle with permissions to open for an exclusive lock. -}
-	openforlock f = catchMaybeIO $ ifM (doesFileExist f)
+	opencontentforlock f = catchMaybeIO $ ifM (doesFileExist f)
 		( withModifiedFileMode f
 			(`unionFileModes` ownerWriteMode)
-			open
+			(openforlock f)
-		, open
+		, openforlock f
 		)
-	  where
+	openforlock f = openFd f ReadWrite Nothing defaultFileFlags
-		open = openFd f ReadWrite Nothing defaultFileFlags
+	dolock Nothing = return Nothing
-	lock Nothing = return Nothing
+	dolock (Just fd) = do
-	lock (Just fd) = do
 		v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 		case v of
-			Left _ -> error "content is locked"
+			Left _ -> alreadylocked
 			Right _ -> return $ Just fd
-	unlock Nothing = noop
+	unlock mlockfile mfd = do
-	unlock (Just l) = closeFd l
+		maybe noop cleanuplockfile mlockfile
+		liftIO $ maybe noop closeFd mfd
 #else
-lockContent _key a = a -- no locking for Windows!
+	lock _ (Just lockfile) = maybe alreadylocked (return . Just) =<< lockExclusive lockfile
+	lock _ Nothing = return Nothing
+	unlock mlockfile mlockhandle = do
+		liftIO $ maybe noop dropLock mlockhandle
+		maybe noop cleanuplockfile mlockfile
 #endif
 
 {- Runs an action, passing it a temporary filename to get,
@@ -377,6 +425,7 @@ removeAnnex :: Key -> Annex ()
 removeAnnex key = withObjectLoc key remove removedirect
   where
 	remove file = cleanObjectLoc key $ do
+		secureErase file
 		liftIO $ nukeFile file
 		removeInodeCache key
 	removedirect fs = do
@@ -385,11 +434,18 @@ removeAnnex key = withObjectLoc key remove removedirect
 		mapM_ (resetfile cache) fs
 	resetfile cache f = whenM (sameInodeCache f cache) $ do
 		l <- inRepo $ gitAnnexLink f key
-		top <- fromRepo Git.repoPath
+		secureErase f
-		cwd <- liftIO getCurrentDirectory
+		replaceFile f $ makeAnnexLink l
-		let top' = fromMaybe top $ absNormPath cwd top
+
-		let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l)
+{- Runs the secure erase command if set, otherwise does nothing.
-		replaceFile f $ makeAnnexLink l'
+ - File may or may not be deleted at the end; caller is responsible for
+ - making sure it's deleted. -}
+secureErase :: FilePath -> Annex ()
+secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
+  where
+  	go basecmd = void $ liftIO $
+		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
+	gencmd = massReplace [ ("%file", shellEscape file) ]
 
 {- Moves a key's file out of .git/annex/objects/ -}
 fromAnnex :: Key -> FilePath -> Annex ()

Annex/Content/Direct.hs

@@ -52,10 +52,12 @@ associatedFiles key = do
 associatedFilesRelative :: Key -> Annex [FilePath] 
 associatedFilesRelative key = do
 	mapping <- calcRepo $ gitAnnexMapping key
-	liftIO $ catchDefaultIO [] $ do
+	liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> do
-		h <- openFile mapping ReadMode
 		fileEncoding h
-		lines <$> hGetContents h
+		-- Read strictly to ensure the file is closed
+		-- before changeAssociatedFiles tries to write to it.
+		-- (Especially needed on Windows.)
+		lines <$> hGetContentsStrict h
 
 {- Changes the associated files information for a key, applying a
  - transformation to the list. Returns new associatedFiles value. -}
@@ -66,15 +68,10 @@ changeAssociatedFiles key transform = do
 	let files' = transform files
 	when (files /= files') $ do
 		modifyContent mapping $
-			liftIO $ viaTmp write mapping $ unlines files'
+			liftIO $ viaTmp writeFileAnyEncoding mapping $
+				unlines files'
 	top <- fromRepo Git.repoPath
 	return $ map (top </>) files'
-  where
-	write file content = do
-		h <- openFile file WriteMode
-		fileEncoding h
- 		hPutStr h content
-		hClose h
 
 {- Removes the list of associated files. -}
 removeAssociatedFiles :: Key -> Annex ()

Annex/Drop.hs

@@ -0,0 +1,124 @@
+{- dropping of unwanted content
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Drop where
+
+import Common.Annex
+import Logs.Trust
+import Config.NumCopies
+import Types.Remote (uuid)
+import Types.Key (key2file)
+import qualified Remote
+import qualified Command.Drop
+import Command
+import Annex.Wanted
+import Annex.Exception
+import Config
+import Annex.Content.Direct
+
+import qualified Data.Set as S
+import System.Log.Logger (debugM)
+
+type Reason = String
+
+{- Drop a key from local and/or remote when allowed by the preferred content
+ - and numcopies settings.
+ -
+ - The UUIDs are ones where the content is believed to be present.
+ - The Remote list can include other remotes that do not have the content;
+ - only ones that match the UUIDs will be dropped from.
+ - If allowed to drop fromhere, that drop will be tried first.
+ -
+ - A remote can be specified that is known to have the key. This can be
+ - used an an optimisation when eg, a key has just been uploaded to a
+ - remote.
+ -
+ - In direct mode, all associated files are checked, and only if all
+ - of them are unwanted are they dropped.
+ -
+ - The runner is used to run commands, and so can be either callCommand
+ - or commandAction.
+ -}
+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
+handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
+	fs <- ifM isDirect
+		( do
+			l <- associatedFilesRelative key
+			return $ if null l
+				then maybeToList afile
+				else l
+		, return $ maybeToList afile
+		)
+	n <- getcopies fs
+	if fromhere && checkcopies n Nothing
+		then go fs rs =<< dropl fs n
+		else go fs rs n
+  where
+	getcopies fs = do
+		(untrusted, have) <- trustPartition UnTrusted locs
+		numcopies <- if null fs
+			then getNumCopies
+			else maximum <$> mapM getFileNumCopies fs
+		return (NumCopies (length have), numcopies, S.fromList untrusted)
+
+	{- Check that we have enough copies still to drop the content.
+	 - When the remote being dropped from is untrusted, it was not
+	 - counted as a copy, so having only numcopies suffices. Otherwise,
+	 - we need more than numcopies to safely drop. -}
+	checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies
+	checkcopies (have, numcopies, untrusted) (Just u)
+		| S.member u untrusted = have >= numcopies
+		| otherwise = have > numcopies
+	
+	decrcopies (have, numcopies, untrusted) Nothing =
+		(NumCopies (fromNumCopies have - 1), numcopies, untrusted)
+	decrcopies v@(_have, _numcopies, untrusted) (Just u)
+		| S.member u untrusted = v
+		| otherwise = decrcopies v Nothing
+
+	go _ [] _ = noop
+	go fs (r:rest) n
+		| uuid r `S.notMember` slocs = go fs rest n
+		| checkcopies n (Just $ Remote.uuid r) =
+			dropr fs r n >>= go fs rest
+		| otherwise = noop
+
+	checkdrop fs n u a
+		| null fs = check $ -- no associated files; unused content
+			wantDrop True u (Just key) Nothing
+		| otherwise = check $
+			allM (wantDrop True u (Just key) . Just) fs
+		where
+			check c = ifM c
+				( dodrop n u a
+				, return n
+				)
+
+	dodrop n@(have, numcopies, _untrusted) u a = 
+		ifM (safely $ runner $ a numcopies)
+			( do
+				liftIO $ debugM "drop" $ unwords
+					[ "dropped"
+					, fromMaybe (key2file key) afile
+					, "(from " ++ maybe "here" show u ++ ")"
+					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
+					, ": " ++ reason
+					]
+				return $ decrcopies n u
+			, return n
+			)
+
+	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
+		Command.Drop.startLocal afile numcopies key knownpresentremote
+
+	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
+		Command.Drop.startRemote afile numcopies key r
+
+	slocs = S.fromList locs
+	
+	safely a = either (const False) id <$> tryAnnex a
+

Annex/Exception.hs

@@ -14,6 +14,7 @@
 
 module Annex.Exception (
 	bracketIO,
+	bracketAnnex,
 	tryAnnex,
 	tryAnnexIO,
 	throwAnnex,
@@ -29,6 +30,9 @@ import Common.Annex
 bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
 bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup)
 
+bracketAnnex :: Annex v -> (v -> Annex b) -> (v -> Annex a) -> Annex a
+bracketAnnex = M.bracket
+
 {- try in the Annex monad -}
 tryAnnex :: Annex a -> Annex (Either SomeException a)
 tryAnnex = M.try

Annex/FileMatcher.hs

@@ -1,6 +1,6 @@
 {- git-annex file matching
  -
- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -28,18 +28,25 @@ import qualified Data.Set as S
 type FileMatcher = Matcher MatchFiles
 
 checkFileMatcher :: FileMatcher -> FilePath -> Annex Bool
-checkFileMatcher matcher file = checkFileMatcher' matcher file S.empty True
+checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True
 
-checkFileMatcher' :: FileMatcher -> FilePath -> AssumeNotPresent -> Bool -> Annex Bool
+checkMatcher :: FileMatcher -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
-checkFileMatcher' matcher file notpresent def
+checkMatcher matcher mkey afile notpresent def
 	| isEmpty matcher = return def
-	| otherwise = do
+	| otherwise = case (mkey, afile) of
+		(_, Just file) -> go =<< fileMatchInfo file
+		(Just key, _) -> go (MatchingKey key)
+		_ -> return def
+  where
+	go mi = matchMrun matcher $ \a -> a notpresent mi
+
+fileMatchInfo :: FilePath -> Annex MatchInfo
+fileMatchInfo file = do
 	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
-		let fi = FileInfo
+	return $ MatchingFile $ FileInfo
 		{ matchFile = matchfile
 		, relFile = file
 		}
-		matchMrun matcher $ \a -> a notpresent fi
 
 matchAll :: FileMatcher
 matchAll = generate []
@@ -65,11 +72,14 @@ parseToken checkpresent checkpreferreddir groupmap t
 	| t `elem` tokens = Right $ token t
 	| t == "present" = use checkpresent
 	| t == "inpreferreddir" = use checkpreferreddir
+	| t == "unused" = Right (Operation limitUnused)
 	| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $
 		M.fromList
 			[ ("include", limitInclude)
 			, ("exclude", limitExclude)
 			, ("copies", limitCopies)
+			, ("lackingcopies", limitLackingCopies False)
+			, ("approxlackingcopies", limitLackingCopies True)
 			, ("inbackend", limitInBackend)
 			, ("largerthan", limitSize (>))
 			, ("smallerthan", limitSize (<))

Annex/Init.hs

@@ -7,7 +7,7 @@
 
 {-# LANGUAGE CPP #-}
 
-module Init (
+module Annex.Init (
 	ensureInitialized,
 	isInitialized,
 	initialize,

Annex/Journal.hs

@@ -20,6 +20,10 @@ import Annex.Exception
 import qualified Git
 import Annex.Perms
 
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
 {- Records content for a file in the branch to the journal.
  -
  - Using the journal, rather than immediatly staging content to the index
@@ -116,13 +120,8 @@ lockJournal a = do
 		l <- noUmask mode $ createFile lockfile mode
 		waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
 		return l
-#else
-	lock lockfile _mode = do
-		writeFile lockfile ""
-		return lockfile
-#endif
-#ifndef mingw32_HOST_OS
 	unlock = closeFd
 #else
-	unlock = removeFile
+	lock lockfile _mode = waitToLock $ lockExclusive lockfile
+	unlock = dropLock
 #endif

Annex/Link.hs

@@ -51,19 +51,15 @@ getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
 				| otherwise -> return Nothing
 			Nothing -> fallback
 
-	probefilecontent f = do
+	probefilecontent f = withFile f ReadMode $ \h -> do
-		h <- openFile f ReadMode
 		fileEncoding h
 		-- The first 8k is more than enough to read; link
 		-- files are small.
 		s <- take 8192 <$> hGetContents h
 		-- If we got the full 8k, the file is too large
 		if length s == 8192
-			then do
+			then return ""
-				hClose h
+			else 
-				return ""
-			else do
-				hClose h
 				-- If there are any NUL or newline
 				-- characters, or whitespace, we
 				-- certianly don't have a link to a

Annex/LockPool.hs

@@ -1,6 +1,6 @@
 {- git-annex lock pool
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -9,13 +9,16 @@
 
 module Annex.LockPool where
 
-import qualified Data.Map as M
-import System.Posix.Types (Fd)
-
 import Common.Annex
 import Annex
+import Types.LockPool
+
+import qualified Data.Map as M
+
 #ifndef mingw32_HOST_OS
 import Annex.Perms
+#else
+import Utility.WinLock
 #endif
 
 {- Create a specified lock file, and takes a shared lock. -}
@@ -26,31 +29,32 @@ lockFile file = go =<< fromPool file
 	go Nothing = do
 #ifndef mingw32_HOST_OS
 		mode <- annexFileMode
-		fd <- liftIO $ noUmask mode $
+		lockhandle <- liftIO $ noUmask mode $
 			openFd file ReadOnly (Just mode) defaultFileFlags
-		liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
+		liftIO $ waitToSetLock lockhandle (ReadLock, AbsoluteSeek, 0, 0)
 #else
-		liftIO $ writeFile file ""
+		lockhandle <- liftIO $ waitToLock $ lockShared file
-		let fd = 0
 #endif
-		changePool $ M.insert file fd
+		changePool $ M.insert file lockhandle
 
 unlockFile :: FilePath -> Annex ()
 unlockFile file = maybe noop go =<< fromPool file
   where
-	go fd = do
+	go lockhandle = do
 #ifndef mingw32_HOST_OS
-		liftIO $ closeFd fd
+		liftIO $ closeFd lockhandle
+#else
+		liftIO $ dropLock lockhandle
 #endif
 		changePool $ M.delete file
 
-getPool :: Annex (M.Map FilePath Fd)
+getPool :: Annex LockPool
 getPool = getState lockpool
 
-fromPool :: FilePath -> Annex (Maybe Fd)
+fromPool :: FilePath -> Annex (Maybe LockHandle)
 fromPool file = M.lookup file <$> getPool
 
-changePool :: (M.Map FilePath Fd -> M.Map FilePath Fd) -> Annex ()
+changePool :: (LockPool -> LockPool) -> Annex ()
 changePool a = do
 	m <- getPool
 	changeState $ \s -> s { lockpool = a m }

Annex/Wanted.hs

@@ -14,19 +14,16 @@ import Annex.UUID
 import qualified Data.Set as S
 
 {- Check if a file is preferred content for the local repository. -}
-wantGet :: Bool -> AssociatedFile -> Annex Bool
+wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool
-wantGet def Nothing = return def
+wantGet def key file = isPreferredContent Nothing S.empty key file def
-wantGet def (Just file) = isPreferredContent Nothing S.empty file def
 
 {- Check if a file is preferred content for a remote. -}
-wantSend :: Bool -> AssociatedFile -> UUID -> Annex Bool
+wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
-wantSend def Nothing _ = return def
+wantSend def key file to = isPreferredContent (Just to) S.empty key file def
-wantSend def (Just file) to = isPreferredContent (Just to) S.empty file def
 
 {- Check if a file can be dropped, maybe from a remote.
  - Don't drop files that are preferred content. -}
-wantDrop :: Bool -> Maybe UUID -> AssociatedFile -> Annex Bool
+wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool
-wantDrop def _ Nothing = return $ not def
+wantDrop def from key file = do
-wantDrop def from (Just file) = do
 	u <- maybe getUUID (return . id) from
-	not <$> isPreferredContent (Just u) (S.singleton u) file def
+	not <$> isPreferredContent (Just u) (S.singleton u) key file def

Assistant.hs

@@ -145,7 +145,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 				, assist $ transferPollerThread
 				, assist $ transfererThread
 				, assist $ daemonStatusThread
-				, assist $ sanityCheckerDailyThread
+				, assist $ sanityCheckerDailyThread urlrenderer
 				, assist $ sanityCheckerHourlyThread
 				, assist $ problemFixerThread urlrenderer
 #ifdef WITH_CLIBS

Assistant/Alert.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant alerts
  -
- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -253,13 +253,32 @@ upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ]
 
 upgradeFinishedAlert :: Maybe AlertButton -> GitAnnexVersion -> Alert
 upgradeFinishedAlert button version =
-	baseUpgradeAlert (maybe [] (:[]) button) $ fromString $ 
+	baseUpgradeAlert (maybeToList button) $ fromString $ 
 		"Finished upgrading git-annex to version " ++ version
 
 upgradeFailedAlert :: String -> Alert
 upgradeFailedAlert msg = (errorAlert msg [])
 	{ alertHeader = Just $ fromString "Upgrade failed." }
 
+unusedFilesAlert :: [AlertButton] -> String -> Alert
+unusedFilesAlert buttons message = Alert
+	{ alertHeader = Just $ fromString $ unwords
+		[ "Old and deleted files are piling up --"
+		, message
+		]
+	, alertIcon = Just InfoIcon
+	, alertPriority = High
+	, alertButtons = buttons
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just UnusedFilesAlert
+	, alertCombiner = Just $ fullCombiner $ \new _old -> new
+	, alertData = []
+	}
+
 brokenRepositoryAlert :: [AlertButton] -> Alert
 brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
 
@@ -298,7 +317,7 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert
 	, alertPriority = High
 	, alertName = Just $ PairAlert who
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
-	, alertButtons = maybe [] (:[]) button
+	, alertButtons = maybeToList button
 	}
 
 xmppNeededAlert :: AlertButton -> Alert

Assistant/DaemonStatus.hs

@@ -55,11 +55,11 @@ calcSyncRemotes = do
 	let good r = Remote.uuid r `elem` alive
 	let syncable = filter good rs
 	let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $
-		filter (not . isXMPPRemote) syncable
+		filter (not . Remote.isXMPPRemote) syncable
 
 	return $ \dstatus -> dstatus
 		{ syncRemotes = syncable
-		, syncGitRemotes = filter Remote.syncableRemote syncable
+		, syncGitRemotes = filter Remote.gitSyncableRemote syncable
 		, syncDataRemotes = syncdata
 		, syncingToCloudRemote = any iscloud syncdata
 		}
@@ -257,11 +257,5 @@ alertDuring alert a = do
 	i <- addAlert $ alert { alertClass = Activity }
 	removeAlert  i `after` a
 
-{- Remotes using the XMPP transport have urls like xmpp::user@host -}
-isXMPPRemote :: Remote -> Bool
-isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
-  where
-	r = Remote.repo remote
-
 getXMPPClientID :: Remote -> ClientID
 getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

Assistant/Drop.hs

@@ -5,108 +5,21 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Assistant.Drop where
+module Assistant.Drop (
+	handleDrops,
+	handleDropsFrom,
+) where
 
 import Assistant.Common
 import Assistant.DaemonStatus
+import Annex.Drop (handleDropsFrom, Reason)
 import Logs.Location
-import Logs.Trust
+import CmdLine.Action
-import Types.Remote (uuid)
-import qualified Remote
-import qualified Command.Drop
-import Command
-import Annex.Wanted
-import Annex.Exception
-import Config
-import Annex.Content.Direct
-
-import qualified Data.Set as S
-
-type Reason = String
 
 {- Drop from local and/or remote when allowed by the preferred content and
  - numcopies settings. -}
 handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
-handleDrops _ _ _ Nothing _ = noop
 handleDrops reason fromhere key f knownpresentremote = do
 	syncrs <- syncDataRemotes <$> getDaemonStatus
 	locs <- liftAnnex $ loggedLocations key
-	handleDropsFrom locs syncrs reason fromhere key f knownpresentremote
+	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction
-
-{- The UUIDs are ones where the content is believed to be present.
- - The Remote list can include other remotes that do not have the content;
- - only ones that match the UUIDs will be dropped from.
- - If allowed to drop fromhere, that drop will be tried first.
- -
- - In direct mode, all associated files are checked, and only if all
- - of them are unwanted are they dropped.
- -}
-handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
-handleDropsFrom _ _ _ _ _ Nothing _ = noop
-handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
-	fs <- liftAnnex $ ifM isDirect
-		( do
-			l <- associatedFilesRelative key
-			if null l
-				then return [afile]
-				else return l
-		, return [afile]
-		)
-	n <- getcopies fs
-	if fromhere && checkcopies n Nothing
-		then go fs rs =<< dropl fs n
-		else go fs rs n
-  where
-	getcopies fs = liftAnnex $ do
-		(untrusted, have) <- trustPartition UnTrusted locs
-		numcopies <- maximum <$> mapM (getNumCopies <=< numCopies) fs
-		return (length have, numcopies, S.fromList untrusted)
-
-	{- Check that we have enough copies still to drop the content.
-	 - When the remote being dropped from is untrusted, it was not
-	 - counted as a copy, so having only numcopies suffices. Otherwise,
-	 - we need more than numcopies to safely drop. -}
-	checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies
-	checkcopies (have, numcopies, untrusted) (Just u)
-		| S.member u untrusted = have >= numcopies
-		| otherwise = have > numcopies
-	
-	decrcopies (have, numcopies, untrusted) Nothing =
-		(have - 1, numcopies, untrusted)
-	decrcopies v@(_have, _numcopies, untrusted) (Just u)
-		| S.member u untrusted = v
-		| otherwise = decrcopies v Nothing
-
-	go _ [] _ = noop
-	go fs (r:rest) n
-		| uuid r `S.notMember` slocs = go fs rest n
-		| checkcopies n (Just $ Remote.uuid r) =
-			dropr fs r n >>= go fs rest
-		| otherwise = noop
-
-	checkdrop fs n@(have, numcopies, _untrusted) u a =
-		ifM (liftAnnex $ allM (wantDrop True u . Just) fs)
-			( ifM (liftAnnex $ safely $ doCommand $ a (Just numcopies))
-				( do
-					debug
-						[ "dropped"
-						, afile
-						, "(from " ++ maybe "here" show u ++ ")"
-						, "(copies now " ++ show (have - 1) ++ ")"
-						, ": " ++ reason
-						]
-					return $ decrcopies n u
-				, return n
-				)
-			, return n
-			)
-
-	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
-		Command.Drop.startLocal (Just afile) numcopies key knownpresentremote
-
-	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
-		Command.Drop.startRemote (Just afile) numcopies key r
-
-	safely a = either (const False) id <$> tryAnnex a
-
-	slocs = S.fromList locs

Assistant/Sync.hs

@@ -71,7 +71,7 @@ reconnectRemotes notifypushes rs = void $ do
 		mapM_ signal $ filter (`notElem` failedrs) rs'
   where
 	gitremotes = filter (notspecialremote . Remote.repo) rs
-	(xmppremotes, nonxmppremotes) = partition isXMPPRemote rs
+	(xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
 	notspecialremote r
 		| Git.repoIsUrl r = True
 		| Git.repoIsLocal r = True
@@ -133,7 +133,7 @@ pushToRemotes' now notifypushes remotes = do
 			<$> gitRepo
 			<*> inRepo Git.Branch.current
 			<*> getUUID
-	let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
+	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
 	ret <- go True branch g u normalremotes
 	unless (null xmppremotes) $ do
 		shas <- liftAnnex $ map fst <$>
@@ -206,7 +206,7 @@ syncAction rs a
 		return failed
   where
 	visibleremotes = filter (not . Remote.readonly) $
-		filter (not . isXMPPRemote) rs
+		filter (not . Remote.isXMPPRemote) rs
 
 {- Manually pull from remotes and merge their branches. Returns any
  - remotes that it failed to pull from, and a Bool indicating
@@ -220,7 +220,7 @@ syncAction rs a
 manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
 manualPull currentbranch remotes = do
 	g <- liftAnnex gitRepo
-	let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
+	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
 	failed <- liftIO $ forM normalremotes $ \r ->
 		ifM (Git.Command.runBool [Param "fetch", Param $ Remote.name r] g)
 			( return Nothing

Assistant/Threads/Committer.hs

@@ -464,7 +464,7 @@ checkChangeContent change@(Change { changeInfo = i }) =
 		Nothing -> noop
 		Just k -> whenM (scanComplete <$> getDaemonStatus) $ do
 			present <- liftAnnex $ inAnnex k
-			if present
+			void $ if present
 				then queueTransfers "new file created" Next k (Just f) Upload
 				else queueTransfers "new or renamed file wanted" Next k (Just f) Download
 			handleDrops "file renamed" present k (Just f) Nothing

Assistant/Threads/ConfigMonitor.hs

@@ -17,6 +17,7 @@ import Logs.UUID
 import Logs.Trust
 import Logs.PreferredContent
 import Logs.Group
+import Logs.NumCopies
 import Remote.List (remoteListRefresh)
 import qualified Git.LsTree as LsTree
 import Git.FilePath
@@ -59,6 +60,7 @@ configFilesActions =
 	, (remoteLog, void $ liftAnnex remoteListRefresh)
 	, (trustLog, void $ liftAnnex trustMapLoad)
 	, (groupLog, void $ liftAnnex groupMapLoad)
+	, (numcopiesLog, void $ liftAnnex globalNumCopiesLoad)
 	, (scheduleLog, void updateScheduleLog)
 	-- Preferred content settings depend on most of the other configs,
 	-- so will be reloaded whenever any configs change.

Assistant/Threads/SanityChecker.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.Threads.SanityChecker (
 	sanityCheckerStartupThread,
 	sanityCheckerDailyThread,
@@ -15,7 +17,10 @@ import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Assistant.Repair
+import Assistant.Drop
 import Assistant.Ssh
+import Assistant.TransferQueue
+import Assistant.Types.UrlRenderer
 import qualified Annex.Branch
 import qualified Git.LsFiles
 import qualified Git.Command
@@ -27,10 +32,20 @@ import Utility.Batch
 import Utility.NotificationBroadcaster
 import Config
 import Utility.HumanTime
+import Utility.Tense
 import Git.Repair
 import Git.Index
+import Assistant.Unused
+import Logs.Unused
+import Logs.Transfer
+import Config.Files
+import qualified Annex
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+#endif
 
 import Data.Time.Clock.POSIX
+import qualified Data.Text as T
 
 {- This thread runs once at startup, and most other threads wait for it
  - to finish. (However, the webapp thread does not, to prevent the UI
@@ -78,8 +93,8 @@ sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do
 	hourlyCheck
 
 {- This thread wakes up daily to make sure the tree is in good shape. -}
-sanityCheckerDailyThread :: NamedThread
+sanityCheckerDailyThread :: UrlRenderer -> NamedThread
-sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do
+sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ forever $ do
 	waitForNextCheck
 
 	debug ["starting sanity check"]
@@ -90,7 +105,8 @@ sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do
 		modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
 
 		now <- liftIO getPOSIXTime -- before check started
-		r <- either showerr return =<< (tryIO . batch) <~> dailyCheck
+		r <- either showerr return 
+			=<< (tryIO . batch) <~> dailyCheck urlrenderer
 
 		modifyDaemonStatus_ $ \s -> s
 			{ sanityCheckRunning = False
@@ -119,9 +135,10 @@ waitForNextCheck = do
 {- It's important to stay out of the Annex monad as much as possible while
  - running potentially expensive parts of this check, since remaining in it
  - will block the watcher. -}
-dailyCheck :: Assistant Bool
+dailyCheck :: UrlRenderer -> Assistant Bool
-dailyCheck = do
+dailyCheck urlrenderer = do
 	g <- liftAnnex gitRepo
+	batchmaker <- liftIO getBatchCommandMaker
 
 	-- Find old unstaged symlinks, and add them to git.
 	(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g
@@ -140,12 +157,29 @@ dailyCheck = do
 	 - to have a lot of small objects and they should not be a
 	 - significant size. -}
 	when (Git.Config.getMaybe "gc.auto" g == Just "0") $
-		liftIO $ void $ Git.Command.runBool
+		liftIO $ void $ Git.Command.runBatch batchmaker
 			[ Param "-c", Param "gc.auto=670000"
 			, Param "gc"
 			, Param "--auto"
 			] g
 
+	{- Check if the unused files found last time have been dealt with. -}
+	checkOldUnused urlrenderer
+
+	{- Run git-annex unused once per day. This is run as a separate
+	 - process to stay out of the annex monad and so it can run as a
+	 - batch job. -}
+	program <- liftIO readProgramFile
+	let (program', params') = batchmaker (program, [Param "unused"])
+	void $ liftIO $ boolSystem program' params'
+	{- Invalidate unused keys cache, and queue transfers of all unused
+	 - keys, or if no transfers are called for, drop them. -}
+	unused <- liftAnnex unusedKeys'
+	void $ liftAnnex $ setUnusedKeys unused
+	forM_ unused $ \k -> do
+		unlessM (queueTransfers "unused" Later k Nothing Upload) $
+			handleDrops "unused" True k Nothing Nothing
+
 	return True
   where
 	toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
@@ -159,7 +193,8 @@ dailyCheck = do
 		insanity $ "found unstaged symlink: " ++ file
 
 hourlyCheck :: Assistant ()
-hourlyCheck = checkLogSize 0
+hourlyCheck = do
+	checkLogSize 0
 
 {- Rotate logs until log file size is < 1 mb. -}
 checkLogSize :: Int -> Assistant ()
@@ -184,3 +219,23 @@ oneHour = 60 * 60
 oneDay :: Int
 oneDay = 24 * oneHour
 
+{- If annex.expireunused is set, find any keys that have lingered unused
+ - for the specified duration, and remove them.
+ -
+ - Otherwise, check to see if unused keys are piling up, and let the user
+ - know. -}
+checkOldUnused :: UrlRenderer -> Assistant ()
+checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig
+  where
+	go (Just Nothing) = noop
+  	go (Just (Just expireunused)) = expireUnused (Just expireunused)
+	go Nothing = maybe noop prompt =<< describeUnusedWhenBig
+
+	prompt msg = 
+#ifdef WITH_WEBAPP
+		do
+			button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
+			void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg
+#else
+		debug [show $ renderTense Past msg]
+#endif

Assistant/Threads/TransferScanner.hs

@@ -29,6 +29,7 @@ import qualified Git.LsFiles as LsFiles
 import qualified Backend
 import Annex.Content
 import Annex.Wanted
+import CmdLine.Action
 
 import qualified Data.Set as S
 
@@ -156,16 +157,16 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
 		syncrs <- syncDataRemotes <$> getDaemonStatus
 		locs <- liftAnnex $ loggedLocations key
 		present <- liftAnnex $ inAnnex key
-		handleDropsFrom locs syncrs
+		liftAnnex $ handleDropsFrom locs syncrs
 			"expensive scan found too many copies of object"
-			present key (Just f) Nothing
+			present key (Just f) Nothing callCommandAction
 		liftAnnex $ do
 			let slocs = S.fromList locs
 			let use a = return $ mapMaybe (a key slocs) syncrs
 			ts <- if present
-				then filterM (wantSend True (Just f) . Remote.uuid . fst)
+				then filterM (wantSend True (Just key) (Just f) . Remote.uuid . fst)
 					=<< use (genTransfer Upload False)
-				else ifM (wantGet True $ Just f)
+				else ifM (wantGet True (Just key) (Just f))
 					( use (genTransfer Download True) , return [] )
 			let unwanted' = S.difference unwanted slocs
 			return (unwanted', ts)

Assistant/Threads/WebApp.hs

@@ -27,6 +27,7 @@ import Assistant.WebApp.Configurators.IA
 import Assistant.WebApp.Configurators.WebDAV
 import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Configurators.Preferences
+import Assistant.WebApp.Configurators.Unused
 import Assistant.WebApp.Configurators.Edit
 import Assistant.WebApp.Configurators.Delete
 import Assistant.WebApp.Configurators.Fsck

Assistant/Threads/XMPPClient.hs

@@ -322,7 +322,7 @@ pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
 	| baseJID selfjid == baseJID theirjid = autoaccept
 	| otherwise = do
 		knownjids <- mapMaybe (parseJID . getXMPPClientID)
-			. filter isXMPPRemote . syncRemotes <$> getDaemonStatus
+			. filter Remote.isXMPPRemote . syncRemotes <$> getDaemonStatus
 		um <- liftAnnex uuidMap
 		if elem (baseJID theirjid) knownjids && M.member theiruuid um
 			then autoaccept

Assistant/TransferQueue.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant pending transfer queue
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -51,14 +51,17 @@ stubInfo f r = stubTransferInfo
 
 {- Adds transfers to queue for some of the known remotes.
  - Honors preferred content settings, only transferring wanted files. -}
-queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
 queueTransfers = queueTransfersMatching (const True)
 
 {- Adds transfers to queue for some of the known remotes, that match a
  - condition. Honors preferred content settings. -}
-queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
 queueTransfersMatching matching reason schedule k f direction
-	| direction == Download = whenM (liftAnnex $ wantGet True f) go
+	| direction == Download = ifM (liftAnnex $ wantGet True (Just k) f)
+		( go
+		, return False
+		)
 	| otherwise = go
   where
 	go = do
@@ -67,9 +70,13 @@ queueTransfersMatching matching reason schedule k f direction
 			=<< syncDataRemotes <$> getDaemonStatus
 		let matchingrs = filter (matching . Remote.uuid) rs
 		if null matchingrs
-			then defer
+			then do
-			else forM_ matchingrs $ \r ->
+				defer
+				return False
+			else do
+				forM_ matchingrs $ \r ->
 					enqueue reason schedule (gentransfer r) (stubInfo f r)
+				return True
 	selectremotes rs
 		{- Queue downloads from all remotes that
 		 - have the key. The list of remotes is ordered with
@@ -82,7 +89,7 @@ queueTransfersMatching matching reason schedule k f direction
 		 - already have it. -}
 		| otherwise = do
 			s <- locs
-			filterM (wantSend True f . Remote.uuid) $
+			filterM (wantSend True (Just k) f . Remote.uuid) $
 				filter (\r -> not (inset s r || Remote.readonly r)) rs
 	  where
 	  	locs = S.fromList <$> Remote.keyLocations k

Assistant/TransferSlots.hs

@@ -103,8 +103,8 @@ runTransferThread' program batchmaker d run = go
 {- By the time this is called, the daemonstatus's currentTransfers map should
  - already have been updated to include the transfer. -}
 genTransfer :: Transfer -> TransferInfo -> TransferGenerator
-genTransfer t info = case (transferRemote info, associatedFile info) of
+genTransfer t info = case transferRemote info of
-	(Just remote, Just file) 
+	Just remote 
 		| Git.repoIsLocalUnknown (Remote.repo remote) -> do
 			-- optimisation for removable drives not plugged in
 			liftAnnex $ recordFailedTransfer t info
@@ -114,7 +114,7 @@ genTransfer t info = case (transferRemote info, associatedFile info) of
 			( do
 				debug [ "Transferring:" , describeTransfer t info ]
 				notifyTransfer
-				return $ Just (t, info, go remote file)
+				return $ Just (t, info, go remote)
 			, do
 				debug [ "Skipping unnecessary transfer:",
 					describeTransfer t info ]
@@ -149,10 +149,12 @@ genTransfer t info = case (transferRemote info, associatedFile info) of
 	 - usual cleanup. However, first check if something else is
 	 - running the transfer, to avoid removing active transfers.
 	 -}
-	go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
+	go remote transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
 		( do
-			void $ addAlert $ makeAlertFiller True $
+			maybe noop
-				transferFileAlert direction True file
+				(void . addAlert . makeAlertFiller True 
+					. transferFileAlert direction True)
+				(associatedFile info)
 			unless isdownload $
 				handleDrops
 					("object uploaded to " ++ show remote)
@@ -188,11 +190,11 @@ genTransfer t info = case (transferRemote info, associatedFile info) of
 shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
 shouldTransfer t info
 	| transferDirection t == Download =
-		(not <$> inAnnex key) <&&> wantGet True file
+		(not <$> inAnnex key) <&&> wantGet True (Just key) file
 	| transferDirection t == Upload = case transferRemote info of
 		Nothing -> return False
 		Just r -> notinremote r
-			<&&> wantSend True file (Remote.uuid r)
+			<&&> wantSend True (Just key) file (Remote.uuid r)
 	| otherwise = return False
   where
 	key = transferKey t
@@ -216,7 +218,7 @@ finishedTransfer t (Just info)
 	| transferDirection t == Download =
 		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
 			dodrops False
-			queueTransfersMatching (/= transferUUID t)
+			void $ queueTransfersMatching (/= transferUUID t)
 				"newly received object"
 				Later (transferKey t) (associatedFile info) Upload
 	| otherwise = dodrops True

Assistant/Types/Alert.hs

@@ -32,6 +32,7 @@ data AlertName
 	| SyncAlert
 	| NotFsckedAlert
 	| UpgradeAlert
+	| UnusedFilesAlert
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.

Assistant/Unused.hs

@@ -0,0 +1,86 @@
+{- git-annex assistant unused files
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Unused where
+
+import qualified Data.Map as M
+
+import Assistant.Common
+import qualified Git
+import Types.Key
+import Logs.Unused
+import Logs.Location
+import Annex.Content
+import Utility.DataUnits
+import Utility.DiskFree
+import Utility.HumanTime
+import Utility.Tense
+
+import Data.Time.Clock.POSIX
+import qualified Data.Text as T
+
+describeUnused :: Assistant (Maybe TenseText)
+describeUnused = describeUnused' False
+
+describeUnusedWhenBig :: Assistant (Maybe TenseText)
+describeUnusedWhenBig = describeUnused' True
+
+{- This uses heuristics: 1000 unused keys, or more unused keys 
+ - than the remaining free disk space, or more than 1/10th the total
+ - disk space being unused keys all suggest a problem. -}
+describeUnused' :: Bool -> Assistant (Maybe TenseText)
+describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
+  where
+	go m = do
+		let num = M.size m
+		let diskused = foldl' sumkeysize 0 (M.keys m)
+		df <- forpath getDiskFree
+		disksize <- forpath getDiskSize
+		return $ if num == 0
+			then Nothing
+			else if not whenbig || moreused df diskused || tenthused disksize diskused
+				then Just $ tenseWords
+					[ UnTensed $ T.pack $ roughSize storageUnits False diskused
+					, Tensed "are" "were"
+					, "taken up by unused files"
+					]
+				else if num > 1000
+					then Just $ tenseWords
+						[ UnTensed $ T.pack $ show num ++ " unused files"
+						, Tensed "exist" "existed"
+						]
+					else Nothing
+
+	moreused Nothing _ = False
+	moreused (Just df) used = df <= used
+
+	tenthused Nothing _ = False
+	tenthused (Just disksize) used = used >= disksize `div` 10
+
+	sumkeysize s k = s + fromMaybe 0 (keySize k)
+
+	forpath a = inRepo $ liftIO . a . Git.repoPath
+
+{- With a duration, expires all unused files that are older.
+ - With Nothing, expires *all* unused files. -}
+expireUnused :: Maybe Duration -> Assistant ()
+expireUnused duration = do
+	m <- liftAnnex $ readUnusedLog ""
+	now <- liftIO getPOSIXTime
+	let oldkeys = M.keys $ M.filter (tooold now) m
+	forM_ oldkeys $ \k -> do
+		debug ["removing old unused key", key2file k]
+		liftAnnex $ do
+			removeAnnex k
+			logStatus k InfoMissing
+  where
+	boundry = durationToPOSIXTime <$> duration
+	tooold now (_, mt) = case boundry of
+		Nothing -> True
+		Just b -> maybe False (\t -> now - t >= b) mt

Assistant/Upgrade.hs

@@ -276,7 +276,6 @@ deleteFromManifest dir = do
 
 removeEmptyRecursive :: FilePath -> IO ()
 removeEmptyRecursive dir = do
-	print ("remove", dir)
 	mapM_ removeEmptyRecursive =<< dirContents dir
 	void $ tryIO $ removeDirectory dir
 

Assistant/WebApp/Configurators/Delete.hs

@@ -96,12 +96,11 @@ deleteCurrentRepository = dangerPage $ do
 				rs <- syncRemotes <$> getDaemonStatus
 				mapM_ (\r -> changeSyncable (Just r) False) rs
 
-			{- Make all directories writable, so all annexed
+			{- Make all directories writable and files writable
-			 - content can be deleted. -}
+			 - so all annexed content can be deleted. -}
 			liftIO $ do
-				recurseDir SystemFS dir >>=
+				recurseDir SystemFS dir
-					filterM doesDirectoryExist >>=
+					>>= mapM_ (void . tryIO . allowWrite)
-						mapM_ allowWrite
 				removeDirectoryRecursive dir
 			
 			redirect ShutdownConfirmedR

Assistant/WebApp/Configurators/Edit.hs

@@ -264,6 +264,7 @@ getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
 		liftAnnex $ setConfig 
 			(remoteConfig (Remote.repo rmt) "ignore")
 			(Git.Config.boolConfig False)
-		liftAssistant $ syncRemote rmt
 		liftAnnex $ void Remote.remoteListRefresh
+		liftAssistant updateSyncRemotes
+		liftAssistant $ syncRemote rmt
 		redirect DashboardR

Assistant/WebApp/Configurators/Local.hs

@@ -14,7 +14,7 @@ import Assistant.WebApp.Gpg
 import Assistant.WebApp.MakeRemote
 import Assistant.Sync
 import Assistant.Restart
-import Init
+import Annex.Init
 import qualified Git
 import qualified Git.Construct
 import qualified Git.Config

Assistant/WebApp/Configurators/Preferences.hs

@@ -17,6 +17,7 @@ import qualified Annex
 import qualified Git
 import Config
 import Config.Files
+import Config.NumCopies
 import Utility.DataUnits
 import Git.Config
 import Types.Distribution
@@ -81,7 +82,7 @@ prefsAForm def = PrefsForm
 getPrefs :: Annex PrefsForm
 getPrefs = PrefsForm
 	<$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig)
-	<*> (annexNumCopies <$> Annex.getGitConfig)
+	<*> (fromNumCopies <$> getNumCopies)
 	<*> inAutoStartFile
 	<*> (annexAutoUpgrade <$> Annex.getGitConfig)
 	<*> (annexDebug <$> Annex.getGitConfig)
@@ -89,7 +90,8 @@ getPrefs = PrefsForm
 storePrefs :: PrefsForm -> Annex ()
 storePrefs p = do
 	setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p)
-	setConfig (annexConfig "numcopies") (show $ numCopies p)
+	setGlobalNumCopies (NumCopies $ numCopies p)
+	unsetConfig (annexConfig "numcopies") -- deprecated
 	setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
 	unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
 		here <- fromRepo Git.repoPath

Assistant/WebApp/Configurators/Unused.hs

@@ -0,0 +1,80 @@
+{- git-annex assistant unused file preferences
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.WebApp.Configurators.Unused where
+
+import Assistant.WebApp.Common
+import qualified Annex
+import Utility.HumanTime
+import Assistant.Unused
+import Config
+import Git.Config
+import Logs.Unused
+import Utility.Tense
+
+import qualified Text.Hamlet as Hamlet
+
+data UnusedForm = UnusedForm
+	{ enableExpire :: Bool
+	, expireWhen :: Integer
+	}
+
+unusedForm :: UnusedForm -> Hamlet.Html -> MkMForm UnusedForm
+unusedForm def msg = do
+	(enableRes, enableView) <- mreq (selectFieldList enabledisable) ""
+		(Just $ enableExpire def)
+	(whenRes, whenView) <- mreq intField ""
+		(Just $ expireWhen def)
+	let form = do
+		webAppFormAuthToken
+		$(widgetFile "configurators/unused/form")
+	return (UnusedForm <$> enableRes <*> whenRes, form)
+  where
+	enabledisable :: [(Text, Bool)]
+	enabledisable = [("Disable expiry", False), ("Enable expiry", True)]
+
+getConfigUnusedR :: Handler Html
+getConfigUnusedR = postConfigUnusedR
+postConfigUnusedR :: Handler Html
+postConfigUnusedR = page "Unused files" (Just Configuration) $ do
+	current <- liftAnnex getUnused
+	((res, form), enctype) <- liftH $ runFormPostNoToken $ unusedForm current
+	case res of
+		FormSuccess new -> liftH $ do
+			liftAnnex $ storeUnused new
+			redirect ConfigurationR
+		_ -> do
+			munuseddesc <- liftAssistant describeUnused
+			ts <- liftAnnex $ dateUnusedLog ""
+			mlastchecked <- case ts of
+				Nothing -> pure Nothing
+				Just t -> Just <$> liftIO (durationSince t)
+			$(widgetFile "configurators/unused")
+
+getUnused :: Annex UnusedForm
+getUnused = convert . annexExpireUnused <$> Annex.getGitConfig
+  where
+	convert Nothing = noexpire
+	convert (Just Nothing) = noexpire
+	convert (Just (Just n)) = UnusedForm True $ durationToDays n
+
+	-- The 7 is so that, if they enable expiry, they have to change
+	-- it to get faster than  a week.
+	noexpire = UnusedForm False 7
+
+storeUnused :: UnusedForm -> Annex ()
+storeUnused f = setConfig (annexConfig "expireunused") $
+	if not (enableExpire f) || expireWhen f < 0
+		then boolConfig False
+		else fromDuration $ daysToDuration $ expireWhen f
+
+getCleanupUnusedR :: Handler Html
+getCleanupUnusedR = do
+	liftAssistant $ expireUnused Nothing
+	redirect ConfigUnusedR

Assistant/WebApp/Configurators/XMPP.hs

@@ -161,7 +161,7 @@ buddyListDisplay = do
 #ifdef WITH_XMPP
 
 getXMPPRemotes :: Assistant [(JID, Remote)]
-getXMPPRemotes = catMaybes . map pair . filter isXMPPRemote . syncGitRemotes
+getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes
 	<$> getDaemonStatus
   where
   	pair r = maybe Nothing (\jid -> Just (jid, r)) $

Assistant/WebApp/RepoList.hs

@@ -164,7 +164,7 @@ repoList reposelector
 		| Remote.readonly r = False
 		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r)
 			&& Remote.uuid r /= NoUUID 
-			&& not (isXMPPRemote r)
+			&& not (Remote.isXMPPRemote r)
 		| otherwise = True
 	selectedremote Nothing = False
 	selectedremote (Just (iscloud, _))

Assistant/WebApp/routes

@@ -25,6 +25,7 @@
 /config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
 /config/upgrade/finish ConfigFinishUpgradeR GET
 /config/upgrade/automatically ConfigEnableAutomaticUpgradeR GET
+/config/unused ConfigUnusedR GET POST
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new NewRepositoryR GET POST
@@ -118,4 +119,6 @@
 /repair/#UUID RepairRepositoryR GET POST
 /repair/run/#UUID RepairRepositoryRunR GET POST
 
+/unused/cleanup CleanupUnusedR GET
+
 /static StaticR Static getStatic

Build/EvilLinker.hs

@@ -125,8 +125,8 @@ getOutput c ps environ = do
 	putStrLn $ unwords [c, show ps]
 	systemenviron <- getEnvironment
 	let environ' = fromMaybe [] environ ++ systemenviron
-	out@(s, ok) <- processTranscript' c ps (Just environ') Nothing
+	out@(_, ok) <- processTranscript' c ps (Just environ') Nothing
-	putStrLn $ unwords [c, "finished", show ok, "output size:", show (length s)]
+	putStrLn $ unwords [c, "finished", show ok]
 	return out
 
 atFile :: FilePath -> String

Build/LinuxMkLibs.hs

@@ -141,4 +141,4 @@ parseLdd = catMaybes . map (getlib . dropWhile isSpace) . lines
  - XXX Debian specific. -}
 glibcLibs :: IO [FilePath]
 glibcLibs = lines <$> readProcess "sh"
-	["-c", "dpkg -L libc6 libgcc1 | egrep '\\.so|gconv'"]
+	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]

Checks.hs

@@ -12,7 +12,7 @@ module Checks where
 
 import Common.Annex
 import Types.Command
-import Init
+import Annex.Init
 import Config
 import Utility.Daemon
 import qualified Git

CmdLine.hs

@@ -23,7 +23,6 @@ import System.Posix.Signals
 
 import Common.Annex
 import qualified Annex
-import qualified Annex.Queue
 import qualified Git
 import qualified Git.AutoCorrect
 import Annex.Content
@@ -41,7 +40,7 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
 		Left e -> maybe (throw e) (\a -> a params) (cmdnorepo cmd)
 		Right g -> do
 			state <- Annex.new g
-			(actions, state') <- Annex.run state $ do
+			Annex.eval state $ do
 				checkEnvironment
 				checkfuzzy
 				forM_ fields $ uncurry Annex.setField
@@ -50,8 +49,9 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
 				sequence_ flags
 				whenM (annexDebug <$> Annex.getGitConfig) $
 					liftIO enableDebugOutput
-				prepCommand cmd params
+				startup
-		 	tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd]
+				performCommandAction cmd params
+				shutdown $ cmdnocommit cmd
   where
 	err msg = msg ++ "\n\n" ++ usage header allcmds
 	cmd = Prelude.head cmds
@@ -92,44 +92,19 @@ getOptCmd argv cmd commonoptions = check $
 		, commandUsage cmd
 		]
 
-{- Runs a list of Annex actions. Catches IO errors and continues
- - (but explicitly thrown errors terminate the whole command).
- -}
-tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
-tryRun = tryRun' 0
-tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
-tryRun' errnum _ cmd []
-	| errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
-	| otherwise = noop
-tryRun' errnum state cmd (a:as) = do
-	r <- run
-	handle $! r
-  where
-	run = tryIO $ Annex.run state $ do
-		Annex.Queue.flushWhenFull
-		a
-	handle (Left err) = showerr err >> cont False state
-	handle (Right (success, state')) = cont success state'
-	cont success s = do
-		let errnum' = if success then errnum else errnum + 1
-		(tryRun' $! errnum') s cmd as
-	showerr err = Annex.eval state $ do
-		showErr err
-		showEndFail
-
 {- Actions to perform each time ran. -}
-startup :: Annex Bool
+startup :: Annex ()
-startup = liftIO $ do
+startup =
 #ifndef mingw32_HOST_OS
-	void $ installHandler sigINT Default Nothing
+	liftIO $ void $ installHandler sigINT Default Nothing
+#else
+	return ()
 #endif
-	return True
 
 {- Cleanup actions. -}
-shutdown :: Bool -> Annex Bool
+shutdown :: Bool -> Annex ()
 shutdown nocommit = do
 	saveState nocommit
 	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
 	liftIO reapZombies -- zombies from long-running git processes
 	sshCleanup -- ssh connection caching
-	return True

CmdLine/Action.hs

@@ -0,0 +1,70 @@
+{- git-annex command-line actions
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module CmdLine.Action where
+
+import Common.Annex
+import qualified Annex
+import Types.Command
+import qualified Annex.Queue
+import Annex.Exception
+
+type CommandActionRunner = CommandStart -> CommandCleanup
+
+{- Runs a command, starting with the check stage, and then
+ - the seek stage. Finishes by printing the number of commandActions that
+ - failed. -}
+performCommandAction :: Command -> CmdParams -> Annex ()
+performCommandAction Command { cmdseek = seek, cmdcheck = c, cmdname = name } params = do
+	mapM_ runCheck c
+	Annex.changeState $ \s -> s { Annex.errcounter = 0 }
+	seek params
+	showerrcount =<< Annex.getState Annex.errcounter
+  where
+	showerrcount 0 = noop
+	showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed"
+
+{- Runs one of the actions needed to perform a command.
+ - Individual actions can fail without stopping the whole command,
+ - including by throwing IO errors (but other errors terminate the whole
+ - command).
+ - 
+ - This should only be run in the seek stage. -}
+commandAction :: CommandActionRunner
+commandAction a = handle =<< tryAnnexIO go
+  where
+	go = do
+		Annex.Queue.flushWhenFull
+		callCommandAction a
+	handle (Right True) = return True
+	handle (Right False) = incerr
+	handle (Left err) = do
+		showErr err
+		showEndFail
+		incerr
+	incerr = do
+		Annex.changeState $ \s -> 
+			let ! c = Annex.errcounter s + 1 
+			    ! s' = s { Annex.errcounter = c }
+			in s'
+		return False
+
+{- Runs a single command action through the start, perform and cleanup
+ - stages, without catching errors. Useful if one command wants to run
+ - part of another command. -}
+callCommandAction :: CommandActionRunner
+callCommandAction = start
+  where
+	start   = stage $ maybe skip perform
+	perform = stage $ maybe failure cleanup
+	cleanup = stage $ status
+	stage = (=<<)
+	skip = return True
+	failure = showEndFail >> return False
+	status r = showEndResult r >> return r

CmdLine/GitAnnex.hs

@@ -7,12 +7,11 @@
 
 {-# LANGUAGE CPP, OverloadedStrings #-}
 
-module GitAnnex where
+module CmdLine.GitAnnex where
 
 import qualified Git.CurrentRepo
 import CmdLine
 import Command
-import GitAnnex.Options
 
 import qualified Command.Add
 import qualified Command.Unannex
@@ -50,6 +49,7 @@ import qualified Command.Info
 import qualified Command.Status
 import qualified Command.Migrate
 import qualified Command.Uninit
+import qualified Command.NumCopies
 import qualified Command.Trust
 import qualified Command.Untrust
 import qualified Command.Semitrust
@@ -117,6 +117,7 @@ cmds = concat
 	, Command.Unannex.def
 	, Command.Uninit.def
 	, Command.PreCommit.def
+	, Command.NumCopies.def
 	, Command.Trust.def
 	, Command.Untrust.def
 	, Command.Semitrust.def
@@ -178,4 +179,4 @@ run args = do
 #ifdef WITH_EKG
 	_ <- forkServer "localhost" 4242
 #endif
-	dispatch True args cmds options [] header Git.CurrentRepo.get
+	dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get

CmdLine/GitAnnex/Options.hs

@@ -5,23 +5,25 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module GitAnnex.Options where
+module CmdLine.GitAnnex.Options where
 
 import System.Console.GetOpt
 
 import Common.Annex
 import qualified Git.Config
 import Git.Types
-import Command
 import Types.TrustLevel
+import Types.NumCopies
+import Types.Messages
 import qualified Annex
 import qualified Remote
 import qualified Limit
 import qualified Limit.Wanted
-import qualified Option
+import CmdLine.Option
+import CmdLine.Usage
 
-options :: [Option]
+gitAnnexOptions :: [Option]
-options = Option.common ++
+gitAnnexOptions = commonOptions ++
 	[ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber)
 		"override default number of copies"
 	, Option [] ["trust"] (trustArg Trusted)
@@ -40,6 +42,10 @@ options = Option.common ++
 		"match files present in a remote"
 	, Option ['C'] ["copies"] (ReqArg Limit.addCopies paramNumber)
 		"skip files with fewer copies"
+	, Option [] ["lackingcopies"] (ReqArg (Limit.addLackingCopies False) paramNumber)
+		"match files that need more copies"
+	, Option [] ["approxlackingcopies"] (ReqArg (Limit.addLackingCopies True) paramNumber)
+		"match files that need more copies (faster)"
 	, Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName)
 		"match files using a key-value backend"
 	, Option [] ["inallgroup"] (ReqArg Limit.addInAllGroup paramGroup)
@@ -58,11 +64,11 @@ options = Option.common ++
 		"override default User-Agent"
 	, Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier"))
 		"Trust Amazon Glacier inventory"
-	] ++ Option.matcher
+	] ++ matcherOptions
   where
 	trustArg t = ReqArg (Remote.forceTrust t) paramRemote
 	setnumcopies v = maybe noop
-		(\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just n })
+		(\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n })
 		(readish v)
 	setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v }
 	setgitconfig v = inRepo (Git.Config.store v)
@@ -75,13 +81,19 @@ keyOptions =
 		"operate on all versions of all files"
 	, Option ['U'] ["unused"] (NoArg (Annex.setFlag "unused"))
 		"operate on files found by last run of git-annex unused"
+	, Option [] ["key"] (ReqArg (Annex.setField "key") paramKey)
+		"operate on specified key"
 	]
 
 fromOption :: Option
-fromOption = Option.field ['f'] "from" paramRemote "source remote"
+fromOption = fieldOption ['f'] "from" paramRemote "source remote"
 
 toOption :: Option
-toOption = Option.field ['t'] "to" paramRemote "destination remote"
+toOption = fieldOption ['t'] "to" paramRemote "destination remote"
 
 fromToOptions :: [Option]
 fromToOptions = [fromOption, toOption]
+
+jsonOption :: Option
+jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
+	"enable JSON output"

CmdLine/GitAnnexShell.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module GitAnnexShell where
+module CmdLine.GitAnnexShell where
 
 import System.Environment
 import System.Console.GetOpt
@@ -16,12 +16,11 @@ import CmdLine
 import Command
 import Annex.UUID
 import Annex (setField)
-import qualified Option
+import CmdLine.GitAnnexShell.Fields
-import Fields
 import Utility.UserInfo
 import Remote.GCrypt (getGCryptUUID)
 import qualified Annex
-import Init
+import Annex.Init
 
 import qualified Command.ConfigList
 import qualified Command.InAnnex
@@ -54,7 +53,7 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
 	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
 
 options :: [OptDescr (Annex ())]
-options = Option.common ++
+options = commonOptions ++
 	[ Option [] ["uuid"] (ReqArg checkUUID paramUUID) "local repository uuid"
 	]
   where
@@ -104,7 +103,7 @@ builtin cmd dir params = do
 		Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
   where
 	addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k
-	newcmd opts c = c { cmdseek = map (addrsyncopts opts) (cmdseek c) }
+	newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) }
 
 external :: [String] -> IO ()
 external params = do

CmdLine/GitAnnexShell/Fields.hs

@@ -1,14 +1,15 @@
-{- git-annex fields
+{- git-annex-shell fields
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Fields where
+module CmdLine.GitAnnexShell.Fields where
 
 import Common.Annex
 import qualified Annex
+import Git.FilePath
 
 import Data.Char
 
@@ -29,7 +30,7 @@ remoteUUID = Field "remoteuuid" $
 associatedFile :: Field
 associatedFile = Field "associatedfile" $ \f ->
 	-- is the file a safe relative filename?
-	not (isAbsolute f) && not ("../" `isPrefixOf` f)
+	not (absoluteGitPath f) && not ("../" `isPrefixOf` f)
 
 direct :: Field
 direct = Field "direct" $ \f -> f == "1"

CmdLine/Option.hs

@@ -5,12 +5,12 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Option (
+module CmdLine.Option (
-	common,
+	commonOptions,
-	matcher,
+	matcherOptions,
-	flag,
+	flagOption,
-	field,
+	fieldOption,
-	name,
+	optionName,
 	ArgDescr(..),
 	OptDescr(..),
 ) where
@@ -21,10 +21,10 @@ import Common.Annex
 import qualified Annex
 import Types.Messages
 import Limit
-import Usage
+import CmdLine.Usage
 
-common :: [Option]
+commonOptions :: [Option]
-common =
+commonOptions =
 	[ Option [] ["force"] (NoArg (setforce True))
 		"allow actions that may lose annexed data"
 	, Option ['F'] ["fast"] (NoArg (setfast True))
@@ -35,8 +35,6 @@ common =
 		"avoid verbose output"
 	, Option ['v'] ["verbose"] (NoArg (Annex.setOutput NormalOutput))
 		"allow verbose output (default)"
-	, Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
-		"enable JSON output"
 	, Option ['d'] ["debug"] (NoArg setdebug)
 		"show debug messages"
 	, Option [] ["no-debug"] (NoArg unsetdebug)
@@ -52,8 +50,8 @@ common =
 	setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True }
 	unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False }
 
-matcher :: [Option]
+matcherOptions :: [Option]
-matcher =
+matcherOptions =
 	[ longopt "not" "negate next option"
 	, longopt "and" "both previous and next option must match"
 	, longopt "or" "either previous or next option must match"
@@ -65,15 +63,15 @@ matcher =
 	shortopt o = Option o [] $ NoArg $ addToken o
 
 {- An option that sets a flag. -}
-flag :: String -> String -> String -> Option
+flagOption :: String -> String -> String -> Option
-flag short opt description = 
+flagOption short opt description = 
 	Option short [opt] (NoArg (Annex.setFlag opt)) description
 
 {- An option that sets a field. -}
-field :: String -> String -> String -> String -> Option
+fieldOption :: String -> String -> String -> String -> Option
-field short opt paramdesc description = 
+fieldOption short opt paramdesc description = 
 	Option short [opt] (ReqArg (Annex.setField opt) paramdesc) description
 
 {- The flag or field name used for an option. -}
-name :: Option -> String
+optionName :: Option -> String
-name (Option _ o _ _) = Prelude.head o
+optionName (Option _ o _ _) = Prelude.head o

CmdLine/Seek.hs

@@ -4,14 +4,12 @@
  - the values a user passes to a command, and prepare actions operating
  - on them.
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Seek where
+module CmdLine.Seek where
-
-import System.PosixCompat.Files
 
 import Common.Annex
 import Types.Command
@@ -22,24 +20,15 @@ import qualified Git
 import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
 import qualified Limit
-import qualified Option
+import CmdLine.Option
-import Config
+import CmdLine.Action
 import Logs.Location
 import Logs.Unused
 import Annex.CatFile
 
-seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
-seekHelper a params = do
-	ll <- inRepo $ \g ->
-		runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params
-	{- Show warnings only for files/directories that do not exist. -}
-	forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
-		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
-			fileNotFound p
-	return $ concat ll
-
 withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
-withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params
+withFilesInGit a params = seekActions $ prepFiltered a $
+	seekHelper LsFiles.inRepo params
 
 withFilesNotInGit :: (FilePath -> CommandStart) -> CommandSeek
 withFilesNotInGit a params = do
@@ -47,7 +36,8 @@ withFilesNotInGit a params = do
 	files <- filter (not . dotfile) <$>
 		seekunless (null ps && not (null params)) ps
 	dotfiles <- seekunless (null dotps) dotps
-	prepFiltered a $ return $ concat $ segmentPaths params (files++dotfiles)
+	seekActions $ prepFiltered a $
+		return $ concat $ segmentPaths params (files++dotfiles)
   where
 	(dotps, ps) = partition dotfile params
 	seekunless True _ = return []
@@ -57,7 +47,8 @@ withFilesNotInGit a params = do
 		liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g
 
 withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
-withPathContents a params = map a . concat <$> liftIO (mapM get params)
+withPathContents a params = seekActions $ 
+	map a . concat <$> liftIO (mapM get params)
   where
 	get p = ifM (isDirectory <$> getFileStatus p)
 		( map (\f -> (f, makeRelative (parentDir p) f))
@@ -66,20 +57,20 @@ withPathContents a params = map a . concat <$> liftIO (mapM get params)
 		)
 
 withWords :: ([String] -> CommandStart) -> CommandSeek
-withWords a params = return [a params]
+withWords a params = seekActions $ return [a params]
 
 withStrings :: (String -> CommandStart) -> CommandSeek
-withStrings a params = return $ map a params
+withStrings a params = seekActions $ return $ map a params
 
 withPairs :: ((String, String) -> CommandStart) -> CommandSeek
-withPairs a params = return $ map a $ pairs [] params
+withPairs a params = seekActions $ return $ map a $ pairs [] params
   where
 	pairs c [] = reverse c
 	pairs c (x:y:xs) = pairs ((x,y):c) xs
 	pairs _ _ = error "expected pairs"
 
 withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
-withFilesToBeCommitted a params = prepFiltered a $
+withFilesToBeCommitted a params = seekActions $ prepFiltered a $
 	seekHelper LsFiles.stagedNotDeleted params
 
 withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek
@@ -94,7 +85,8 @@ withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
  - not some other sort of symlink.
  -}
 withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek
-withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles
+withFilesUnlocked' typechanged a params = seekActions $
+	prepFiltered a unlockedfiles
   where
   	check f = liftIO (notSymlink f) <&&> 
 		(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
@@ -102,32 +94,25 @@ withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles
 
 {- Finds files that may be modified. -}
 withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek
-withFilesMaybeModified a params =
+withFilesMaybeModified a params = seekActions $
 	prepFiltered a $ seekHelper LsFiles.modified params
 
 withKeys :: (Key -> CommandStart) -> CommandSeek
-withKeys a params = return $ map (a . parse) params
+withKeys a params = seekActions $ return $ map (a . parse) params
   where
 	parse p = fromMaybe (error "bad key") $ file2key p
 
-withValue :: Annex v -> (v -> CommandSeek) -> CommandSeek
+{- Gets the value of a field options, which is fed into
-withValue v a params = do
+ - a conversion function.
-	r <- v
-	a r params
-
-{- Modifies a seek action using the value of a field option, which is fed into
- - a conversion function, and then is passed into the seek action.
- - This ensures that the conversion function only runs once.
  -}
-withField :: Option -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek
+getOptionField :: Option -> (Maybe String -> Annex a) -> Annex a
-withField option converter = withValue $
+getOptionField option converter = converter <=< Annex.getField $ optionName option
-	converter <=< Annex.getField $ Option.name option
 
-withFlag :: Option -> (Bool -> CommandSeek) -> CommandSeek
+getOptionFlag :: Option -> Annex Bool
-withFlag option = withValue $ Annex.getFlag (Option.name option)
+getOptionFlag option = Annex.getFlag (optionName option)
 
 withNothing :: CommandStart -> CommandSeek
-withNothing a [] = return [a]
+withNothing a [] = seekActions $ return [a]
 withNothing _ _ = error "This command takes no parameters."
 
 {- If --all is specified, or in a bare repo, runs an action on all
@@ -136,6 +121,8 @@ withNothing _ _ = error "This command takes no parameters."
  - If --unused is specified, runs an action on all keys found by
  - the last git annex unused scan.
  -
+ - If --key is specified, operates only on that key.
+ -
  - Otherwise, fall back to a regular CommandSeek action on
  - whatever params were passed. -}
 withKeyOptions :: (Key -> CommandStart) -> CommandSeek -> CommandSeek
@@ -143,36 +130,51 @@ withKeyOptions keyop fallbackop params = do
 	bare <- fromRepo Git.repoIsLocalBare
 	allkeys <- Annex.getFlag "all"
 	unused <- Annex.getFlag "unused"
+	specifickey <- Annex.getField "key"
 	auto <- Annex.getState Annex.auto
-	case    (allkeys || bare , unused, auto ) of
+	when (auto && bare) $
-		(True    , False , False) -> go loggedKeys
+		error "Cannot use --auto in a bare repository"
-		(False   , True  , False) -> go unusedKeys
+	case	(allkeys, unused, null params, specifickey) of
-		(True    , True  , _    )
+		(False  , False , True       , Nothing)
-			| bare && not allkeys -> go unusedKeys
+			| bare -> go auto loggedKeys
-			| otherwise -> error "Cannot use --all with --unused."
+			| otherwise -> fallbackop params
-		(False   , False , _    ) -> fallbackop params
+		(False  , False , _          , Nothing) -> fallbackop params
-		(_       , _     , True )
+		(True   , False , True       , Nothing) -> go auto loggedKeys
-			| bare -> error "Cannot use --auto in a bare repository."
+		(False  , True  , True       , Nothing) -> go auto unusedKeys'
-			| otherwise -> error "Cannot use --auto with --all or --unused."
+		(False  , False , True       , Just ks) -> case file2key ks of
+			Nothing -> error "Invalid key"
+			Just k -> go auto $ return [k]
+		_ -> error "Can only specify one of file names, --all, --unused, or --key"
   where
-  	go a = do
+  	go True _ = error "Cannot use --auto with --all or --unused or --key"
-		unless (null params) $
+	go False a = do
-			error "Cannot mix --all or --unused with file names."
+		matcher <- Limit.getMatcher
-		map keyop <$> a
+		seekActions $ map (process matcher) <$> a
+	process matcher k = ifM (matcher $ MatchingKey k)
+		( keyop k , return Nothing)
 
 prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart]
 prepFiltered a fs = do
 	matcher <- Limit.getMatcher
 	map (process matcher) <$> fs
   where
-	process matcher f = ifM (matcher $ FileInfo f f)
+	process matcher f = ifM (matcher $ MatchingFile $ FileInfo f f)
 		( a f , return Nothing )
 
+seekActions :: Annex [CommandStart] -> Annex ()
+seekActions gen = do
+	as <- gen
+	mapM_ commandAction as
+
+seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
+seekHelper a params = do
+	ll <- inRepo $ \g ->
+		runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params
+	{- Show warnings only for files/directories that do not exist. -}
+	forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
+		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
+			fileNotFound p
+	return $ concat ll
+
 notSymlink :: FilePath -> IO Bool
 notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
-
-whenNotDirect :: CommandSeek -> CommandSeek
-whenNotDirect a params = ifM isDirect ( return [] , a params )
-
-whenDirect :: CommandSeek -> CommandSeek
-whenDirect a params = ifM isDirect ( a params, return [] )

CmdLine/Usage.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Usage where
+module CmdLine.Usage where
 
 import Common.Annex
 

Command.hs

@@ -1,10 +1,12 @@
 {- git-annex command infrastructure
  -
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE BangPatterns #-}
+
 module Command (
 	command,
 	noRepo,
@@ -14,13 +16,9 @@ module Command (
 	next,
 	stop,
 	stopUnless,
-	prepCommand,
-	doCommand,
 	whenAnnexed,
 	ifAnnexed,
 	isBareRepo,
-	numCopies,
-	numCopiesCheck,
 	checkAuto,
 	module ReExported
 ) where
@@ -29,18 +27,17 @@ import Common.Annex
 import qualified Backend
 import qualified Annex
 import qualified Git
-import qualified Remote
 import Types.Command as ReExported
 import Types.Option as ReExported
-import Seek as ReExported
+import CmdLine.Seek as ReExported
 import Checks as ReExported
-import Usage as ReExported
+import CmdLine.Usage as ReExported
-import Logs.Trust
+import CmdLine.Action as ReExported
-import Config
+import CmdLine.Option as ReExported
-import Annex.CheckAttr
+import CmdLine.GitAnnex.Options as ReExported
 
 {- Generates a normal command -}
-command :: String -> String -> [CommandSeek] -> CommandSection -> String -> Command
+command :: String -> String -> CommandSeek -> CommandSection -> String -> Command
 command = Command [] Nothing commonChecks False False
 
 {- Indicates that a command doesn't need to commit any changes to
@@ -74,25 +71,6 @@ stop = return Nothing
 stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
 stopUnless c a = ifM c ( a , stop )
 
-{- Prepares to run a command via the check and seek stages, returning a
- - list of actions to perform to run the command. -}
-prepCommand :: Command -> [String] -> Annex [CommandCleanup]
-prepCommand Command { cmdseek = seek, cmdcheck = c } params = do
-	mapM_ runCheck c
-	map doCommand . concat <$> mapM (\s -> s params) seek
-
-{- Runs a command through the start, perform and cleanup stages -}
-doCommand :: CommandStart -> CommandCleanup
-doCommand = start
-  where
-	start   = stage $ maybe skip perform
-	perform = stage $ maybe failure cleanup
-	cleanup = stage $ status
-	stage = (=<<)
-	skip = return True
-	failure = showEndFail >> return False
-	status r = showEndResult r >> return r
-
 {- Modifies an action to only act on files that are already annexed,
  - and passes the key and backend on to it. -}
 whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
@@ -104,20 +82,6 @@ ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file
 isBareRepo :: Annex Bool
 isBareRepo = fromRepo Git.repoIsLocalBare
 
-numCopies :: FilePath  -> Annex (Maybe Int)
-numCopies file = do
-	forced <- Annex.getState Annex.forcenumcopies
-	case forced of
-		Just n -> return $ Just n
-		Nothing -> readish <$> checkAttr "annex.numcopies" file
-
-numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v
-numCopiesCheck file key vs = do
-	numcopiesattr <- numCopies file
-	needed <- getNumCopies numcopiesattr
-	have <- trustExclude UnTrusted =<< Remote.keyLocations key
-	return $ length have `vs` needed
-
 checkAuto :: Annex Bool -> Annex Bool
 checkAuto checker = ifM (Annex.getState Annex.auto)
 	( checker , return True )

Command/Add.hs

@@ -9,8 +9,6 @@
 
 module Command.Add where
 
-import System.PosixCompat.Files
-
 import Common.Annex
 import Annex.Exception
 import Command
@@ -41,18 +39,18 @@ def = [notBareRepo $ command "add" paramPaths seek SectionCommon
 {- Add acts on both files not checked into git yet, and unlocked files.
  -
  - In direct mode, it acts on any files that have changed. -}
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ go withFilesNotInGit
+	matcher <- largeFilesMatcher
-	, whenNotDirect $ go withFilesUnlocked
+	let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
-	, whenDirect $ go withFilesMaybeModified
-	]
-  where
-  	go a = withValue largeFilesMatcher $ \matcher ->
-		a $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
 		( start file
 		, stop
 		)
+	go withFilesNotInGit
+	ifM isDirect
+		( go withFilesMaybeModified
+		, go withFilesUnlocked
+		)
 
 {- The add subcommand annexes a file, generating a key for it using a
  - backend, and then moving it into the annex directory and setting up

Command/AddUnused.hs

@@ -18,8 +18,8 @@ def :: [Command]
 def = [notDirect $ command "addunused" (paramRepeating paramNumRange)
 	seek SectionMaintenance "add back unused files"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withUnusedMaps start]
+seek = withUnusedMaps start
 
 start :: UnusedMaps -> Int -> CommandStart
 start = startUnused "addunused" perform

Command/AddUrl.hs

@@ -21,7 +21,6 @@ import qualified Annex.Url as Url
 import qualified Backend.URL
 import Annex.Content
 import Logs.Web
-import qualified Option
 import Types.Key
 import Types.KeySource
 import Config
@@ -39,19 +38,20 @@ def = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $
 		SectionCommon "add urls to annex"]
 
 fileOption :: Option
-fileOption = Option.field [] "file" paramFile "specify what file the url is added to"
+fileOption = fieldOption [] "file" paramFile "specify what file the url is added to"
 
 pathdepthOption :: Option
-pathdepthOption = Option.field [] "pathdepth" paramNumber "path components to use in filename"
+pathdepthOption = fieldOption [] "pathdepth" paramNumber "path components to use in filename"
 
 relaxedOption :: Option
-relaxedOption = Option.flag [] "relaxed" "skip size check"
+relaxedOption = flagOption [] "relaxed" "skip size check"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField fileOption return $ \f ->
+seek ps = do
-	withFlag relaxedOption $ \relaxed ->
+	f <- getOptionField fileOption return
-	withField pathdepthOption (return . maybe Nothing readish) $ \d ->
+	relaxed <- getOptionFlag relaxedOption
-	withStrings $ start relaxed f d]
+	d <- getOptionField pathdepthOption (return . maybe Nothing readish)
+	withStrings (start relaxed f d) ps
 
 start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
 start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s

Command/Assistant.hs

@@ -9,9 +9,8 @@ module Command.Assistant where
 
 import Common.Annex
 import Command
-import qualified Option
 import qualified Command.Watch
-import Init
+import Annex.Init
 import Config.Files
 import qualified Build.SysConfig
 import Utility.HumanTime
@@ -32,17 +31,18 @@ options =
 	]
 
 autoStartOption :: Option
-autoStartOption = Option.flag [] "autostart" "start in known repositories"
+autoStartOption = flagOption [] "autostart" "start in known repositories"
 
 startDelayOption :: Option
-startDelayOption = Option.field [] "startdelay" paramNumber "delay before running startup scan"
+startDelayOption = fieldOption [] "startdelay" paramNumber "delay before running startup scan"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFlag Command.Watch.stopOption $ \stopdaemon ->
+seek ps = do
-	withFlag Command.Watch.foregroundOption $ \foreground ->
+	stopdaemon <- getOptionFlag Command.Watch.stopOption
-	withFlag autoStartOption $ \autostart ->
+	foreground <- getOptionFlag Command.Watch.foregroundOption
-	withField startDelayOption (pure . maybe Nothing parseDuration) $ \startdelay -> 
+	autostart <- getOptionFlag autoStartOption
-	withNothing $ start foreground stopdaemon autostart startdelay]
+	startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration)
+	withNothing (start foreground stopdaemon autostart startdelay) ps
 
 start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
 start foreground stopdaemon autostart startdelay

Command/Commit.hs

@@ -16,8 +16,8 @@ def :: [Command]
 def = [command "commit" paramNothing seek
 	SectionPlumbing "commits any staged changes to the git-annex branch"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = next $ next $ do

Command/ConfigList.hs

@@ -17,8 +17,8 @@ def :: [Command]
 def = [noCommit $ command "configlist" paramNothing seek
 	SectionPlumbing "outputs relevant git configuration"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/Copy.hs

@@ -9,22 +9,23 @@ module Command.Copy where
 
 import Common.Annex
 import Command
-import GitAnnex.Options
 import qualified Command.Move
 import qualified Remote
 import Annex.Wanted
+import Config.NumCopies
 
 def :: [Command]
 def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek
 	SectionCommon "copy content of files to/from another repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withField toOption Remote.byNameWithUUID $ \to ->
+	to <- getOptionField toOption Remote.byNameWithUUID
-	  withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (Command.Move.startKey to from False) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start to from
+	 	(Command.Move.startKey to from False)
-	]
+		(withFilesInGit $ whenAnnexed $ start to from)
+		ps
 
 {- A copy is just a move that does not delete the source file.
  - However, --auto mode avoids unnecessary copies, and avoids getting or
@@ -35,5 +36,5 @@ start to from file (key, backend) = stopUnless shouldCopy $
   where
 	shouldCopy = checkAuto (check <||> numCopiesCheck file key (<))
 	check = case to of
-		Nothing -> wantGet False (Just file)
+		Nothing -> wantGet False (Just key) (Just file)
-		Just r -> wantSend False (Just file) (Remote.uuid r)
+		Just r -> wantSend False (Just key) (Just file) (Remote.uuid r)

Command/Dead.hs

@@ -19,8 +19,8 @@ def :: [Command]
 def = [command "dead" (paramRepeating paramRemote) seek
 	SectionSetup "hide a lost repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start ws = do

Command/Describe.hs

@@ -16,8 +16,8 @@ def :: [Command]
 def = [command "describe" (paramPair paramRemote paramDesc) seek
 	SectionSetup "change description of a repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start (name:description) = do

Command/Direct.hs

@@ -23,8 +23,8 @@ def = [notBareRepo $ noDaemonRunning $
 	command "direct" paramNothing seek
 		SectionSetup "switch repository to direct mode"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = ifM isDirect ( stop , next perform )

Command/Drop.hs

@@ -14,26 +14,25 @@ import qualified Annex
 import Annex.UUID
 import Logs.Location
 import Logs.Trust
+import Config.NumCopies
 import Annex.Content
-import Config
-import qualified Option
 import Annex.Wanted
-import Types.Key
 
 def :: [Command]
-def = [withOptions [fromOption] $ command "drop" paramPaths seek
+def = [withOptions [dropFromOption] $ command "drop" paramPaths seek
 	SectionCommon "indicate content of files not currently wanted"]
 
-fromOption :: Option
+dropFromOption :: Option
-fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote"
+dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField fromOption Remote.byNameWithUUID $ \from ->
+seek ps = do
-	withFilesInGit $ whenAnnexed $ start from]
+	from <- getOptionField dropFromOption Remote.byNameWithUUID
+	withFilesInGit (whenAnnexed $ start from) ps
 
 start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
 start from file (key, _) = checkDropAuto from file key $ \numcopies ->
-	stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just file)) $
+	stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just key) (Just file)) $
 		case from of
 			Nothing -> startLocal (Just file) numcopies key Nothing
 			Just remote -> do
@@ -42,17 +41,17 @@ start from file (key, _) = checkDropAuto from file key $ \numcopies ->
 					then startLocal (Just file) numcopies key Nothing
 					else startRemote (Just file) numcopies key remote
 
-startLocal :: AssociatedFile -> Maybe Int -> Key -> Maybe Remote -> CommandStart
+startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart
 startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do
-	showStart "drop" (fromMaybe (key2file key) afile)
+	showStart' "drop" key afile
 	next $ performLocal key numcopies knownpresentremote
 
-startRemote :: AssociatedFile -> Maybe Int -> Key -> Remote -> CommandStart
+startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart
 startRemote afile numcopies key remote = do
-	showStart ("drop " ++ Remote.name remote) (fromMaybe (key2file key) afile)
+	showStart' ("drop " ++ Remote.name remote) key afile
 	next $ performRemote key numcopies remote
 
-performLocal :: Key -> Maybe Int -> Maybe Remote -> CommandPerform
+performLocal :: Key -> NumCopies -> Maybe Remote -> CommandPerform
 performLocal key numcopies knownpresentremote = lockContent key $ do
 	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
 	let trusteduuids' = case knownpresentremote of
@@ -64,7 +63,7 @@ performLocal key numcopies knownpresentremote = lockContent key $ do
 		removeAnnex key
 		next $ cleanupLocal key
 
-performRemote :: Key -> Maybe Int -> Remote -> CommandPerform
+performRemote :: Key -> NumCopies -> Remote -> CommandPerform
 performRemote key numcopies remote = lockContent key $ do
 	-- Filter the remote it's being dropped from out of the lists of
 	-- places assumed to have the key, and places to check.
@@ -97,23 +96,21 @@ cleanupRemote key remote ok = do
 {- Checks specified remotes to verify that enough copies of a key exist to
  - allow it to be safely removed (with no data loss). Can be provided with
  - some locations where the key is known/assumed to be present. -}
-canDropKey :: Key -> Maybe Int -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
+canDropKey :: Key -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
-canDropKey key numcopiesM have check skip = do
+canDropKey key numcopies have check skip = do
 	force <- Annex.getState Annex.force
-	if force || numcopiesM == Just 0
+	if force || numcopies == NumCopies 0
 		then return True
-		else do
+		else findCopies key numcopies skip have check
-			need <- getNumCopies numcopiesM
-			findCopies key need skip have check
 
-findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
+findCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
 findCopies key need skip = helper [] []
   where
 	helper bad missing have []
-		| length have >= need = return True
+		| NumCopies (length have) >= need = return True
 		| otherwise = notEnoughCopies key need have (skip++missing) bad
 	helper bad missing have (r:rs)
-		| length have >= need = return True
+		| NumCopies (length have) >= need = return True
 		| otherwise = do
 			let u = Remote.uuid r
 			let duplicate = u `elem` have
@@ -124,12 +121,12 @@ findCopies key need skip = helper [] []
 				(False, Right False) -> helper bad (u:missing) have rs
 				_                    -> helper bad missing have rs
 
-notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
+notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
 notEnoughCopies key need have skip bad = do
 	unsafe
 	showLongNote $
 		"Could only verify the existence of " ++
-		show (length have) ++ " out of " ++ show need ++ 
+		show (length have) ++ " out of " ++ show (fromNumCopies need) ++ 
 		" necessary copies"
 	Remote.showTriedRemotes bad
 	Remote.showLocations key (have++skip)
@@ -138,25 +135,21 @@ notEnoughCopies key need have skip bad = do
 	return False
   where
 	unsafe = showNote "unsafe"
-	hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"
+	hint = showLongNote "(Use --force to override this check, or adjust numcopies.)"
 
 {- In auto mode, only runs the action if there are enough
- - copies on other semitrusted repositories.
+ - copies on other semitrusted repositories. -}
- -
+checkDropAuto :: Maybe Remote -> FilePath -> Key -> (NumCopies -> CommandStart) -> CommandStart
- - Passes any numcopies attribute of the file on to the action as an
- - optimisation. -}
-checkDropAuto :: Maybe Remote -> FilePath -> Key -> (Maybe Int -> CommandStart) -> CommandStart
 checkDropAuto mremote file key a = do
-	numcopiesattr <- numCopies file
+	numcopies <- getFileNumCopies file
-	Annex.getState Annex.auto >>= auto numcopiesattr
+	Annex.getState Annex.auto >>= auto numcopies
   where
-	auto numcopiesattr False = a numcopiesattr
+	auto numcopies False = a numcopies
-	auto numcopiesattr True = do
+	auto numcopies True = do
-		needed <- getNumCopies numcopiesattr
 		locs <- Remote.keyLocations key
 		uuid <- getUUID
 		let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote
 		locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs
-		if length locs' >= needed
+		if NumCopies (length locs') >= numcopies
-			then a numcopiesattr
+			then a numcopies
 			else stop

Command/DropKey.hs

@@ -12,20 +12,19 @@ import Command
 import qualified Annex
 import Logs.Location
 import Annex.Content
-import Types.Key
 
 def :: [Command]
 def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek
 	SectionPlumbing "drops annexed content for specified keys"] 
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withKeys start]
+seek = withKeys start
 
 start :: Key -> CommandStart
 start key = stopUnless (inAnnex key) $ do
 	unlessM (Annex.getState Annex.force) $
 		error "dropkey can cause data loss; use --force if you're sure you want to do this"
-	showStart "dropkey" (key2file key)
+	showStart' "dropkey" key Nothing
 	next $ perform key
 
 perform :: Key -> CommandPerform

Command/DropUnused.hs

@@ -13,28 +13,30 @@ import qualified Annex
 import qualified Command.Drop
 import qualified Remote
 import qualified Git
-import qualified Option
 import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
+import Config.NumCopies
 
 def :: [Command]
-def = [withOptions [Command.Drop.fromOption] $
+def = [withOptions [Command.Drop.dropFromOption] $
 	command "dropunused" (paramRepeating paramNumRange)
 		seek SectionMaintenance "drop unused file content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withUnusedMaps start]
+seek ps = do
+	numcopies <- getNumCopies
+	withUnusedMaps (start numcopies) ps
 
-start :: UnusedMaps -> Int -> CommandStart
+start :: NumCopies -> UnusedMaps -> Int -> CommandStart
-start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation)
+start numcopies = startUnused "dropunused" (perform numcopies) (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation)
 
-perform :: Key -> CommandPerform
+perform :: NumCopies -> Key -> CommandPerform
-perform key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< from
+perform numcopies key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< from
   where
 	dropremote r = do
 		showAction $ "from " ++ Remote.name r
-		Command.Drop.performRemote key Nothing r
+		Command.Drop.performRemote key numcopies r
-	droplocal = Command.Drop.performLocal key Nothing Nothing
+	droplocal = Command.Drop.performLocal key numcopies Nothing
-	from = Annex.getField $ Option.name Command.Drop.fromOption
+	from = Annex.getField $ optionName Command.Drop.dropFromOption
 
 performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
 performOther filespec key = do

Command/EnableRemote.hs

@@ -20,8 +20,8 @@ def = [command "enableremote"
 	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
 	seek SectionSetup "enables use of an existing special remote"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start [] = unknownNameError "Specify the name of the special remote to enable."
@@ -40,10 +40,10 @@ start (name:ws) = go =<< InitRemote.findExisting name
 unknownNameError :: String -> Annex a
 unknownNameError prefix = do
 	names <- InitRemote.remoteNames
-	error $ prefix ++
+	error $ prefix ++ "\n" ++
 		if null names
-			then ""
+			then "(No special remotes are currently known; perhaps use initremote instead?)"
-			else " Known special remotes: " ++ unwords names
+			else "Known special remotes: " ++ unwords names
 
 perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
 perform t u c = do

Command/ExamineKey.hs

@@ -10,16 +10,18 @@ module Command.ExamineKey where
 import Common.Annex
 import Command
 import qualified Utility.Format
-import Command.Find (formatOption, withFormat, showFormatted, keyVars)
+import Command.Find (formatOption, getFormat, showFormatted, keyVars)
 import Types.Key
 
 def :: [Command]
-def = [noCommit $ noMessages $ withOptions [formatOption] $
+def = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $
 	command "examinekey" (paramRepeating paramKey) seek
 	SectionPlumbing "prints information from a key"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFormat $ \f -> withKeys $ start f]
+seek ps = do
+	format <- getFormat
+	withKeys (start format) ps
 
 start :: Maybe Utility.Format.Format -> Key -> CommandStart
 start format key = do

Command/Find.hs

@@ -17,26 +17,27 @@ import qualified Annex
 import qualified Utility.Format
 import Utility.DataUnits
 import Types.Key
-import qualified Option
 
 def :: [Command]
-def = [noCommit $ noMessages $ withOptions [formatOption, print0Option] $
+def = [noCommit $ noMessages $ withOptions [formatOption, print0Option, jsonOption] $
 	command "find" paramPaths seek SectionQuery "lists available files"]
 
 formatOption :: Option
-formatOption = Option.field [] "format" paramFormat "control format of output"
+formatOption = fieldOption [] "format" paramFormat "control format of output"
 
-withFormat :: (Maybe Utility.Format.Format -> CommandSeek) -> CommandSeek
+getFormat :: Annex (Maybe Utility.Format.Format)
-withFormat = withField formatOption $ return . fmap Utility.Format.gen
+getFormat = getOptionField formatOption $ return . fmap Utility.Format.gen
 
 print0Option :: Option
-print0Option = Option.Option [] ["print0"] (Option.NoArg set)
+print0Option = Option [] ["print0"] (NoArg set)
 	"terminate output with null"
   where
-	set = Annex.setField (Option.name formatOption) "${file}\0"
+	set = Annex.setField (optionName formatOption) "${file}\0"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFormat $ \f -> withFilesInGit $ whenAnnexed $ start f]
+seek ps = do
+	format <- getFormat
+	withFilesInGit (whenAnnexed $ start format) ps
 
 start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
 start format file (key, _) = do

Command/Fix.hs

@@ -9,8 +9,6 @@
 
 module Command.Fix where
 
-import System.PosixCompat.Files
-
 import Common.Annex
 import Command
 import qualified Annex.Queue
@@ -24,8 +22,8 @@ def :: [Command]
 def = [notDirect $ noCommit $ command "fix" paramPaths seek
 	SectionMaintenance "fix up symlinks to point to annexed content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesInGit $ whenAnnexed start]
+seek = withFilesInGit $ whenAnnexed start
 
 {- Fixes the symlink to an annexed file. -}
 start :: FilePath -> (Key, Backend) -> CommandStart

Command/Forget.hs

@@ -12,7 +12,6 @@ import Command
 import qualified Annex.Branch as Branch
 import Logs.Transitions
 import qualified Annex
-import qualified Option
 
 import Data.Time.Clock.POSIX
 
@@ -24,11 +23,12 @@ forgetOptions :: [Option]
 forgetOptions = [dropDeadOption]
 
 dropDeadOption :: Option
-dropDeadOption = Option.flag [] "drop-dead" "drop references to dead repositories"
+dropDeadOption = flagOption [] "drop-dead" "drop references to dead repositories"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFlag dropDeadOption $ \dropdead ->
+seek ps = do
-	withNothing $ start dropdead]
+	dropdead <- getOptionFlag dropDeadOption
+	withNothing (start dropdead) ps
 
 start :: Bool -> CommandStart
 start dropdead = do

Command/FromKey.hs

@@ -7,8 +7,6 @@
 
 module Command.FromKey where
 
-import System.PosixCompat.Files
-
 import Common.Annex
 import Command
 import qualified Annex.Queue
@@ -20,8 +18,8 @@ def = [notDirect $ notBareRepo $
 	command "fromkey" (paramPair paramKey paramPath) seek
 		SectionPlumbing "adds a file using a specific key"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start (keyname:file:[]) = do

Command/Fsck.hs

@@ -9,8 +9,6 @@
 
 module Command.Fsck where
 
-import System.PosixCompat.Files
-
 import Common.Annex
 import Command
 import qualified Annex
@@ -25,15 +23,14 @@ import Annex.Perms
 import Annex.Link
 import Logs.Location
 import Logs.Trust
+import Config.NumCopies
 import Annex.UUID
 import Utility.DataUnits
 import Utility.FileMode
 import Config
-import qualified Option
 import Types.Key
 import Utility.HumanTime
 import Git.FilePath
-import GitAnnex.Options hiding (fromOption)
 
 #ifndef mingw32_HOST_OS
 import System.Posix.Process (getProcessID)
@@ -49,41 +46,42 @@ def :: [Command]
 def = [withOptions fsckOptions $ command "fsck" paramPaths seek
 	SectionMaintenance "check for problems"]
 
-fromOption :: Option
+fsckFromOption :: Option
-fromOption = Option.field ['f'] "from" paramRemote "check remote"
+fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote"
 
 startIncrementalOption :: Option
-startIncrementalOption = Option.flag ['S'] "incremental" "start an incremental fsck"
+startIncrementalOption = flagOption ['S'] "incremental" "start an incremental fsck"
 
 moreIncrementalOption :: Option
-moreIncrementalOption = Option.flag ['m'] "more" "continue an incremental fsck"
+moreIncrementalOption = flagOption ['m'] "more" "continue an incremental fsck"
 
 incrementalScheduleOption :: Option
-incrementalScheduleOption = Option.field [] "incremental-schedule" paramTime
+incrementalScheduleOption = fieldOption [] "incremental-schedule" paramTime
 	"schedule incremental fscking"
 
 fsckOptions :: [Option]
 fsckOptions = 
-	[ fromOption
+	[ fsckFromOption
 	, startIncrementalOption
 	, moreIncrementalOption
 	, incrementalScheduleOption
 	] ++ keyOptions
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fsckFromOption Remote.byNameWithUUID
-	  withIncremental $ \i ->
+	i <- getIncremental
-	  withKeyOptions (startKey i) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start from i
+		(startKey i)
-	]
+		(withFilesInGit $ whenAnnexed $ start from i)
+		ps
 
-withIncremental :: (Incremental -> CommandSeek) -> CommandSeek
+getIncremental :: Annex Incremental
-withIncremental = withValue $ do
+getIncremental = do
 	i <- maybe (return False) (checkschedule . parseDuration)
-		=<< Annex.getField (Option.name incrementalScheduleOption)
+		=<< Annex.getField (optionName incrementalScheduleOption)
-	starti <- Annex.getFlag (Option.name startIncrementalOption)
+	starti <- Annex.getFlag (optionName startIncrementalOption)
-	morei <- Annex.getFlag (Option.name moreIncrementalOption)
+	morei <- Annex.getFlag (optionName moreIncrementalOption)
 	case (i, starti, morei) of
 		(False, False, False) -> return NonIncremental
 		(False, True, _) -> startIncremental
@@ -110,14 +108,14 @@ withIncremental = withValue $ do
 
 start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart
 start from inc file (key, backend) = do
-	numcopies <- numCopies file
+	numcopies <- getFileNumCopies file
 	case from of
 		Nothing -> go $ perform key file backend numcopies
 		Just r -> go $ performRemote key file backend numcopies r
   where
 	go = runFsck inc file key
 
-perform :: Key -> FilePath -> Backend -> Maybe Int -> Annex Bool
+perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
 perform key file backend numcopies = check
 	-- order matters
 	[ fixLink key file
@@ -131,7 +129,7 @@ perform key file backend numcopies = check
 
 {- To fsck a remote, the content is retrieved to a tmp file,
  - and checked locally. -}
-performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> Annex Bool
+performRemote :: Key -> FilePath -> Backend -> NumCopies -> Remote -> Annex Bool
 performRemote key file backend numcopies remote =
 	dispatch =<< Remote.hasKey remote key
   where
@@ -367,27 +365,26 @@ checkBackendOr' bad backend key file postcheck =
 				, return True
 				)
 
-checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool
+checkKeyNumCopies :: Key -> FilePath -> NumCopies -> Annex Bool
 checkKeyNumCopies key file numcopies = do
-	needed <- getNumCopies numcopies
 	(untrustedlocations, safelocations) <- trustPartition UnTrusted =<< Remote.keyLocations key
-	let present = length safelocations
+	let present = NumCopies (length safelocations)
-	if present < needed
+	if present < numcopies
 		then do
 			ppuuids <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations
-			warning $ missingNote file present needed ppuuids
+			warning $ missingNote file present numcopies ppuuids
 			return False
 		else return True
 
-missingNote :: String -> Int -> Int -> String -> String
+missingNote :: String -> NumCopies -> NumCopies -> String -> String
-missingNote file 0 _ [] = 
+missingNote file (NumCopies 0) _ [] = 
 		"** No known copies exist of " ++ file
-missingNote file 0 _ untrusted =
+missingNote file (NumCopies 0) _ untrusted =
 		"Only these untrusted locations may have copies of " ++ file ++
 		"\n" ++ untrusted ++
 		"Back it up to trusted locations with git-annex copy."
 missingNote file present needed [] =
-		"Only " ++ show present ++ " of " ++ show needed ++ 
+		"Only " ++ show (fromNumCopies present) ++ " of " ++ show (fromNumCopies needed) ++ 
 		" trustworthy copies exist of " ++ file ++
 		"\nBack it up with git-annex copy."
 missingNote file present needed untrusted = 
@@ -481,10 +478,9 @@ recordStartTime = do
 	createAnnexDirectory $ parentDir f
 	liftIO $ do
 		nukeFile f
-		h <- openFile f WriteMode
+		withFile f WriteMode $ \h -> do
 			t <- modificationTime <$> getFileStatus f
 			hPutStr h $ showTime $ realToFrac t
-		hClose h
   where
 	showTime :: POSIXTime -> String
 	showTime = show

Command/FuzzTest.hs

@@ -25,8 +25,8 @@ def :: [Command]
 def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing
 	"generates fuzz test files"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do
@@ -146,13 +146,6 @@ genFuzzFile = do
 genFuzzDir :: IO FuzzDir
 genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int)
 
-localFile :: FilePath -> Bool
-localFile f
-	| isAbsolute f = False
-	| ".." `isInfixOf` f = False
-	| ".git" `isPrefixOf` f = False
-	| otherwise = True
-
 data TimeStampedFuzzAction 
 	= Started UTCTime FuzzAction
 	| Finished UTCTime Bool

Command/GCryptSetup.hs

@@ -18,8 +18,8 @@ def = [dontCheck repoExists $ noCommit $
 	command "gcryptsetup" paramValue seek
 		SectionPlumbing "sets up gcrypt repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withStrings start]
+seek = withStrings start
 
 start :: String -> CommandStart
 start gcryptid = next $ next $ do

Command/Get.hs

@@ -12,10 +12,9 @@ import Command
 import qualified Remote
 import Annex.Content
 import Logs.Transfer
+import Config.NumCopies
 import Annex.Wanted
-import GitAnnex.Options
 import qualified Command.Move
-import Types.Key
 
 def :: [Command]
 def = [withOptions getOptions $ command "get" paramPaths seek
@@ -24,17 +23,18 @@ def = [withOptions getOptions $ command "get" paramPaths seek
 getOptions :: [Option]
 getOptions = fromOption : keyOptions
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek ps = do
-	[ withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (startKeys from) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start from
+		(startKeys from)
-	]
+		(withFilesInGit $ whenAnnexed $ start from)
+		ps
 
 start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
 start from file (key, _) = start' expensivecheck from key (Just file)
   where
-	expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just file))
+	expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file))
 
 startKeys :: Maybe Remote -> Key -> CommandStart
 startKeys from key = start' (return True) from key Nothing
@@ -49,7 +49,7 @@ start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $
 					go $ Command.Move.fromPerform src False key afile
   where
   	go a = do
-		showStart "get" (fromMaybe (key2file key) afile)
+		showStart' "get" key afile
 		next a
 
 perform :: Key -> AssociatedFile -> CommandPerform
@@ -59,7 +59,11 @@ perform key afile = stopUnless (getViaTmp key $ getKeyFile key afile) $
 {- Try to find a copy of the file in one of the remotes,
  - and copy it to here. -}
 getKeyFile :: Key -> AssociatedFile -> FilePath -> Annex Bool
-getKeyFile key afile dest = dispatch =<< Remote.keyPossibilities key
+getKeyFile key afile dest = getKeyFile' key afile dest
+	=<< Remote.keyPossibilities key
+
+getKeyFile' :: Key -> AssociatedFile -> FilePath -> [Remote] -> Annex Bool
+getKeyFile' key afile dest = dispatch
   where
 	dispatch [] = do
 		showNote "not available"

Command/Group.hs

@@ -19,8 +19,8 @@ def :: [Command]
 def = [command "group" (paramPair paramRemote paramDesc) seek
 	SectionSetup "add a repository to a group"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start (name:g:[]) = do

Command/Help.hs

@@ -18,7 +18,6 @@ import qualified Command.Copy
 import qualified Command.Sync
 import qualified Command.Whereis
 import qualified Command.Fsck
-import GitAnnex.Options
 
 import System.Console.GetOpt
 
@@ -26,8 +25,8 @@ def :: [Command]
 def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
 	command "help" paramNothing seek SectionQuery "display help"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start params = do
@@ -42,7 +41,7 @@ start' ["options"] = showCommonOptions
 start' _ = showGeneralHelp
 
 showCommonOptions :: IO ()
-showCommonOptions = putStrLn $ usageInfo "Common options:" options
+showCommonOptions = putStrLn $ usageInfo "Common options:" gitAnnexOptions
 
 showGeneralHelp :: IO ()
 showGeneralHelp = putStrLn $ unlines

Command/Import.hs

@@ -7,13 +7,10 @@
 
 module Command.Import where
 
-import System.PosixCompat.Files
-
 import Common.Annex
 import Command
 import qualified Annex
 import qualified Command.Add
-import qualified Option
 import Utility.CopyFile
 import Backend
 import Remote
@@ -32,16 +29,16 @@ opts =
 	]
 
 duplicateOption :: Option
-duplicateOption = Option.flag [] "duplicate" "do not delete source files"
+duplicateOption = flagOption [] "duplicate" "do not delete source files"
 
 deduplicateOption :: Option
-deduplicateOption = Option.flag [] "deduplicate" "delete source files whose content was imported before"
+deduplicateOption = flagOption [] "deduplicate" "delete source files whose content was imported before"
 
 cleanDuplicatesOption :: Option
-cleanDuplicatesOption = Option.flag [] "clean-duplicates" "delete duplicate source files (import nothing)"
+cleanDuplicatesOption = flagOption [] "clean-duplicates" "delete duplicate source files (import nothing)"
 
 skipDuplicatesOption :: Option
-skipDuplicatesOption = Option.flag [] "skip-duplicates" "import only new files"
+skipDuplicatesOption = flagOption [] "skip-duplicates" "import only new files"
 
 data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates
 	deriving (Eq)
@@ -53,7 +50,7 @@ getDuplicateMode = gen
 	<*> getflag cleanDuplicatesOption
 	<*> getflag skipDuplicatesOption
   where
-  	getflag = Annex.getFlag . Option.name
+  	getflag = Annex.getFlag . optionName
   	gen False False False False = Default
 	gen True False False False = Duplicate
 	gen False True False False = DeDuplicate
@@ -61,8 +58,10 @@ getDuplicateMode = gen
 	gen False False False True = SkipDuplicates
 	gen _ _ _ _ = error "bad combination of --duplicate, --deduplicate, --clean-duplicates, --skip-duplicates"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withValue getDuplicateMode $ \mode -> withPathContents $ start mode]
+seek ps = do
+	mode <- getDuplicateMode
+	withPathContents (start mode) ps
 
 start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart
 start mode (srcfile, destfile) =

Command/ImportFeed.hs

@@ -21,7 +21,6 @@ import qualified Annex
 import Command
 import qualified Annex.Url as Url
 import Logs.Web
-import qualified Option
 import qualified Utility.Format
 import Utility.Tmp
 import Command.AddUrl (addUrlFile, relaxedOption)
@@ -39,13 +38,14 @@ def = [notBareRepo $ withOptions [templateOption, relaxedOption] $
 		SectionCommon "import files from podcast feeds"]
 
 templateOption :: Option
-templateOption = Option.field [] "template" paramFormat "template for filenames"
+templateOption = fieldOption [] "template" paramFormat "template for filenames"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField templateOption return $ \tmpl ->
+seek ps = do
-	withFlag relaxedOption $ \relaxed ->
+	tmpl <- getOptionField templateOption return
-	withValue (getCache tmpl) $ \cache ->
+	relaxed <- getOptionFlag relaxedOption
-	withStrings $ start relaxed cache]
+	cache <- getCache tmpl
+	withStrings (start relaxed cache) ps
 
 start :: Bool -> Cache -> URLString -> CommandStart
 start relaxed cache url = do

Command/InAnnex.hs

@@ -15,8 +15,8 @@ def :: [Command]
 def = [noCommit $ command "inannex" (paramRepeating paramKey) seek
 	SectionPlumbing "checks if keys are present in the annex"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withKeys start]
+seek = withKeys start
 
 start :: Key -> CommandStart
 start key = inAnnexSafe key >>= dispatch

Command/Indirect.hs

@@ -7,7 +7,6 @@
 
 module Command.Indirect where
 
-import System.PosixCompat.Files
 import Control.Exception.Extensible
 
 import Common.Annex
@@ -23,7 +22,7 @@ import Annex.Content
 import Annex.Content.Direct
 import Annex.CatFile
 import Annex.Exception
-import Init
+import Annex.Init
 import qualified Command.Add
 
 def :: [Command]
@@ -31,8 +30,8 @@ def = [notBareRepo $ noDaemonRunning $
 	command "indirect" paramNothing seek
 		SectionSetup "switch repository to indirect mode"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = ifM isDirect

Command/Info.hs

@@ -14,7 +14,6 @@ import qualified Data.Map as M
 import Text.JSON
 import Data.Tuple
 import Data.Ord
-import System.PosixCompat.Files
 
 import Common.Annex
 import qualified Remote
@@ -28,6 +27,7 @@ import Annex.Content
 import Types.Key
 import Logs.UUID
 import Logs.Trust
+import Config.NumCopies
 import Remote
 import Config
 import Utility.Percentage
@@ -70,11 +70,12 @@ data StatInfo = StatInfo
 type StatState = StateT StatInfo Annex
 
 def :: [Command]
-def = [noCommit $ command "info" paramPaths seek
+def = [noCommit $ withOptions [jsonOption] $
-	SectionQuery "shows general information about the annex"]
+	command "info" paramPaths seek SectionQuery
+	"shows general information about the annex"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [FilePath] -> CommandStart
 start [] = do
@@ -310,7 +311,7 @@ getLocalStatInfo dir = do
   where
 	initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats)
 	update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) =
-		ifM (matcher $ FileInfo file file)
+		ifM (matcher $ MatchingFile $ FileInfo file file)
 			( do
 				!presentdata' <- ifM (inAnnex key)
 					( return $ addKey key presentdata

Command/Init.hs

@@ -9,14 +9,14 @@ module Command.Init where
 
 import Common.Annex
 import Command
-import Init
+import Annex.Init
 	
 def :: [Command]
 def = [dontCheck repoExists $
 	command "init" paramDesc seek SectionSetup "initialize git-annex"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start ws = do

Command/InitRemote.hs

@@ -24,8 +24,8 @@ def = [command "initremote"
 	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
 	seek SectionSetup "creates a special (non-git) remote"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start [] = error "Specify a name for the remote."

Command/List.hs

@@ -20,7 +20,6 @@ import Remote
 import Logs.Trust
 import Logs.UUID
 import Annex.UUID
-import qualified Option
 import qualified Annex
 import Git.Types (RemoteName)
 
@@ -29,16 +28,16 @@ def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek
 	SectionQuery "show which remotes contain files"]
 
 allrepos :: Option
-allrepos = Option.flag [] "allrepos" "show all repositories, not only remotes"
+allrepos = flagOption [] "allrepos" "show all repositories, not only remotes"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek ps = do
-	[ withValue getList $ withNothing . startHeader
+	list <- getList
-	, withValue getList $ withFilesInGit . whenAnnexed . start
+	printHeader list
-	]
+	withFilesInGit (whenAnnexed $ start list) ps
 
 getList :: Annex [(UUID, RemoteName, TrustLevel)]
-getList = ifM (Annex.getFlag $ Option.name allrepos)
+getList = ifM (Annex.getFlag $ optionName allrepos)
 	( nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAll)
 	, getRemotes
 	)
@@ -58,10 +57,8 @@ getList = ifM (Annex.getFlag $ Option.name allrepos)
 		return $ sortBy (comparing snd3) $
 			filter (\t -> thd3 t /= DeadTrusted) rs3
 
-startHeader :: [(UUID, RemoteName, TrustLevel)] -> CommandStart
+printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
-startHeader l = do
+printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l
-	liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l
-	stop
 
 start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart
 start l file (key, _) = do

Command/Lock.hs

@@ -16,8 +16,10 @@ def :: [Command]
 def = [notDirect $ command "lock" paramPaths seek SectionCommon
 	"undo unlock command"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start]
+seek ps = do
+	withFilesUnlocked start ps
+	withFilesUnlockedToBeCommitted start ps
 
 start :: FilePath -> CommandStart
 start file = do

Command/Log.hs

@@ -24,7 +24,6 @@ import qualified Annex.Branch
 import qualified Git
 import Git.Command
 import qualified Remote
-import qualified Option
 import qualified Annex
 
 data RefChange = RefChange 
@@ -44,25 +43,26 @@ options = passthruOptions ++ [gourceOption]
 
 passthruOptions :: [Option]
 passthruOptions = map odate ["since", "after", "until", "before"] ++
-	[ Option.field ['n'] "max-count" paramNumber
+	[ fieldOption ['n'] "max-count" paramNumber
 		"limit number of logs displayed"
 	]
   where
-	odate n = Option.field [] n paramDate $ "show log " ++ n ++ " date"
+	odate n = fieldOption [] n paramDate $ "show log " ++ n ++ " date"
 
 gourceOption :: Option
-gourceOption = Option.flag [] "gource" "format output for gource"
+gourceOption = flagOption [] "gource" "format output for gource"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withValue Remote.uuidDescriptions $ \m ->
+seek ps = do
-	withValue (liftIO getCurrentTimeZone) $ \zone ->
+	m <- Remote.uuidDescriptions
-	withValue (concat <$> mapM getoption passthruOptions) $ \os ->
+	zone <- liftIO getCurrentTimeZone
-	withFlag gourceOption $ \gource ->
+	os <- concat <$> mapM getoption passthruOptions
-	withFilesInGit $ whenAnnexed $ start m zone os gource]
+	gource <- getOptionFlag gourceOption
+	withFilesInGit (whenAnnexed $ start m zone os gource) ps
   where
 	getoption o = maybe [] (use o) <$>
-		Annex.getField (Option.name o)
+		Annex.getField (optionName o)
-	use o v = [Param ("--" ++ Option.name o), Param v]
+	use o v = [Param ("--" ++ optionName o), Param v]
 
 start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool ->
 	FilePath -> (Key, Backend) -> CommandStart

Command/LookupKey.hs

@@ -17,8 +17,8 @@ def = [notBareRepo $ noCommit $ noMessages $
 	command "lookupkey" (paramRepeating paramFile) seek
 		SectionPlumbing "looks up key used for file"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withStrings start]
+seek = withStrings start
 
 start :: String -> CommandStart
 start file = do

Command/Map.hs

@@ -31,8 +31,8 @@ def = [dontCheck repoExists $
 	command "map" paramNothing seek SectionQuery
 		"generate map of repositories"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/Merge.hs

@@ -17,11 +17,10 @@ def :: [Command]
 def = [command "merge" paramNothing seek SectionMaintenance
 	"automatically merge changes from remotes"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withNothing mergeBranch
+	withNothing mergeBranch ps
-	, withNothing mergeSynced
+	withNothing mergeSynced ps
-	]
 
 mergeBranch :: CommandStart
 mergeBranch = do

Command/Migrate.hs

@@ -22,8 +22,8 @@ def = [notDirect $
 	command "migrate" paramPaths seek
 		SectionUtility "switch data to different backend"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesInGit $ whenAnnexed start]
+seek = withFilesInGit $ whenAnnexed start
 
 start :: FilePath -> (Key, Backend) -> CommandStart
 start file (key, oldbackend) = do

Command/Mirror.hs

@@ -9,34 +9,33 @@ module Command.Mirror where
 
 import Common.Annex
 import Command
-import GitAnnex.Options
 import qualified Command.Move
 import qualified Command.Drop
 import qualified Command.Get
 import qualified Remote
 import Annex.Content
 import qualified Annex
+import Config.NumCopies
 
 def :: [Command]
 def = [withOptions (fromToOptions ++ keyOptions) $
 	command "mirror" paramPaths seek
 		SectionCommon "mirror content of files to/from another repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withField toOption Remote.byNameWithUUID $ \to ->
+	to <- getOptionField toOption Remote.byNameWithUUID
-	  withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (startKey Nothing to from Nothing) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start to from
+		(startKey to from Nothing)
-	]
+		(withFilesInGit $ whenAnnexed $ start to from)
+		ps
 
 start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
-start to from file (key, _backend) = do
+start to from file (key, _backend) = startKey to from (Just file) key
-	numcopies <- numCopies file
-	startKey numcopies to from (Just file) key
 
-startKey :: Maybe Int -> Maybe Remote -> Maybe Remote -> Maybe FilePath -> Key -> CommandStart
+startKey :: Maybe Remote -> Maybe Remote -> Maybe FilePath -> Key -> CommandStart
-startKey numcopies to from afile key = do
+startKey to from afile key = do
 	noAuto
 	case (from, to) of
 		(Nothing, Nothing) -> error "specify either --from or --to"
@@ -48,7 +47,9 @@ startKey numcopies to from afile key = do
 		error "--auto is not supported for mirror"
 	mirrorto r = ifM (inAnnex key)
 		( Command.Move.toStart r False afile key
-		, Command.Drop.startRemote afile numcopies key r
+		, do
+			numcopies <- getnumcopies
+			Command.Drop.startRemote afile numcopies key r
 		)
 	mirrorfrom r = do
 		haskey <- Remote.hasKey r key
@@ -56,6 +57,9 @@ startKey numcopies to from afile key = do
 			Left _ -> stop
 			Right True -> Command.Get.start' (return True) Nothing key afile
 			Right False -> ifM (inAnnex key)
-				( Command.Drop.startLocal afile numcopies key Nothing
+				( do
+					numcopies <- getnumcopies
+					Command.Drop.startLocal afile numcopies key Nothing
 				, stop
 				)
+	getnumcopies = maybe getNumCopies getFileNumCopies afile

Command/Move.hs

@@ -16,8 +16,6 @@ import qualified Remote
 import Annex.UUID
 import Logs.Presence
 import Logs.Transfer
-import GitAnnex.Options
-import Types.Key
 
 def :: [Command]
 def = [withOptions moveOptions $ command "move" paramPaths seek
@@ -26,13 +24,14 @@ def = [withOptions moveOptions $ command "move" paramPaths seek
 moveOptions :: [Option]
 moveOptions = fromToOptions ++ keyOptions
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek ps = do
-	[ withField toOption Remote.byNameWithUUID $ \to ->
+	to <- getOptionField toOption Remote.byNameWithUUID
-	  withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (startKey to from True) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start to from True
+		(startKey to from True)
-	]
+		(withFilesInGit $ whenAnnexed $ start to from True)
+		ps
 
 start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
 start to from move file (key, _) = start' to from move (Just file) key
@@ -53,17 +52,14 @@ start' to from move afile key = do
 		"--auto is not supported for move"
 
 showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()
-showMoveAction True _ (Just file) = showStart "move" file
+showMoveAction move = showStart' (if move then "move" else "copy")
-showMoveAction False _ (Just file) = showStart "copy" file
-showMoveAction True key Nothing = showStart "move" (key2file key)
-showMoveAction False key Nothing = showStart "copy" (key2file key)
 
 {- Moves (or copies) the content of an annexed file to a remote.
  -
  - If the remote already has the content, it is still removed from
  - the current repository.
  -
- - Note that unlike drop, this does not honor annex.numcopies.
+ - Note that unlike drop, this does not honor numcopies.
  - A file's content can be moved even if there are insufficient copies to
  - allow it to be dropped.
  -}

Command/NumCopies.hs

@@ -0,0 +1,56 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.NumCopies where
+
+import Common.Annex
+import qualified Annex
+import Command
+import Config.NumCopies
+import Types.Messages
+
+def :: [Command]
+def = [command "numcopies" paramNumber seek
+	SectionSetup "configure desired number of copies"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start [] = startGet
+start [s] = do
+	case readish s of
+		Nothing -> error $ "Bad number: " ++ s
+		Just n
+			| n > 0 -> startSet n
+			| n == 0 -> ifM (Annex.getState Annex.force)
+				( startSet n
+				, error "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force."
+				)
+			| otherwise -> error "Number cannot be negative!"
+start _ = error "Specify a single number."
+
+startGet :: CommandStart
+startGet = next $ next $ do
+	Annex.setOutput QuietOutput
+	v <- getGlobalNumCopies
+	case v of
+		Just n -> liftIO $ putStrLn $ show $ fromNumCopies n
+		Nothing -> do
+			liftIO $ putStrLn $ "global numcopies is not set"
+			old <- deprecatedNumCopies
+			case old of
+				Nothing -> liftIO $ putStrLn "(default is 1)"
+				Just n -> liftIO $ putStrLn $ "(deprecated git config annex.numcopies is set to " ++ show (fromNumCopies n) ++ " locally)"
+	return True
+
+startSet :: Int -> CommandStart
+startSet n = do
+	showStart "numcopies" (show n)
+	next $ next $ do
+		setGlobalNumCopies $ NumCopies n
+		return True

Command/PreCommit.hs

@@ -9,6 +9,7 @@ module Command.PreCommit where
 
 import Common.Annex
 import Command
+import Config
 import qualified Command.Add
 import qualified Command.Fix
 import Annex.Direct
@@ -17,19 +18,20 @@ def :: [Command]
 def = [command "pre-commit" paramPaths seek SectionPlumbing
 	"run by git pre-commit hook"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = ifM isDirect
-	-- fix symlinks to files being committed
-	[ whenNotDirect $ withFilesToBeCommitted $ whenAnnexed Command.Fix.start
-	-- inject unlocked files into the annex
-	, whenNotDirect $ withFilesUnlockedToBeCommitted startIndirect
 	-- update direct mode mappings for committed files
-	, whenDirect $ withWords startDirect
+	( withWords startDirect ps
-	]
+	, do
+		-- fix symlinks to files being committed
+		withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps
+		-- inject unlocked files into the annex
+		withFilesUnlockedToBeCommitted startIndirect ps
+	)
 
 startIndirect :: FilePath -> CommandStart
 startIndirect file = next $ do
-	unlessM (doCommand $ Command.Add.start file) $
+	unlessM (callCommandAction $ Command.Add.start file) $
 		error $ "failed to add " ++ file ++ "; canceling commit"
 	next $ return True
 

Command/ReKey.hs

@@ -22,8 +22,8 @@ def = [notDirect $ command "rekey"
 	(paramOptional $ paramRepeating $ paramPair paramPath paramKey)
 	seek SectionPlumbing "change keys used for files"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withPairs start]
+seek = withPairs start
 
 start :: (FilePath, String) -> CommandStart
 start (file, keyname) = ifAnnexed file go stop

Command/RecvKey.hs

@@ -7,8 +7,6 @@
 
 module Command.RecvKey where
 
-import System.PosixCompat.Files
-
 import Common.Annex
 import Command
 import CmdLine
@@ -17,7 +15,7 @@ import Annex
 import Utility.Rsync
 import Logs.Transfer
 import Command.SendKey (fieldTransfer)
-import qualified Fields
+import qualified CmdLine.GitAnnexShell.Fields as Fields
 import qualified Types.Key
 import qualified Types.Backend
 import qualified Backend
@@ -26,8 +24,8 @@ def :: [Command]
 def = [noCommit $ command "recvkey" paramKey seek
 	SectionPlumbing "runs rsync in server mode to receive content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withKeys start]
+seek = withKeys start
 
 start :: Key -> CommandStart
 start key = ifM (inAnnex key)

Command/Reinject.hs

@@ -17,8 +17,8 @@ def :: [Command]
 def = [command "reinject" (paramPair "SRC" "DEST") seek
 	SectionUtility "sets content of annexed file"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [FilePath] -> CommandStart
 start (src:dest:[])

Command/Repair.hs

@@ -20,8 +20,8 @@ def :: [Command]
 def = [noCommit $ dontCheck repoExists $
 	command "repair" paramNothing seek SectionMaintenance "recover broken git repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = next $ next $ runRepair =<< Annex.getState Annex.force

Command/RmUrl.hs

@@ -16,8 +16,8 @@ def = [notBareRepo $
 	command "rmurl" (paramPair paramFile paramUrl) seek
 		SectionCommon "record file is not available at url"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withPairs start]
+seek = withPairs start
 
 start :: (FilePath, String) -> CommandStart
 start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do