Merge branch 'master' into no-xmpp

Annex/AdjustedBranch.hs

@@ -596,7 +596,7 @@ checkAdjustedClone = ifM isBareRepo
 				aps <- fmap commitParent <$> findAdjustingCommit (AdjBranch currbranch)
 				case aps of
 					Just [p] -> setBasisBranch basis p
-					_ -> error $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch
+					_ -> giveup $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch
 			ifM versionSupportsUnlockedPointers
 				( return InAdjustedClone
 				, return NeedUpgradeForAdjustedClone
@@ -610,6 +610,6 @@ isGitVersionSupported = not <$> Git.Version.older "2.2.0"
 checkVersionSupported :: Annex ()
 checkVersionSupported = do
 	unlessM versionSupportsAdjustedBranch $
-		error "Adjusted branches are only supported in v6 or newer repositories."
+		giveup "Adjusted branches are only supported in v6 or newer repositories."
 	unlessM (liftIO isGitVersionSupported) $
-		error "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."
+		giveup "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."

Annex/Branch.hs

@@ -61,6 +61,7 @@ import qualified Annex.Queue
 import Annex.Branch.Transitions
 import qualified Annex
 import Annex.Hook
+import Utility.FileSystemEncoding
 
 {- Name of the branch that is used to store git-annex's information. -}
 name :: Git.Ref
@@ -225,7 +226,7 @@ getHistorical date file =
 	-- This check avoids some ugly error messages when the reflog
 	-- is empty.
 	ifM (null <$> inRepo (Git.RefLog.get' [Param (fromRef fullname), Param "-n1"]))
-		( error ("No reflog for " ++ fromRef fullname)
+		( giveup ("No reflog for " ++ fromRef fullname)
 		, getRef (Git.Ref.dateRef fullname date) file
 		)
 
@@ -436,7 +437,6 @@ stageJournal jl = withIndex $ do
 	g <- gitRepo
 	let dir = gitAnnexJournalDir g
 	(jlogf, jlogh) <- openjlog
-	liftIO $ fileEncoding jlogh
 	h <- hashObjectHandle
 	withJournalHandle $ \jh ->
 		Git.UpdateIndex.streamUpdateIndex g
@@ -574,7 +574,7 @@ checkBranchDifferences ref = do
 		<$> catFile ref differenceLog
 	mydiffs <- annexDifferences <$> Annex.getGitConfig
 	when (theirdiffs /= mydiffs) $
-		error "Remote repository is tuned in incompatable way; cannot be merged with local repository."
+		giveup "Remote repository is tuned in incompatable way; cannot be merged with local repository."
 
 ignoreRefs :: [Git.Sha] -> Annex ()
 ignoreRefs rs = do

Annex/CatFile.hs

@@ -33,6 +33,7 @@ import Git.FilePath
 import Git.Index
 import qualified Git.Ref
 import Annex.Link
+import Utility.FileSystemEncoding
 
 catFile :: Git.Branch -> FilePath -> Annex L.ByteString
 catFile branch file = do

Annex/ChangedRefs.hs

@@ -0,0 +1,108 @@
+{- Waiting for changed git refs
+ -
+ - Copyright 2014-216 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.ChangedRefs
+	( ChangedRefs(..)
+	, ChangedRefsHandle
+	, waitChangedRefs
+	, drainChangedRefs
+	, stopWatchingChangedRefs
+	, watchChangedRefs
+	) where
+
+import Annex.Common
+import Utility.DirWatcher
+import Utility.DirWatcher.Types
+import qualified Git
+import Git.Sha
+import qualified Utility.SimpleProtocol as Proto
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TBMChan
+
+newtype ChangedRefs = ChangedRefs [Git.Ref]
+	deriving (Show)
+
+instance Proto.Serializable ChangedRefs where
+	serialize (ChangedRefs l) = unwords $ map Git.fromRef l
+	deserialize = Just . ChangedRefs . map Git.Ref . words
+
+data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)
+
+-- | Wait for one or more git refs to change.
+--
+-- When possible, coalesce ref writes that occur closely together
+-- in time. Delay up to 0.05 seconds to get more ref writes.
+waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs
+waitChangedRefs (ChangedRefsHandle _ chan) = do
+	v <- atomically $ readTBMChan chan
+	case v of
+		Nothing -> return $ ChangedRefs []
+		Just r -> do
+			threadDelay 50000
+			rs <- atomically $ loop []
+			return $ ChangedRefs (r:rs)
+  where
+	loop rs = do
+		v <- tryReadTBMChan chan
+		case v of
+			Just (Just r) -> loop (r:rs)
+			_ -> return rs
+
+-- | Remove any changes that might be buffered in the channel,
+-- without waiting for any new changes.
+drainChangedRefs :: ChangedRefsHandle -> IO ()
+drainChangedRefs (ChangedRefsHandle _ chan) = atomically go
+  where
+	go = do
+		v <- tryReadTBMChan chan
+		case v of
+			Just (Just _) -> go
+			_ -> return ()
+
+stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()
+stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do
+	stopWatchDir wh
+	atomically $ closeTBMChan chan
+	drainChangedRefs h
+
+watchChangedRefs :: Annex (Maybe ChangedRefsHandle)
+watchChangedRefs = do
+	-- This channel is used to accumulate notifications,
+	-- because the DirWatcher might have multiple threads that find
+	-- changes at the same time. It is bounded to allow a watcher
+	-- to be started once and reused, without too many changes being
+	-- buffered in memory.
+	chan <- liftIO $ newTBMChanIO 100
+	
+	g <- gitRepo
+	let refdir = Git.localGitDir g </> "refs"
+	liftIO $ createDirectoryIfMissing True refdir
+
+	let notifyhook = Just $ notifyHook chan
+	let hooks = mkWatchHooks
+		{ addHook = notifyhook
+		, modifyHook = notifyhook
+		}
+
+	if canWatch
+		then do
+			h <- liftIO $ watchDir refdir (const False) True hooks id
+			return $ Just $ ChangedRefsHandle h chan
+		else return Nothing
+
+notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
+notifyHook chan reffile _
+	| ".lock" `isSuffixOf` reffile = noop
+	| otherwise = void $ do
+		sha <- catchDefaultIO Nothing $
+			extractSha <$> readFile reffile
+		-- When the channel is full, there is probably no reader
+		-- running, or ref changes have been occuring very fast,
+		-- so it's ok to not write the change to it.
+		maybe noop (void . atomically . tryWriteTBMChan chan) sha

Annex/Content.hs

@@ -268,8 +268,8 @@ lockContentUsing locker key a = do
 		(unlock lockfile)
 		(const a)
   where
-	alreadylocked = error "content is locked"
+	alreadylocked = giveup "content is locked"
-	failedtolock e = error $ "failed to lock content: " ++ show e
+	failedtolock e = giveup $ "failed to lock content: " ++ show e
 
 	lock contentfile lockfile =
 		(maybe alreadylocked return 

Annex/Content/Direct.hs

@@ -52,8 +52,7 @@ associatedFiles key = do
 associatedFilesRelative :: Key -> Annex [FilePath] 
 associatedFilesRelative key = do
 	mapping <- calcRepo $ gitAnnexMapping key
-	liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> do
+	liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h ->
-		fileEncoding h
 		-- Read strictly to ensure the file is closed
 		-- before changeAssociatedFiles tries to write to it.
 		-- (Especially needed on Windows.)
@@ -68,8 +67,7 @@ changeAssociatedFiles key transform = do
 	let files' = transform files
 	when (files /= files') $
 		modifyContent mapping $
-			liftIO $ viaTmp writeFileAnyEncoding mapping $
+			liftIO $ viaTmp writeFile mapping $ unlines files'
-				unlines files'
 	top <- fromRepo Git.repoPath
 	return $ map (top </>) files'
 

Annex/DirHashes.hs

@@ -26,6 +26,7 @@ import Common
 import Types.Key
 import Types.GitConfig
 import Types.Difference
+import Utility.FileSystemEncoding
 
 type Hasher = Key -> FilePath
 

Annex/FileMatcher.hs

@@ -165,7 +165,7 @@ largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
 	mkmatcher expr = do
 		parser <- mkLargeFilesParser
 		either badexpr return $ parsedToMatcher $ parser expr
-	badexpr e = error $ "bad annex.largefiles configuration: " ++ e
+	badexpr e = giveup $ "bad annex.largefiles configuration: " ++ e
 
 simply :: MatchFiles Annex -> ParseResult
 simply = Right . Operation

Annex/Init.hs

@@ -129,7 +129,7 @@ ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
   where
 	needsinit = ifM Annex.Branch.hasSibling
 			( initialize Nothing Nothing
-			, error "First run: git-annex init"
+			, giveup "First run: git-annex init"
 			)
 
 {- Checks if a repository is initialized. Does not check version for ugrade. -}

Annex/Journal.hs

@@ -37,7 +37,6 @@ setJournalFile _jl file content = do
 	let tmpfile = tmp </> takeFileName jfile
 	liftIO $ do
 		withFile tmpfile WriteMode $ \h -> do
-			fileEncoding h
 #ifdef mingw32_HOST_OS
 			hSetNewlineMode h noNewlineTranslation
 #endif
@@ -53,7 +52,7 @@ getJournalFile _jl = getJournalFileStale
  - changes. -}
 getJournalFileStale :: FilePath -> Annex (Maybe String)
 getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
-	readFileStrictAnyEncoding $ journalFile file g
+	readFileStrict $ journalFile file g
 
 {- List of files that have updated content in the journal. -}
 getJournalledFiles :: JournalLocked -> Annex [FilePath]

Annex/Link.hs

@@ -24,6 +24,7 @@ import Git.Types
 import Git.FilePath
 import Annex.HashObject
 import Utility.FileMode
+import Utility.FileSystemEncoding
 
 import qualified Data.ByteString.Lazy as L
 
@@ -63,7 +64,6 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
 			Nothing -> fallback
 
 	probefilecontent f = withFile f ReadMode $ \h -> do
-		fileEncoding h
 		-- The first 8k is more than enough to read; link
 		-- files are small.
 		s <- take 8192 <$> hGetContents h

Annex/Locations.hs

@@ -63,7 +63,6 @@ module Annex.Locations (
 	gitAnnexUrlFile,
 	gitAnnexTmpCfgFile,
 	gitAnnexSshDir,
-	gitAnnexSshConfig,
 	gitAnnexRemotesDir,
 	gitAnnexAssistantDefaultDir,
 	HashLevels(..),
@@ -403,10 +402,6 @@ gitAnnexTmpCfgFile r = gitAnnexDir r </> "config.tmp"
 gitAnnexSshDir :: Git.Repo -> FilePath
 gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"
 
-{- .git/annex/ssh.config is used to configure ssh. -}
-gitAnnexSshConfig :: Git.Repo -> FilePath
-gitAnnexSshConfig r = gitAnnexDir r </> "ssh.config"
-
 {- .git/annex/remotes/ is used for remote-specific state. -}
 gitAnnexRemotesDir :: Git.Repo -> FilePath
 gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes"

Annex/Notification.hs

@@ -7,7 +7,7 @@
 
 {-# LANGUAGE CPP #-}
 
-module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where
+module Annex.Notification (NotifyWitness, noNotification, notifyTransfer, notifyDrop) where
 
 import Annex.Common
 import Types.Transfer
@@ -21,6 +21,10 @@ import qualified DBus.Client
 -- Witness that notification has happened.
 data NotifyWitness = NotifyWitness
 
+-- Only use when no notification should be done.
+noNotification :: NotifyWitness
+noNotification = NotifyWitness
+
 {- Wrap around an action that performs a transfer, which may run multiple
  - attempts. Displays notification when supported and when the user asked
  - for it. -}

Annex/SpecialRemote.hs

@@ -13,12 +13,11 @@ import Types.Remote (RemoteConfig, RemoteConfigKey, typename, setup)
 import Logs.Remote
 import Logs.Trust
 import qualified Git.Config
+import Git.Types (RemoteName)
 
 import qualified Data.Map as M
 import Data.Ord
 
-type RemoteName = String
-
 {- See if there's an existing special remote with this name.
  -
  - Prefer remotes that are not dead when a name appears multiple times. -}

Annex/Ssh.hs

@@ -33,7 +33,7 @@ import qualified Git.Url
 import Config
 import Annex.Path
 import Utility.Env
-import Utility.Tmp
+import Utility.FileSystemEncoding
 import Types.CleanupActions
 import Git.Env
 #ifndef mingw32_HOST_OS
@@ -50,37 +50,13 @@ sshOptions (host, port) gc opts = go =<< sshCachingInfo (host, port)
 	go (Just socketfile, params) = do
 		prepSocket socketfile
 		ret params
-	ret ps = do
+	ret ps = return $ concat
-		overideconfigfile <- fromRepo gitAnnexSshConfig
+		[ ps
-		-- We assume that the file content does not change.
+		, map Param (remoteAnnexSshOptions gc)
-		-- If it did, a more expensive test would be needed.
+		, opts
-		liftIO $ unlessM (doesFileExist overideconfigfile) $
+		, portParams port
-			viaTmp writeFile overideconfigfile $ unlines
+		, [Param "-T"]
-				-- Make old version of ssh that does
+		]
-				-- not know about Include ignore those
-				-- entries.
-				[ "IgnoreUnknown Include"
-				-- ssh expands "~"
-				, "Include ~/.ssh/config"
-				-- ssh will silently skip the file
-				-- if it does not exist
-				, "Include /etc/ssh/ssh_config"
-				-- Everything below this point is only
-				-- used if there's no setting for it in
-				-- the above files.
-				--
-				-- Make sure that ssh detects stalled
-				-- connections.
-				, "ServerAliveInterval 60"
-				]
-		return $ concat
-			[ ps
-			, [Param "-F", File overideconfigfile]
-			, map Param (remoteAnnexSshOptions gc)
-			, opts
-			, portParams port
-			, [Param "-T"]
-			]
 
 {- Returns a filename to use for a ssh connection caching socket, and
  - parameters to enable ssh connection caching. -}

Annex/Transfer.hs

@@ -45,6 +45,11 @@ instance Observable (Bool, Verification) where
 	observeBool = fst
 	observeFailure = (False, UnVerified)
 
+instance Observable (Either e Bool) where
+	observeBool (Left _) = False
+	observeBool (Right b) = b
+	observeFailure = Right False
+
 upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
 upload u key f d a _witness = guardHaveUUID u $ 
 	runTransfer (Transfer Upload u key) f d a

Annex/VariantFile.hs

@@ -8,6 +8,7 @@
 module Annex.VariantFile where
 
 import Annex.Common
+import Utility.FileSystemEncoding
 
 import Data.Hash.MD5
 

Annex/View.hs

@@ -110,7 +110,7 @@ refineView origview = checksize . calc Unchanged origview
 			in (view', Narrowing)
 	
 	checksize r@(v, _)
-		| viewTooLarge v = error $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
+		| viewTooLarge v = giveup $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
 		| otherwise = r
 
 updateViewComponent :: ViewComponent -> MetaField -> ViewFilter -> Writer [ViewChange] ViewComponent
@@ -424,4 +424,4 @@ genViewBranch view = withViewIndex $ do
 	return branch
 
 withCurrentView :: (View -> Annex a) -> Annex a
-withCurrentView a = maybe (error "Not in a view.") a =<< currentView
+withCurrentView a = maybe (giveup "Not in a view.") a =<< currentView

Assistant/Alert.hs

@@ -26,7 +26,6 @@ import qualified Control.Exception as E
 import Assistant.DaemonStatus
 import Assistant.WebApp.Types
 import Assistant.WebApp (renderUrl)
-import Yesod
 #endif
 import Assistant.Monad
 import Assistant.Types.UrlRenderer

Assistant/Fsck.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <id@joeyh.name>
  -
- - Licensed under the GNU AGPL version 3 or higher.
+ - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Assistant.Fsck where

Assistant/Gpg.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <id@joeyh.name>
  -
- - Licensed under the GNU AGPL version 3 or higher.
+ - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Assistant.Gpg where

Assistant/Repair.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <id@joeyh.name>
  -
- - Licensed under the GNU AGPL version 3 or higher.
+ - Licensed under the GNU GPL version 3 or higher.
  -}
 
 {-# LANGUAGE CPP #-}

Assistant/Restart.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <id@joeyh.name>
  -
- - Licensed under the GNU AGPL version 3 or higher.
+ - Licensed under the GNU GPL version 3 or higher.
  -}
 
 {-# LANGUAGE CPP #-}

Assistant/Sync.hs

@@ -19,6 +19,7 @@ import Utility.Parallel
 import qualified Git
 import qualified Git.Command
 import qualified Git.Merge
+import qualified Git.Ref
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Remote.List as Remote
@@ -204,16 +205,9 @@ manualPull currentbranch remotes = do
 			)
 	haddiverged <- liftAnnex Annex.Branch.forceUpdate
 	forM_ normalremotes $ \r ->
-		liftAnnex $ Command.Sync.mergeRemote r currentbranch mergeConfig
+		liftAnnex $ Command.Sync.mergeRemote r currentbranch Command.Sync.mergeConfig
 	return (catMaybes failed, haddiverged)
 
-mergeConfig :: [Git.Merge.MergeConfig]
-mergeConfig = 
-	[ Git.Merge.MergeNonInteractive
-	-- Pairing involves merging unrelated histories
-	, Git.Merge.MergeUnrelatedHistories
-	]
-
 {- Start syncing a remote, using a background thread. -}
 syncRemote :: Remote -> Assistant ()
 syncRemote remote = do

Assistant/Threads/Merger.hs

@@ -11,6 +11,8 @@ import Assistant.Common
 import Assistant.TransferQueue
 import Assistant.BranchChange
 import Assistant.Sync
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import qualified Annex.Branch
@@ -78,7 +80,7 @@ onChange file
 					, "into", Git.fromRef b
 					]
 				void $ liftAnnex $ Command.Sync.merge
-					currbranch mergeConfig
+					currbranch Command.Sync.mergeConfig
 					Git.Branch.AutomaticCommit
 					changedbranch
 	mergecurrent _ = noop

Assistant/Threads/RemoteControl.hs

@@ -30,7 +30,7 @@ remoteControlThread :: NamedThread
 remoteControlThread = namedThread "RemoteControl" $ do
 	program <- liftIO programPath
 	(cmd, params) <- liftIO $ toBatchCommand
-		(program, [Param "remotedaemon"])
+		(program, [Param "remotedaemon", Param "--foreground"])
 	let p = proc cmd (toCommand params)
 	(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
 		{ std_in = CreatePipe

Assistant/Threads/Watcher.hs

@@ -65,10 +65,10 @@ checkCanWatch
 #else
 		noop
 #endif
-	| otherwise = error "watch mode is not available on this system"
+	| otherwise = giveup "watch mode is not available on this system"
 
 needLsof :: Annex ()
-needLsof = error $ unlines
+needLsof = giveup $ unlines
 	[ "The lsof command is needed for watch mode to be safe, and is not in PATH."
 	, "To override lsof checks to ensure that files are not open for writing"
 	, "when added to the annex, you can use --force"

Assistant/Threads/WebApp.hs

@@ -38,6 +38,7 @@ import Assistant.WebApp.OtherRepos
 import Assistant.WebApp.Repair
 import Assistant.Types.ThreadedMonad
 import Utility.WebApp
+import Utility.AuthToken
 import Utility.Tmp
 import Utility.FileMode
 import Git
@@ -70,11 +71,11 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
 #ifdef __ANDROID__
 	when (isJust listenhost') $
 		-- See Utility.WebApp
-		error "Sorry, --listen is not currently supported on Android"
+		giveup "Sorry, --listen is not currently supported on Android"
 #endif
 	webapp <- WebApp
 		<$> pure assistantdata
-		<*> genAuthToken
+		<*> genAuthToken 128
 		<*> getreldir
 		<*> pure staticRoutes
 		<*> pure postfirstrun

Assistant/TransferrerPool.hs

@@ -74,8 +74,6 @@ mkTransferrer program batchmaker = do
 		, std_in = CreatePipe
 		, std_out = CreatePipe
 		}
-	fileEncoding readh
-	fileEncoding writeh
 	return $ Transferrer
 		{ transferrerRead = readh
 		, transferrerWrite = writeh

Assistant/Upgrade.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <id@joeyh.name>
  -
- - Licensed under the GNU AGPL version 3 or higher.
+ - Licensed under the GNU GPL version 3 or higher.
  -}
 
 {-# LANGUAGE CPP #-}
@@ -153,7 +153,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
   where
 	changeprogram program = liftIO $ do
 		unlessM (boolSystem program [Param "version"]) $
-			error "New git-annex program failed to run! Not using."
+			giveup "New git-annex program failed to run! Not using."
 		pf <- programFile
 		liftIO $ writeFile pf program
 	

Assistant/WebApp.hs

@@ -14,7 +14,7 @@ import Assistant.WebApp.Types
 import Assistant.Common
 import Utility.NotificationBroadcaster
 import Utility.Yesod
-import Utility.WebApp
+import Utility.AuthToken
 
 import Data.Text (Text)
 import Control.Concurrent

Assistant/WebApp/Configurators/AWS.hs

@@ -139,7 +139,7 @@ postAddS3R = awsConfigurator $ do
 				]
 		_ -> $(widgetFile "configurators/adds3")
 #else
-postAddS3R = error "S3 not supported by this build"
+postAddS3R = giveup "S3 not supported by this build"
 #endif
 
 getAddGlacierR :: Handler Html
@@ -161,7 +161,7 @@ postAddGlacierR = glacierConfigurator $ do
 				]
 		_ -> $(widgetFile "configurators/addglacier")
 #else
-postAddGlacierR = error "S3 not supported by this build"
+postAddGlacierR = giveup "S3 not supported by this build"
 #endif
 
 getEnableS3R :: UUID -> Handler Html
@@ -179,7 +179,7 @@ postEnableS3R :: UUID -> Handler Html
 #ifdef WITH_S3
 postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
 #else
-postEnableS3R _ = error "S3 not supported by this build"
+postEnableS3R _ = giveup "S3 not supported by this build"
 #endif
 
 getEnableGlacierR :: UUID -> Handler Html
@@ -205,7 +205,7 @@ enableAWSRemote remotetype uuid = do
 				T.pack <$> Remote.prettyUUID uuid
 			$(widgetFile "configurators/enableaws")
 #else
-enableAWSRemote _ _ = error "S3 not supported by this build"
+enableAWSRemote _ _ = giveup "S3 not supported by this build"
 #endif
 
 makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()

Assistant/WebApp/Configurators/IA.hs

@@ -147,7 +147,7 @@ postAddIAR = iaConfigurator $ do
 					]
 		_ -> $(widgetFile "configurators/addia")
 #else
-postAddIAR = error "S3 not supported by this build"
+postAddIAR = giveup "S3 not supported by this build"
 #endif
 
 getEnableIAR :: UUID -> Handler Html
@@ -157,7 +157,7 @@ postEnableIAR :: UUID -> Handler Html
 #ifdef WITH_S3
 postEnableIAR = iaConfigurator . enableIARemote
 #else
-postEnableIAR _ = error "S3 not supported by this build"
+postEnableIAR _ = giveup "S3 not supported by this build"
 #endif
 
 #ifdef WITH_S3

Assistant/WebApp/Configurators/Local.hs

@@ -151,7 +151,7 @@ getFirstRepositoryR = postFirstRepositoryR
 postFirstRepositoryR :: Handler Html
 postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
 	unlessM (liftIO $ inPath "git") $
-		error "You need to install git in order to use git-annex!"
+		giveup "You need to install git in order to use git-annex!"
 #ifdef __ANDROID__
 	androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
 	let path = "/sdcard/annex"
@@ -309,7 +309,7 @@ getFinishAddDriveR drive = go
 		mu <- liftAnnex $ probeGCryptRemoteUUID dir
 		case mu of
 			Just u -> enableexistinggcryptremote u
-			Nothing -> error "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
+			Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
 	enableexistinggcryptremote u = do
 		remotename' <- liftAnnex $ getGCryptRemoteName u dir
 		makewith $ const $ do

Assistant/WebApp/Configurators/Ssh.hs

@@ -196,7 +196,7 @@ postEnableSshGCryptR u = whenGcryptInstalled $
 	enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
 		sshConfigurator $
 			checkExistingGCrypt sshdata' $
-				error "Expected to find an encrypted git repository, but did not."
+				giveup "Expected to find an encrypted git repository, but did not."
 	getsshinput = parseSshUrl <=< M.lookup "gitrepo"
 
 getEnableSshGitRemoteR :: UUID -> Handler Html
@@ -475,7 +475,7 @@ checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $
 	case mu of
 		Just u -> void $ liftH $
 			combineExistingGCrypt sshdata u
-		Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
+		Nothing -> giveup "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
   where
 	repourl = genSshUrl sshdata
 
@@ -641,7 +641,7 @@ enableRsyncNetGCrypt sshinput reponame =
 		checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted notinstalled $
 			enableGCrypt sshdata reponame
   where
-	notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
+	notencrypted = giveup "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
 	notinstalled = error "internal"
 
 {- Prepares rsync.net ssh key and creates the directory that will be 

Assistant/WebApp/Configurators/WebDAV.hs

@@ -82,7 +82,7 @@ postAddBoxComR = boxConfigurator $ do
 				]
 		_ -> $(widgetFile "configurators/addbox.com")
 #else
-postAddBoxComR = error "WebDAV not supported by this build"
+postAddBoxComR = giveup "WebDAV not supported by this build"
 #endif
 
 getEnableWebDAVR :: UUID -> Handler Html
@@ -120,7 +120,7 @@ postEnableWebDAVR uuid = do
 					T.pack <$> Remote.prettyUUID uuid
 				$(widgetFile "configurators/enablewebdav")
 #else
-postEnableWebDAVR _ = error "WebDAV not supported by this build"
+postEnableWebDAVR _ = giveup "WebDAV not supported by this build"
 #endif
 
 #ifdef WITH_WEBDAV

Assistant/WebApp/Control.hs

@@ -74,5 +74,5 @@ getLogR :: Handler Html
 getLogR = page "Logs" Nothing $ do
 	logfile <- liftAnnex $ fromRepo gitAnnexLogFile
 	logs <- liftIO $ listLogs logfile
-	logcontent <- liftIO $ concat <$> mapM readFileStrictAnyEncoding logs
+	logcontent <- liftIO $ concat <$> mapM readFile logs
 	$(widgetFile "control/log")

Assistant/WebApp/Gpg.hs

@@ -56,7 +56,7 @@ withNewSecretKey use = do
 	liftIO $ genSecretKey cmd RSA "" userid maxRecommendedKeySize
 	results <- M.keys . M.filter (== userid) <$> liftIO (secretKeys cmd)
 	case results of
-		[] -> error "Failed to generate gpg key!"
+		[] -> giveup "Failed to generate gpg key!"
 		(key:_) -> use key
 
 {- Tries to find the name used in remote.log for a gcrypt repository
@@ -85,7 +85,7 @@ getGCryptRemoteName u repoloc = do
 	void $ inRepo $ Git.Remote.Remove.remove tmpremote
 	maybe missing return mname
   where
-	missing = error $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
+	missing = giveup $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
 
 {- Checks to see if a repo is encrypted with gcrypt, and runs one action if
  - it's not an another if it is.
@@ -103,7 +103,7 @@ checkGCryptRepoEncryption location notencrypted notinstalled encrypted =
 	dispatch Git.GCrypt.Decryptable = encrypted
 	dispatch Git.GCrypt.NotEncrypted = notencrypted
 	dispatch Git.GCrypt.NotDecryptable =
-		error "This git repository is encrypted with a GnuPG key that you do not have."
+		giveup "This git repository is encrypted with a GnuPG key that you do not have."
 
 {- Gets the UUID of the gcrypt repo at a location, which may not exist.
  - Only works if the gcrypt repo was created as a git-annex remote. -}

Assistant/WebApp/Notifications.hs

@@ -15,7 +15,7 @@ import Assistant.WebApp.Types
 import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 import Utility.Yesod
-import Utility.WebApp
+import Utility.AuthToken
 
 import Data.Text (Text)
 import qualified Data.Text as T

Assistant/WebApp/Types.hs

@@ -10,12 +10,16 @@
 {-# LANGUAGE FlexibleInstances, FlexibleContexts, ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Assistant.WebApp.Types where
+module Assistant.WebApp.Types (
+	module Assistant.WebApp.Types,
+	Route
+) where
 
 import Assistant.Common
 import Assistant.Ssh
 import Assistant.Pairing
 import Utility.NotificationBroadcaster
+import Utility.AuthToken
 import Utility.WebApp
 import Utility.Yesod
 import Types.Transfer

Backend/Utilities.hs

@@ -10,6 +10,7 @@ module Backend.Utilities where
 import Data.Hash.MD5
 
 import Annex.Common
+import Utility.FileSystemEncoding
 
 {- Generates a keyName from an input string. Takes care of sanitizing it.
  - If it's not too long, the full string is used as the keyName.

Build/DistributionUpdate.hs

@@ -14,6 +14,7 @@ import Build.Version (getChangelogVersion, Version)
 import Utility.UserInfo
 import Utility.Url
 import Utility.Tmp
+import Utility.FileSystemEncoding
 import qualified Git.Construct
 import qualified Annex
 import Annex.Content
@@ -50,6 +51,7 @@ autobuilds =
 
 main :: IO ()
 main = do
+	useFileSystemEncoding
 	version <- liftIO getChangelogVersion
 	repodir <- getRepoDir
 	changeWorkingDirectory repodir

Build/EvilSplicer.hs

@@ -210,7 +210,6 @@ applySplices destdir imports splices@(first:_) = do
 	when (oldcontent /= Just newcontent) $ do
 		putStrLn $ "splicing " ++ f
 		withFile dest WriteMode $ \h -> do
-		        fileEncoding h
 			hPutStr h newcontent
 		        hClose h
   where
@@ -474,7 +473,7 @@ mangleCode = flip_colon
 	 -
 	 - To fix, we could just put a semicolon at the start of every line
 	 - containing " -> " ... Except that lambdas also contain that.
-	 - But we can get around that: GHC outputs lambas like this:
+	 - But we can get around that: GHC outputs lambdas like this:
 	 -
 	 - \ foo
 	 -   -> bar
@@ -487,7 +486,7 @@ mangleCode = flip_colon
 	 - containing " -> " unless there's a "\ " first, or it's
 	 - all whitespace up until it.
 	 -}
-	case_layout = parsecAndReplace $ do
+	case_layout = skipfree $ parsecAndReplace $ do
 		void newline
 		indent1 <- many1 $ char ' '
 		prefix <- manyTill (noneOf "\n") (try (string "-> "))
@@ -508,7 +507,7 @@ mangleCode = flip_colon
 	 -        var var
 	 -   -> foo
 	 -}
-	case_layout_multiline = parsecAndReplace $ do
+	case_layout_multiline = skipfree $ parsecAndReplace $ do
 		void newline
 		indent1 <- many1 $ char ' '
 		firstline <- restofline
@@ -521,6 +520,11 @@ mangleCode = flip_colon
 			else return $ "\n" ++ indent1 ++ "; " ++ firstline ++ "\n"
 				++ indent1 ++ indent2 ++ "-> "
 
+	{- Type definitions for free monads triggers the case_* hacks, avoid. -}
+	skipfree f s
+		| "MonadFree" `isInfixOf` s = s
+		| otherwise = f s
+
 	{- (foo, \ -> bar) is not valid haskell, GHC.
 	 - Change to (foo, bar)
 	 -
@@ -716,7 +720,9 @@ parsecAndReplace p s = case parse find "" s of
 	find = many $ try (Right <$> p) <|> (Left <$> anyChar)
 
 main :: IO ()
-main = go =<< getArgs
+main = do
+	useFileSystemEncoding
+	go =<< getArgs
   where
 	go (destdir:log:header:[]) = run destdir log (Just header)
 	go (destdir:log:[]) = run destdir log Nothing

Build/LinuxMkLibs.hs

@@ -70,7 +70,6 @@ installLinkerShim top linker exe = do
 			-- Assume that for a symlink, the destination
 			-- will also be shimmed.
 			let sl' = ".." </> takeFileName sl </> takeFileName sl
-			print (sl', exedest)
 			createSymbolicLink sl' exedest
 		, renameFile exe exedest
 		)

Build/Mans.hs

@@ -50,8 +50,11 @@ buildMans = do
 			else return (Just dest)
 
 isManSrc :: FilePath -> Bool
-isManSrc s = "git-annex" `isPrefixOf` (takeFileName s)
+isManSrc s
-	&& takeExtension s == ".mdwn"
+	| not (takeExtension s == ".mdwn") = False
+	| otherwise = "git-annex" `isPrefixOf` f || "git-remote-" `isPrefixOf` f
+  where
+	f = takeFileName s
 
 srcToDest :: FilePath -> FilePath
 srcToDest s = "man" </> progName s ++ ".1"

CHANGELOG

@@ -1,3 +1,91 @@
+git-annex (6.20161211) UNRELEASED; urgency=medium
+
+  * p2p --pair makes it easy to pair repositories over P2P, using
+    Magic Wormhole codes to find the other repository.
+  * metadata --batch: Fix bug when conflicting metadata changes were
+    made in the same batch run.
+  * Pass annex.web-options to wget and curl after other options, so that
+    eg --no-show-progress can be set by the user to disable the default
+    --show-progress.
+  * Revert ServerAliveInterval change in 6.20161111, which caused problems
+    with too many old versions of ssh and unusual ssh configurations.
+    It should have not been needed anyway since ssh is supposted to
+    have TCPKeepAlive enabled by default.
+  * Make all --batch input, as well as fromkey and registerurl stdin
+    be processed without requiring it to be in the current encoding.
+  * p2p: --link no longer takes a remote name, instead the --name
+    option can be used.
+  * Linux standalone: Improve generation of locale definition files,
+    supporting locales such as, en_GB.UTF-8.
+  * rekey --force: Incorrectly marked the new key's content as being
+    present in the local repo even when it was not.
+  * enable-tor: Put tor sockets in /var/lib/tor-annex/, rather
+    than in /etc/tor/hidden_service/.
+  * enable-tor: No longer needs to be run as root.
+  * enable-tor: When run as a regular user, test a connection back to 
+    the hidden service over tor.
+  * Always use filesystem encoding for all file and handle reads and
+    writes.
+  * Fix build with directory-1.3.
+  * Debian: Suggest tor and magic-wormhole.
+  * Debian: Build webapp on armel.
+
+ -- Joey Hess <id@joeyh.name>  Sun, 11 Dec 2016 21:29:51 -0400
+
+git-annex (6.20161210) unstable; urgency=medium
+
+  * Linux standalone: Updated ghc to fix its "unable to decommit memory"
+    bug, which may have resulted in data loss when these builds were used
+    with Linux kernels older than 4.5.
+  * enable-tor: New command, enables tor hidden service for P2P syncing.
+  * p2p: New command, allows linking repositories using a P2P network.
+  * remotedaemon: Serve tor hidden service.
+  * Added git-remote-tor-annex, which allows git pull and push to the tor
+    hidden service.
+  * remotedaemon: Fork to background by default. Added --foreground switch
+    to enable old behavior.
+  * addurl: Fix bug in checking annex.largefiles expressions using
+    largerthan, mimetype, and smallerthan; the first two always failed
+    to match, and the latter always matched.
+  * Relicense 5 source files that are not part of the webapp from AGPL to GPL.
+  * map: Run xdot if it's available in PATH. On OSX, the dot command
+    does not support graphical display, while xdot does.
+  * Debian: xdot is a better interactive viewer than dot, so Suggest
+    xdot, rather than graphviz.
+  * rmurl: Multiple pairs of files and urls can be provided on the
+    command line.
+  * rmurl: Added --batch mode.
+  * fromkey: Accept multiple pairs of files and keys.
+    Thanks, Daniel Brooks.
+  * rekey: Added --batch mode.
+  * add: Stage modified non-large files when running in indirect mode. 
+    (This was already done in v6 mode and direct mode.)
+  * git-annex-shell, remotedaemon, git remote: Fix some memory DOS attacks.
+  * Fix build with http-client 0.5.
+    Thanks, Alper Nebi Yasak.
+
+ -- Joey Hess <id@joeyh.name>  Sat, 10 Dec 2016 11:56:25 -0400
+
+git-annex (6.20161118) unstable; urgency=medium
+
+  * git-annex.cabal: Loosen bounds on persistent to allow 2.5, which
+    on Debian has been patched to work with esqueleto.
+    This may break cabal's resolver on non-Debian systems;
+    if so, either use stack to build, or run cabal with 
+    --constraint='persistent ==2.2.4.1'
+    Hopefully this mess with esqueleto will be resolved soon.
+  * sync: Pass --allow-unrelated-histories to git merge when used with git
+    git 2.9.0 or newer. This makes merging a remote into a freshly created
+    direct mode repository work the same as it works in indirect mode.
+  * Avoid backtraces on expected failures when built with ghc 8;
+    only use backtraces for unexpected errors.
+  * fsck --all --from was checking the existence and content of files
+    in the local repository, rather than on the special remote. Oops.
+  * Linux arm standalone: Build with a 32kb page size, which is needed
+    on several ARM NAS devices, including Drobo 5N, and WD NAS.
+
+ -- Joey Hess <id@joeyh.name>  Fri, 18 Nov 2016 11:43:14 -0400
+
 git-annex (6.20161111) unstable; urgency=medium
 
   * Restarting a crashing git process could result in filename encoding

CmdLine/Action.hs

@@ -38,7 +38,7 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
 	showerrcount =<< Annex.getState Annex.errcounter
   where
 	showerrcount 0 = noop
-	showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed"
+	showerrcount cnt = giveup $ name ++ ": " ++ show cnt ++ " failed"
 
 {- Runs one of the actions needed to perform a command.
  - Individual actions can fail without stopping the whole command,

CmdLine/Batch.hs

@@ -48,15 +48,16 @@ batchBadInput Batch = liftIO $ putStrLn ""
 
 -- Reads lines of batch mode input and passes to the action to handle.
 batchInput :: (String -> Either String a) -> (a -> Annex ()) -> Annex ()
-batchInput parser a = do
+batchInput parser a = go =<< batchLines
-	mp <- liftIO $ catchMaybeIO getLine
-	case mp of
-		Nothing -> return ()
-		Just v -> do
-			either parseerr a (parser v)
-			batchInput parser a
   where
-	parseerr s = error $ "Batch input parse failure: " ++ s
+	go [] = return ()
+	go (l:rest) = do
+		either parseerr a (parser l)
+		go rest
+	parseerr s = giveup $ "Batch input parse failure: " ++ s
+
+batchLines :: Annex [String]
+batchLines = liftIO $ lines <$> getContents
 
 -- Runs a CommandStart in batch mode.
 --

CmdLine/GitAnnex.hs

@@ -52,6 +52,7 @@ import qualified Command.Init
 import qualified Command.Describe
 import qualified Command.InitRemote
 import qualified Command.EnableRemote
+import qualified Command.EnableTor
 import qualified Command.Expire
 import qualified Command.Repair
 import qualified Command.Unused
@@ -95,18 +96,19 @@ import qualified Command.Direct
 import qualified Command.Indirect
 import qualified Command.Upgrade
 import qualified Command.Forget
+import qualified Command.P2P
 import qualified Command.Proxy
 import qualified Command.DiffDriver
 import qualified Command.Smudge
 import qualified Command.Undo
 import qualified Command.Version
+import qualified Command.RemoteDaemon
 #ifdef WITH_ASSISTANT
 import qualified Command.Watch
 import qualified Command.Assistant
 #ifdef WITH_WEBAPP
 import qualified Command.WebApp
 #endif
-import qualified Command.RemoteDaemon
 #endif
 import qualified Command.Test
 #ifdef WITH_TESTSUITE
@@ -139,6 +141,7 @@ cmds testoptparser testrunner =
 	, Command.Describe.cmd
 	, Command.InitRemote.cmd
 	, Command.EnableRemote.cmd
+	, Command.EnableTor.cmd
 	, Command.Reinject.cmd
 	, Command.Unannex.cmd
 	, Command.Uninit.cmd
@@ -199,18 +202,19 @@ cmds testoptparser testrunner =
 	, Command.Indirect.cmd
 	, Command.Upgrade.cmd
 	, Command.Forget.cmd
+	, Command.P2P.cmd
 	, Command.Proxy.cmd
 	, Command.DiffDriver.cmd
 	, Command.Smudge.cmd
 	, Command.Undo.cmd
 	, Command.Version.cmd
+	, Command.RemoteDaemon.cmd
 #ifdef WITH_ASSISTANT
 	, Command.Watch.cmd
 	, Command.Assistant.cmd
 #ifdef WITH_WEBAPP
 	, Command.WebApp.cmd
 #endif
-	, Command.RemoteDaemon.cmd
 #endif
 	, Command.Test.cmd testoptparser testrunner
 #ifdef WITH_TESTSUITE

CmdLine/GitAnnexShell.hs

@@ -71,7 +71,7 @@ globalOptions =
 		check Nothing = unexpected expected "uninitialized repository"
 		check (Just u) = unexpectedUUID expected u
 	unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u
-	unexpected expected s = error $
+	unexpected expected s = giveup $
 		"expected repository UUID " ++ expected ++ " but found " ++ s
 
 run :: [String] -> IO ()
@@ -109,7 +109,7 @@ builtin cmd dir params = do
 		Git.Config.read r
 			`catchIO` \_ -> do
 				hn <- fromMaybe "unknown" <$> getHostname
-				error $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
+				giveup $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
 
 external :: [String] -> IO ()
 external params = do
@@ -120,7 +120,7 @@ external params = do
 	checkDirectory lastparam
 	checkNotLimited
 	unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $
-		error "git-shell failed"
+		giveup "git-shell failed"
 
 {- Split the input list into 3 groups separated with a double dash --.
  - Parameters between two -- markers are field settings, in the form:
@@ -150,6 +150,6 @@ checkField (field, val)
 	| otherwise = False
 
 failure :: IO ()
-failure = error $ "bad parameters\n\n" ++ usage h cmds
+failure = giveup $ "bad parameters\n\n" ++ usage h cmds
   where
 	h = "git-annex-shell [-c] command [parameters ...] [option ...]"

CmdLine/GitAnnexShell/Checks.hs

@@ -26,7 +26,7 @@ checkEnv var = do
 	case v of
 		Nothing -> noop
 		Just "" -> noop
-		Just _ -> error $ "Action blocked by " ++ var
+		Just _ -> giveup $ "Action blocked by " ++ var
 
 checkDirectory :: Maybe FilePath -> IO ()
 checkDirectory mdir = do
@@ -44,7 +44,7 @@ checkDirectory mdir = do
 					then noop
 					else req d' (Just dir')
   where
-	req d mdir' = error $ unwords 
+	req d mdir' = giveup $ unwords 
 		[ "Only allowed to access"
 		, d
 		, maybe "and could not determine directory from command line" ("not " ++) mdir'
@@ -64,4 +64,4 @@ gitAnnexShellCheck :: Command -> Command
 gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
   where
 	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
-		error "Not a git-annex or gcrypt repository."
+		giveup "Not a git-annex or gcrypt repository."

CmdLine/GitRemoteTorAnnex.hs

@@ -0,0 +1,66 @@
+{- git-remote-tor-annex program
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module CmdLine.GitRemoteTorAnnex where
+
+import Common
+import qualified Annex
+import qualified Git.CurrentRepo
+import P2P.Protocol
+import P2P.IO
+import Utility.Tor
+import Utility.AuthToken
+import Annex.UUID
+import P2P.Address
+import P2P.Auth
+
+run :: [String] -> IO ()
+run (_remotename:address:[]) = forever $ do
+	-- gitremote-helpers protocol
+	l <- getLine
+	case l of
+		"capabilities" -> putStrLn "connect" >> ready
+		"connect git-upload-pack" -> go UploadPack
+		"connect git-receive-pack" -> go ReceivePack
+		_ -> error $ "git-remote-helpers protocol error at " ++ show l
+  where
+	(onionaddress, onionport)
+		| '/' `elem` address = parseAddressPort $
+			reverse $ takeWhile (/= '/') $ reverse address
+		| otherwise = parseAddressPort address
+	go service = do
+		ready
+		either giveup exitWith
+			=<< connectService onionaddress onionport service
+	ready = do
+		putStrLn ""
+		hFlush stdout
+		
+run (_remotename:[]) = giveup "remote address not configured"
+run _ = giveup "expected remote name and address parameters"
+
+parseAddressPort :: String -> (OnionAddress, OnionPort)
+parseAddressPort s = 
+	let (a, sp) = separate (== ':') s
+	in case readish sp of
+		Nothing -> giveup "onion address must include port number"
+		Just p -> (OnionAddress a, p)
+
+connectService :: OnionAddress -> OnionPort -> Service -> IO (Either String ExitCode)
+connectService address port service = do
+	state <- Annex.new =<< Git.CurrentRepo.get
+	Annex.eval state $ do
+		authtoken <- fromMaybe nullAuthToken
+			<$> loadP2PRemoteAuthToken (TorAnnex address port)
+		myuuid <- getUUID
+		g <- Annex.gitRepo
+		conn <- liftIO $ connectPeer g (TorAnnex address port)
+		liftIO $ runNetProto conn $ do
+			v <- auth myuuid authtoken
+			case v of
+				Just _theiruuid -> connect service stdin stdout
+				Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv

CmdLine/Seek.hs

@@ -40,7 +40,7 @@ withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> CmdParams
 withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force)
 	( withFilesInGit a params
 	, if null params
-		then error needforce
+		then giveup needforce
 		else seekActions $ prepFiltered a (getfiles [] params)
 	)
   where
@@ -54,7 +54,7 @@ withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force)
 			[] -> do
 				void $ liftIO $ cleanup
 				getfiles c ps
-			_ -> error needforce
+			_ -> giveup needforce
 
 withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
 withFilesNotInGit skipdotfiles a params
@@ -117,7 +117,7 @@ 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"
+	pairs _ _ = giveup "expected pairs"
 
 withFilesToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
 withFilesToBeCommitted a params = seekActions $ prepFiltered a $
@@ -152,11 +152,11 @@ withFilesMaybeModified a params = seekActions $
 withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek
 withKeys a params = seekActions $ return $ map (a . parse) params
   where
-	parse p = fromMaybe (error "bad key") $ file2key p
+	parse p = fromMaybe (giveup "bad key") $ file2key p
 
 withNothing :: CommandStart -> CmdParams -> CommandSeek
 withNothing a [] = seekActions $ return [a]
-withNothing _ _ = error "This command takes no parameters."
+withNothing _ _ = giveup "This command takes no parameters."
 
 {- Handles the --all, --branch, --unused, --failed, --key, and
  - --incomplete options, which specify particular keys to run an
@@ -191,7 +191,7 @@ withKeyOptions'
 withKeyOptions' ko auto mkkeyaction fallbackaction params = do
 	bare <- fromRepo Git.repoIsLocalBare
 	when (auto && bare) $
-		error "Cannot use --auto in a bare repository"
+		giveup "Cannot use --auto in a bare repository"
 	case (null params, ko) of
 		(True, Nothing)
 			| bare -> noauto $ runkeyaction loggedKeys
@@ -203,10 +203,10 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do
 		(True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k])
 		(True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys
 		(True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs
-		(False, Just _) -> error "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete"
+		(False, Just _) -> giveup "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete"
   where
 	noauto a
-		| auto = error "Cannot use --auto with --all or --branch or --unused or --key or --incomplete"
+		| auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete"
 		| otherwise = a
 	incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True
 	runkeyaction getks = do

Command.hs

@@ -101,15 +101,15 @@ repoExists = CommandCheck 0 ensureInitialized
 
 notDirect :: Command -> Command
 notDirect = addCheck $ whenM isDirect $
-	error "You cannot run this command in a direct mode repository."
+	giveup "You cannot run this command in a direct mode repository."
 
 notBareRepo :: Command -> Command
 notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $
-	error "You cannot run this command in a bare repository."
+	giveup "You cannot run this command in a bare repository."
 
 noDaemonRunning :: Command -> Command
 noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
-	error "You cannot run this command while git-annex watch or git-annex assistant is running."
+	giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
   where
 	daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile
 

Command/Add.hs

@@ -41,9 +41,6 @@ optParser desc = AddOptions
 		)
 	<*> parseBatchOption
 
-{- 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 :: AddOptions -> CommandSeek
 seek o = allowConcurrentOutput $ do
 	matcher <- largeFilesMatcher
@@ -59,10 +56,9 @@ seek o = allowConcurrentOutput $ do
 		NoBatch -> do
 			let go a = a gofile (addThese o)
 			go (withFilesNotInGit (not $ includeDotFiles o))
-			ifM (versionSupportsUnlockedPointers <||> isDirect)
+			go withFilesMaybeModified
-				( go withFilesMaybeModified
+			unlessM (versionSupportsUnlockedPointers <||> isDirect) $
-				, go withFilesOldUnlocked
+				go withFilesOldUnlocked
-				)
 
 {- Pass file off to git-add. -}
 startSmall :: FilePath -> CommandStart

Command/AddUnused.hs

@@ -38,4 +38,4 @@ perform key = next $ do
  - it seems better to error out, rather than moving bad/tmp content into
  - the annex. -}
 performOther :: String -> Key -> CommandPerform
-performOther other _ = error $ "cannot addunused " ++ other ++ "content"
+performOther other _ = giveup $ "cannot addunused " ++ other ++ "content"

Command/AddUrl.hs

@@ -27,6 +27,7 @@ import Types.UrlContents
 import Annex.FileMatcher
 import Logs.Location
 import Utility.Metered
+import Utility.FileSystemEncoding
 import qualified Annex.Transfer as Transfer
 import Annex.Quvi
 import qualified Utility.Quvi as Quvi
@@ -133,7 +134,7 @@ checkUrl r o u = do
 				let f' = adjustFile o (deffile </> fromSafeFilePath f)
 				void $ commandAction $
 					startRemote r (relaxedOption o) f' u' sz
-		| otherwise = error $ unwords
+		| otherwise = giveup $ unwords
 			[ "That url contains multiple files according to the"
 			, Remote.name r
 			, " remote; cannot add it to a single file."
@@ -182,7 +183,7 @@ startWeb :: AddUrlOptions -> String -> CommandStart
 startWeb o s = go $ fromMaybe bad $ parseURI urlstring
   where
 	(urlstring, downloader) = getDownloader s
-	bad = fromMaybe (error $ "bad url " ++ urlstring) $
+	bad = fromMaybe (giveup $ "bad url " ++ urlstring) $
 		Url.parseURIRelaxed $ urlstring
 	go url = case downloader of
 		QuviDownloader -> usequvi
@@ -208,7 +209,7 @@ startWeb o s = go $ fromMaybe bad $ parseURI urlstring
 						)
 		showStart "addurl" file
 		next $ performWeb (relaxedOption o) urlstring file urlinfo
-	badquvi = error $ "quvi does not know how to download url " ++ urlstring
+	badquvi = giveup $ "quvi does not know how to download url " ++ urlstring
 	usequvi = do
 		page <- fromMaybe badquvi
 			<$> withQuviOptions Quvi.forceQuery [Quvi.quiet, Quvi.httponly] urlstring
@@ -340,13 +341,18 @@ cleanup :: UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()
 cleanup u url file key mtmp = case mtmp of
 	Nothing -> go
 	Just tmp -> do
+		-- Move to final location for large file check.
+		liftIO $ renameFile tmp file
 		largematcher <- largeFilesMatcher
-		ifM (checkFileMatcher largematcher file)
+		large <- checkFileMatcher largematcher file
-			( go
+		if large
-			, do
+			then do
-				liftIO $ renameFile tmp file
+				-- Move back to tmp because addAnnexedFile
-				void $ Command.Add.addSmall file
+				-- needs the file in a different location
-			)
+				-- than the work tree file.
+				liftIO $ renameFile file tmp
+				go
+			else void $ Command.Add.addSmall file
   where
 	go = do
 		maybeShowJSON $ JSONChunk [("key", key2file key)]
@@ -372,7 +378,7 @@ url2file url pathdepth pathmax = case pathdepth of
 		| depth >= length urlbits -> frombits id
 		| depth > 0 -> frombits $ drop depth
 		| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
-		| otherwise -> error "bad --pathdepth"
+		| otherwise -> giveup "bad --pathdepth"
   where
 	fullurl = concat
 		[ maybe "" uriRegName (uriAuthority url)
@@ -385,7 +391,7 @@ url2file url pathdepth pathmax = case pathdepth of
 
 urlString2file :: URLString -> Maybe Int -> Int -> FilePath
 urlString2file s pathdepth pathmax = case Url.parseURIRelaxed s of
-	Nothing -> error $ "bad uri " ++ s
+	Nothing -> giveup $ "bad uri " ++ s
 	Just u -> url2file u pathdepth pathmax
 
 adjustFile :: AddUrlOptions -> FilePath -> FilePath

Command/Assistant.hs

@@ -66,14 +66,14 @@ startNoRepo :: AssistantOptions -> IO ()
 startNoRepo o
 	| autoStartOption o = autoStart o
 	| autoStopOption o = autoStop
-	| otherwise = error "Not in a git repository."
+	| otherwise = giveup "Not in a git repository."
 
 autoStart :: AssistantOptions -> IO ()
 autoStart o = do
 	dirs <- liftIO readAutoStartFile
 	when (null dirs) $ do
 		f <- autoStartFile
-		error $ "Nothing listed in " ++ f
+		giveup $ "Nothing listed in " ++ f
 	program <- programPath
 	haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice"
 	forM_ dirs $ \d -> do

Command/CheckPresentKey.hs

@@ -40,7 +40,7 @@ seek o = case batchOption o of
 			_ -> wrongnumparams
 		batchInput Right $ checker >=> batchResult
   where
-	wrongnumparams = error "Wrong number of parameters"
+	wrongnumparams = giveup "Wrong number of parameters"
 					
 data Result = Present | NotPresent | CheckFailure String
 
@@ -71,8 +71,8 @@ batchResult Present = liftIO $ putStrLn "1"
 batchResult _ = liftIO $ putStrLn "0"
 
 toKey :: String -> Key
-toKey = fromMaybe (error "Bad key") . file2key
+toKey = fromMaybe (giveup "Bad key") . file2key
 
 toRemote :: String -> Annex Remote
-toRemote rn = maybe (error "Unknown remote") return
+toRemote rn = maybe (giveup "Unknown remote") return
 	=<< Remote.byNameWithUUID (Just rn)

Command/ContentLocation.hs

@@ -19,7 +19,7 @@ cmd = noCommit $ noMessages $
 
 run :: () -> String -> Annex Bool
 run _ p = do
-	let k = fromMaybe (error "bad key") $ file2key p
+	let k = fromMaybe (giveup "bad key") $ file2key p
 	maybe (return False) (\f -> liftIO (putStrLn f) >> return True)
 		=<< inAnnex' (pure True) Nothing check k
   where

Command/Dead.hs

@@ -37,7 +37,7 @@ startKey key = do
 	ls <- keyLocations key
 	case ls of
 		[] -> next $ performKey key
-		_ -> error "This key is still known to be present in some locations; not marking as dead."
+		_ -> giveup "This key is still known to be present in some locations; not marking as dead."
 		
 performKey :: Key -> CommandPerform
 performKey key = do

Command/Describe.hs

@@ -25,7 +25,7 @@ start (name:description) = do
 	showStart "describe" name
 	u <- Remote.nameToUUID name
 	next $ perform u $ unwords description
-start _ = error "Specify a repository and a description."	
+start _ = giveup "Specify a repository and a description."	
 
 perform :: UUID -> String -> CommandPerform
 perform u description = do

Command/DiffDriver.hs

@@ -73,7 +73,7 @@ parseReq opts = case separate (== "--") opts of
 	mk (unmergedpath:[]) = UnmergedReq { rPath = unmergedpath }
 	mk _ = badopts
 
-	badopts = error $ "Unexpected input: " ++ unwords opts
+	badopts = giveup $ "Unexpected input: " ++ unwords opts
 
 {- Check if either file is a symlink to a git-annex object,
  - which git-diff will leave as a normal file containing the link text.

Command/Direct.hs

@@ -26,7 +26,7 @@ seek = withNothing start
 start :: CommandStart
 start = ifM versionSupportsDirectMode
 	( ifM isDirect ( stop , next perform )
-	, error "Direct mode is not suppported by this repository version. Use git-annex unlock instead."
+	, giveup "Direct mode is not suppported by this repository version. Use git-annex unlock instead."
 	)
 
 perform :: CommandPerform

Command/DropKey.hs

@@ -32,7 +32,7 @@ optParser desc = DropKeyOptions
 seek :: DropKeyOptions -> CommandSeek
 seek o = do
 	unlessM (Annex.getState Annex.force) $
-		error "dropkey can cause data loss; use --force if you're sure you want to do this"
+		giveup "dropkey can cause data loss; use --force if you're sure you want to do this"
 	withKeys start (toDrop o)
 	case batchOption o of
 		Batch -> batchInput parsekey $ batchCommandAction . start

Command/EnableRemote.hs

@@ -12,6 +12,7 @@ import qualified Annex
 import qualified Logs.Remote
 import qualified Types.Remote as R
 import qualified Git
+import qualified Git.Types as Git
 import qualified Annex.SpecialRemote
 import qualified Remote
 import qualified Types.Remote as Remote
@@ -40,9 +41,7 @@ start (name:rest) = go =<< filter matchingname <$> Annex.fromRepo Git.remotes
 		=<< Annex.SpecialRemote.findExisting name
 	go (r:_) = startNormalRemote name r
 
-type RemoteName = String
+startNormalRemote :: Git.RemoteName -> Git.Repo -> CommandStart
-
-startNormalRemote :: RemoteName -> Git.Repo -> CommandStart
 startNormalRemote name r = do
 	showStart "enableremote" name
 	next $ next $ do
@@ -51,7 +50,7 @@ startNormalRemote name r = do
 		u <- getRepoUUID r'
 		return $ u /= NoUUID
 
-startSpecialRemote :: RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart
+startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart
 startSpecialRemote name config Nothing = do
 	m <- Annex.SpecialRemote.specialRemoteMap
 	confm <- Logs.Remote.readRemoteLog
@@ -63,7 +62,7 @@ startSpecialRemote name config Nothing = do
 		_ -> unknownNameError "Unknown remote name."
 startSpecialRemote name config (Just (u, c)) = do
 	let fullconfig = config `M.union` c	
-	t <- either error return (Annex.SpecialRemote.findType fullconfig)
+	t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
 	showStart "enableremote" name
 	gc <- maybe def Remote.gitconfig <$> Remote.byUUID u
 	next $ performSpecialRemote t u fullconfig gc
@@ -94,7 +93,7 @@ unknownNameError prefix = do
 	disabledremotes <- filterM isdisabled =<< Annex.fromRepo Git.remotes
 	let remotesmsg = unlines $ map ("\t" ++) $
 		mapMaybe Git.remoteName disabledremotes
-	error $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
+	giveup $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
   where
 	isdisabled r = anyM id
 		[ (==) NoUUID <$> getRepoUUID r

Command/EnableTor.hs

@@ -0,0 +1,130 @@
+{- git-annex command
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.EnableTor where
+
+import Command
+import qualified Annex
+import P2P.Address
+import Utility.Tor
+import Annex.UUID
+import Config.Files
+import P2P.IO
+import qualified P2P.Protocol as P2P
+import Utility.ThreadScheduler
+
+import Control.Concurrent.Async
+import qualified Network.Socket as S
+#ifndef mingw32_HOST_OS
+import Utility.Su
+import System.Posix.User
+#endif
+
+cmd :: Command
+cmd = noCommit $ dontCheck repoExists $
+	command "enable-tor" SectionSetup "enable tor hidden service"
+		"uid" (withParams seek)
+
+seek :: CmdParams -> CommandSeek
+seek = withWords start
+
+-- This runs as root, so avoid making any commits or initializing
+-- git-annex, or doing other things that create root-owned files.
+start :: [String] -> CommandStart
+start os = do
+	uuid <- getUUID
+	when (uuid == NoUUID) $
+		giveup "This can only be run in a git-annex repository."
+#ifndef mingw32_HOST_OS
+	curruserid <- liftIO getEffectiveUserID
+	if curruserid == 0
+		then case readish =<< headMaybe os of
+			Nothing -> giveup "Need user-id parameter."
+			Just userid -> go uuid userid
+		else do
+			showStart "enable-tor" ""
+			showLongNote "Need root access to enable tor..."
+			gitannex <- liftIO readProgramFile
+			let ps = [Param (cmdname cmd), Param (show curruserid)]
+			ifM (liftIO $ runAsRoot gitannex ps)
+				( next $ next checkHiddenService
+				, giveup $ unwords $
+					[ "Failed to run as root:" , gitannex ] ++ toCommand ps
+				)
+#else
+	go uuid 0
+#endif
+  where
+	go uuid userid = do
+		(onionaddr, onionport) <- liftIO $
+			addHiddenService torAppName userid (fromUUID uuid)
+		storeP2PAddress $ TorAnnex onionaddr onionport
+		stop
+
+checkHiddenService :: CommandCleanup
+checkHiddenService = bracket setup cleanup go
+  where
+	setup = do
+		showLongNote "Tor hidden service is configured. Checking connection to it. This may take a few minutes."
+		startlistener
+	
+	cleanup = liftIO . cancel
+	
+	go _ = check (150 :: Int) =<< filter istoraddr <$> loadP2PAddresses
+	
+	istoraddr (TorAnnex _ _) = True
+
+	check 0 _ = giveup "Still unable to connect to hidden service. It might not yet be usable by others. Please check Tor's logs for details."
+	check _ [] = giveup "Somehow didn't get an onion address."
+	check n addrs@(addr:_) = do
+		g <- Annex.gitRepo
+		-- Connect but don't bother trying to auth,
+		-- we just want to know if the tor circuit works.
+		cv <- liftIO $ tryNonAsync $ connectPeer g addr
+		case cv of
+			Left e -> do
+				warning $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.."
+				liftIO $ threadDelaySeconds (Seconds 2)
+				check (n-1) addrs
+			Right conn -> do
+				liftIO $ closeConnection conn
+				showLongNote "Tor hidden service is working."
+				return True
+	
+	-- Unless the remotedaemon is already listening on the hidden
+	-- service's socket, start a listener. This is only run during the
+	-- check, and it refuses all auth attempts.
+	startlistener = do
+		r <- Annex.gitRepo
+		u <- getUUID
+		uid <- liftIO getRealUserID
+		let ident = fromUUID u
+		v <- liftIO $ getHiddenServiceSocketFile torAppName uid ident
+		case v of
+			Just sockfile -> ifM (liftIO $ haslistener sockfile)
+				( liftIO $ async $ return ()
+				, liftIO $ async $ runlistener sockfile u r
+				)
+			Nothing -> giveup "Could not find socket file in Tor configuration!"
+	
+	runlistener sockfile u r = serveUnixSocket sockfile $ \h -> do
+		let conn = P2PConnection
+			{ connRepo = r
+			, connCheckAuth = const False
+			, connIhdl = h
+			, connOhdl = h
+			}
+		void $ runNetProto conn $ P2P.serveAuth u
+		hClose h
+
+	haslistener sockfile = catchBoolIO $ do
+		soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
+		S.connect soc (S.SockAddrUnix sockfile)
+		S.close soc
+		return True

Command/ExamineKey.hs

@@ -21,6 +21,6 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $
 
 run :: Maybe Utility.Format.Format -> String -> Annex Bool
 run format p = do
-	let k = fromMaybe (error "bad key") $ file2key p
+	let k = fromMaybe (giveup "bad key") $ file2key p
 	showFormatted format (key2file k) (keyVars k)
 	return True

Command/Expire.hs

@@ -92,7 +92,7 @@ start (Expire expire) noact actlog descs u =
 data Expire = Expire (M.Map (Maybe UUID) (Maybe POSIXTime))
 
 parseExpire :: [String] -> Annex Expire
-parseExpire [] = error "Specify an expire time."
+parseExpire [] = giveup "Specify an expire time."
 parseExpire ps = do
 	now <- liftIO getPOSIXTime
 	Expire . M.fromList <$> mapM (parse now) ps
@@ -104,7 +104,7 @@ parseExpire ps = do
 			return (Just r, parsetime now t)
 	parsetime _ "never" = Nothing
 	parsetime now s = case parseDuration s of
-		Nothing -> error $ "bad expire time: " ++ s
+		Nothing -> giveup $ "bad expire time: " ++ s
 		Just d -> Just (now - durationToPOSIXTime d)
 
 parseActivity :: Monad m => String -> m Activity

Command/FromKey.hs

@@ -20,30 +20,32 @@ import Network.URI
 cmd :: Command
 cmd = notDirect $ notBareRepo $
 	command "fromkey" SectionPlumbing "adds a file using a specific key"
-		(paramPair paramKey paramPath)
+		(paramRepeating (paramPair paramKey paramPath))
 		(withParams seek)
 
 seek :: CmdParams -> CommandSeek
+seek [] = withNothing startMass []
 seek ps = do
 	force <- Annex.getState Annex.force
-	withWords (start force) ps
+	withPairs (start force) ps
 
-start :: Bool -> [String] -> CommandStart
+start :: Bool -> (String, FilePath) -> CommandStart
-start force (keyname:file:[]) = do
+start force (keyname, file) = do
 	let key = mkKey keyname
 	unless force $ do
 		inbackend <- inAnnex key
-		unless inbackend $ error $
+		unless inbackend $ giveup $
 			"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
 	showStart "fromkey" file
 	next $ perform key file
-start _ [] = do
+
+startMass :: CommandStart
+startMass = do
 	showStart "fromkey" "stdin"
 	next massAdd
-start _ _ = error "specify a key and a dest file"
 
 massAdd :: CommandPerform
-massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
+massAdd = go True =<< map (separate (== ' ')) <$> batchLines
   where
 	go status [] = next $ return status
 	go status ((keyname,f):rest) | not (null keyname) && not (null f) = do
@@ -51,7 +53,7 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
 		ok <- perform' key f
 		let !status' = status && ok
 		go status' rest
-	go _ _ = error "Expected pairs of key and file on stdin, but got something else."
+	go _ _ = giveup "Expected pairs of key and file on stdin, but got something else."
 
 -- From user input to a Key.
 -- User can input either a serialized key, or an url.
@@ -66,7 +68,7 @@ mkKey s = case parseURI s of
 		Backend.URL.fromUrl s Nothing
 	_ -> case file2key s of
 		Just k -> k
-		Nothing -> error $ "bad key/url " ++ s
+		Nothing -> giveup $ "bad key/url " ++ s
 
 perform :: Key -> FilePath -> CommandPerform
 perform key file = do

Command/Fsck.hs

@@ -89,7 +89,7 @@ seek o = allowConcurrentOutput $ do
 	checkDeadRepo u
 	i <- prepIncremental u (incrementalOpt o)
 	withKeyOptions (keyOptions o) False
-		(\k ai -> startKey i k ai =<< getNumCopies)
+		(\k ai -> startKey from i k ai =<< getNumCopies)
 		(withFilesInGit $ whenAnnexed $ start from i)
 		(fsckFiles o)
 	cleanupIncremental i
@@ -109,7 +109,7 @@ start from inc file key = do
 			numcopies <- getFileNumCopies file
 			case from of
 				Nothing -> go $ perform key file backend numcopies
-				Just r -> go $ performRemote key file backend numcopies r
+				Just r -> go $ performRemote key (Just file) backend numcopies r
   where
 	go = runFsck inc (mkActionItem (Just file)) key
 
@@ -129,8 +129,8 @@ perform key file backend numcopies = do
 
 {- To fsck a remote, the content is retrieved to a tmp file,
  - and checked locally. -}
-performRemote :: Key -> FilePath -> Backend -> NumCopies -> Remote -> Annex Bool
+performRemote :: Key -> AssociatedFile -> Backend -> NumCopies -> Remote -> Annex Bool
-performRemote key file backend numcopies remote =
+performRemote key afile backend numcopies remote =
 	dispatch =<< Remote.hasKey remote key
   where
 	dispatch (Left err) = do
@@ -147,10 +147,10 @@ performRemote key file backend numcopies remote =
 				return False
 	dispatch (Right False) = go False Nothing
 	go present localcopy = check
-		[ verifyLocationLogRemote key file remote present
+		[ verifyLocationLogRemote key (maybe (key2file key) id afile) remote present
 		, checkKeySizeRemote key remote localcopy
 		, checkBackendRemote backend key remote localcopy
-		, checkKeyNumCopies key (Just file) numcopies
+		, checkKeyNumCopies key afile numcopies
 		]
 	withtmp a = do
 		pid <- liftIO getPID
@@ -161,7 +161,7 @@ performRemote key file backend numcopies remote =
 		cleanup
 		cleanup `after` a tmp
 	getfile tmp = ifM (checkDiskSpace (Just (takeDirectory tmp)) key 0 True)
-		( ifM (Remote.retrieveKeyFileCheap remote key (Just file) tmp)
+		( ifM (Remote.retrieveKeyFileCheap remote key afile tmp)
 			( return (Just True)
 			, ifM (Annex.getState Annex.fast)
 				( return Nothing
@@ -173,12 +173,14 @@ performRemote key file backend numcopies remote =
 		)
 	dummymeter _ = noop
 
-startKey :: Incremental -> Key -> ActionItem -> NumCopies -> CommandStart
+startKey :: Maybe Remote -> Incremental -> Key -> ActionItem -> NumCopies -> CommandStart
-startKey inc key ai numcopies =
+startKey from inc key ai numcopies =
 	case Backend.maybeLookupBackendName (keyBackendName key) of
 		Nothing -> stop
 		Just backend -> runFsck inc ai key $
-			performKey key backend numcopies
+			case from of
+				Nothing -> performKey key backend numcopies
+				Just r -> performRemote key Nothing backend numcopies r
 
 performKey :: Key -> Backend -> NumCopies -> Annex Bool
 performKey key backend numcopies = do
@@ -584,7 +586,7 @@ prepIncremental u (Just StartIncrementalO) = do
 	recordStartTime u
 	ifM (FsckDb.newPass u)
 		( StartIncremental <$> openFsckDb u
-		, error "Cannot start a new --incremental fsck pass; another fsck process is already running."
+		, giveup "Cannot start a new --incremental fsck pass; another fsck process is already running."
 		)
 prepIncremental u (Just MoreIncrementalO) =
 	ContIncremental <$> openFsckDb u

Command/FuzzTest.hs

@@ -39,7 +39,7 @@ start = do
 
 guardTest :: Annex ()
 guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
-	error $ unlines
+	giveup $ unlines
 		[ "Running fuzz tests *writes* to and *deletes* files in"
 		, "this repository, and pushes those changes to other"
 		, "repositories! This is a developer tool, not something"

Command/GCryptSetup.hs

@@ -25,7 +25,7 @@ start :: String -> CommandStart
 start gcryptid = next $ next $ do
 	u <- getUUID
 	when (u /= NoUUID) $
-		error "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
+		giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
 	
 	g <- gitRepo
 	gu <- Remote.GCrypt.getGCryptUUID True g
@@ -35,5 +35,5 @@ start gcryptid = next $ next $ do
 			then do
 				void $ Remote.GCrypt.setupRepo gcryptid g
 				return True
-			else error "cannot use gcrypt in a non-bare repository"
+			else giveup "cannot use gcrypt in a non-bare repository"
-		else error "gcryptsetup uuid mismatch"
+		else giveup "gcryptsetup uuid mismatch"

Command/Group.hs

@@ -30,7 +30,7 @@ start (name:[]) = do
 	u <- Remote.nameToUUID name
 	showRaw . unwords . S.toList =<< lookupGroups u
 	stop
-start _ = error "Specify a repository and a group."
+start _ = giveup "Specify a repository and a group."
 
 setGroup :: UUID -> Group -> CommandPerform
 setGroup uuid g = do

Command/GroupWanted.hs

@@ -25,4 +25,4 @@ start (g:[]) = next $ performGet groupPreferredContentMapRaw g
 start (g:expr:[]) = do
 	showStart "groupwanted" g
 	next $ performSet groupPreferredContentSet expr g
-start _ = error "Specify a group."
+start _ = giveup "Specify a group."

Command/Import.hs

@@ -62,7 +62,7 @@ seek o = allowConcurrentOutput $ do
 	repopath <- liftIO . absPath =<< fromRepo Git.repoPath
 	inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o)
 	unless (null inrepops) $ do
-		error $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
+		giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
 	largematcher <- largeFilesMatcher
 	withPathContents (start largematcher (duplicateMode o)) (importFiles o)
 

Command/ImportFeed.hs

@@ -138,23 +138,25 @@ findDownloads u = go =<< downloadFeed u
 			Just $ ToDownload f u i $ Enclosure enclosureurl
 		Nothing -> mkquvi f i
 	mkquvi f i = case getItemLink i of
-		Just link -> ifM (quviSupported link)
+		Just link -> do
-			( return $ Just $ ToDownload f u i $ QuviLink link
+			liftIO $ print ("link", link)
-			, return Nothing
+			ifM (quviSupported link)
-			)
+				( return $ Just $ ToDownload f u i $ QuviLink link
+				, return Nothing
+				)
 		Nothing -> return Nothing
 
 {- Feeds change, so a feed download cannot be resumed. -}
 downloadFeed :: URLString -> Annex (Maybe Feed)
 downloadFeed url
-	| Url.parseURIRelaxed url == Nothing = error "invalid feed url"
+	| Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"
 	| otherwise = do
 		showOutput
 		uo <- Url.getUrlOptions
 		liftIO $ withTmpFile "feed" $ \f h -> do
 			hClose h
 			ifM (Url.download url f uo)
-				( parseFeedString <$> readFileStrictAnyEncoding f
+				( parseFeedString <$> readFileStrict f
 				, return Nothing
 				)
 
@@ -336,7 +338,7 @@ noneValue = "none"
  - Throws an error if the feed is broken, otherwise shows a warning. -}
 feedProblem :: URLString -> String -> Annex ()
 feedProblem url message = ifM (checkFeedBroken url)
-	( error $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
+	( giveup $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
 	, warning $ "warning: " ++ message
 	)
 

Command/Indirect.hs

@@ -33,9 +33,9 @@ start :: CommandStart
 start = ifM isDirect
 	( do
 		unlessM (coreSymlinks <$> Annex.getGitConfig) $
-			error "Git is configured to not use symlinks, so you must use direct mode."
+			giveup "Git is configured to not use symlinks, so you must use direct mode."
 		whenM probeCrippledFileSystem $
-			error "This repository seems to be on a crippled filesystem, you must use direct mode."
+			giveup "This repository seems to be on a crippled filesystem, you must use direct mode."
 		next perform
 	, stop
 	)

Command/InitRemote.hs

@@ -26,16 +26,16 @@ seek :: CmdParams -> CommandSeek
 seek = withWords start
 
 start :: [String] -> CommandStart
-start [] = error "Specify a name for the remote."
+start [] = giveup "Specify a name for the remote."
 start (name:ws) = ifM (isJust <$> findExisting name)
-	( error $ "There is already a special remote named \"" ++ name ++
+	( giveup $ "There is already a special remote named \"" ++ name ++
 		"\". (Use enableremote to enable an existing special remote.)"
 	, do
 		ifM (isJust <$> Remote.byNameOnly name)
-			( error $ "There is already a remote named \"" ++ name ++ "\""
+			( giveup $ "There is already a remote named \"" ++ name ++ "\""
 			, do
 				let c = newConfig name
-				t <- either error return (findType config)
+				t <- either giveup return (findType config)
 
 				showStart "initremote" name
 				next $ perform t name $ M.union config c

Command/Lock.hs

@@ -79,7 +79,7 @@ performNew file key = do
 		unlessM (sameInodeCache obj (maybeToList mfc)) $ do
 			modifyContent obj $ replaceFile obj $ \tmp -> do
 				unlessM (checkedCopyFile key obj tmp Nothing) $
-					error "unable to lock file"
+					giveup "unable to lock file"
 			Database.Keys.storeInodeCaches key [obj]
 
 	-- Try to repopulate obj from an unmodified associated file.
@@ -115,4 +115,4 @@ performOld file = do
 	next $ return True
 
 errorModified :: a
-errorModified =  error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"
+errorModified =  giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"

Command/LockContent.hs

@@ -10,6 +10,7 @@ module Command.LockContent where
 import Command
 import Annex.Content
 import Remote.Helper.Ssh (contentLockedMarker)
+import Utility.SimpleProtocol
 
 cmd :: Command
 cmd = noCommit $ 
@@ -32,13 +33,13 @@ start [ks] = do
 		then exitSuccess
 		else exitFailure
   where
-	k = fromMaybe (error "bad key") (file2key ks)
+	k = fromMaybe (giveup "bad key") (file2key ks)
 	locksuccess = ifM (inAnnex k)
 		( liftIO $ do
 			putStrLn contentLockedMarker
 			hFlush stdout
-			_ <- getLine
+			_ <- getProtocolLine stdin
 			return True
 		, return False
 		)
-start _ = error "Specify exactly 1 key."
+start _ = giveup "Specify exactly 1 key."

Command/Log.hs

@@ -93,7 +93,7 @@ seek o = do
 	case (logFiles o, allOption o) of
 		(fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) fs
 		([], True) -> commandAction (startAll o outputter)
-		(_, True) -> error "Cannot specify both files and --all"
+		(_, True) -> giveup "Cannot specify both files and --all"
 
 start :: LogOptions -> (FilePath -> Outputter) -> FilePath -> Key -> CommandStart
 start o outputter file key = do

Command/Map.hs

@@ -47,15 +47,25 @@ start = do
 	liftIO $ writeFile file (drawMap rs trustmap umap)
 	next $ next $
 		ifM (Annex.getState Annex.fast)
-			( do
+			( runViewer file []
-				showLongNote $ "left map in " ++ file
+			, runViewer file
-				return True
+	 			[ ("xdot", [File file])
-			, do
+				, ("dot", [Param "-Tx11", File file])
-				showLongNote $ "running: dot -Tx11 " ++ file
+				]	
-				showOutput
-				liftIO $ boolSystem "dot" [Param "-Tx11", File file]
 			)
 
+runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool
+runViewer file [] = do
+	showLongNote $ "left map in " ++ file
+	return True
+runViewer file ((c, ps):rest) = ifM (liftIO $ inPath c)
+	( do
+		showLongNote $ "running: " ++ c ++ unwords (toCommand ps)
+		showOutput
+		liftIO $ boolSystem c ps
+	, runViewer file rest
+	)
+
 {- Generates a graph for dot(1). Each repository, and any other uuids
  - (except for dead ones), are displayed as a node, and each of its
  - remotes is represented as an edge pointing at the node for the remote.

Command/MetaData.hs

@@ -20,6 +20,7 @@ import qualified Data.Text as T
 import qualified Data.ByteString.Lazy.UTF8 as BU
 import Data.Time.Clock.POSIX
 import Data.Aeson
+import Control.Concurrent
 
 cmd :: Command
 cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $ 
@@ -65,23 +66,22 @@ optParser desc = MetaDataOptions
 			)
 
 seek :: MetaDataOptions -> CommandSeek
-seek o = do
+seek o = case batchOption o of
-	now <- liftIO getPOSIXTime
+	NoBatch -> do
-	case batchOption o of
+		now <- liftIO getPOSIXTime
-		NoBatch -> do
+		let seeker = case getSet o of
-			let seeker = case getSet o of
+			Get _ -> withFilesInGit
-				Get _ -> withFilesInGit
+			GetAll -> withFilesInGit
-				GetAll -> withFilesInGit
+			Set _ -> withFilesInGitNonRecursive
-				Set _ -> withFilesInGitNonRecursive
+				"Not recursively setting metadata. Use --force to do that."
-					"Not recursively setting metadata. Use --force to do that."
+		withKeyOptions (keyOptions o) False
-			withKeyOptions (keyOptions o) False
+			(startKeys now o)
-				(startKeys now o)
+			(seeker $ whenAnnexed $ start now o)
-				(seeker $ whenAnnexed $ start now o)
+			(forFiles o)
-				(forFiles o)
+	Batch -> withMessageState $ \s -> case outputType s of
-		Batch -> withMessageState $ \s -> case outputType s of
+		JSONOutput _ -> batchInput parseJSONInput $
-			JSONOutput _ -> batchInput parseJSONInput $
+			commandAction . startBatch
-				commandAction . startBatch now
+		_ -> giveup "--batch is currently only supported in --json mode"
-			_ -> error "--batch is currently only supported in --json mode"
 
 start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart
 start now o file k = startKeys now o k (mkActionItem afile)
@@ -150,13 +150,13 @@ parseJSONInput i = do
 		(Nothing, Just f) -> Right (Left f, m)
 		(Nothing, Nothing) -> Left "JSON input is missing either file or key"
 
-startBatch :: POSIXTime -> (Either FilePath Key, MetaData) -> CommandStart
+startBatch :: (Either FilePath Key, MetaData) -> CommandStart
-startBatch now (i, (MetaData m)) = case i of
+startBatch (i, (MetaData m)) = case i of
 	Left f -> do
 		mk <- lookupFile f
 		case mk of
 			Just k -> go k (mkActionItem (Just f))
-			Nothing -> error $ "not an annexed file: " ++ f
+			Nothing -> giveup $ "not an annexed file: " ++ f
 	Right k -> go k (mkActionItem k)
   where
 	go k ai = do
@@ -169,6 +169,15 @@ startBatch now (i, (MetaData m)) = case i of
 			, keyOptions = Nothing
 			, batchOption = NoBatch
 			}
+		now <- liftIO getPOSIXTime
+		-- It would be bad if two batch mode changes used exactly
+		-- the same timestamp, since the order of adds and removals
+		-- of the same metadata value would then be indeterminate.
+		-- To guarantee that never happens, delay 1 microsecond,
+		-- so the timestamp will always be different. This is
+		-- probably less expensive than cleaner methods,
+		-- such as taking from a list of increasing timestamps.
+		liftIO $ threadDelay 1
 		next $ perform now o k
 	mkModMeta (f, s)
 		| S.null s = DelMeta f Nothing

Command/Move.hs

@@ -197,4 +197,4 @@ fromPerform src move key afile = ifM (inAnnex key)
 			]
 		ok <- Remote.removeKey src key
 		next $ Command.Drop.cleanupRemote key src ok
-	faileddropremote = error "Unable to drop from remote."
+	faileddropremote = giveup "Unable to drop from remote."

Command/NotifyChanges.hs

@@ -8,15 +8,11 @@
 module Command.NotifyChanges where
 
 import Command
-import Utility.DirWatcher
+import Annex.ChangedRefs
-import Utility.DirWatcher.Types
-import qualified Git
-import Git.Sha
 import RemoteDaemon.Transport.Ssh.Types
+import Utility.SimpleProtocol
 
-import Control.Concurrent
 import Control.Concurrent.Async
-import Control.Concurrent.STM
 
 cmd :: Command
 cmd = noCommit $ 
@@ -28,55 +24,19 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing start
 
 start :: CommandStart
-start = do
+start = go =<< watchChangedRefs
-	-- This channel is used to accumulate notifcations,
-	-- because the DirWatcher might have multiple threads that find
-	-- changes at the same time.
-	chan <- liftIO newTChanIO
-	
-	g <- gitRepo
-	let refdir = Git.localGitDir g </> "refs"
-	liftIO $ createDirectoryIfMissing True refdir
-
-	let notifyhook = Just $ notifyHook chan
-	let hooks = mkWatchHooks
-		{ addHook = notifyhook
-		, modifyHook = notifyhook
-		}
-
-	void $ liftIO $ watchDir refdir (const False) True hooks id
-
-	let sender = do
-		send READY
-		forever $ send . CHANGED =<< drain chan
-	
-	-- No messages need to be received from the caller,
-	-- but when it closes the connection, notice and terminate.
-	let receiver = forever $ void getLine
-	void $ liftIO $ concurrently sender receiver
-	stop
-
-notifyHook :: TChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
-notifyHook chan reffile _
-	| ".lock" `isSuffixOf` reffile = noop
-	| otherwise = void $ do
-		sha <- catchDefaultIO Nothing $
-			extractSha <$> readFile reffile
-		maybe noop (atomically . writeTChan chan) sha
-
--- When possible, coalesce ref writes that occur closely together
--- in time. Delay up to 0.05 seconds to get more ref writes.
-drain :: TChan Git.Sha -> IO [Git.Sha]
-drain chan = do
-	r <- atomically $ readTChan chan
-	threadDelay 50000
-	rs <- atomically $ drain' chan
-	return (r:rs)
-
-drain' :: TChan Git.Sha -> STM [Git.Sha]
-drain' chan = loop []
   where
-	loop rs = maybe (return rs) (\r -> loop (r:rs)) =<< tryReadTChan chan
+	go (Just h) = do
+		-- No messages need to be received from the caller,
+		-- but when it closes the connection, notice and terminate.
+		let receiver = forever $ void $ getProtocolLine stdin
+		let sender = forever $ send . CHANGED =<< waitChangedRefs h
+
+		liftIO $ send READY
+		void $ liftIO $ concurrently sender receiver
+		liftIO $ stopWatchingChangedRefs h
+		stop
+	go Nothing = stop
 
 send :: Notification -> IO ()
 send n = do

Command/NumCopies.hs

@@ -23,15 +23,15 @@ seek = withWords start
 start :: [String] -> CommandStart
 start [] = startGet
 start [s] = case readish s of
-	Nothing -> error $ "Bad number: " ++ s
+	Nothing -> giveup $ "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."
+			, giveup "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!"
+		| otherwise -> giveup "Number cannot be negative!"
-start _ = error "Specify a single number."
+start _ = giveup "Specify a single number."
 
 startGet :: CommandStart
 startGet = next $ next $ do

Command/P2P.hs

@@ -0,0 +1,302 @@
+{- git-annex command
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.P2P where
+
+import Command
+import P2P.Address
+import P2P.Auth
+import P2P.IO
+import qualified P2P.Protocol as P2P
+import Git.Types
+import qualified Git.Remote
+import qualified Git.Command
+import qualified Annex
+import Annex.UUID
+import Config
+import Utility.AuthToken
+import Utility.Tmp
+import Utility.FileMode
+import Utility.ThreadScheduler
+import qualified Utility.MagicWormhole as Wormhole
+
+import Control.Concurrent.Async
+import qualified Data.Text as T
+
+cmd :: Command
+cmd = command "p2p" SectionSetup
+	"configure peer-2-peer links between repositories"
+	paramNothing (seek <$$> optParser)
+
+data P2POpts
+	= GenAddresses
+	| LinkRemote
+	| Pair
+
+optParser :: CmdParamsDesc -> Parser (P2POpts, Maybe RemoteName)
+optParser _ = (,)
+	<$> (pair <|> linkremote <|> genaddresses)
+	<*> optional name
+  where
+	genaddresses = flag' GenAddresses
+		( long "gen-addresses"
+		<> help "generate addresses that allow accessing this repository over P2P networks"
+		)
+	linkremote = flag' LinkRemote
+		( long "link"
+		<> help "set up a P2P link to a git remote"
+		)
+	pair = flag' Pair
+		( long "pair"
+		<> help "pair with another repository"
+		)
+	name = Git.Remote.makeLegalName <$> strOption
+		( long "name"
+		<> metavar paramName
+		<> help "name of remote"
+		)
+
+seek :: (P2POpts, Maybe RemoteName) -> CommandSeek
+seek (GenAddresses, _) = genAddresses =<< loadP2PAddresses
+seek (LinkRemote, Just name) = commandAction $
+	linkRemote name
+seek (LinkRemote, Nothing) = commandAction $
+	linkRemote =<< unusedPeerRemoteName
+seek (Pair, Just name) = commandAction $
+	startPairing name =<< loadP2PAddresses
+seek (Pair, Nothing) = commandAction $ do
+	name <- unusedPeerRemoteName
+	startPairing name =<< loadP2PAddresses
+
+unusedPeerRemoteName :: Annex RemoteName
+unusedPeerRemoteName = go (1 :: Integer) =<< usednames
+  where
+	usednames = mapMaybe remoteName . remotes <$> Annex.gitRepo
+	go n names = do
+		let name = "peer" ++ show n
+		if name `elem` names
+			then go (n+1) names
+			else return name
+
+-- Only addresses are output to stdout, to allow scripting.
+genAddresses :: [P2PAddress] -> Annex ()
+genAddresses [] = giveup "No P2P networks are currrently available."
+genAddresses addrs = do
+	authtoken <- liftIO $ genAuthToken 128
+	storeP2PAuthToken authtoken
+	earlyWarning "These addresses allow access to this git-annex repository. Only share them with people you trust with that access, using trusted communication channels!"
+	liftIO $ putStr $ unlines $
+		map formatP2PAddress $
+			map (`P2PAddressAuth` authtoken) addrs
+
+-- Address is read from stdin, to avoid leaking it in shell history.
+linkRemote :: RemoteName -> CommandStart
+linkRemote remotename = do
+	showStart "p2p link" remotename
+	next $ next prompt
+  where
+	prompt = do
+		liftIO $ putStrLn ""
+		liftIO $ putStr "Enter peer address: "
+		liftIO $ hFlush stdout
+		s <- liftIO getLine
+		if null s
+			then do
+				liftIO $ hPutStrLn stderr "Nothing entered, giving up."
+				return False
+			else case unformatP2PAddress s of
+				Nothing -> do
+					liftIO $ hPutStrLn stderr "Unable to parse that address, please check its format and try again."
+					prompt
+				Just addr -> do
+					r <- setupLink remotename addr
+					case r of
+						LinkSuccess -> return True
+						ConnectionError e -> giveup e
+						AuthenticationError e -> giveup e
+
+startPairing :: RemoteName -> [P2PAddress] -> CommandStart
+startPairing _ [] = giveup "No P2P networks are currrently available."
+startPairing remotename addrs = do
+	showStart "p2p pair" remotename
+	ifM (liftIO Wormhole.isInstalled)
+		( next $ performPairing remotename addrs
+		, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
+		) 
+
+performPairing :: RemoteName -> [P2PAddress] -> CommandPerform
+performPairing remotename addrs = do
+	-- This note is displayed mainly so when magic wormhole
+	-- complains about possible protocol mismatches or other problems,
+	-- it's clear what's doing the complaining.
+	showNote "using Magic Wormhole"
+	next $ do
+		showOutput
+		r <- wormholePairing remotename addrs ui
+		case r of
+			PairSuccess -> return True
+			SendFailed -> do
+				warning "Failed sending data to pair."
+				return False
+			ReceiveFailed -> do
+				warning "Failed receiving data from pair."
+				return False
+			LinkFailed e -> do
+				warning $ "Failed linking to pair: " ++ e
+				return False
+  where
+	ui observer producer = do
+		ourcode <- Wormhole.waitCode observer
+		putStrLn ""
+		putStrLn $ "This repository's pairing code is: " ++
+			Wormhole.fromCode ourcode
+		putStrLn ""
+		theircode <- getcode ourcode
+		Wormhole.sendCode producer theircode
+	
+	getcode ourcode = do
+		putStr "Enter the other repository's pairing code: "
+		hFlush stdout
+		l <- getLine
+		case Wormhole.toCode l of
+			Just code
+				| code /= ourcode -> do
+					putStrLn "Exchanging pairing data..."
+					return code
+				| otherwise -> do
+					putStrLn "Oops -- You entered this repository's pairing code. We need the pairing code of the *other* repository."
+					getcode ourcode
+			Nothing -> do
+				putStrLn "That does not look like a valid code. Try again..."
+				getcode ourcode
+
+-- We generate half of the authtoken; the pair will provide
+-- the other half.
+newtype HalfAuthToken = HalfAuthToken T.Text
+	deriving (Show)
+
+data PairData = PairData HalfAuthToken [P2PAddress]
+	deriving (Show)
+
+serializePairData :: PairData -> String
+serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $
+	T.unpack ha : map formatP2PAddress addrs
+
+deserializePairData :: String -> Maybe PairData
+deserializePairData s = case lines s of
+	[] -> Nothing
+	(ha:l) -> do
+		addrs <- mapM unformatP2PAddress l
+		return (PairData (HalfAuthToken (T.pack ha)) addrs)
+
+data PairingResult
+	= PairSuccess
+	| SendFailed
+	| ReceiveFailed
+	| LinkFailed String
+
+wormholePairing
+	:: RemoteName
+	-> [P2PAddress]
+	-> (Wormhole.CodeObserver -> Wormhole.CodeProducer -> IO ())
+	-> Annex PairingResult
+wormholePairing remotename ouraddrs ui = do
+	ourhalf <- liftIO $ HalfAuthToken . fromAuthToken
+		<$> genAuthToken 64
+	let ourpairdata = PairData ourhalf ouraddrs
+
+	-- The magic wormhole interface only supports exchanging
+	-- files. Permissions of received files may allow others
+	-- to read them. So, set up a temp directory that only
+	-- we can read.
+	withTmpDir "pair" $ \tmp -> do
+		liftIO $ void $ tryIO $ modifyFileMode tmp $ 
+			removeModes otherGroupModes
+		let sendf = tmp </> "send"
+		let recvf = tmp </> "recv"
+		liftIO $ writeFileProtected sendf $
+			serializePairData ourpairdata
+
+		observer <- liftIO Wormhole.mkCodeObserver
+		producer <- liftIO Wormhole.mkCodeProducer
+		void $ liftIO $ async $ ui observer producer
+		(sendres, recvres) <- liftIO $
+			Wormhole.sendFile sendf observer []
+				`concurrently`
+			Wormhole.receiveFile recvf producer []
+		liftIO $ nukeFile sendf
+		if sendres /= True
+			then return SendFailed
+			else if recvres /= True
+				then return ReceiveFailed
+				else do
+					r <- liftIO $ tryIO $
+						readFileStrict recvf
+					case r of
+						Left _e -> return ReceiveFailed
+						Right s -> maybe 
+							(return ReceiveFailed)
+							(finishPairing 100 remotename ourhalf)
+							(deserializePairData s)
+
+-- | Allow the peer we're pairing with to authenticate to us,
+-- using an authtoken constructed from the two HalfAuthTokens.
+-- Connect to the peer we're pairing with, and try to link to them.
+--
+-- Multiple addresses may have been received for the peer. This only
+-- makes a link to one address.
+--
+-- Since we're racing the peer as they do the same, the first try is likely
+-- to fail to authenticate. Can retry any number of times, to avoid the
+-- users needing to redo the whole process.
+finishPairing :: Int -> RemoteName -> HalfAuthToken -> PairData -> Annex PairingResult
+finishPairing retries remotename (HalfAuthToken ourhalf) (PairData (HalfAuthToken theirhalf) theiraddrs) = do
+	case (toAuthToken (ourhalf <> theirhalf), toAuthToken (theirhalf <> ourhalf)) of
+		(Just ourauthtoken, Just theirauthtoken) -> do
+			liftIO $ putStrLn $ "Successfully exchanged pairing data. Connecting to " ++ remotename ++  "..."
+			storeP2PAuthToken ourauthtoken
+			go retries theiraddrs theirauthtoken
+		_ -> return ReceiveFailed
+  where
+	go 0 [] _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "."
+	go n [] theirauthtoken = do
+		liftIO $ threadDelaySeconds (Seconds 2)
+		liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..."
+		go (n-1) theiraddrs theirauthtoken
+	go n (addr:rest) theirauthtoken = do
+		r <- setupLink remotename (P2PAddressAuth addr theirauthtoken)
+		case r of
+			LinkSuccess -> return PairSuccess
+			_ -> go n rest theirauthtoken
+
+data LinkResult
+	= LinkSuccess
+	| ConnectionError String
+	| AuthenticationError String
+
+setupLink :: RemoteName -> P2PAddressAuth -> Annex LinkResult
+setupLink remotename (P2PAddressAuth addr authtoken) = do
+	g <- Annex.gitRepo
+	cv <- liftIO $ tryNonAsync $ connectPeer g addr
+	case cv of
+		Left e -> return $ ConnectionError $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. ("  ++ show e ++ ")"
+		Right conn -> do
+			u <- getUUID
+			go =<< liftIO (runNetProto conn $ P2P.auth u authtoken)
+  where
+	go (Right (Just theiruuid)) = do
+		ok <- inRepo $ Git.Command.runBool
+			[ Param "remote", Param "add"
+			, Param remotename
+			, Param (formatP2PAddress addr)
+			]
+		when ok $ do
+			storeUUIDIn (remoteConfig remotename "uuid") theiruuid
+			storeP2PRemoteAuthToken addr authtoken
+		return LinkSuccess
+	go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again."
+	go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ e

Command/PreCommit.hs

@@ -46,7 +46,7 @@ seek ps = lockPreCommitHook $ ifM isDirect
 			( do
 				(fs, cleanup) <- inRepo $ Git.typeChangedStaged ps
 				whenM (anyM isOldUnlocked fs) $
-					error "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
+					giveup "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
 				void $ liftIO cleanup
 			, do
 				-- fix symlinks to files being committed

Command/Proxy.hs

@@ -30,7 +30,7 @@ seek :: CmdParams -> CommandSeek
 seek = withWords start
 
 start :: [String] -> CommandStart
-start [] = error "Did not specify command to run."
+start [] = giveup "Did not specify command to run."
 start (c:ps) = liftIO . exitWith =<< ifM isDirect
 	( do
 		tmp <- gitAnnexTmpMiscDir <$> gitRepo

Command/ReKey.hs

@@ -25,15 +25,39 @@ cmd = notDirect $
 	command "rekey" SectionPlumbing
 		"change keys used for files"
 		(paramRepeating $ paramPair paramPath paramKey)
-		(withParams seek)
+		(seek <$$> optParser)
 
-seek :: CmdParams -> CommandSeek
+data ReKeyOptions = ReKeyOptions
-seek = withPairs start
+	{ reKeyThese :: CmdParams
+	, batchOption :: BatchMode
+	}
 
-start :: (FilePath, String) -> CommandStart
+optParser :: CmdParamsDesc -> Parser ReKeyOptions
-start (file, keyname) = ifAnnexed file go stop
+optParser desc = ReKeyOptions
+	<$> cmdParams desc
+	<*> parseBatchOption
+
+-- Split on the last space, since a FilePath can contain whitespace,
+-- but a Key very rarely does.
+batchParser :: String -> Either String (FilePath, Key)
+batchParser s = case separate (== ' ') (reverse s) of
+	(rk, rf)
+		| null rk || null rf -> Left "Expected: \"file key\""
+		| otherwise -> case file2key (reverse rk) of
+			Nothing -> Left "bad key"
+			Just k -> Right (reverse rf, k)
+
+seek :: ReKeyOptions -> CommandSeek
+seek o = case batchOption o of
+	Batch -> batchInput batchParser (batchCommandAction . start)
+	NoBatch -> withPairs (start . parsekey) (reKeyThese o)
+  where
+	parsekey (file, skey) =
+		(file, fromMaybe (giveup "bad key") (file2key skey))
+
+start :: (FilePath, Key) -> CommandStart
+start (file, newkey) = ifAnnexed file go stop
   where
-	newkey = fromMaybe (error "bad key") $ file2key keyname
 	go oldkey
 		| oldkey == newkey = stop
 		| otherwise = do
@@ -44,9 +68,9 @@ perform :: FilePath -> Key -> Key -> CommandPerform
 perform file oldkey newkey = do
 	ifM (inAnnex oldkey) 
 		( unlessM (linkKey file oldkey newkey) $
-			error "failed"
+			giveup "failed"
 		, unlessM (Annex.getState Annex.force) $
-			error $ file ++ " is not available (use --force to override)"
+			giveup $ file ++ " is not available (use --force to override)"
 		)
 	next $ cleanup file oldkey newkey
 
@@ -102,6 +126,6 @@ cleanup file oldkey newkey = do
 			Database.Keys.removeAssociatedFile oldkey 
 				=<< inRepo (toTopFilePath file)
 		)
-
+	whenM (inAnnex newkey) $
-	logStatus newkey InfoPresent
+		logStatus newkey InfoPresent
 	return True

Command/ReadPresentKey.hs

@@ -27,5 +27,5 @@ start (ks:us:[]) = do
 		then liftIO exitSuccess
 		else liftIO exitFailure
   where
-	k = fromMaybe (error "bad key") (file2key ks)
+	k = fromMaybe (giveup "bad key") (file2key ks)
-start _ = error "Wrong number of parameters"
+start _ = giveup "Wrong number of parameters"

Command/RegisterUrl.hs

@@ -32,10 +32,10 @@ start (keyname:url:[]) = do
 start [] = do
 	showStart "registerurl" "stdin"
 	next massAdd
-start _ = error "specify a key and an url"
+start _ = giveup "specify a key and an url"
 
 massAdd :: CommandPerform
-massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
+massAdd = go True =<< map (separate (== ' ')) <$> batchLines
   where
 	go status [] = next $ return status
 	go status ((keyname,u):rest) | not (null keyname) && not (null u) = do
@@ -43,7 +43,7 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
 		ok <- perform' key u
 		let !status' = status && ok
 		go status' rest
-	go _ _ = error "Expected pairs of key and url on stdin, but got something else."
+	go _ _ = giveup "Expected pairs of key and url on stdin, but got something else."
 
 perform :: Key -> URLString -> CommandPerform
 perform key url = do

Command/Reinject.hs

@@ -16,8 +16,7 @@ import Types.KeySource
 cmd :: Command
 cmd = command "reinject" SectionUtility 
 	"inject content of file back into annex"
-	(paramRepeating (paramPair "SRC" "DEST")
+	(paramRepeating (paramPair "SRC" "DEST"))
-		`paramOr` "--known " ++ paramRepeating "SRC")
 	(seek <$$> optParser)
 
 data ReinjectOptions = ReinjectOptions
@@ -47,7 +46,7 @@ startSrcDest (src:dest:[])
 		next $ ifAnnexed dest
 			(\key -> perform src key (verifyKeyContent DefaultVerify UnVerified key src))
 			stop
-startSrcDest _ = error "specify a src file and a dest file"
+startSrcDest _ = giveup "specify a src file and a dest file"
 
 startKnown :: FilePath -> CommandStart
 startKnown src = notAnnexed src $ do
@@ -63,7 +62,8 @@ startKnown src = notAnnexed src $ do
 			)
 
 notAnnexed :: FilePath -> CommandStart -> CommandStart
-notAnnexed src = ifAnnexed src (error $ "cannot used annexed file as src: " ++ src)
+notAnnexed src = ifAnnexed src $
+	giveup $ "cannot used annexed file as src: " ++ src
 
 perform :: FilePath -> Key -> Annex Bool -> CommandPerform
 perform src key verify = ifM move

Command/RemoteDaemon.hs

@@ -1,25 +1,32 @@
 {- git-annex command
  -
- - Copyright 2014 Joey Hess <id@joeyh.name>
+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Command.RemoteDaemon where
 
 import Command
 import RemoteDaemon.Core
+import Utility.Daemon
 
 cmd :: Command
-cmd = noCommit $ 
+cmd = noCommit $
-	command "remotedaemon" SectionPlumbing
+	command "remotedaemon" SectionMaintenance
-		"detects when remotes have changed, and fetches from them"
+		"persistent communication with remotes"
-		paramNothing (withParams seek)
+		paramNothing (run <$$> const parseDaemonOptions)
 
-seek :: CmdParams -> CommandSeek
+run :: DaemonOptions -> CommandSeek
-seek = withNothing start
+run o
-
+	| stopDaemonOption o = error "--stop not implemented for remotedaemon"
-start :: CommandStart
+	| foregroundDaemonOption o = liftIO runInteractive
-start = do
+	| otherwise = do
-	liftIO runForeground
+#ifndef mingw32_HOST_OS
-	stop
+		nullfd <- liftIO $ openFd "/dev/null" ReadOnly Nothing defaultFileFlags
+		liftIO $ daemonize nullfd Nothing False runNonInteractive
+#else
+		liftIO $ foreground Nothing runNonInteractive	
+#endif

Command/ResolveMerge.hs

@@ -33,8 +33,8 @@ start = do
 		( do
 			void $ commitResolvedMerge Git.Branch.ManualCommit
 			next $ next $ return True
-		, error "Merge conflict could not be automatically resolved."
+		, giveup "Merge conflict could not be automatically resolved."
 		)
   where
-	nobranch = error "No branch is currently checked out."
+	nobranch = giveup "No branch is currently checked out."
-	nomergehead = error "No SHA found in .git/merge_head"
+	nomergehead = giveup "No SHA found in .git/merge_head"

Command/RmUrl.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -15,13 +15,33 @@ cmd :: Command
 cmd = notBareRepo $
 	command "rmurl" SectionCommon 
 		"record file is not available at url"
-		(paramPair paramFile paramUrl)
+		(paramRepeating (paramPair paramFile paramUrl))
-		(withParams seek)
+		(seek <$$> optParser)
 
-seek :: CmdParams -> CommandSeek
+data RmUrlOptions = RmUrlOptions
-seek = withPairs start
+	{ rmThese :: CmdParams
+	, batchOption :: BatchMode
+	}
 
-start :: (FilePath, String) -> CommandStart
+optParser :: CmdParamsDesc -> Parser RmUrlOptions
+optParser desc = RmUrlOptions
+	<$> cmdParams desc
+	<*> parseBatchOption
+
+seek :: RmUrlOptions -> CommandSeek
+seek o = case batchOption o of
+	Batch -> batchInput batchParser (batchCommandAction . start)
+	NoBatch -> withPairs start (rmThese o)
+
+-- Split on the last space, since a FilePath can contain whitespace,
+-- but a url should not.
+batchParser :: String -> Either String (FilePath, URLString)
+batchParser s = case separate (== ' ') (reverse s) of
+	(ru, rf)
+		| null ru || null rf -> Left "Expected: \"file url\""
+		| otherwise -> Right (reverse rf, reverse ru)
+
+start :: (FilePath, URLString) -> CommandStart
 start (file, url) = flip whenAnnexed file $ \_ key -> do
 	showStart "rmurl" file
 	next $ next $ cleanup url key

Command/Schedule.hs

@@ -29,9 +29,9 @@ start = parse
   where
 	parse (name:[]) = go name performGet
 	parse (name:expr:[]) = go name $ \uuid -> do
-		showStart "schedile" name
+		showStart "schedule" name
 		performSet expr uuid
-	parse _ = error "Specify a repository."
+	parse _ = giveup "Specify a repository."
 
 	go name a = do
 		u <- Remote.nameToUUID name
@@ -47,7 +47,7 @@ performGet uuid = do
 
 performSet :: String -> UUID -> CommandPerform
 performSet expr uuid = case parseScheduledActivities expr of
-	Left e -> error $ "Parse error: " ++ e
+	Left e -> giveup $ "Parse error: " ++ e
 	Right l -> do
 		scheduleSet uuid l
 		next $ return True

Command/SetKey.hs

@@ -23,10 +23,10 @@ start :: [String] -> CommandStart
 start (keyname:file:[]) = do
 	showStart "setkey" file
 	next $ perform file (mkKey keyname)
-start _ = error "specify a key and a content file"
+start _ = giveup "specify a key and a content file"
 
 mkKey :: String -> Key
-mkKey = fromMaybe (error "bad key") . file2key
+mkKey = fromMaybe (giveup "bad key") . file2key
 
 perform :: FilePath -> Key -> CommandPerform
 perform file key = do

Command/SetPresentKey.hs

@@ -26,9 +26,9 @@ start (ks:us:vs:[]) = do
 	showStart' "setpresentkey" k (mkActionItem k)
 	next $ perform k (toUUID us) s
   where
-	k = fromMaybe (error "bad key") (file2key ks)
+	k = fromMaybe (giveup "bad key") (file2key ks)
-	s = fromMaybe (error "bad value") (parseStatus vs)
+	s = fromMaybe (giveup "bad value") (parseStatus vs)
-start _ = error "Wrong number of parameters"
+start _ = giveup "Wrong number of parameters"
 
 perform :: Key -> UUID -> LogStatus -> CommandPerform
 perform k u s = next $ do