Merge branch 'master' into no-xmpp

7 files changed, 97 insertions, 26 deletions

diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs
index 7d9dce574..27621e445 100644
--- a/CmdLine/Action.hs
+++ b/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,
diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs
index cca93b0b3..82038314c 100644
--- a/CmdLine/Batch.hs
+++ b/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
-	mp <- liftIO $ catchMaybeIO getLine
-	case mp of
-		Nothing -> return ()
-		Just v -> do
-			either parseerr a (parser v)
-			batchInput parser a
+batchInput parser a = go =<< batchLines
   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.
 --
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs
index a5913e9e0..394bd173b 100644
--- a/CmdLine/GitAnnex.hs
+++ b/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
diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs
index 599d12fec..70c86ec2f 100644
--- a/CmdLine/GitAnnexShell.hs
+++ b/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 ...]"
diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs
index 63d2e594f..47bc11a76 100644
--- a/CmdLine/GitAnnexShell/Checks.hs
+++ b/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."
diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs
new file mode 100644
index 000000000..5208a47ca
--- /dev/null
+++ b/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
diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs
index 5d20ad0db..7fc64c528 100644
--- a/CmdLine/Seek.hs
+++ b/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