Merge branch 'no-xmpp'

Assistant.hs

@@ -41,10 +41,6 @@ import Assistant.Threads.WebApp
 #ifdef WITH_PAIRING
 import Assistant.Threads.PairListener
 #endif
-#ifdef WITH_XMPP
-import Assistant.Threads.XMPPClient
-import Assistant.Threads.XMPPPusher
-#endif
 #else
 import Assistant.Types.UrlRenderer
 #endif
@@ -153,11 +149,6 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 #ifdef WITH_PAIRING
 				, assist $ pairListenerThread urlrenderer
 #endif
-#ifdef WITH_XMPP
-				, assist $ xmppClientThread urlrenderer
-				, assist $ xmppSendPackThread urlrenderer
-				, assist $ xmppReceivePackThread urlrenderer
-#endif
 #endif
 				, assist pushThread
 				, assist pushRetryThread

Assistant/DaemonStatus.hs

@@ -12,7 +12,6 @@ module Assistant.DaemonStatus where
 import Assistant.Common
 import Assistant.Alert.Utility
 import Utility.Tmp
-import Assistant.Types.NetMessager
 import Utility.NotificationBroadcaster
 import Types.Transfer
 import Logs.Transfer
@@ -20,14 +19,12 @@ import Logs.Trust
 import Logs.TimeStamp
 import qualified Remote
 import qualified Types.Remote as Remote
-import qualified Git
 
 import Control.Concurrent.STM
 import System.Posix.Types
 import Data.Time.Clock.POSIX
 import qualified Data.Map as M
 import qualified Data.Set as S
-import qualified Data.Text as T
 
 getDaemonStatus :: Assistant DaemonStatus
 getDaemonStatus = (atomically . readTVar) <<~ daemonStatusHandle
@@ -264,6 +261,3 @@ alertDuring :: Alert -> Assistant a -> Assistant a
 alertDuring alert a = do
 	i <- addAlert $ alert { alertClass = Activity }
 	removeAlert  i `after` a
-
-getXMPPClientID :: Remote -> ClientID
-getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

Assistant/Monad.hs

@@ -40,8 +40,6 @@ import Assistant.Types.BranchChange
 import Assistant.Types.Commits
 import Assistant.Types.Changes
 import Assistant.Types.RepoProblem
-import Assistant.Types.Buddies
-import Assistant.Types.NetMessager
 import Assistant.Types.ThreadName
 import Assistant.Types.RemoteControl
 import Assistant.Types.CredPairCache
@@ -68,8 +66,6 @@ data AssistantData = AssistantData
 	, changePool :: ChangePool
 	, repoProblemChan :: RepoProblemChan
 	, branchChangeHandle :: BranchChangeHandle
-	, buddyList :: BuddyList
-	, netMessager :: NetMessager
 	, remoteControl :: RemoteControl
 	, credPairCache :: CredPairCache
 	}
@@ -88,8 +84,6 @@ newAssistantData st dstatus = AssistantData
 	<*> newChangePool
 	<*> newRepoProblemChan
 	<*> newBranchChangeHandle
-	<*> newBuddyList
-	<*> newNetMessager
 	<*> newRemoteControl
 	<*> newCredPairCache
 

Assistant/NetMessager.hs

@@ -1,180 +0,0 @@
-{- git-annex assistant out of band network messager interface
- -
- - Copyright 2012-2013 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE BangPatterns #-}
-
-module Assistant.NetMessager where
-
-import Assistant.Common
-import Assistant.Types.NetMessager
-
-import Control.Concurrent.STM
-import Control.Concurrent.MSampleVar
-import qualified Data.Set as S
-import qualified Data.Map as M
-import qualified Data.DList as D
-
-sendNetMessage :: NetMessage -> Assistant ()
-sendNetMessage m = 
-	(atomically . flip writeTChan m) <<~ (netMessages . netMessager)
-
-waitNetMessage :: Assistant (NetMessage)
-waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager)
-
-notifyNetMessagerRestart :: Assistant ()
-notifyNetMessagerRestart =
-	flip writeSV () <<~ (netMessagerRestart . netMessager)
-
-{- This can be used to get an early indication if the network has
- - changed, to immediately restart a connection. However, that is not
- - available on all systems, so clients also need to deal with
- - restarting dropped connections in the usual way. -}
-waitNetMessagerRestart :: Assistant ()
-waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager)
-
-{- Store a new important NetMessage for a client, and if an equivilant
- - older message is already stored, remove it from both importantNetMessages
- - and sentImportantNetMessages. -}
-storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant ()
-storeImportantNetMessage m client matchingclient = go <<~ netMessager
-  where
-	go nm = atomically $ do
-		q <- takeTMVar $ importantNetMessages nm
-		sent <- takeTMVar $ sentImportantNetMessages nm
-		putTMVar (importantNetMessages nm) $
-			M.alter (Just . maybe (S.singleton m) (S.insert m)) client $
-				M.mapWithKey removematching q
-		putTMVar (sentImportantNetMessages nm) $
-			M.mapWithKey removematching sent
-	removematching someclient s
-		| matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s
-		| otherwise = s
-
-{- Indicates that an important NetMessage has been sent to a client. -}
-sentImportantNetMessage :: NetMessage -> ClientID -> Assistant ()
-sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager)
-  where
-	go v = atomically $ do
-		sent <- takeTMVar v
-		putTMVar v $
-			M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent
-
-{- Checks for important NetMessages that have been stored for a client, and
- - sent to a client. Typically the same client for both, although 
- - a modified or more specific client may need to be used. -}
-checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage)
-checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
-  where
-	go nm = atomically $ do
-		stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm)
-		sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm)
-		return (fromMaybe S.empty stored, fromMaybe S.empty sent)
-
-{- Queues a push initiation message in the queue for the appropriate
- - side of the push but only if there is not already an initiation message
- - from the same client in the queue. -}
-queuePushInitiation :: NetMessage -> Assistant ()
-queuePushInitiation msg@(Pushing clientid stage) = do
-	tv <- getPushInitiationQueue side
-	liftIO $ atomically $ do
-		r <- tryTakeTMVar tv
-		case r of
-			Nothing -> putTMVar tv [msg]
-			Just l -> do
-				let !l' = msg : filter differentclient l
-				putTMVar tv l'
-  where
-	side = pushDestinationSide stage
-	differentclient (Pushing cid _) = cid /= clientid
-	differentclient _ = True
-queuePushInitiation _ = noop
-
-{- Waits for a push inititation message to be received, and runs
- - function to select a message from the queue. -}
-waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage
-waitPushInitiation side selector = do
-	tv <- getPushInitiationQueue side
-	liftIO $ atomically $ do
-		q <- takeTMVar tv
-		if null q
-			then retry
-			else do
-				let (msg, !q') = selector q
-				unless (null q') $
-					putTMVar tv q'
-				return msg
-
-{- Stores messages for a push into the appropriate inbox.
- -
- - To avoid overflow, only 1000 messages max are stored in any
- - inbox, which should be far more than necessary.
- -
- - TODO: If we have more than 100 inboxes for different clients,
- - discard old ones that are not currently being used by any push.
- -}
-storeInbox :: NetMessage -> Assistant ()
-storeInbox msg@(Pushing clientid stage) = do
-	inboxes <- getInboxes side
-	stored <- liftIO $ atomically $ do
-		m <- readTVar inboxes
-		let update = \v -> do
-			writeTVar inboxes $
-				M.insertWith' const clientid v m
-			return True
-		case M.lookup clientid m of
-			Nothing -> update (1, tostore)
-			Just (sz, l)
-				| sz > 1000 -> return False
-				| otherwise ->
-					let !sz' = sz + 1
-					    !l' = D.append l tostore
-					in update (sz', l')
-	if stored
-		then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"]
-		else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"]
-  where
-	side = pushDestinationSide stage
-	tostore = D.singleton msg
-storeInbox _ = noop
-
-{- Gets the new message for a push from its inbox.
- - Blocks until a message has been received. -}
-waitInbox :: ClientID -> PushSide -> Assistant (NetMessage)
-waitInbox clientid side = do
-	inboxes <- getInboxes side
-	liftIO $ atomically $ do
-		m <- readTVar inboxes
-		case M.lookup clientid m of
-			Nothing -> retry
-			Just (sz, dl)
-				| sz < 1 -> retry
-				| otherwise -> do
-					let msg = D.head dl
-					let dl' = D.tail dl
-					let !sz' = sz - 1
-					writeTVar inboxes $
-						M.insertWith' const clientid (sz', dl') m
-					return msg
-
-emptyInbox :: ClientID -> PushSide -> Assistant ()
-emptyInbox clientid side = do
-	inboxes <- getInboxes side
-	liftIO $ atomically $
-		modifyTVar' inboxes $
-			M.delete clientid
-	
-getInboxes :: PushSide -> Assistant Inboxes
-getInboxes side =
-	getSide side . netMessagerInboxes <$> getAssistant netMessager
-
-getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage])
-getPushInitiationQueue side =
-	getSide side . netMessagerPushInitiations <$> getAssistant netMessager
-
-netMessagerDebug :: ClientID -> [String] -> Assistant ()
-netMessagerDebug clientid l = debug $
-	"NetMessager" : l ++ [show $ logClientID clientid]

Assistant/Sync.hs

@@ -9,8 +9,6 @@ module Assistant.Sync where
 
 import Assistant.Common
 import Assistant.Pushes
-import Assistant.NetMessager
-import Assistant.Types.NetMessager
 import Assistant.Alert
 import Assistant.Alert.Utility
 import Assistant.DaemonStatus
@@ -20,7 +18,6 @@ import qualified Command.Sync
 import Utility.Parallel
 import qualified Git
 import qualified Git.Command
-import qualified Git.Ref
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Remote.List as Remote
@@ -39,7 +36,6 @@ import Types.Transfer
 
 import Data.Time.Clock
 import qualified Data.Map as M
-import qualified Data.Set as S
 import Control.Concurrent
 
 {- Syncs with remotes that may have been disconnected for a while.
@@ -50,21 +46,14 @@ import Control.Concurrent
  - the remotes have diverged from the local git-annex branch. Otherwise,
  - it's sufficient to requeue failed transfers.
  -
- - XMPP remotes are also signaled that we can push to them, and we request
- - they push to us. Since XMPP pushes run ansynchronously, any scan of the
- - XMPP remotes has to be deferred until they're done pushing to us, so
- - all XMPP remotes are marked as possibly desynced.
- -
  - Also handles signaling any connectRemoteNotifiers, after the syncing is
  - done.
  -}
-reconnectRemotes :: Bool -> [Remote] -> Assistant ()
-reconnectRemotes _ [] = noop
-reconnectRemotes notifypushes rs = void $ do
+reconnectRemotes :: [Remote] -> Assistant ()
+reconnectRemotes [] = noop
+reconnectRemotes rs = void $ do
 	rs' <- liftIO $ filterM (Remote.checkAvailable True) rs
 	unless (null rs') $ do
-		modifyDaemonStatus_ $ \s -> s
-			{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
 		failedrs <- syncAction rs' (const go)
 		forM_ failedrs $ \r ->
 			whenM (liftIO $ Remote.checkAvailable False r) $
@@ -72,7 +61,7 @@ reconnectRemotes notifypushes rs = void $ do
 		mapM_ signal $ filter (`notElem` failedrs) rs'
   where
 	gitremotes = filter (notspecialremote . Remote.repo) rs
-	(xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
+	(_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
 	notspecialremote r
 		| Git.repoIsUrl r = True
 		| Git.repoIsLocal r = True
@@ -81,7 +70,7 @@ reconnectRemotes notifypushes rs = void $ do
 	sync currentbranch@(Just _, _) = do
 		(failedpull, diverged) <- manualPull currentbranch gitremotes
 		now <- liftIO getCurrentTime
-		failedpush <- pushToRemotes' now notifypushes gitremotes
+		failedpush <- pushToRemotes' now gitremotes
 		return (nub $ failedpull ++ failedpush, diverged)
 	{- No local branch exists yet, but we can try pulling. -}
 	sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes
@@ -101,9 +90,6 @@ reconnectRemotes notifypushes rs = void $ do
  - as "git annex sync", except in parallel, and will co-exist with use of
  - "git annex sync".
  -
- - After the pushes to normal git remotes, also signals XMPP clients that
- - they can request an XMPP push.
- -
  - Avoids running possibly long-duration commands in the Annex monad, so
  - as not to block other threads.
  -
@@ -121,27 +107,21 @@ reconnectRemotes notifypushes rs = void $ do
  -
  - Returns any remotes that it failed to push to.
  -}
-pushToRemotes :: Bool -> [Remote] -> Assistant [Remote]
-pushToRemotes notifypushes remotes = do
+pushToRemotes :: [Remote] -> Assistant [Remote]
+pushToRemotes remotes = do
 	now <- liftIO getCurrentTime
 	let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes
-	syncAction remotes' (pushToRemotes' now notifypushes)
-pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
-pushToRemotes' now notifypushes remotes = do
+	syncAction remotes' (pushToRemotes' now)
+pushToRemotes' :: UTCTime -> [Remote] -> Assistant [Remote]
+pushToRemotes' now remotes = do
 	(g, branch, u) <- liftAnnex $ do
 		Annex.Branch.commit "update"
 		(,,)
 			<$> gitRepo
 			<*> join Command.Sync.getCurrBranch
 			<*> getUUID
-	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
+	let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
 	ret <- go True branch g u normalremotes
-	unless (null xmppremotes) $ do
-		shas <- liftAnnex $ map fst <$>
-			inRepo (Git.Ref.matchingWithHEAD
-				[Annex.Branch.fullname, Git.Ref.headRef])
-		forM_ xmppremotes $ \r -> sendNetMessage $
-			Pushing (getXMPPClientID r) (CanPush u shas)
 	return ret
   where
 	go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
@@ -151,11 +131,7 @@ pushToRemotes' now notifypushes remotes = do
 		(succeeded, failed) <- parallelPush g rs (push branch)
 		updatemap succeeded []
 		if null failed
-			then do
-				when notifypushes $
-					sendNetMessage $ NotifyPush $
-						map Remote.uuid succeeded
-				return failed
+			then return []
 			else if shouldretry
 				then retry currbranch g u failed
 				else fallback branch g u failed
@@ -174,9 +150,6 @@ pushToRemotes' now notifypushes remotes = do
 		debug ["fallback pushing to", show rs]
 		(succeeded, failed) <- parallelPush g rs (taggedPush u Nothing branch)
 		updatemap succeeded failed
-		when (notifypushes && (not $ null succeeded)) $
-			sendNetMessage $ NotifyPush $
-				map Remote.uuid succeeded
 		return failed
 		
 	push branch remote = Command.Sync.pushBranch remote branch
@@ -194,10 +167,6 @@ parallelPush g rs a = do
 {- Displays an alert while running an action that syncs with some remotes,
  - and returns any remotes that it failed to sync with.
  -
- - XMPP remotes are handled specially; since the action can only start
- - an async process for them, they are not included in the alert, but are
- - still passed to the action.
- -
  - Readonly remotes are also hidden (to hide the web special remote).
  -}
 syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote]
@@ -221,15 +190,11 @@ syncAction rs a
  - remotes that it failed to pull from, and a Bool indicating
  - whether the git-annex branches of the remotes and local had
  - diverged before the pull.
- -
- - After pulling from the normal git remotes, requests pushes from any
- - XMPP remotes. However, those pushes will run asynchronously, so their
- - results are not included in the return data.
  -}
 manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
 manualPull currentbranch remotes = do
 	g <- liftAnnex gitRepo
-	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
+	let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
 	failed <- forM normalremotes $ \r -> do
 		g' <- liftAnnex $ sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g
 		ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g')
@@ -239,9 +204,6 @@ manualPull currentbranch remotes = do
 	haddiverged <- liftAnnex Annex.Branch.forceUpdate
 	forM_ normalremotes $ \r ->
 		liftAnnex $ Command.Sync.mergeRemote r currentbranch Command.Sync.mergeConfig
-	u <- liftAnnex getUUID
-	forM_ xmppremotes $ \r ->
-		sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
 	return (catMaybes failed, haddiverged)
 
 {- Start syncing a remote, using a background thread. -}
@@ -249,7 +211,7 @@ syncRemote :: Remote -> Assistant ()
 syncRemote remote = do
 	updateSyncRemotes
 	thread <- asIO $ do
-		reconnectRemotes False [remote]
+		reconnectRemotes [remote]
 		addScanRemotes True [remote]
 	void $ liftIO $ forkIO $ thread
 

Assistant/Threads/Merger.hs

@@ -10,19 +10,12 @@ module Assistant.Threads.Merger where
 import Assistant.Common
 import Assistant.TransferQueue
 import Assistant.BranchChange
-import Assistant.DaemonStatus
-import Assistant.ScanRemotes
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import qualified Annex.Branch
 import qualified Git
 import qualified Git.Branch
 import qualified Command.Sync
-import Annex.TaggedPush
-import Remote (remoteFromUUID)
-
-import qualified Data.Set as S
-import qualified Data.Text as T
 
 {- This thread watches for changes to .git/refs/, and handles incoming
  - pushes. -}
@@ -69,8 +62,7 @@ onChange file
 		branchChanged
 		diverged <- liftAnnex Annex.Branch.forceUpdate
 		when diverged $
-			unlessM handleDesynced $
-				queueDeferredDownloads "retrying deferred download" Later
+			queueDeferredDownloads "retrying deferred download" Later
 	| "/synced/" `isInfixOf` file =
 		mergecurrent =<< liftAnnex (join Command.Sync.getCurrBranch)
 	| otherwise = noop
@@ -90,22 +82,6 @@ onChange file
 					changedbranch
 	mergecurrent _ = noop
 
-	handleDesynced = case fromTaggedBranch changedbranch of
-		Nothing -> return False
-		Just (u, info) -> do
-			mr <- liftAnnex $ remoteFromUUID u
-			case mr of
-				Nothing -> return False
-				Just r -> do
-					s <- desynced <$> getDaemonStatus
-					if S.member u s || Just (T.unpack $ getXMPPClientID r) == info
-						then do
-							modifyDaemonStatus_ $ \st -> st
-								{ desynced = S.delete u s }
-							addScanRemotes True [r]
-							return True
-						else return False
-
 equivBranches :: Git.Ref -> Git.Ref -> Bool
 equivBranches x y = base x == base y
   where

Assistant/Threads/MountWatcher.hs

@@ -146,7 +146,7 @@ handleMount urlrenderer dir = do
 	debug ["detected mount of", dir]
 	rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
 	mapM_ (fsckNudge urlrenderer . Just) rs
-	reconnectRemotes True rs
+	reconnectRemotes rs
 
 {- Finds remotes located underneath the mount point.
  -

Assistant/Threads/NetWatcher.hs

@@ -22,7 +22,6 @@ import Assistant.RemoteControl
 import Utility.DBus
 import DBus.Client
 import DBus
-import Assistant.NetMessager
 #else
 #ifdef linux_HOST_OS
 #warning Building without dbus support; will poll for network connection changes
@@ -44,9 +43,8 @@ netWatcherThread = thread noop
  - while (despite the local network staying up), are synced with
  - periodically.
  -
- - Note that it does not call notifyNetMessagerRestart, or
- - signal the RemoteControl, because it doesn't know that the
- - network has changed.
+ - Note that it does not signal the RemoteControl, because it doesn't 
+ - know that the network has changed.
  -}
 netWatcherFallbackThread :: NamedThread
 netWatcherFallbackThread = namedThread "NetWatcherFallback" $
@@ -76,7 +74,6 @@ dbusThread = do
 		sendRemoteControl LOSTNET
 	connchange True = do
 		debug ["detected network connection"]
-		notifyNetMessagerRestart
 		handleConnection
 		sendRemoteControl RESUME
 	onerr e _ = do
@@ -197,7 +194,7 @@ listenWicdConnections client setconnected = do
 handleConnection :: Assistant ()
 handleConnection = do
 	liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus
-	reconnectRemotes True =<< networkRemotes
+	reconnectRemotes =<< networkRemotes
 
 {- Network remotes to sync with. -}
 networkRemotes :: Assistant [Remote]

Assistant/Threads/Pusher.hs

@@ -24,7 +24,7 @@ pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
 	topush <- getFailedPushesBefore (fromIntegral halfhour)
 	unless (null topush) $ do
 		debug ["retrying", show (length topush), "failed pushes"]
-		void $ pushToRemotes True topush
+		void $ pushToRemotes topush
   where
 	halfhour = 1800
 
@@ -35,7 +35,7 @@ pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do
 	-- Next, wait until at least one commit has been made
 	void getCommits
 	-- Now see if now's a good time to push.
-	void $ pushToRemotes True =<< pushTargets
+	void $ pushToRemotes =<< pushTargets
 
 {- We want to avoid pushing to remotes that are marked readonly.
  -

Assistant/Threads/TransferScanner.hs

@@ -76,7 +76,7 @@ transferScannerThread urlrenderer = namedThread "TransferScanner" $ do
 	 -   to determine if the remote has been emptied.
 	 -}
 	startupScan = do
-		reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus
+		reconnectRemotes =<< syncGitRemotes <$> getDaemonStatus
 		addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus
 
 {- This is a cheap scan for failed transfers involving a remote. -}

Assistant/Threads/WebApp.hs

@@ -26,7 +26,6 @@ import Assistant.WebApp.Configurators.Pairing
 import Assistant.WebApp.Configurators.AWS
 import Assistant.WebApp.Configurators.IA
 import Assistant.WebApp.Configurators.WebDAV
-import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Configurators.Preferences
 import Assistant.WebApp.Configurators.Unused
 import Assistant.WebApp.Configurators.Edit
@@ -37,6 +36,7 @@ import Assistant.WebApp.Documentation
 import Assistant.WebApp.Control
 import Assistant.WebApp.OtherRepos
 import Assistant.WebApp.Repair
+import Assistant.WebApp.Pairing
 import Assistant.Types.ThreadedMonad
 import Utility.WebApp
 import Utility.AuthToken
@@ -83,6 +83,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
 		<*> pure cannotrun
 		<*> pure noannex
 		<*> pure listenhost'
+		<*> newWormholePairingState
 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
 	app <- toWaiAppPlain webapp
 	app' <- ifM debugEnabled

Assistant/Threads/XMPPClient.hs

@@ -1,375 +0,0 @@
-{- git-annex XMPP client
- -
- - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Threads.XMPPClient where
-
-import Assistant.Common hiding (ProtocolError)
-import Assistant.XMPP
-import Assistant.XMPP.Client
-import Assistant.NetMessager
-import Assistant.Types.NetMessager
-import Assistant.Types.Buddies
-import Assistant.XMPP.Buddies
-import Assistant.Sync
-import Assistant.DaemonStatus
-import qualified Remote
-import Utility.ThreadScheduler
-import Assistant.WebApp (UrlRenderer)
-import Assistant.WebApp.Types hiding (liftAssistant)
-import Assistant.Alert
-import Assistant.Pairing
-import Assistant.XMPP.Git
-import Annex.UUID
-import Logs.UUID
-import qualified Command.Sync
-
-import Network.Protocol.XMPP
-import Control.Concurrent
-import Control.Concurrent.STM.TMVar
-import Control.Concurrent.STM (atomically)
-import qualified Data.Text as T
-import qualified Data.Set as S
-import qualified Data.Map as M
-import Data.Time.Clock
-import Control.Concurrent.Async
-
-xmppClientThread :: UrlRenderer -> NamedThread
-xmppClientThread urlrenderer = namedThread "XMPPClient" $
-	restartableClient . xmppClient urlrenderer =<< getAssistant id
-
-{- Runs the client, handing restart events. -}
-restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant ()
-restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
-  where
-	go Nothing = waitNetMessagerRestart
-	go (Just creds) = do
-		xmppuuid <- maybe NoUUID Remote.uuid . headMaybe 
-			. filter Remote.isXMPPRemote . syncRemotes
-			<$> getDaemonStatus
-		tid <- liftIO $ forkIO $ a creds xmppuuid
-		waitNetMessagerRestart
-		liftIO $ killThread tid
-
-xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO ()
-xmppClient urlrenderer d creds xmppuuid =
-	retry (runclient creds) =<< getCurrentTime
-  where
-	liftAssistant = runAssistant d
-	inAssistant = liftIO . liftAssistant
-
-	{- When the client exits, it's restarted;
-	 - if it keeps failing, back off to wait 5 minutes before
-	 - trying it again. -}
-	retry client starttime = do
-		{- The buddy list starts empty each time
-		 - the client connects, so that stale info
-		 - is not retained. -}
-		liftAssistant $
-			updateBuddyList (const noBuddies) <<~ buddyList
-		void client
-		liftAssistant $ do
-			modifyDaemonStatus_ $ \s -> s
-				{ xmppClientID = Nothing }
-			changeCurrentlyConnected $ S.delete xmppuuid
-			
-		now <- getCurrentTime
-		if diffUTCTime now starttime > 300
-			then do
-				liftAssistant $ debug ["connection lost; reconnecting"]
-				retry client now
-			else do
-				liftAssistant $ debug ["connection failed; will retry"]
-				threadDelaySeconds (Seconds 300)
-				retry client =<< getCurrentTime
-
-	runclient c = liftIO $ connectXMPP c $ \jid -> do
-		selfjid <- bindJID jid
-		putStanza gitAnnexSignature
-
-		inAssistant $ do
-			modifyDaemonStatus_ $ \s -> s
-				{ xmppClientID = Just $ xmppJID creds }
-			changeCurrentlyConnected $ S.insert xmppuuid
-			debug ["connected", logJid selfjid]
-
-		lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime
-
-		sender <- xmppSession $ sendnotifications selfjid
-		receiver <- xmppSession $ receivenotifications selfjid lasttraffic
-		pinger <- xmppSession $ sendpings selfjid lasttraffic
-		{- Run all 3 threads concurrently, until
-		 - any of them throw an exception.
-		 - Then kill all 3 threads, and rethrow the
-		 - exception.
-		 -
-		 - If this thread gets an exception, the 3 threads
-		 - will also be killed. -}
-		liftIO $ pinger `concurrently` sender `concurrently` receiver
-
-	sendnotifications selfjid = forever $
-		join $ inAssistant $ relayNetMessage selfjid
-	receivenotifications selfjid lasttraffic = forever $ do
-		l <- decodeStanza selfjid <$> getStanza
-		void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime
-		inAssistant $ debug
-			["received:", show $ map logXMPPEvent l]
-		mapM_ (handlemsg selfjid) l
-	sendpings selfjid lasttraffic = forever $ do
-		putStanza pingstanza
-
-		startping <- liftIO getCurrentTime
-		liftIO $ threadDelaySeconds (Seconds 120)
-		t <- liftIO $ atomically $ readTMVar lasttraffic
-		when (t < startping) $ do
-			inAssistant $ debug ["ping timeout"]
-			error "ping timeout"
-	  where
-		{- XEP-0199 says that the server will respond with either
-		 - a ping response or an error message. Either will
-		 - cause traffic, so good enough. -}
-		pingstanza = xmppPing selfjid
-
-	handlemsg selfjid (PresenceMessage p) = do
-		void $ inAssistant $ 
-			updateBuddyList (updateBuddies p) <<~ buddyList
-		resendImportantMessages selfjid p
-	handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
-	handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
-	handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) =
-		maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
-	handlemsg _ (GotNetMessage m@(Pushing _ pushstage))
-		| isPushNotice pushstage = inAssistant $ handlePushNotice m
-		| isPushInitiation pushstage = inAssistant $ queuePushInitiation m
-		| otherwise = inAssistant $ storeInbox m
-	handlemsg _ (Ignorable _) = noop
-	handlemsg _ (Unknown _) = noop
-	handlemsg _ (ProtocolError _) = noop
-
-	resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do
-		let c = formatJID jid
-		(stored, sent) <- inAssistant $
-			checkImportantNetMessages (formatJID (baseJID jid), c)
-		forM_ (S.toList $ S.difference stored sent) $ \msg -> do
-			let msg' = readdressNetMessage msg c
-			inAssistant $ debug
-				[ "sending to new client:"
-				, logJid jid
-				, show $ logNetMessage msg'
-				]
-			join $ inAssistant $ convertNetMsg msg' selfjid
-			inAssistant $ sentImportantNetMessage msg c
-	resendImportantMessages _ _ = noop
-
-data XMPPEvent
-	= GotNetMessage NetMessage
-	| PresenceMessage Presence
-	| Ignorable ReceivedStanza
-	| Unknown ReceivedStanza
-	| ProtocolError ReceivedStanza
-	deriving Show
-
-logXMPPEvent :: XMPPEvent -> String
-logXMPPEvent (GotNetMessage m) = logNetMessage m
-logXMPPEvent (PresenceMessage p) = logPresence p
-logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p
-logXMPPEvent (Ignorable _) = "Ignorable message"
-logXMPPEvent (Unknown _) = "Unknown message"
-logXMPPEvent (ProtocolError _) = "Protocol error message"
-
-logPresence :: Presence -> String
-logPresence (p@Presence { presenceFrom = Just jid }) = unwords
-	[ "Presence from"
-	, logJid jid
-	, show $ extractGitAnnexTag p
-	]
-logPresence _ = "Presence from unknown"
-
-logJid :: JID -> String
-logJid jid =
-	let name = T.unpack (buddyName jid)
-	    resource = maybe "" (T.unpack . strResource) (jidResource jid)
-	in take 1 name ++ show (length name) ++ "/" ++ resource
-
-logClient :: Client -> String
-logClient (Client jid) = logJid jid
-
-{- Decodes an XMPP stanza into one or more events. -}
-decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
-decodeStanza selfjid s@(ReceivedPresence p)
-	| presenceType p == PresenceError = [ProtocolError s]
-	| isNothing (presenceFrom p) = [Ignorable s]
-	| presenceFrom p == Just selfjid = [Ignorable s]
-	| otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)
-  where
-	decode i
-		| tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
-			decodePushNotification (tagValue i)
-		| tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence
-		| otherwise = [Unknown s]
-	{- Things sent via presence imply a presence message,
-	 - along with their real meaning. -}
-	impliedp v = [PresenceMessage p, v]
-decodeStanza selfjid s@(ReceivedMessage m)
-	| isNothing (messageFrom m) = [Ignorable s]
-	| messageFrom m == Just selfjid = [Ignorable s]
-	| messageType m == MessageError = [ProtocolError s]
-	| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
-decodeStanza _ s = [Unknown s]
-
-{- Waits for a NetMessager message to be sent, and relays it to XMPP.
- -
- - Chat messages must be directed to specific clients, not a base
- - account JID, due to git-annex clients using a negative presence priority.
- - PairingNotification messages are always directed at specific
- - clients, but Pushing messages are sometimes not, and need to be exploded
- - out to specific clients.
- -
- - Important messages, not directed at any specific client, 
- - are cached to be sent later when additional clients connect.
- -}
-relayNetMessage :: JID -> Assistant (XMPP ())
-relayNetMessage selfjid = do
-	msg <- waitNetMessage
-	debug ["sending:", logNetMessage msg]
-	a1 <- handleImportant msg
-	a2 <- convert msg
-	return (a1 >> a2)
-  where
-	handleImportant msg = case parseJID =<< isImportantNetMessage msg of
-		Just tojid
-			| tojid == baseJID tojid -> do
-				storeImportantNetMessage msg (formatJID tojid) $
-					\c -> (baseJID <$> parseJID c) == Just tojid
-				return $ putStanza presenceQuery
-		_ -> return noop
-	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
-		if tojid == baseJID tojid
-			then do
-				clients <- maybe [] (S.toList . buddyAssistants)
-					<$> getBuddy (genBuddyKey tojid) <<~ buddyList
-				debug ["exploded undirected message to clients", unwords $ map logClient clients]
-				return $ forM_ clients $ \(Client jid) ->
-					putStanza $ pushMessage pushstage jid selfjid
-			else do
-				debug ["to client:", logJid tojid]
-				return $ putStanza $ pushMessage pushstage tojid selfjid
-	convert msg = convertNetMsg msg selfjid
-
-{- Converts a NetMessage to an XMPP action. -}
-convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ())
-convertNetMsg msg selfjid = convert msg
-  where
-	convert (NotifyPush us) = return $ putStanza $ pushNotification us
-	convert QueryPresence = return $ putStanza presenceQuery
-	convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do
-		changeBuddyPairing tojid True
-		return $ putStanza $ pairingNotification stage u tojid selfjid
-	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
-		return $ putStanza $  pushMessage pushstage tojid selfjid
-
-withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ())
-withOtherClient selfjid c a = case parseJID c of
-	Nothing -> return noop
-	Just tojid
-		| tojid == selfjid -> return noop
-		| otherwise -> a tojid
-
-withClient :: ClientID -> (JID -> XMPP ()) -> XMPP ()
-withClient c a = maybe noop a $ parseJID c
-
-{- Returns an IO action that runs a XMPP action in a separate thread,
- - using a session to allow it to access the same XMPP client. -}
-xmppSession :: XMPP () -> XMPP (IO ())
-xmppSession a = do
-	s <- getSession
-	return $ void $ runXMPP s a
-
-{- We only pull from one remote out of the set listed in the push
- - notification, as an optimisation.
- -
- - Note that it might be possible (though very unlikely) for the push
- - notification to take a while to be sent, and multiple pushes happen
- - before it is sent, so it includes multiple remotes that were pushed
- - to at different times. 
- -
- - It could then be the case that the remote we choose had the earlier
- - push sent to it, but then failed to get the later push, and so is not
- - fully up-to-date. If that happens, the pushRetryThread will come along
- - and retry the push, and we'll get another notification once it succeeds,
- - and pull again. -}
-pull :: [UUID] -> Assistant ()
-pull [] = noop
-pull us = do
-	rs <- filter matching . syncGitRemotes <$> getDaemonStatus
-	debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
-	pullone rs =<< liftAnnex (join Command.Sync.getCurrBranch)
-  where
-	matching r = Remote.uuid r `S.member` s
-	s = S.fromList us
-
-	pullone [] _ = noop
-	pullone (r:rs) branch =
-		unlessM (null . fst <$> manualPull branch [r]) $
-			pullone rs branch
-
-{- PairReq from another client using our JID is automatically
- - accepted. This is so pairing devices all using the same XMPP
- - account works without confirmations.
- -
- - Also, autoaccept PairReq from the same JID of any repo we've
- - already paired with, as long as the UUID in the PairReq is
- - one we know about.
--}
-pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()
-pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
-	| baseJID selfjid == baseJID theirjid = autoaccept
-	| otherwise = do
-		knownjids <- mapMaybe (parseJID . getXMPPClientID)
-			. filter Remote.isXMPPRemote . syncRemotes <$> getDaemonStatus
-		um <- liftAnnex uuidMap
-		if elem (baseJID theirjid) knownjids && M.member theiruuid um
-			then autoaccept
-			else showalert
-
-  where
-	autoaccept = do
-		selfuuid <- liftAnnex getUUID
-		sendNetMessage $
-			PairingNotification PairAck (formatJID theirjid) selfuuid
-		finishXMPPPairing theirjid theiruuid
-	-- Show an alert to let the user decide if they want to pair.
-	showalert = do
-		button <- mkAlertButton True (T.pack "Respond") urlrenderer $
-			ConfirmXMPPPairFriendR $
-				PairKey theiruuid $ formatJID theirjid
-		void $ addAlert $ pairRequestReceivedAlert
-			(T.unpack $ buddyName theirjid)
-			button
-
-{- PairAck must come from one of the buddies we are pairing with;
- - don't pair with just anyone. -}
-pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
-	whenM (isBuddyPairing theirjid) $ do
-		changeBuddyPairing theirjid False
-		selfuuid <- liftAnnex getUUID
-		sendNetMessage $
-			PairingNotification PairDone (formatJID theirjid) selfuuid
-		finishXMPPPairing theirjid theiruuid
-
-pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =
-	changeBuddyPairing theirjid False
-
-isBuddyPairing :: JID -> Assistant Bool
-isBuddyPairing jid = maybe False buddyPairing <$> 
-	getBuddy (genBuddyKey jid) <<~ buddyList
-
-changeBuddyPairing :: JID -> Bool -> Assistant ()
-changeBuddyPairing jid ispairing =
-	updateBuddyList (M.adjust set key) <<~ buddyList
-  where
-	key = genBuddyKey jid
-	set b = b { buddyPairing = ispairing }

Assistant/Threads/XMPPPusher.hs

@@ -1,82 +0,0 @@
-{- git-annex XMPP pusher threads
- -
- - This is a pair of threads. One handles git send-pack,
- - and the other git receive-pack. Each thread can be running at most
- - one such operation at a time.
- -
- - Why not use a single thread? Consider two clients A and B.
- - If both decide to run a receive-pack at the same time to the other,
- - they would deadlock with only one thread. For larger numbers of
- - clients, the two threads are also sufficient.
- -
- - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Threads.XMPPPusher where
-
-import Assistant.Common
-import Assistant.NetMessager
-import Assistant.Types.NetMessager
-import Assistant.WebApp (UrlRenderer)
-import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)
-import Assistant.XMPP.Git
-
-import Control.Exception as E
-
-xmppSendPackThread :: UrlRenderer -> NamedThread
-xmppSendPackThread = pusherThread "XMPPSendPack" SendPack
-
-xmppReceivePackThread :: UrlRenderer -> NamedThread
-xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack
-
-pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread
-pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing
-  where
-	go lastpushedto = do
-		msg <- waitPushInitiation side $ selectNextPush lastpushedto
-		debug ["started running push", logNetMessage msg]
-
-		runpush <- asIO $ runPush checker msg
-		r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID)))
-		let successful = case r of
-			Right (Just _) -> True
-			_ -> False
-
-		{- Empty the inbox, because stuff may have
-		 - been left in it if the push failed. -}
-		let justpushedto = getclient msg
-		maybe noop (`emptyInbox` side) justpushedto
-
-		debug ["finished running push", logNetMessage msg, show successful]
-		go $ if successful then justpushedto else lastpushedto
-	
-	checker = checkCloudRepos urlrenderer
-
-	getclient (Pushing cid _) = Just cid
-	getclient _ = Nothing
-
-{- Select the next push to run from the queue.
- - The queue cannot be empty!
- -
- - We prefer to select the most recently added push, because its requestor
- - is more likely to still be connected.
- -
- - When passed the ID of a client we just pushed to, we prefer to not
- - immediately push again to that same client. This avoids one client 
- - drowing out others. So pushes from the client we just pushed to are 
- - relocated to the beginning of the list, to be processed later.
- -}
-selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage])
-selectNextPush _ (m:[]) = (m, []) -- common case
-selectNextPush _ [] = error "selectNextPush: empty list"
-selectNextPush lastpushedto l = go [] l
-  where
-	go (r:ejected) [] = (r, ejected)
-	go rejected (m:ms) = case m of
-		(Pushing clientid _)
-			| Just clientid /= lastpushedto -> (m, rejected ++ ms)
-		_ -> go (m:rejected) ms
-	go [] [] = error "empty push queue"
-

Assistant/Types/Buddies.hs

@@ -1,80 +0,0 @@
-{- git-annex assistant buddies
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE CPP #-}
-
-module Assistant.Types.Buddies where
-
-import Annex.Common
-
-import qualified Data.Map as M
-import Control.Concurrent.STM
-import Utility.NotificationBroadcaster
-import Data.Text as T
-
-{- For simplicity, dummy types are defined even when XMPP is disabled. -}
-#ifdef WITH_XMPP
-import Network.Protocol.XMPP
-import Data.Set as S
-import Data.Ord
-
-newtype Client = Client JID
-	deriving (Eq, Show)
-
-instance Ord Client where
-	compare = comparing show
-
-data Buddy = Buddy
-	{ buddyPresent :: S.Set Client
-	, buddyAway :: S.Set Client
-	, buddyAssistants :: S.Set Client
-	, buddyPairing :: Bool
-	}
-#else
-data Buddy = Buddy
-#endif
-	deriving (Eq, Show)
-
-data BuddyKey = BuddyKey T.Text
-	deriving (Eq, Ord, Show, Read)
-
-data PairKey = PairKey UUID T.Text
-	deriving (Eq, Ord, Show, Read)
-
-type Buddies = M.Map BuddyKey Buddy
-
-{- A list of buddies, and a way to notify when it changes. -}
-type BuddyList = (TMVar Buddies, NotificationBroadcaster)
-
-noBuddies :: Buddies
-noBuddies = M.empty
-
-newBuddyList :: IO BuddyList
-newBuddyList = (,)
-	<$> atomically (newTMVar noBuddies)
-	<*> newNotificationBroadcaster
-
-getBuddyList :: BuddyList -> IO [Buddy]
-getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
-
-getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)
-getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)
-
-getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
-getBuddyBroadcaster (_, h) = h
-
-{- Applies a function to modify the buddy list, and if it's changed,
- - sends notifications to any listeners. -}
-updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()
-updateBuddyList a (v, caster) = do
-	changed <- atomically $ do
-		buds <- takeTMVar v
-		let buds' = a buds
-		putTMVar v buds'
-		return $ buds /= buds'
-	when changed $
-		sendNotification caster

Assistant/Types/DaemonStatus.hs

@@ -12,7 +12,6 @@ import Assistant.Pairing
 import Utility.NotificationBroadcaster
 import Types.Transfer
 import Assistant.Types.ThreadName
-import Assistant.Types.NetMessager
 import Assistant.Types.Alert
 import Utility.Url
 
@@ -54,8 +53,6 @@ data DaemonStatus = DaemonStatus
 	, syncingToCloudRemote :: Bool
 	-- Set of uuids of remotes that are currently connected.
 	, currentlyConnectedRemotes :: S.Set UUID
-	-- List of uuids of remotes that we may have gotten out of sync with.
-	, desynced :: S.Set UUID
 	-- Pairing request that is in progress.
 	, pairingInProgress :: Maybe PairingInProgress
 	-- Broadcasts notifications about all changes to the DaemonStatus.
@@ -77,9 +74,6 @@ data DaemonStatus = DaemonStatus
 	, globalRedirUrl :: Maybe URLString
 	-- Actions to run after a Key is transferred.
 	, transferHook :: M.Map Key (Transfer -> IO ())
-	-- When the XMPP client is connected, this will contain the XMPP
-	-- address.
-	, xmppClientID :: Maybe ClientID
 	-- MVars to signal when a remote gets connected.
 	, connectRemoteNotifiers :: M.Map UUID [MVar ()]
 	}
@@ -105,7 +99,6 @@ newDaemonStatus = DaemonStatus
 	<*> pure []
 	<*> pure False
 	<*> pure S.empty
-	<*> pure S.empty
 	<*> pure Nothing
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
@@ -117,5 +110,4 @@ newDaemonStatus = DaemonStatus
 	<*> newNotificationBroadcaster
 	<*> pure Nothing
 	<*> pure M.empty
-	<*> pure Nothing
 	<*> pure M.empty

Assistant/Types/NetMessager.hs

@@ -1,155 +0,0 @@
-{- git-annex assistant out of band network messager types
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Types.NetMessager where
-
-import Annex.Common
-import Assistant.Pairing
-import Git.Types
-
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Set as S
-import qualified Data.Map as M
-import qualified Data.DList as D
-import Control.Concurrent.STM
-import Control.Concurrent.MSampleVar
-import Data.ByteString (ByteString)
-import Data.Text (Text)
-
-{- Messages that can be sent out of band by a network messager. -}
-data NetMessage 
-	-- indicate that pushes have been made to the repos with these uuids
-	= NotifyPush [UUID]
-	-- requests other clients to inform us of their presence
-	| QueryPresence
-	-- notification about a stage in the pairing process,
-	-- involving a client, and a UUID.
-	| PairingNotification PairStage ClientID UUID
-	-- used for git push over the network messager
-	| Pushing ClientID PushStage
-	deriving (Eq, Ord, Show)
-
-{- Something used to identify the client, or clients to send the message to. -}
-type ClientID = Text
-
-data PushStage
-	-- indicates that we have data to push over the out of band network
-	= CanPush UUID [Sha]
-	-- request that a git push be sent over the out of band network
-	| PushRequest UUID
-	-- indicates that a push is starting
-	| StartingPush UUID
-	-- a chunk of output of git receive-pack
-	| ReceivePackOutput SequenceNum ByteString
-	-- a chuck of output of git send-pack
-	| SendPackOutput SequenceNum ByteString
-	-- sent when git receive-pack exits, with its exit code
-	| ReceivePackDone ExitCode
-	deriving (Eq, Ord, Show)
-
-{- A sequence number. Incremented by one per packet in a sequence,
- - starting with 1 for the first packet. 0 means sequence numbers are
- - not being used. -}
-type SequenceNum = Int
-
-{- NetMessages that are important (and small), and should be stored to be
- - resent when new clients are seen. -}
-isImportantNetMessage :: NetMessage -> Maybe ClientID
-isImportantNetMessage (Pushing c (CanPush _ _)) = Just c
-isImportantNetMessage (Pushing c (PushRequest _)) = Just c
-isImportantNetMessage _ = Nothing
-
-{- Checks if two important NetMessages are equivilant.
- - That is to say, assuming they were sent to the same client,
- - would it do the same thing for one as for the other? -}
-equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool
-equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True
-equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True
-equivilantImportantNetMessages _ _ = False
-
-readdressNetMessage :: NetMessage -> ClientID -> NetMessage
-readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid
-readdressNetMessage (Pushing _ stage) c = Pushing c stage
-readdressNetMessage m _ = m
-
-{- Convert a NetMessage to something that can be logged. -}
-logNetMessage :: NetMessage -> String
-logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $
-	case stage of
-		ReceivePackOutput n _ -> ReceivePackOutput n elided
-		SendPackOutput n _ -> SendPackOutput n elided
-		s -> s
-  where
-	elided = T.encodeUtf8 $ T.pack "<elided>"
-logNetMessage (PairingNotification stage c uuid) =
-	show $ PairingNotification stage (logClientID c) uuid
-logNetMessage m = show m
-
-logClientID :: ClientID -> ClientID
-logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]
-
-{- Things that initiate either side of a push, but do not actually send data. -}
-isPushInitiation :: PushStage -> Bool
-isPushInitiation (PushRequest _) = True
-isPushInitiation (StartingPush _) = True
-isPushInitiation _ = False
-
-isPushNotice :: PushStage -> Bool
-isPushNotice (CanPush _ _) = True
-isPushNotice _ = False
-
-data PushSide = SendPack | ReceivePack
-	deriving (Eq, Ord, Show)
-
-pushDestinationSide :: PushStage -> PushSide
-pushDestinationSide (CanPush _ _) = ReceivePack
-pushDestinationSide (PushRequest _) = SendPack
-pushDestinationSide (StartingPush _) = ReceivePack
-pushDestinationSide (ReceivePackOutput _ _) = SendPack
-pushDestinationSide (SendPackOutput _ _) = ReceivePack
-pushDestinationSide (ReceivePackDone _) = SendPack
-
-type SideMap a = PushSide -> a
-
-mkSideMap :: STM a -> IO (SideMap a)
-mkSideMap gen = do
-	(sp, rp) <- atomically $ (,) <$> gen <*> gen
-	return $ lookupside sp rp
-  where
-	lookupside sp _ SendPack = sp
-	lookupside _ rp ReceivePack = rp
-
-getSide :: PushSide -> SideMap a -> a
-getSide side m = m side
-
-type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage))
-
-data NetMessager = NetMessager
-	-- outgoing messages
-	{ netMessages :: TChan NetMessage
-	-- important messages for each client
-	, importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
-	-- important messages that are believed to have been sent to a client
-	, sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
-	-- write to this to restart the net messager
-	, netMessagerRestart :: MSampleVar ()
-	-- queue of incoming messages that request the initiation of pushes
-	, netMessagerPushInitiations :: SideMap (TMVar [NetMessage])
-	-- incoming messages containing data for a running
-	-- (or not yet started) push
-	, netMessagerInboxes :: SideMap Inboxes
-	}
-
-newNetMessager :: IO NetMessager
-newNetMessager = NetMessager
-	<$> atomically newTChan
-	<*> atomically (newTMVar M.empty)
-	<*> atomically (newTMVar M.empty)
-	<*> newEmptySV
-	<*> mkSideMap newEmptyTMVar
-	<*> mkSideMap (newTVar M.empty)

Assistant/WebApp/Configurators.hs

@@ -5,26 +5,18 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.Configurators where
 
 import Assistant.WebApp.Common
 import Assistant.WebApp.RepoList
-#ifdef WITH_XMPP
-import Assistant.XMPP.Client
-#endif
 
 {- The main configuration screen. -}
 getConfigurationR :: Handler Html
 getConfigurationR = ifM inFirstRun
 	( redirect FirstRepositoryR
 	, page "Configuration" (Just Configuration) $ do
-#ifdef WITH_XMPP
-		xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds
-#else
-		let xmppconfigured = False
-#endif
 		$(widgetFile "configurators/main")
 	)
 
@@ -39,8 +31,8 @@ makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")
 makeCloudRepositories :: Widget
 makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
 
-makeXMPPConnection :: Widget
-makeXMPPConnection = $(widgetFile "configurators/addrepository/xmppconnection")
+makeWormholePairing :: Widget
+makeWormholePairing = $(widgetFile "configurators/addrepository/wormholepairing")
 
 makeSshRepository :: Widget
 makeSshRepository = $(widgetFile "configurators/addrepository/ssh")

Assistant/WebApp/Configurators/Delete.hs

@@ -37,16 +37,8 @@ notCurrentRepo uuid a = do
 	go Nothing = error "Unknown UUID"
 	go (Just _) = a
 
-handleXMPPRemoval :: UUID -> Handler Html -> Handler Html
-handleXMPPRemoval uuid nonxmpp = do
-	remote <- fromMaybe (error "unknown remote")
-		<$> liftAnnex (Remote.remoteFromUUID uuid)
-	if Remote.isXMPPRemote remote
-		then deletionPage $ $(widgetFile "configurators/delete/xmpp")
-		else nonxmpp
-
 getDeleteRepositoryR :: UUID -> Handler Html
-getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
+getDeleteRepositoryR uuid = notCurrentRepo uuid $ do
 	deletionPage $ do
 		reponame <- liftAnnex $ Remote.prettyUUID uuid
 		$(widgetFile "configurators/delete/start")

Assistant/WebApp/Configurators/Pairing.hs

@@ -1,41 +1,40 @@
 {- git-annex assistant webapp configurator for pairing
  -
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012,2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Configurators.Pairing where
 
 import Assistant.Pairing
 import Assistant.WebApp.Common
-import Assistant.Types.Buddies
 import Annex.UUID
 #ifdef WITH_PAIRING
-import Assistant.Pairing.Network
-import Assistant.Pairing.MakeRemote
-import Assistant.Ssh
-import Assistant.Alert
 import Assistant.DaemonStatus
+import Assistant.Pairing.MakeRemote
+import Assistant.Pairing.Network
+import Assistant.Ssh
 import Utility.Verifiable
 #endif
-#ifdef WITH_XMPP
-import Assistant.XMPP.Client
-import Assistant.XMPP.Buddies
-import Assistant.XMPP.Git
-import Network.Protocol.XMPP
-import Assistant.Types.NetMessager
-import Assistant.NetMessager
-import Assistant.WebApp.RepoList
-import Assistant.WebApp.Configurators
-import Assistant.WebApp.Configurators.XMPP
-#endif
 import Utility.UserInfo
+import Utility.Tor
+import Assistant.WebApp.Pairing
+import Assistant.Alert
+import qualified Utility.MagicWormhole as Wormhole
+import Assistant.MakeRemote
+import Assistant.RemoteControl
+import Assistant.Sync
+import Assistant.WebApp.SideBar
+import Command.P2P (unusedPeerRemoteName, PairingResult(..))
+import P2P.Address
 import Git
+import Config.Files
 
+import qualified Data.Map as M
 import qualified Data.Text as T
 #ifdef WITH_PAIRING
 import qualified Data.Text.Encoding as T
@@ -44,84 +43,110 @@ import Data.Char
 import qualified Control.Exception as E
 import Control.Concurrent
 #endif
-#ifdef WITH_XMPP
-import qualified Data.Set as S
-#endif
+import Control.Concurrent.STM hiding (check)
 
-getStartXMPPPairFriendR :: Handler Html
-#ifdef WITH_XMPP
-getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
-	( do
-		{- Ask buddies to send presence info, to get
-		 - the buddy list populated. -}
-		liftAssistant $ sendNetMessage QueryPresence
-		pairPage $
-			$(widgetFile "configurators/pairing/xmpp/friend/prompt")
-	, do
-		-- go get XMPP configured, then come back
-		redirect XMPPConfigForPairFriendR
+getStartWormholePairFriendR :: Handler Html
+getStartWormholePairFriendR = startWormholePairR PairingWithFriend
+
+getStartWormholePairSelfR :: Handler Html
+getStartWormholePairSelfR = startWormholePairR PairingWithSelf
+
+startWormholePairR :: PairingWith -> Handler Html
+startWormholePairR pairingwith = whenTorInstalled $ whenWormholeInstalled $
+	pairPage $
+		$(widgetFile "configurators/pairing/wormhole/start")
+
+getPrepareWormholePairR :: PairingWith -> Handler Html
+getPrepareWormholePairR pairingwith = do
+	enableTor
+	myaddrs <- liftAnnex loadP2PAddresses
+	remotename <- liftAnnex unusedPeerRemoteName
+	h <- liftAssistant $
+		startWormholePairing pairingwith remotename myaddrs
+	i <- liftIO . addWormholePairingState h
+		=<< wormholePairingState <$> getYesod
+	redirect $ RunningWormholePairR i
+
+enableTor :: Handler ()
+enableTor = do
+	gitannex <- liftIO readProgramFile
+	(transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing
+	if ok
+		-- Reload remotedameon so it's serving the tor hidden
+		-- service.
+		then liftAssistant $ sendRemoteControl RELOAD
+		else giveup $ "Failed to enable tor\n\n" ++ transcript
+
+getRunningWormholePairR :: WormholePairingId -> Handler Html
+getRunningWormholePairR = runningWormholePairR
+
+postRunningWormholePairR :: WormholePairingId -> Handler Html
+postRunningWormholePairR = runningWormholePairR
+
+runningWormholePairR :: WormholePairingId -> Handler Html
+runningWormholePairR i = go =<< getWormholePairingHandle i
+  where
+	go Nothing = redirect StartWormholePairFriendR
+	go (Just h) = pairPage $  withPairingWith h $ \pairingwith -> do
+		ourcode <- liftIO $ getOurWormholeCode h
+		let codeprompt = case pairingwith of
+			PairingWithFriend -> "Your friend's pairing code"
+			PairingWithSelf -> "The other device's pairing code"
+		((result, form), enctype) <- liftH $
+			runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
+				areq (checkwormholecode ourcode pairingwith textField) (bfs codeprompt) Nothing
+		case result of
+			FormSuccess t -> case Wormhole.toCode (T.unpack t) of
+				Nothing -> giveup invalidcode
+				Just theircode -> finish h theircode
+			_ -> showform form enctype ourcode pairingwith
+	
+	showform form enctype ourcode pairingwith =
+		$(widgetFile "configurators/pairing/wormhole/prompt")
+	
+	checkwormholecode ourcode pairingwith = check $ \t ->
+		case Wormhole.toCode (T.unpack t) of
+			Nothing -> Left (T.pack invalidcode)
+			Just theircode
+				| theircode == ourcode -> Left $
+					case pairingwith of
+						PairingWithSelf -> "Oops -- You entered this repository's pairing code. Enter the pairing code of the *other* repository."
+						PairingWithFriend -> "Oops -- You entered your pairing code. Enter your friend's pairing code."
+				| otherwise -> Right t
+
+	invalidcode = "That does not look like a valid pairing code. Try again..."
+
+	finish h theircode = do
+		void $ liftIO $ sendTheirWormholeCode h theircode
+		res <- liftAssistant $ finishWormholePairing h
+		case res of
+			SendFailed -> giveup "Failed sending data to pair."
+			ReceiveFailed -> giveup "Failed receiving data from pair."
+			LinkFailed e -> giveup $ "Failed linking to pair: " ++ e
+			PairSuccess -> withRemoteName h $ \remotename -> do
+				r <- liftAnnex $ addRemote (return remotename)
+				liftAssistant $ syncRemote r
+				liftAssistant $ sendRemoteControl RELOAD
+				redirect DashboardR
+
+getWormholePairingHandle :: WormholePairingId -> Handler (Maybe WormholePairingHandle)
+getWormholePairingHandle i = do
+	s <- wormholePairingState <$> getYesod
+	liftIO $ atomically $ M.lookup i <$> readTVar s
+
+whenTorInstalled :: Handler Html -> Handler Html
+whenTorInstalled a = ifM (liftIO torIsInstalled)
+	( a
+	, page "Need Tor" (Just Configuration) $
+		$(widgetFile "configurators/needtor")
 	)
-#else
-getStartXMPPPairFriendR = noXMPPPairing
 
-noXMPPPairing :: Handler Html
-noXMPPPairing = noPairing "XMPP"
-#endif
-
-getStartXMPPPairSelfR :: Handler Html
-#ifdef WITH_XMPP
-getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
-  where
-	go Nothing = do
-		-- go get XMPP configured, then come back
-		redirect XMPPConfigForPairSelfR
-	go (Just creds) = do
-		{- Ask buddies to send presence info, to get
-		 - the buddy list populated. -}
-		liftAssistant $ sendNetMessage QueryPresence
-		let account = xmppJID creds
-		pairPage $
-			$(widgetFile "configurators/pairing/xmpp/self/prompt")
-#else
-getStartXMPPPairSelfR = noXMPPPairing
-#endif
-
-getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
-getRunningXMPPPairFriendR = sendXMPPPairRequest . Just
-
-getRunningXMPPPairSelfR :: Handler Html
-getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing
-
-{- Sends a XMPP pair request, to a buddy or to self. -}
-sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
-#ifdef WITH_XMPP
-sendXMPPPairRequest mbid = do
-	bid <- maybe getself return mbid
-	buddy <- liftAssistant $ getBuddy bid <<~ buddyList
-	go $ S.toList . buddyAssistants <$> buddy
-  where
-	go (Just (clients@((Client exemplar):_))) = do
-		u <- liftAnnex getUUID
-		liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $
-			PairingNotification PairReq (formatJID c) u
-		xmppPairStatus True $
-			if selfpair then Nothing else Just exemplar
-	go _
-		{- Nudge the user to turn on their other device. -}
-		| selfpair = do
-			liftAssistant $ sendNetMessage QueryPresence
-			pairPage $
-				$(widgetFile "configurators/pairing/xmpp/self/retry")
-		{- Buddy could have logged out, etc.
-		 - Go back to buddy list. -}
-		| otherwise = redirect StartXMPPPairFriendR
-	selfpair = isNothing mbid
-	getself = maybe (error "XMPP not configured")
-			(return . BuddyKey . xmppJID)
-				=<< liftAnnex getXMPPCreds
-#else
-sendXMPPPairRequest _ = noXMPPPairing
-#endif
+whenWormholeInstalled :: Handler Html -> Handler Html
+whenWormholeInstalled a = ifM (liftIO Wormhole.isInstalled)
+	( a
+	, page "Need Magic Wormhole" (Just Configuration) $
+		$(widgetFile "configurators/needmagicwormhole")
+	)
 
 {- Starts local pairing. -}
 getStartLocalPairR :: Handler Html
@@ -158,41 +183,6 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
 postFinishLocalPairR _ = noLocalPairing
 #endif
 
-getConfirmXMPPPairFriendR :: PairKey -> Handler Html
-#ifdef WITH_XMPP
-getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
-	Nothing -> error "bad JID"
-	Just theirjid -> pairPage $ do
-		let name = buddyName theirjid
-		$(widgetFile "configurators/pairing/xmpp/friend/confirm")
-#else
-getConfirmXMPPPairFriendR _ = noXMPPPairing
-#endif
-
-getFinishXMPPPairFriendR :: PairKey -> Handler Html
-#ifdef WITH_XMPP
-getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
-	Nothing -> error "bad JID"
-	Just theirjid -> do
-		selfuuid <- liftAnnex getUUID
-		liftAssistant $ do
-			sendNetMessage $
-				PairingNotification PairAck (formatJID theirjid) selfuuid
-			finishXMPPPairing theirjid theiruuid
-		xmppPairStatus False $ Just theirjid
-#else
-getFinishXMPPPairFriendR _ = noXMPPPairing
-#endif
-
-{- Displays a page indicating pairing status and 
- - prompting to set up cloud repositories. -}
-#ifdef WITH_XMPP
-xmppPairStatus :: Bool -> Maybe JID -> Handler Html
-xmppPairStatus inprogress theirjid = pairPage $ do
-	let friend = buddyName <$> theirjid
-	$(widgetFile "configurators/pairing/xmpp/end")
-#endif
-
 getRunningLocalPairR :: SecretReminder -> Handler Html
 #ifdef WITH_PAIRING
 getRunningLocalPairR s = pairPage $ do

Assistant/WebApp/Configurators/XMPP.hs

@@ -1,226 +0,0 @@
-{- git-annex assistant XMPP configuration
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU AGPL version 3 or higher.
- -}
-
-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
-{-# LANGUAGE CPP #-}
-
-module Assistant.WebApp.Configurators.XMPP where
-
-import Assistant.WebApp.Common
-import Assistant.WebApp.Notifications
-import Utility.NotificationBroadcaster
-#ifdef WITH_XMPP
-import qualified Remote
-import Assistant.XMPP.Client
-import Assistant.XMPP.Buddies
-import Assistant.Types.Buddies
-import Assistant.NetMessager
-import Assistant.Alert
-import Assistant.DaemonStatus
-import Assistant.WebApp.RepoList
-import Assistant.WebApp.Configurators
-import Assistant.XMPP
-import qualified Git.Remote.Remove
-import Remote.List
-import Creds
-#endif
-
-#ifdef WITH_XMPP
-import Network.Protocol.XMPP
-import Network
-import qualified Data.Text as T
-#endif
-
-{- When appropriate, displays an alert suggesting to configure a cloud repo
- - to suppliment an XMPP remote. -}
-checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
-#ifdef WITH_XMPP
-checkCloudRepos urlrenderer r =
-	unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
-		buddyname <- getBuddyName $ Remote.uuid r
-		button <- mkAlertButton True "Add a cloud repository" urlrenderer $
-			NeedCloudRepoR $ Remote.uuid r
-		void $ addAlert $ cloudRepoNeededAlert buddyname button
-#else
-checkCloudRepos _ _ = noop
-#endif
-
-#ifdef WITH_XMPP
-{- Returns the name of the friend corresponding to a
- - repository's UUID, but not if it's our name. -}
-getBuddyName :: UUID -> Assistant (Maybe String)
-getBuddyName u = go =<< getclientjid
-  where
-	go Nothing = return Nothing
-	go (Just myjid) = (T.unpack . buddyName <$>)
-		. headMaybe 
-		. filter (\j -> baseJID j /= baseJID myjid)
-		. map fst
-		. filter (\(_, r) -> Remote.uuid r == u)
-		<$> getXMPPRemotes
-	getclientjid = maybe Nothing parseJID . xmppClientID
-		<$> getDaemonStatus
-#endif
-
-getNeedCloudRepoR :: UUID -> Handler Html
-#ifdef WITH_XMPP
-getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
-	buddyname <- liftAssistant $ getBuddyName for
-	$(widgetFile "configurators/xmpp/needcloudrepo")
-#else
-getNeedCloudRepoR _ = xmppPage $
-	$(widgetFile "configurators/xmpp/disabled")
-#endif
-
-getXMPPConfigR :: Handler Html
-getXMPPConfigR = postXMPPConfigR
-
-postXMPPConfigR :: Handler Html
-postXMPPConfigR = xmppform DashboardR
-
-getXMPPConfigForPairFriendR :: Handler Html
-getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
-
-postXMPPConfigForPairFriendR :: Handler Html
-postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
-
-getXMPPConfigForPairSelfR :: Handler Html
-getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
-
-postXMPPConfigForPairSelfR :: Handler Html
-postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
-
-xmppform :: Route WebApp -> Handler Html
-#ifdef WITH_XMPP
-xmppform next = xmppPage $ do
-	((result, form), enctype) <- liftH $ do
-		oldcreds <- liftAnnex getXMPPCreds
-		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $
-			creds2Form <$> oldcreds
-	let showform problem = $(widgetFile "configurators/xmpp")
-	case result of
-		FormSuccess f -> either (showform . Just) (liftH . storecreds)
-			=<< liftIO (validateForm f)
-		_ -> showform Nothing
-  where
-	storecreds creds = do
-		void $ liftAnnex $ setXMPPCreds creds
-		liftAssistant notifyNetMessagerRestart
-		redirect next
-#else
-xmppform _ = xmppPage $
-	$(widgetFile "configurators/xmpp/disabled")
-#endif
-
-{- Called by client to get a list of buddies.
- -
- - Returns a div, which will be inserted into the calling page.
- -}
-getBuddyListR :: NotificationId -> Handler Html
-getBuddyListR nid = do
-	waitNotifier getBuddyListBroadcaster nid
-
-	p <- widgetToPageContent buddyListDisplay
-	withUrlRenderer $ [hamlet|^{pageBody p}|]
-
-buddyListDisplay :: Widget
-buddyListDisplay = do
-	autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
-#ifdef WITH_XMPP
-	myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus
-	let isself (BuddyKey b) = Just b == myjid
-	buddies <- liftAssistant $ do
-		pairedwith <- map fst <$> getXMPPRemotes
-		catMaybes . map (buddySummary pairedwith)
-			<$> (getBuddyList <<~ buddyList)
-	$(widgetFile "configurators/xmpp/buddylist")
-#else
-	noop
-#endif
-  where
-	ident = "buddylist"
-
-#ifdef WITH_XMPP
-
-getXMPPRemotes :: Assistant [(JID, Remote)]
-getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes
-	<$> getDaemonStatus
-  where
-	pair r = maybe Nothing (\jid -> Just (jid, r)) $
-		parseJID $ getXMPPClientID r
-
-data XMPPForm = XMPPForm
-	{ formJID :: Text
-	, formPassword :: Text }
-
-creds2Form :: XMPPCreds -> XMPPForm
-creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
-
-xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
-xmppAForm d = XMPPForm
-	<$> areq jidField (bfs "Jabber address") (formJID <$> d)
-	<*> areq passwordField (bfs "Password") Nothing
-
-jidField :: MkField Text
-jidField = checkBool (isJust . parseJID) bad textField
-  where
-	bad :: Text
-	bad = "This should look like an email address.."
-
-validateForm :: XMPPForm -> IO (Either String XMPPCreds)
-validateForm f = do
-	let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
-	let username = fromMaybe "" (strNode <$> jidNode jid)
-	testXMPP $ XMPPCreds
-		{ xmppUsername = username
-		, xmppPassword = formPassword f
-		, xmppHostname = T.unpack $ strDomain $ jidDomain jid
-		, xmppPort = 5222
-		, xmppJID = formJID f
-		}
-
-testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
-testXMPP creds = do
-	(good, bad) <- partition (either (const False) (const True) . snd) 
-		<$> connectXMPP creds (const noop)
-	case good of
-		(((h, PortNumber p), _):_) -> return $ Right $ creds
-			{ xmppHostname = h
-			, xmppPort = fromIntegral p
-			}
-		(((h, _), _):_) -> return $ Right $ creds
-			{ xmppHostname = h
-			}
-		_ -> return $ Left $ intercalate "; " $ map formatlog bad
-  where
-	formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
-	formatlog _ = ""
-
-	showport (PortNumber n) = show n
-	showport (Service s) = s
-	showport (UnixSocket s) = s
-#endif
-
-getDisconnectXMPPR :: Handler Html
-getDisconnectXMPPR = do
-#ifdef WITH_XMPP
-	rs <- filter Remote.isXMPPRemote . syncRemotes
-		<$> liftAssistant getDaemonStatus
-	liftAnnex $ do
-		mapM_ (inRepo . Git.Remote.Remove.remove . Remote.name) rs
-		void remoteListRefresh
-		removeCreds xmppCredsFile
-	liftAssistant $ do
-		updateSyncRemotes
-		notifyNetMessagerRestart
-	redirect DashboardR
-#else
-	xmppPage $ $(widgetFile "configurators/xmpp/disabled")
-#endif
-
-xmppPage :: Widget -> Handler Html
-xmppPage = page "Jabber" (Just Configuration)

Assistant/WebApp/Notifications.hs

@@ -13,7 +13,6 @@ import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.DaemonStatus
-import Assistant.Types.Buddies
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 import Utility.AuthToken
@@ -60,9 +59,6 @@ getNotifierTransfersR = notifierUrl TransfersR getTransferBroadcaster
 getNotifierSideBarR :: Handler RepPlain
 getNotifierSideBarR = notifierUrl SideBarR getAlertBroadcaster
 
-getNotifierBuddyListR :: Handler RepPlain
-getNotifierBuddyListR = notifierUrl BuddyListR getBuddyListBroadcaster
-
 getNotifierRepoListR :: RepoSelector -> Handler RepPlain
 getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster
   where
@@ -77,9 +73,6 @@ getTransferBroadcaster = transferNotifier <$> getDaemonStatus
 getAlertBroadcaster :: Assistant NotificationBroadcaster
 getAlertBroadcaster = alertNotifier <$> getDaemonStatus
 
-getBuddyListBroadcaster :: Assistant NotificationBroadcaster
-getBuddyListBroadcaster =  getBuddyBroadcaster <$> getAssistant buddyList
-
 getRepoListBroadcaster :: Assistant NotificationBroadcaster
 getRepoListBroadcaster =  syncRemotesNotifier <$> getDaemonStatus
 

Assistant/WebApp/Pairing.hs

@@ -0,0 +1,79 @@
+{- git-annex assistant pairing
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Assistant.WebApp.Pairing where
+
+import Assistant.Common
+import qualified Utility.MagicWormhole as Wormhole
+import Command.P2P (wormholePairing, PairingResult(..))
+import P2P.Address
+import Annex.Concurrent
+import Git.Types
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import qualified Data.Map as M
+
+data PairingWith = PairingWithSelf | PairingWithFriend
+	deriving (Eq, Show, Read)
+
+type WormholePairingState = TVar (M.Map WormholePairingId WormholePairingHandle)
+
+type WormholePairingHandle = (PairingWith, RemoteName, MVar Wormhole.CodeObserver, MVar Wormhole.Code, Async (Annex PairingResult))
+
+newtype WormholePairingId = WormholePairingId Int
+	deriving (Ord, Eq, Show, Read)
+
+newWormholePairingState :: IO WormholePairingState
+newWormholePairingState = newTVarIO M.empty
+
+addWormholePairingState :: WormholePairingHandle -> WormholePairingState -> IO WormholePairingId
+addWormholePairingState h tv = atomically $ do
+	m <- readTVar tv
+	-- use of head is safe because allids is infinite
+	let i = Prelude.head $ filter (`notElem` M.keys m) allids
+	writeTVar tv (M.insertWith' const i h m)
+	return i
+  where
+	allids = map WormholePairingId [1..]
+
+-- | Starts the wormhole pairing processes.
+startWormholePairing :: PairingWith -> RemoteName -> [P2PAddress] -> Assistant WormholePairingHandle
+startWormholePairing pairingwith remotename ouraddrs = do
+	observerrelay <- liftIO newEmptyMVar
+	producerrelay <- liftIO newEmptyMVar
+	-- wormholePairing needs to run in the Annex monad, and is a
+	-- long-duration action. So, don't just liftAnnex to run it;
+	-- fork the Annex state.
+	runner <- liftAnnex $ forkState $ 
+		wormholePairing remotename ouraddrs $ \observer producer -> do
+			putMVar observerrelay observer
+			theircode <- takeMVar producerrelay
+			Wormhole.sendCode producer theircode
+	tid <- liftIO $ async runner
+	return (pairingwith, remotename, observerrelay, producerrelay, tid)
+
+-- | Call after sendTheirWormholeCode. This can take some time to return.
+finishWormholePairing :: WormholePairingHandle -> Assistant PairingResult
+finishWormholePairing (_, _, _, _, tid) = liftAnnex =<< liftIO (wait tid)
+
+-- | Waits for wormhole to produce our code. Can be called repeatedly, safely.
+getOurWormholeCode :: WormholePairingHandle -> IO Wormhole.Code
+getOurWormholeCode (_, _, observerrelay, _, _) =
+	readMVar observerrelay >>= Wormhole.waitCode
+
+-- | Sends their code to wormhole. If their code has already been sent,
+-- avoids blocking and returns False.
+sendTheirWormholeCode :: WormholePairingHandle -> Wormhole.Code -> IO Bool
+sendTheirWormholeCode (_, _, _, producerrelay, _) = tryPutMVar producerrelay
+
+withPairingWith :: WormholePairingHandle -> (PairingWith -> a) -> a
+withPairingWith (pairingwith, _, _, _, _) a = a pairingwith
+
+withRemoteName :: WormholePairingHandle -> (RemoteName -> a) -> a
+withRemoteName (_, remotename, _, _, _) a = a remotename

Assistant/WebApp/RepoList.hs

@@ -260,7 +260,7 @@ getSyncNowRepositoryR uuid = do
 	if u == uuid
 		then do
 			thread <- liftAssistant $ asIO $
-				reconnectRemotes True
+				reconnectRemotes
 					=<< (syncRemotes <$> getDaemonStatus)
 			void $ liftIO $ forkIO thread
 		else maybe noop (liftAssistant . syncRemote)

Assistant/WebApp/Types.hs

@@ -18,7 +18,6 @@ module Assistant.WebApp.Types (
 import Assistant.Common
 import Assistant.Ssh
 import Assistant.Pairing
-import Assistant.Types.Buddies
 import Utility.NotificationBroadcaster
 import Utility.AuthToken
 import Utility.WebApp
@@ -28,6 +27,7 @@ import Utility.Gpg (KeyId)
 import Build.SysConfig (packageversion)
 import Types.ScheduledActivity
 import Assistant.WebApp.RepoId
+import Assistant.WebApp.Pairing
 import Types.Distribution
 
 import Yesod.Static
@@ -49,6 +49,7 @@ data WebApp = WebApp
 	, cannotRun :: Maybe String
 	, noAnnex :: Bool
 	, listenHost ::Maybe HostName
+	, wormholePairingState :: WormholePairingState
 	}
 
 mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
@@ -166,14 +167,6 @@ instance PathPiece UUID where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
 
-instance PathPiece BuddyKey where
-	toPathPiece = pack . show
-	fromPathPiece = readish . unpack
-
-instance PathPiece PairKey where
-	toPathPiece = pack . show
-	fromPathPiece = readish . unpack
-
 instance PathPiece RepoSelector where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
@@ -193,3 +186,11 @@ instance PathPiece RepoId where
 instance PathPiece GitAnnexDistribution where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
+
+instance PathPiece PairingWith where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack
+
+instance PathPiece WormholePairingId where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -16,11 +16,6 @@
 
 /config ConfigurationR GET
 /config/preferences PreferencesR GET POST
-/config/xmpp XMPPConfigR GET POST
-/config/xmpp/for/self XMPPConfigForPairSelfR GET POST
-/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST
-/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
-/config/xmpp/disconnect DisconnectXMPPR GET
 /config/needconnection ConnectionNeededR GET
 /config/fsck ConfigFsckR GET POST
 /config/fsck/preferences ConfigFsckPreferencesR POST
@@ -67,13 +62,10 @@
 /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
 /config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST
 
-/config/repository/pair/xmpp/self/start StartXMPPPairSelfR GET
-/config/repository/pair/xmpp/self/running RunningXMPPPairSelfR GET
-
-/config/repository/pair/xmpp/friend/start StartXMPPPairFriendR GET
-/config/repository/pair/xmpp/friend/running/#BuddyKey RunningXMPPPairFriendR GET
-/config/repository/pair/xmpp/friend/accept/#PairKey ConfirmXMPPPairFriendR GET
-/config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET
+/config/repository/pair/wormhole/start/self StartWormholePairSelfR GET
+/config/repository/pair/wormhole/start/friend StartWormholePairFriendR GET
+/config/repository/pair/wormhole/prepare/#PairingWith PrepareWormholePairR GET
+/config/repository/pair/wormhole/running/#WormholePairingId RunningWormholePairR GET POST
 
 /config/repository/enable/rsync/#UUID EnableRsyncR GET POST
 /config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST
@@ -103,9 +95,6 @@
 /sidebar/#NotificationId SideBarR GET
 /notifier/sidebar NotifierSideBarR GET
 
-/buddylist/#NotificationId BuddyListR GET
-/notifier/buddylist NotifierBuddyListR GET
-
 /repolist/#NotificationId/#RepoSelector RepoListR GET
 /notifier/repolist/#RepoSelector NotifierRepoListR GET
 

Assistant/XMPP.hs

@@ -1,275 +0,0 @@
-{- core xmpp support
- -
- - Copyright 2012-2013 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE OverloadedStrings #-}
-
-module Assistant.XMPP where
-
-import Assistant.Common
-import Assistant.Types.NetMessager
-import Assistant.Pairing
-import Git.Sha (extractSha)
-import Git
-
-import Network.Protocol.XMPP hiding (Node)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Map as M
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import Data.XML.Types
-import qualified "sandi" Codec.Binary.Base64 as B64
-import Data.Bits.Utils
-
-{- Name of the git-annex tag, in our own XML namespace.
- - (Not using a namespace URL to avoid unnecessary bloat.) -}
-gitAnnexTagName :: Name
-gitAnnexTagName  = "{git-annex}git-annex"
-
-{- Creates a git-annex tag containing a particular attribute and value. -}
-gitAnnexTag :: Name -> Text -> Element
-gitAnnexTag attr val = gitAnnexTagContent attr val []
-
-{- Also with some content. -}
-gitAnnexTagContent :: Name -> Text -> [Node] -> Element
-gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])]
-
-isGitAnnexTag :: Element -> Bool
-isGitAnnexTag t = elementName t == gitAnnexTagName
-
-{- Things that a git-annex tag can inserted into. -}
-class GitAnnexTaggable a where
-	insertGitAnnexTag :: a -> Element -> a
-
-	extractGitAnnexTag :: a -> Maybe Element
-
-	hasGitAnnexTag :: a -> Bool
-	hasGitAnnexTag = isJust . extractGitAnnexTag
-
-instance GitAnnexTaggable Message where
-	insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m }
-	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads
-
-instance GitAnnexTaggable Presence where
-	-- always mark extended away and set presence priority to negative
-	insertGitAnnexTag p elt = p
-		{ presencePayloads = extendedAway : negativePriority : elt : presencePayloads p }
-	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
-
-data GitAnnexTagInfo = GitAnnexTagInfo
-	{ tagAttr :: Name
-	, tagValue :: Text
-	, tagElement :: Element
-	}
-
-type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
-
-gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo
-gitAnnexTagInfo v = case extractGitAnnexTag v of
-	{- Each git-annex tag has a single attribute. -}
-	Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo
-		<$> pure attr
-		<*> attributeText attr tag
-		<*> pure tag
-	_ -> Nothing
-
-{- A presence with a git-annex tag in it.
- - Also includes a status tag, which may be visible in XMPP clients. -}
-gitAnnexPresence :: Element -> Presence
-gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable
-  where
-	addStatusTag p = p
-		{ presencePayloads = status : presencePayloads p }
-	status = Element "status" [] [statusMessage]
-	statusMessage = NodeContent $ ContentText $ T.pack "git-annex"
-
-{- A presence with an empty git-annex tag in it, used for letting other
- - clients know we're around and are a git-annex client. -}
-gitAnnexSignature :: Presence
-gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []
-
-{- XMPP client to server ping -}
-xmppPing :: JID -> IQ
-xmppPing selfjid = (emptyIQ IQGet)
-	{ iqID = Just "c2s1"
-	, iqFrom = Just selfjid
-	, iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing
-	, iqPayload = Just $ Element xmppPingTagName [] []
-	}
-
-xmppPingTagName :: Name
-xmppPingTagName = "{urn:xmpp}ping"
-
-{- A message with a git-annex tag in it. -}
-gitAnnexMessage :: Element -> JID -> JID -> Message
-gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
-	{ messageTo = Just tojid
-	, messageFrom = Just fromjid
-	}
-
-{- A notification that we've pushed to some repositories, listing their
- - UUIDs. -}
-pushNotification :: [UUID] -> Presence
-pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
-
-encodePushNotification :: [UUID] -> Text
-encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
-
-decodePushNotification :: Text -> [UUID]
-decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep
-
-uuidSep :: Text
-uuidSep = ","
-
-{- A request for other git-annex clients to send presence. -}
-presenceQuery :: Presence
-presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
-
-{- A notification about a stage of pairing. -}
-pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
-pairingNotification pairstage u = gitAnnexMessage $ 
-	gitAnnexTag pairAttr $ encodePairingNotification pairstage u
-
-encodePairingNotification :: PairStage -> UUID -> Text
-encodePairingNotification pairstage u = T.unwords $ map T.pack
-	[ show pairstage
-	, fromUUID u
-	]
-
-decodePairingNotification :: Decoder
-decodePairingNotification m = parse . words . T.unpack . tagValue
-  where
-	parse [stage, u] = PairingNotification
-		<$> readish stage
-		<*> (formatJID <$> messageFrom m)
-		<*> pure (toUUID u)
-	parse _ = Nothing
-
-pushMessage :: PushStage -> JID -> JID -> Message
-pushMessage = gitAnnexMessage . encode
-  where
-	encode (CanPush u shas) =
-		gitAnnexTag canPushAttr $ T.pack $ unwords $
-			fromUUID u : map fromRef shas
-	encode (PushRequest u) =
-		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
-	encode (StartingPush u) =
-		gitAnnexTag startingPushAttr $ T.pack $ fromUUID u
-	encode (ReceivePackOutput n b) = 
-		gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b
-	encode (SendPackOutput n b) =
-		gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b
-	encode (ReceivePackDone code) =
-		gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code
-	val = T.pack . show
-
-decodeMessage :: Message -> Maybe NetMessage
-decodeMessage m = decode =<< gitAnnexTagInfo m
-  where
-	decode i = M.lookup (tagAttr i) decoders >>= rundecoder i
-	rundecoder i d = d m i
-	decoders = M.fromList $ zip
-		[ pairAttr
-		, canPushAttr
-		, pushRequestAttr
-		, startingPushAttr
-		, receivePackAttr
-		, sendPackAttr
-		, receivePackDoneAttr
-		]
-		[ decodePairingNotification
-		, pushdecoder $ shasgen CanPush
-		, pushdecoder $ gen PushRequest
-		, pushdecoder $ gen StartingPush
-		, pushdecoder $ seqgen ReceivePackOutput
-		, pushdecoder $ seqgen SendPackOutput
-		, pushdecoder $
-			fmap (ReceivePackDone . decodeExitCode) . readish .
-				T.unpack . tagValue
-		]
-	pushdecoder a m' i = Pushing
-		<$> (formatJID <$> messageFrom m')
-		<*> a i
-	gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))
-	seqgen c i = do
-		packet <- decodeTagContent $ tagElement i
-		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
-		return $ c seqnum packet
-	shasgen c i = do
-		let (u:shas) = words $ T.unpack $ tagValue i
-		return $ c (toUUID u) (mapMaybe extractSha shas)
-
-decodeExitCode :: Int -> ExitCode
-decodeExitCode 0 = ExitSuccess
-decodeExitCode n = ExitFailure n
-	
-encodeExitCode :: ExitCode -> Int
-encodeExitCode ExitSuccess = 0
-encodeExitCode (ExitFailure n) = n
-
-{- Base 64 encoding a ByteString to use as the content of a tag. -}
-encodeTagContent :: ByteString -> [Node]
-encodeTagContent b = [NodeContent $ ContentText $ T.pack $ w82s $ B.unpack $ B64.encode b]
-
-decodeTagContent :: Element -> Maybe ByteString
-decodeTagContent elt = either (const Nothing) Just (B64.decode $ B.pack $ s2w8 s)
-  where
-	s = T.unpack $ T.concat $ elementText elt
-
-{- The JID without the client part. -}
-baseJID :: JID -> JID
-baseJID j = JID (jidNode j) (jidDomain j) Nothing
-
-{- An XMPP chat message with an empty body. This should not be displayed
- - by clients, but can be used for communications. -}
-silentMessage :: Message
-silentMessage = (emptyMessage MessageChat)
-	{ messagePayloads = [ emptybody ] }
-  where
-	emptybody = Element
-		{ elementName = "body"
-		, elementAttributes = []
-		, elementNodes = []
-		}
-
-{- Add to a presence to mark its client as extended away. -}
-extendedAway :: Element
-extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
-
-{- Add to a presence to give it a negative priority. -}
-negativePriority :: Element
-negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"]
-
-pushAttr :: Name
-pushAttr = "push"
-
-queryAttr :: Name
-queryAttr = "query"
-
-pairAttr :: Name
-pairAttr = "pair"
-
-canPushAttr :: Name
-canPushAttr = "canpush"
-
-pushRequestAttr :: Name
-pushRequestAttr = "pushrequest"
-
-startingPushAttr :: Name
-startingPushAttr = "startingpush"
-
-receivePackAttr :: Name
-receivePackAttr = "rp"
-
-sendPackAttr :: Name
-sendPackAttr = "sp"
-
-receivePackDoneAttr :: Name
-receivePackDoneAttr = "rpdone"
-
-shasAttr :: Name
-shasAttr = "shas"

Assistant/XMPP/Buddies.hs

@@ -1,87 +0,0 @@
-{- xmpp buddies
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.XMPP.Buddies where
-
-import Assistant.XMPP
-import Annex.Common
-import Assistant.Types.Buddies
-
-import Network.Protocol.XMPP
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Text (Text)
-import qualified Data.Text as T
-
-genBuddyKey :: JID -> BuddyKey
-genBuddyKey j = BuddyKey $ formatJID $ baseJID j
-
-buddyName :: JID -> Text
-buddyName j = maybe (T.pack "") strNode (jidNode j)
-
-ucFirst :: Text -> Text
-ucFirst s = let (first, rest) = T.splitAt 1 s
-	in T.concat [T.toUpper first, rest]
-
-{- Summary of info about a buddy.
- -
- - If the buddy has no clients at all anymore, returns Nothing. -}
-buddySummary :: [JID] -> Buddy -> Maybe (Text, Bool, Bool, Bool, BuddyKey)
-buddySummary pairedwith b = case clients of
-	((Client j):_) -> Just (buddyName j, away, canpair, alreadypaired j, genBuddyKey j)
-	[] -> Nothing
-  where
-	away = S.null (buddyPresent b) && S.null (buddyAssistants b)
-	canpair = not $ S.null (buddyAssistants b)
-	clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b
-	alreadypaired j = baseJID j `elem` pairedwith
-
-{- Updates the buddies with XMPP presence info. -}
-updateBuddies :: Presence -> Buddies -> Buddies
-updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key
-  where
-	key = genBuddyKey jid
-	update (Just b) = Just $ applyPresence p b
-	update Nothing = newBuddy p
-updateBuddies _ = id
-
-{- Creates a new buddy based on XMPP presence info. -}
-newBuddy :: Presence -> Maybe Buddy
-newBuddy p
-	| presenceType p == PresenceAvailable = go
-	| presenceType p == PresenceUnavailable = go
-	| otherwise = Nothing
-  where
-	go = make <$> presenceFrom p
-	make _jid = applyPresence p $ Buddy
-		{ buddyPresent = S.empty
-		, buddyAway = S.empty
-		, buddyAssistants = S.empty
-		, buddyPairing = False
-		}
-
-applyPresence :: Presence -> Buddy -> Buddy
-applyPresence p b = fromMaybe b $! go <$> presenceFrom p
-  where
-	go jid
-		| presenceType p == PresenceUnavailable = b
-			{ buddyAway = addto $ buddyAway b
-			, buddyPresent = removefrom $ buddyPresent b
-			, buddyAssistants = removefrom $ buddyAssistants b
-			}
-		| hasGitAnnexTag p = b
-			{ buddyAssistants = addto $ buddyAssistants b
-			, buddyAway = removefrom $ buddyAway b }
-		| presenceType p == PresenceAvailable = b
-			{ buddyPresent = addto $ buddyPresent b
-			, buddyAway = removefrom $ buddyAway b
-			}
-		| otherwise = b
-	  where
-		client = Client jid
-		removefrom = S.filter (/= client)
-		addto = S.insert client

Assistant/XMPP/Client.hs

@@ -1,83 +0,0 @@
-{- xmpp client support
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.XMPP.Client where
-
-import Assistant.Common
-import Utility.SRV
-import Creds
-
-import Network.Protocol.XMPP
-import Network
-import Control.Concurrent
-import qualified Data.Text as T
-
-{- Everything we need to know to connect to an XMPP server. -}
-data XMPPCreds = XMPPCreds
-	{ xmppUsername :: T.Text
-	, xmppPassword :: T.Text
-	, xmppHostname :: HostName
-	, xmppPort :: Int
-	, xmppJID :: T.Text
-	}
-	deriving (Read, Show)
-
-connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
-connectXMPP c a = case parseJID (xmppJID c) of
-	Nothing -> error "bad JID"
-	Just jid -> connectXMPP' jid c a
-
-{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}
-connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
-connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord)
-  where
-	srvrecord = mkSRVTcp "xmpp-client" $
-		T.unpack $ strDomain $ jidDomain jid
-	serverjid = JID Nothing (jidDomain jid) Nothing
-
-	handlesrv [] = do
-		let h = xmppHostname c
-		let p = PortNumber $ fromIntegral $ xmppPort c
-		r <- run h p $ a jid
-		return [r]
-	handlesrv srvs = go [] srvs
-
-	go l [] = return l
-	go l ((h,p):rest) = do
-		{- Try each SRV record in turn, until one connects,
-		 - at which point the MVar will be full. -}
-		mv <- newEmptyMVar
-		r <- run h p $ do
-			liftIO $ putMVar mv ()
-			a jid
-		ifM (isEmptyMVar mv)
-			( go (r : l) rest
-			, return (r : l)
-			)
-
-	{- Async exceptions are let through so the XMPP thread can
-	 - be killed. -}
-	run h p a' = do
-		r <- tryNonAsync $
-			runClientError (Server serverjid h p) jid
-				(xmppUsername c) (xmppPassword c) (void a')
-		return ((h, p), r)
-
-{- XMPP runClient, that throws errors rather than returning an Either -}
-runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a
-runClientError s j u p x = either (error . show) return =<< runClient s j u p x
-
-getXMPPCreds :: Annex (Maybe XMPPCreds)
-getXMPPCreds = parse <$> readCacheCreds xmppCredsFile
-  where
-	parse s = readish =<< s
-
-setXMPPCreds :: XMPPCreds -> Annex ()
-setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile
-
-xmppCredsFile :: FilePath
-xmppCredsFile = "xmpp"

Assistant/XMPP/Git.hs

@@ -1,381 +0,0 @@
-{- git over XMPP
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE CPP #-}
-
-module Assistant.XMPP.Git where
-
-import Assistant.Common
-import Assistant.NetMessager
-import Assistant.Types.NetMessager
-import Assistant.XMPP
-import Assistant.XMPP.Buddies
-import Assistant.DaemonStatus
-import Assistant.Alert
-import Assistant.MakeRemote
-import Assistant.Sync
-import qualified Command.Sync
-import qualified Annex.Branch
-import Annex.Path
-import Annex.UUID
-import Logs.UUID
-import Annex.TaggedPush
-import Annex.CatFile
-import Config
-import Git
-import qualified Types.Remote as Remote
-import qualified Remote as Remote
-import Remote.List
-import Utility.FileMode
-import Utility.Shell
-import Utility.Env
-
-import Network.Protocol.XMPP
-import qualified Data.Text as T
-import System.Posix.Types
-import qualified System.Posix.IO
-import Control.Concurrent
-import System.Timeout
-import qualified Data.ByteString as B
-import qualified Data.Map as M
-
-{- Largest chunk of data to send in a single XMPP message. -}
-chunkSize :: Int
-chunkSize = 4096
-
-{- How long to wait for an expected message before assuming the other side
- - has gone away and canceling a push. 
- -
- - This needs to be long enough to allow a message of up to 2+ times
- - chunkSize to propigate up to a XMPP server, perhaps across to another
- - server, and back down to us. On the other hand, other XMPP pushes can be
- - delayed for running until the timeout is reached, so it should not be
- - excessive.
- -}
-xmppTimeout :: Int
-xmppTimeout = 120000000 -- 120 seconds
-
-finishXMPPPairing :: JID -> UUID -> Assistant ()
-finishXMPPPairing jid u = void $ alertWhile alert $
-	makeXMPPGitRemote buddy (baseJID jid) u
-  where
-	buddy = T.unpack $ buddyName jid
-	alert = pairRequestAcknowledgedAlert buddy Nothing
-
-gitXMPPLocation :: JID -> String
-gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)
-
-makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
-makeXMPPGitRemote buddyname jid u = do
-	remote <- liftAnnex $ addRemote $
-		makeGitRemote buddyname $ gitXMPPLocation jid
-	liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u
-	liftAnnex $ void remoteListRefresh
-	remote' <- liftAnnex $ fromMaybe (error "failed to add remote")
-		<$> Remote.byName (Just buddyname)
-	syncRemote remote'
-	return True
-
-{- Pushes over XMPP, communicating with a specific client.
- - Runs an arbitrary IO action to push, which should run git-push with
- - an xmpp:: url.
- -
- - To handle xmpp:: urls, git push will run git-remote-xmpp, which is
- - injected into its PATH, and in turn runs git-annex xmppgit. The
- - dataflow them becomes:
- - 
- - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp
- -                                                          |
- - git receive-pack <--> xmppReceivePack <---------------> xmpp
- - 
- - The pipe between git-annex xmppgit and us is set up and communicated
- - using two environment variables, relayIn and relayOut, that are set
- - to the file descriptors to use. Another, relayControl, is used to
- - propigate the exit status of git receive-pack.
- -
- - We listen at the other end of the pipe and relay to and from XMPP.
- -}
-xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool
-xmppPush cid gitpush = do
-	u <- liftAnnex getUUID
-	sendNetMessage $ Pushing cid (StartingPush u)
-
-	(Fd inf, writepush) <- liftIO System.Posix.IO.createPipe
-	(readpush, Fd outf) <- liftIO System.Posix.IO.createPipe
-	(Fd controlf, writecontrol) <- liftIO System.Posix.IO.createPipe
-
-	tmpdir <- gettmpdir
-	installwrapper tmpdir
-
-	environ <- liftIO getEnvironment
-	path <- liftIO getSearchPath
-	let myenviron = addEntries
-		[ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)
-		, (relayIn, show inf)
-		, (relayOut, show outf)
-		, (relayControl, show controlf)
-		]
-		environ
-
-	inh <- liftIO $ fdToHandle readpush
-	outh <- liftIO $ fdToHandle writepush
-	controlh <- liftIO $ fdToHandle writecontrol
-	
-	t1 <- forkIO <~> toxmpp 0 inh
-	t2 <- forkIO <~> fromxmpp outh controlh
-
-	{- This can take a long time to run, so avoid running it in the
-	 - Annex monad. Also, override environment. -}
-	g <- liftAnnex gitRepo
-	r <- liftIO $ gitpush $ g { gitEnv = Just myenviron }
-
-	liftIO $ do
-		mapM_ killThread [t1, t2]
-		mapM_ hClose [inh, outh, controlh]
-		mapM_ closeFd [Fd inf, Fd outf, Fd controlf]
-	
-	return r
-  where
-	toxmpp seqnum inh = do
-		b <- liftIO $ B.hGetSome inh chunkSize
-		if B.null b
-			then liftIO $ killThread =<< myThreadId
-			else do
-				let seqnum' = succ seqnum
-				sendNetMessage $ Pushing cid $
-					SendPackOutput seqnum' b
-				toxmpp seqnum' inh
-	
-	fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg
-	  where
-		handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) = 
-			liftIO $ writeChunk outh b
-		handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) =
-			liftIO $ do
-				hPrint controlh exitcode
-				hFlush controlh
-		handlemsg (Just _) = noop
-		handlemsg Nothing = do
-			debug ["timeout waiting for git receive-pack output via XMPP"]
-			-- Send a synthetic exit code to git-annex
-			-- xmppgit, which will exit and cause git push
-			-- to die.
-			liftIO $ do
-				hPrint controlh (ExitFailure 1)
-				hFlush controlh
-				killThread =<< myThreadId
-	
-	installwrapper tmpdir = liftIO $ do
-		createDirectoryIfMissing True tmpdir
-		let wrapper = tmpdir </> "git-remote-xmpp"
-		program <- programPath
-		writeFile wrapper $ unlines
-			[ shebang_local
-			, "exec " ++ program ++ " xmppgit"
-			]
-		modifyFileMode wrapper $ addModes executeModes
-	
-	{- Use GIT_ANNEX_TMP_DIR if set, since that may be a better temp
-	 - dir (ie, not on a crippled filesystem where we can't make
-	 - the wrapper executable). -}
-	gettmpdir = do
-		v <- liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
-		case v of
-			Nothing -> do
-				tmp <- liftAnnex $ fromRepo gitAnnexTmpMiscDir
-				return $ tmp </> "xmppgit"
-			Just d -> return $ d </> "xmppgit"
-
-type EnvVar = String
-
-envVar :: String -> EnvVar
-envVar s = "GIT_ANNEX_XMPPGIT_" ++ s
-
-relayIn :: EnvVar
-relayIn = envVar "IN"
-
-relayOut :: EnvVar
-relayOut = envVar "OUT"
-
-relayControl :: EnvVar
-relayControl = envVar "CONTROL"
-
-relayHandle :: EnvVar -> IO Handle
-relayHandle var = do
-	v <- getEnv var
-	case readish =<< v of
-		Nothing -> error $ var ++ " not set"
-		Just n -> fdToHandle $ Fd n
-
-{- Called by git-annex xmppgit.
- -
- - git-push is talking to us on stdin
- - we're talking to git-push on stdout
- - git-receive-pack is talking to us on relayIn (via XMPP)
- - we're talking to git-receive-pack on relayOut (via XMPP)
- - git-receive-pack's exit code will be passed to us on relayControl
- -}
-xmppGitRelay :: IO ()
-xmppGitRelay = do
-	flip relay stdout =<< relayHandle relayIn
-	relay stdin =<< relayHandle relayOut
-	code <- hGetLine =<< relayHandle relayControl
-	exitWith $ fromMaybe (ExitFailure 1) $ readish code
-  where
-	{- Is it possible to set up pipes and not need to copy the data
-	 - ourselves? See splice(2) -}
-	relay fromh toh = void $ forkIO $ forever $ do
-		b <- B.hGetSome fromh chunkSize
-		when (B.null b) $ do
-			hClose fromh
-			hClose toh
-			killThread =<< myThreadId
-		writeChunk toh b
-
-{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating
- - its exit status to XMPP. -}
-xmppReceivePack :: ClientID -> Assistant Bool
-xmppReceivePack cid = do
-	repodir <- liftAnnex $ fromRepo repoPath
-	let p = (proc "git" ["receive-pack", repodir])
-		{ std_in = CreatePipe
-		, std_out = CreatePipe
-		, std_err = Inherit
-		}
-	(Just inh, Just outh, _, pid) <- liftIO $ createProcess p
-	readertid <- forkIO <~> relayfromxmpp inh
-	relaytoxmpp 0 outh
-	code <- liftIO $ waitForProcess pid
-	void $ sendNetMessage $ Pushing cid $ ReceivePackDone code
-	liftIO $ do
-		killThread readertid
-		hClose inh
-		hClose outh
-		return $ code == ExitSuccess
-  where
-	relaytoxmpp seqnum outh = do
-		b <- liftIO $ B.hGetSome outh chunkSize
-		-- empty is EOF, so exit
-		unless (B.null b) $ do
-			let seqnum' = succ seqnum
-			sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b
-			relaytoxmpp seqnum' outh
-	relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg
-	  where
-		handlemsg (Just (Pushing _ (SendPackOutput _ b))) =
-			liftIO $ writeChunk inh b
-		handlemsg (Just _) = noop
-		handlemsg Nothing = do
-			debug ["timeout waiting for git send-pack output via XMPP"]
-			-- closing the handle will make git receive-pack exit
-			liftIO $ do
-				hClose inh
-				killThread =<< myThreadId
-
-xmppRemotes :: ClientID -> UUID -> Assistant [Remote]
-xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
-	Nothing -> return []
-	Just jid -> do
-		let loc = gitXMPPLocation jid
-		um <- liftAnnex uuidMap
-		filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes 
-			<$> getDaemonStatus
-  where
-	matching loc r = repoIsUrl r && repoLocation r == loc
-	knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um
-
-{- Returns the ClientID that it pushed to. -}
-runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID)
-runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
-	go =<< liftAnnex (join Command.Sync.getCurrBranch)
-  where
-	go (Just branch, _) = do
-		rs <- xmppRemotes cid theiruuid
-		liftAnnex $ Annex.Branch.commit "update"
-		(g, u) <- liftAnnex $ (,)
-			<$> gitRepo
-			<*> getUUID
-		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) branch g
-		selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
-		if null rs
-			then return Nothing
-			else do
-				forM_ rs $ \r -> do
-					void $ alertWhile (syncAlert [r]) $
-						xmppPush cid (taggedPush u selfjid branch r)
-					checkcloudrepos r
-				return $ Just cid
-	go _ = return Nothing
-runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
-	rs <- xmppRemotes cid theiruuid
-	if null rs
-		then return Nothing
-		else do
-			void $ alertWhile (syncAlert rs) $
-				xmppReceivePack cid
-			mapM_ checkcloudrepos rs
-			return $ Just cid
-runPush _ _ = return Nothing
-
-{- Check if any of the shas that can be pushed are ones we do not
- - have.
- -
- - (Older clients send no shas, so when there are none, always
- - request a push.)
- -}
-handlePushNotice :: NetMessage -> Assistant ()
-handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
-	unlessM (null <$> xmppRemotes cid theiruuid) $
-		if null shas
-			then go
-			else ifM (haveall shas)
-				( debug ["ignoring CanPush with known shas"]
-				, go
-				)
-  where
-	go = do
-		u <- liftAnnex getUUID
-		sendNetMessage $ Pushing cid (PushRequest u)
-	haveall l = liftAnnex $ not <$> anyM donthave l
-	donthave sha = isNothing <$> catObjectDetails sha
-handlePushNotice _ = noop
-
-writeChunk :: Handle -> B.ByteString -> IO ()
-writeChunk h b = do
-	B.hPut h b
-	hFlush h
-
-{- Gets NetMessages for a PushSide, ensures they are in order,
- - and runs an action to handle each in turn. The action will be passed
- - Nothing on timeout.
- -
- - Does not currently reorder messages, but does ensure that any 
- - duplicate messages, or messages not in the sequence, are discarded.
- -}
-withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant ()
-withPushMessagesInSequence cid side a = loop 0
-  where
-	loop seqnum = do
-		m <- timeout xmppTimeout <~> waitInbox cid side
-		let go s = a m >> loop s
-		let next = seqnum + 1
-		case extractSequence =<< m of
-			Just seqnum'
-				| seqnum' == next -> go next
-				| seqnum' == 0 -> go seqnum
-				| seqnum' == seqnum -> do
-					debug ["ignoring duplicate sequence number", show seqnum]
-					loop seqnum
-				| otherwise -> do
-					debug ["ignoring out of order sequence number", show seqnum', "expected", show next]
-					loop seqnum
-			Nothing -> go seqnum
-
-extractSequence :: NetMessage -> Maybe Int
-extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum
-extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum
-extractSequence _ = Nothing

BuildFlags.hs

@@ -63,11 +63,6 @@ buildFlags = filter (not . null)
 #ifdef WITH_DESKTOP_NOTIFY
 	, "DesktopNotify"
 #endif
-#ifdef WITH_XMPP
-	, "XMPP"
-#else
-#warning Building without XMPP.
-#endif
 #ifdef WITH_CONCURRENTOUTPUT
 	, "ConcurrentOutput"
 #else

CHANGELOG

@@ -1,7 +1,13 @@
-git-annex (6.20161211) UNRELEASED; urgency=medium
+git-annex (6.20170101) UNRELEASED; urgency=medium
 
-  * p2p --pair makes it easy to pair repositories over P2P, using
+  * XMPP support has been removed from the assistant in this release.
+    If your repositories used XMPP to keep in sync, that will no longer
+    work, and you should enable some other remote to keep them in sync.
+    A ssh server is one way, or use the new Tor pairing feature.
+  * p2p --pair makes it easy to pair repositories, using
     Magic Wormhole codes to find the other repository.
+  * webapp: The "Share with a friend" and "Share with your other devices"
+    pages have been changed to pair repositories using Tor and Magic Wormhole.
   * 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

COPYRIGHT

@@ -2,11 +2,11 @@ Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
 Source: native package
 
 Files: *
-Copyright: © 2010-2016 Joey Hess <id@joeyh.name>
+Copyright: © 2010-2017 Joey Hess <id@joeyh.name>
 License: GPL-3+
 
 Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*
-Copyright: © 2012-2016 Joey Hess <id@joeyh.name>
+Copyright: © 2012-2017 Joey Hess <id@joeyh.name>
            © 2014 Sören Brunk
 License: AGPL-3+
 
@@ -21,7 +21,7 @@ Copyright: 2011 Bas van Dijk & Roel van Dijk
 License: BSD-2-clause
 
 Files: Utility/*
-Copyright: 2012-2016 Joey Hess <id@joeyh.name>
+Copyright: 2012-2017 Joey Hess <id@joeyh.name>
 License: BSD-2-clause
 
 Files: Utility/Gpg.hs Utility/DirWatcher*

CmdLine/GitAnnex.hs

@@ -109,9 +109,6 @@ import qualified Command.Assistant
 #ifdef WITH_WEBAPP
 import qualified Command.WebApp
 #endif
-#ifdef WITH_XMPP
-import qualified Command.XMPPGit
-#endif
 #endif
 import qualified Command.Test
 #ifdef WITH_TESTSUITE
@@ -218,9 +215,6 @@ cmds testoptparser testrunner =
 #ifdef WITH_WEBAPP
 	, Command.WebApp.cmd
 #endif
-#ifdef WITH_XMPP
-	, Command.XMPPGit.cmd
-#endif
 #endif
 	, Command.Test.cmd testoptparser testrunner
 #ifdef WITH_TESTSUITE

Command/P2P.hs

@@ -168,10 +168,10 @@ performPairing remotename addrs = 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."
+					putStrLn "Oops -- You entered this repository's pairing code. Enter the pairing code of the *other* repository."
 					getcode ourcode
 			Nothing -> do
-				putStrLn "That does not look like a valid code. Try again..."
+				putStrLn "That does not look like a valiad pairing code. Try again..."
 				getcode ourcode
 
 -- We generate half of the authtoken; the pair will provide

Command/XMPPGit.hs

@@ -1,48 +0,0 @@
-{- git-annex command
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Command.XMPPGit where
-
-import Command
-import Assistant.XMPP.Git
-
-cmd :: Command
-cmd = noCommit $ dontCheck repoExists $
-	noRepo (parseparams startNoRepo) $ 
-		command "xmppgit" SectionPlumbing "git to XMPP relay"
-			paramNothing (parseparams seek)
-  where
-	parseparams = withParams
-
-seek :: CmdParams -> CommandSeek
-seek = withWords start
-
-start :: CmdParams -> CommandStart
-start _ = do
-	liftIO gitRemoteHelper
-	liftIO xmppGitRelay
-	stop
-
-startNoRepo :: CmdParams -> IO ()
-startNoRepo _ = xmppGitRelay
-
-{- A basic implementation of the git-remote-helpers protocol. -}
-gitRemoteHelper :: IO ()
-gitRemoteHelper = do
-	expect "capabilities"
-	respond ["connect"]
-	expect "connect git-receive-pack"
-	respond []
-  where
-	expect s = do
-		gitcmd <- getLine
-		unless (gitcmd == s) $
-			error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ gitcmd
-	respond l = do
-		mapM_ putStrLn l
-		putStrLn ""
-		hFlush stdout

Makefile

@@ -283,7 +283,7 @@ dist/caballog: git-annex.cabal
 # TODO should be possible to derive this from caballog.
 hdevtools:
 	hdevtools --stop-server || true
-	hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -DWITH_XMPP -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports
+	hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports
 
 distributionupdate:
 	git pull

NEWS

@@ -1,3 +1,13 @@
+git-annex (6.20170101) unstable; urgency=low
+
+  XMPP support has been removed from the assistant in this release.
+
+  If your repositories used XMPP to keep in sync, that will no longer
+  work, and you should enable some other remote to keep them in sync.
+  A ssh server is one way, or use the new Tor pairing feature.
+
+ -- Joey Hess <id@joeyh.name>  Tue, 27 Dec 2016 16:37:46 -0400
+
 git-annex (4.20131002) unstable; urgency=low
 
    The layout of gcrypt repositories has changed, and

RemoteDaemon/Core.hs

@@ -74,12 +74,13 @@ runController :: TChan Consumed -> TChan Emitted -> IO ()
 runController ichan ochan = do
 	h <- genTransportHandle
 	m <- genRemoteMap h ochan
-	startrunning m
-	mapM_ (\s -> async (s h)) remoteServers
-	go h False m
+	starttransports m
+	serverchans <- mapM (startserver h) remoteServers
+	go h False m serverchans
   where
-	go h paused m = do
+	go h paused m serverchans = do
 		cmd <- atomically $ readTChan ichan
+		broadcast cmd serverchans
 		case cmd of
 			RELOAD -> do
 				h' <- updateTransportHandle h
@@ -87,36 +88,42 @@ runController ichan ochan = do
 				let common = M.intersection m m'
 				let new = M.difference m' m
 				let old = M.difference m m'
-				broadcast STOP old
+				broadcast STOP (mchans old)
 				unless paused $
-					startrunning new
-				go h' paused (M.union common new)
+					starttransports new
+				go h' paused (M.union common new) serverchans
 			LOSTNET -> do
 				-- force close all cached ssh connections
 				-- (done here so that if there are multiple
 				-- ssh remotes, it's only done once)
 				liftAnnex h forceSshCleanup
-				broadcast LOSTNET m
-				go h True m
+				broadcast LOSTNET transportchans
+				go h True m serverchans
 			PAUSE -> do
-				broadcast STOP m
-				go h True m
+				broadcast STOP transportchans
+				go h True m serverchans
 			RESUME -> do
 				when paused $
-					startrunning m
-				go h False m
+					starttransports m
+				go h False m serverchans
 			STOP -> exitSuccess
 			-- All remaining messages are sent to
 			-- all Transports.
 			msg -> do
-				unless paused $ atomically $
-					forM_ chans (`writeTChan` msg)
-				go h paused m
+				unless paused $
+					broadcast msg transportchans
+				go h paused m serverchans
 	  where
-		chans = map snd (M.elems m)
+		transportchans = mchans m
+		mchans = map snd . M.elems
+	
+	startserver h server = do
+		c <- newTChanIO
+		void $ async $ server c h
+		return c
 
-	startrunning m = forM_ (M.elems m) startrunning'
-	startrunning' (transport, c) = do
+	starttransports m = forM_ (M.elems m) starttransports'
+	starttransports' (transport, c) = do
 		-- drain any old control messages from the channel
 		-- to avoid confusing the transport with them
 		atomically $ drain c
@@ -124,9 +131,7 @@ runController ichan ochan = do
 	
 	drain c = maybe noop (const $ drain c) =<< tryReadTChan c
 	
-	broadcast msg m = atomically $ forM_ (M.elems m) send
-	  where
-		send (_, c) = writeTChan c msg
+	broadcast msg cs = atomically $ forM_ cs $ \c -> writeTChan c msg
 
 -- Generates a map with a transport for each supported remote in the git repo,
 -- except those that have annex.sync = false

RemoteDaemon/Transport.hs

@@ -26,5 +26,5 @@ remoteTransports = M.fromList
 	, (torAnnexScheme, RemoteDaemon.Transport.Tor.transport)
 	]
 
-remoteServers :: [TransportHandle -> IO ()]
+remoteServers :: [Server]
 remoteServers = [RemoteDaemon.Transport.Tor.server]

RemoteDaemon/Transport/Tor.hs

@@ -34,14 +34,25 @@ import Control.Concurrent.STM.TBMQueue
 import Control.Concurrent.Async
 
 -- Run tor hidden service.
-server :: TransportHandle -> IO ()
-server th@(TransportHandle (LocalRepo r) _) = do
-	u <- liftAnnex th getUUID
-	uid <- getRealUserID
-	let ident = fromUUID u
-	go u =<< getHiddenServiceSocketFile torAppName uid ident
+server :: Server
+server ichan th@(TransportHandle (LocalRepo r) _) = go
   where
-	go u (Just sock) = do
+	go = checkstartservice >>= handlecontrol
+
+	checkstartservice = do
+		u <- liftAnnex th getUUID
+		uid <- getRealUserID
+		let ident = fromUUID u
+		msock <- getHiddenServiceSocketFile torAppName uid ident
+		case msock of
+			Nothing -> do
+				debugM "remotedaemon" "Tor hidden service not enabled"
+				return False
+			Just sock -> do
+				void $ async $ startservice sock u
+				return True
+	
+	startservice sock u = do
 		q <- newTBMQueueIO maxConnections
 		replicateM_ maxConnections $
 			forkIO $ forever $ serveClient th u r q
@@ -57,7 +68,18 @@ server th@(TransportHandle (LocalRepo r) _) = do
 			unless ok $ do
 				hClose conn
 				warningIO "dropped Tor connection, too busy"
-	go _ Nothing = debugM "remotedaemon" "Tor hidden service not enabled"
+	
+	handlecontrol servicerunning = do
+		msg <- atomically $ readTChan ichan
+		case msg of
+			-- On reload, the configuration may have changed to
+			-- enable the tor hidden service. If it was not
+			-- enabled before, start it,
+			RELOAD | not servicerunning -> go
+			-- We can ignore all other messages; no need
+			-- to restart the hidden service when the network
+			-- changes as tor takes care of all that.
+			_ -> handlecontrol servicerunning
 
 -- How many clients to serve at a time, maximum. This is to avoid DOS attacks.
 maxConnections :: Int

RemoteDaemon/Types.hs

@@ -28,6 +28,10 @@ newtype RemoteURI = RemoteURI URI
 -- from a Chan, and emits others to another Chan.
 type Transport = RemoteRepo -> RemoteURI -> TransportHandle -> TChan Consumed -> TChan Emitted -> IO ()
 
+-- A server for a Transport consumes some messages from a Chan in
+-- order to learn about network changes, reloads, etc.
+type Server = TChan Consumed -> TransportHandle -> IO ()
+
 data RemoteRepo = RemoteRepo Git.Repo RemoteGitConfig
 newtype LocalRepo = LocalRepo Git.Repo
 

Utility/MagicWormhole.hs

@@ -78,7 +78,7 @@ mkCodeProducer :: IO CodeProducer
 mkCodeProducer = CodeProducer <$> newEmptyMVar
 
 waitCode :: CodeObserver -> IO Code
-waitCode (CodeObserver o) = takeMVar o
+waitCode (CodeObserver o) = readMVar o
 
 sendCode :: CodeProducer -> Code -> IO ()
 sendCode (CodeProducer p) = putMVar p
@@ -119,7 +119,7 @@ sendFile f (CodeObserver observer) ps = do
 -- read from the CodeProducer, and fed to wormhole on stdin.
 receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool
 receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout -> do
-	Code c <- takeMVar producer
+	Code c <- readMVar producer
 	hPutStrLn hin c
 	hFlush hin
 	return True

Utility/Tor.hs

@@ -161,3 +161,6 @@ torLibDir = "/var/lib/tor"
 
 varLibDir :: FilePath
 varLibDir = "/var/lib"
+
+torIsInstalled :: IO Bool
+torIsInstalled = inPath "tor"

Utility/WebApp.hs

@@ -84,7 +84,6 @@ fixSockAddr addr = addr
 
 -- disable buggy sloworis attack prevention code
 webAppSettings :: Settings
-
 webAppSettings = setTimeout halfhour defaultSettings
   where
 	halfhour = 30 * 60

debian/control

@@ -60,9 +60,6 @@ Build-Depends:
 	libghc-network-multicast-dev,
 	libghc-network-info-dev [linux-any kfreebsd-any],
 	libghc-safesemaphore-dev,
-	libghc-network-protocol-xmpp-dev (>= 0.4.3-1+b1),
-	libghc-gnutls-dev (>= 0.1.4),
-	libghc-xml-types-dev,
 	libghc-async-dev,
 	libghc-monad-logger-dev,
 	libghc-free-dev,

doc/assistant.mdwn

@@ -21,11 +21,8 @@ instructions.
 * [[Android documentation|/Android]]
 * Want to make two nearby computers share the same synchronised folder?  
   Follow the [[local_pairing_walkthrough]].
-* Or perhaps you want to share files between computers in different
-  locations, like home and work?  
-  Follow the [[remote_sharing_walkthrough]].
-* Want to share a synchronised folder with a friend?  
-  Follow the [[share_with_a_friend_walkthrough]].
+* Want to share files with a friend? Follow the
+  [[share_with_a_friend_walkthrough]]].
 * Want to archive data to a drive or the cloud?  
   Follow the [[archival_walkthrough]].
 

doc/assistant/local_pairing_walkthrough.mdwn

@@ -76,8 +76,8 @@ computers are on the same network. If you go on a trip, any files you
 edit will not be visible to your friend until you get back. 
 
 To get around this, you'll often also want to set up
-[[jabber_pairing|share_with_a_friend_walkthrough]], and a server
-in the cloud, which they can use to exchange files while away.
+[[tor_pairing|share_with_a_friend_walkthrough]] too, 
+which they can use to exchange files while away.
 
 And also, you can pair with as many other computers as you like, not just
 one!

doc/assistant/release_notes.mdwn

@@ -1,3 +1,11 @@
+## version 6.20170101
+
+XMPP support has been removed from the assistant in this release.
+
+If your repositories used XMPP to keep in sync, that will no longer
+work, and you should enable some other remote to keep them in sync.
+A ssh server is one way, or use the new Tor pairing feature.
+
 ## version 5.20140421
 
 This release begins to deprecate XMPP support. In particular, if you use

doc/assistant/remote_sharing_walkthrough/comment_1_e0187b0a926904b363065ab0f850f0b2._comment

@@ -1,10 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawmG4rlD9k1ezNkYZ8jDbITrycUmHV-P8Qs"
- nickname="Jeroen"
- subject="Synced vs. unsynced"
- date="2013-07-29T18:07:45Z"
- content="""
-I've noticed that it is also possible to add an existing annex folder on a remote server without using syncing. Are there any dangers in doing this?
-
-Could you explain what syncing does and when it is needed? Thanks.
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_2_dabcbc9aaf0bdb82716f5a5d55807a21._comment

@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="http://joeyh.name/"
- ip="4.154.0.21"
- subject="comment 2"
- date="2013-07-30T18:08:38Z"
- content="""
-I'm afraid I don't quite understand the question.
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_4_978fab3cd165b4ca245e32fc48cf0970._comment

@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="http://joeyh.name/"
- ip="209.250.56.246"
- subject="comment 4"
- date="2013-11-12T18:18:16Z"
- content="""
-You can easily use a removable drive as a transfer repository to sync two computers that have no network connection. Just use the webapp to add the drive on one computer. The drive will be set up as a transfer repository by default. The webapp will automatically start copying all your files to it. Then you can disconnect the drive, bring it to the other computer, and repeat the process. Everything from the first computer will then sync over from the drive to the second computer. And repeat moving the drive back and forth to keep things in sync.
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_4_d7e879f7b098964040df2e27a18eda72._comment

@@ -1,18 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawmkXtBdMgE1d9nCz2iBc4f85xh4izZ_auU"
- nickname="Ulrich"
- subject="Using a portable drive as another transfer device?"
- date="2013-11-12T16:52:12Z"
- content="""
-I try to understand how to setup git-annex for the following use case:
-
-Two computers, that are paired via remote sharing, using some cloud repository for transfer, and a local NAS for backups.
-
-These two computers are sometimes in the same network, sometimes in different networks, and sometimes even without network at all. From what I read, it should be possible to bypass the cloud when these two machines are on the same network, which sounds great.
-
-Would it be possible to use a portable drive as \"another link\" between these two computers that can be used to sync them even if there is no network between them?
-
-And as you write, if the pairing has been set up manually, then everything is fine - so could it be that it is really easy and only necessary to setup the git-annex on the local drive as an additional remote on both (or only one?) machine?
-
-thanks for any insight!
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_5_00852736d47c05772b15c5ff54ae7da7._comment

@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawmkXtBdMgE1d9nCz2iBc4f85xh4izZ_auU"
- nickname="Ulrich"
- subject="Using a portable drive as another transfer device? – cool."
- date="2013-11-14T19:05:56Z"
- content="""
-Thanks - I was hoping that it is that easy. I'll try that as soon as I have a working version of the latest git-annex (trying to build with brew for Mac OS X 10.9, but without success so far). 
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_6_770c4f1802fc40d76bbaf7783bb3b4ac._comment

@@ -1,14 +0,0 @@
-[[!comment format=mdwn
- username="severo"
- ip="88.182.182.135"
- subject="git-assistant and transfer repository"
- date="2014-03-16T17:05:43Z"
- content="""
-In your comment http://git-annex.branchable.com/assistant/remote_sharing_walkthrough/#comment-f97efe1d05c0101232684b4e4edc4866, you describe a way to synchronize two devices using an intermediate USB drive configured as a \"transfer repository\".
-
-I understand that in that case, the USB drive can only be used as a \"transmitter\", in a git repository form, not as a copy of the files structure. This means the files contained by the USB drive cannot be accessed without git/git-annnex.
-
-Is there a way to use the USB drive as a \"client repository\" in order to allow synchronization, as described earlier, but also as a simple copy of the files, in order to access them from any device (opening them with windows in a cyber coffee for example).
-
-Thanks
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_7_61c1f5b00381b2fa891a8578267881ab._comment

@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="http://joeyh.name/"
- ip="209.250.56.154"
- subject="comment 7"
- date="2014-03-17T19:50:48Z"
- content="""
-@severo the web app does not support setting up that use case. However, you can make a non-bare clone of your repository onto a removable drive, and if you do the assistant will use it just the same as if you'd set up a removable drive using the webapp. Note that you will need to run `git annex sync` inside that repository in order to update the tree it displays.
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_8_35e00cd10e89ae4bcc66af7dadf6bb5c._comment

@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="severo"
- ip="95.152.107.168"
- subject="comment 8"
- date="2014-03-18T10:06:50Z"
- content="""
-Thansk @joeyh.name for your answer. Do you think this feature could be integrated into the git-annex assistant ?
-"""]]

doc/assistant/remote_sharing_walkthrough/comment_9_c900e4ef49388826c87cadef4235c073._comment

@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="severo"
- ip="95.152.107.168"
- subject="comment 9"
- date="2014-03-18T11:16:19Z"
- content="""
-Some explanations in French on how to do: http://seenthis.net/messages/237648#message238202
-"""]]

doc/assistant/share_with_a_friend_walkthrough.mdwn

@@ -1,9 +1,10 @@
-Want to share all the files in your repository with a friend?
+Want to share all the files in your repository securely with a friend?
 
-Let's suppose you use Google Mail, and so does your friend, and you
-sometimes also chat in Google Talk. The git-annex assistant will
-use your Google account to share with your friend. (This actually
-works with any Jabber account you use, not just Google Talk.)
+This connects to your friend's repository using
+[Tor](https://torproject.org/). Both you and your friend will need to
+install [Tor](https://torproject.org/) and
+[Magic Wormhole](https://github.com/warner/magic-wormhole), and then both
+follow these steps to connect your repositories.
 
 Start by opening up your git annex dashboard.
 
@@ -15,44 +16,21 @@ Start by opening up your git annex dashboard.
 
 `*click*`
 
-[[!img xmpp.png alt="Configuring Jabber account"]]
+[[!img enabletor.png alt="Enabling tor hidden service"]]
 
-Fill that out, and git-annex will be able to show you a list of your
-friends.
+You will probably be prompted to enter a password, to configure Tor.
+(Depending on how your system is configured, this may be the root password,
+or your user account's password.)
 
-[[!img buddylist.png alt="Buddy list"]]
+[[!img wormholepairing.png alt="Pairing with a friend form"]]
 
-This list will refresh as friends log on and off, so you can
-leave it open in a tab until a friend is available to start pairing.
+A pairing code will be generated. Tell it to your friend. Ask them
+for their pairing code, and enter it in the form.
 
-(If your friend is not using git-annex yet, now's a great time to spread
-the word!)
+Once you've exchanged pairing codes, your repositories will be connected
+over Tor. They will begin to sync files back and forth, which can take a
+while since Tor is not super-fast.
 
-Once you click on "Start Pairing", your friend will see this pop up
-on their git annex dashboard.
+---
 
-[[!img xmppalert.png alt="Pair request"]]
-
-Once your friend clicks on that, your repositories will be paired.
-
-### But, wait, there's one more step...
-
-Despite the repositories being paired now, you and your friend can't yet
-quite share files. You'll start to see your friend's files show up in your
-git-annex folder, but you won't be able to open them yet.
-
-What you need to do now is set up a repository out there in the cloud,
-that both you and your friend can access. This will be used to transfer
-files between the two of you.
-
-At the end of the pairing process, a number of cloud providers are
-suggested, and the git-annex assistant makes it easy to configure one of
-them. Once you or your friend sets it up, it'll show up in the other
-one's list of repositories:
-
-[[!img repolist.png alt="Repository list"]]
-
-The final step is to share the login information for the cloud repository
-with your friend, so they can enable it too.
-
-With that complete, you'll be able to open your friend's files!
+See [[tips/peer_to_peer_network_with_tor]] for more details.

doc/assistant/share_with_a_friend_walkthrough/comment_1_c87889721e3a7e52ac1ed3752fa7db46._comment

@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawl6RDLuI2b2fHkTRseVQGUNjcQ2qUrOaE0"
- nickname="Фёдор"
- subject="comment 1"
- date="2014-05-25T15:10:34Z"
- content="""
-Do we need a cloud repository just to bypass NAT? I understand it can't share files within Jabber, but it just looks unpolished. Maybe some punching techniques might be handy, pwnat for example.
-"""]]

doc/bugs/assistant_-_GTalk_collision.mdwn

@@ -15,3 +15,5 @@ I expect to remain invisible, but I get the following warning: "Oops! You are no
 Syncing between the repositories works ok.
 
 [[!tag /design/assistant]]
+
+> [[done]]; xmpp support has been removed. --[[Joey]]

doc/bugs/problems_with_android_and_xmpp.mdwn

@@ -80,3 +80,5 @@ fatal: The remote end hung up unexpectedly
 [2014-02-13 13:18:25 CET] XMPPClient: to client: d6/tigase-14134
 
 """]]
+
+> [[done]]; xmpp support has been removed --[[Joey]]

doc/git-annex-xmppgit.mdwn

@@ -1,23 +0,0 @@
-# NAME
-
-git-annex xmppgit - git to XMPP relay
-
-# SYNOPSIS
-
-git annex xmppgit
-
-# DESCRIPTION
-
-This command is used internally by the assistant to perform git pulls over XMPP.
-
-# SEE ALSO
-
-[[git-annex]](1)
-
-[[git-annex-assistant]](1)
-
-# AUTHOR
-
-Joey Hess <id@joeyh.name>
-
-Warning: Automatically converted into a man page by mdwn2man. Edit with care.

doc/git-annex.mdwn

@@ -385,12 +385,6 @@ subdirectories).
   
   See [[git-annex-repair]](1) for details.
 
-* `remotedaemon`
-
-  Persistent communication with remotes.
-
-  See [[git-annex-remotedaemon]](1) for details.
-
 * `p2p`
 
   Configure peer-2-Peer links between repositories.
@@ -670,12 +664,11 @@ subdirectories).
 
   See [[git-annex-smudge]](1) for details.
 
-* `xmppgit`
+* `remotedaemon`
 
-  This command is used internally by the assistant to perform git pulls
-  over XMPP.
-  
-  See [[git-annex-xmppgit]](1) for details.
+  Detects when network remotes have received git pushes and fetches from them.
+
+  See [[git-annex-remotedaemon]](1) for details.
 
 # TESTING COMMANDS
 
@@ -1308,11 +1301,6 @@ Here are all the supported configuration settings.
   Used to identify tahoe special remotes.
   Points to the configuration directory for tahoe.
 
-* `remote.<name>.annex-xmppaddress`
-
-  Used to identify the XMPP address of a Jabber buddy.
-  Normally this is set up by the git-annex assistant when pairing over XMPP.
-
 * `remote.<name>.gcrypt`
 
   Used to identify gcrypt special remotes.

doc/special_remotes/xmpp.mdwn

@@ -1,39 +1,4 @@
-XMPP (Jabber) is used by the [[assistant]] as a git remote. This is,
-technically not a git-annex special remote (large files are not transferred
-over XMPP; only git commits are sent).
-
-Typically XMPP will be set up using the web app, but here's how a manual
-set up could be accomplished:
-
-1. xmpp login credentials need to be stored in `.git/annex/creds/xmpp`.
-   Obviously this file should be mode 600. An example file:
-
-	XMPPCreds {xmppUsername = "joeyhess", xmppPassword = "xxxx", xmppHostname = "xmpp.l.google.com.", xmppPort = 5222, xmppJID = "joeyhess@gmail.com"}
-
-2. A git remote is created using a special url, of the form `xmpp::user@host`
-   For the above example, it would be `url = xmpp::joeyhess@gmail.com`
-
-3. The uuid of one of the other clients using XMPP should be configured
-   using the `annex.uuid` setting, the same as is set up for other remotes.
-
-With the above configuration, the [[assistant]] will use xmpp remotes much as
-any other git remote. Since XMPP requires a client that is continually running
-to see incoming pushes, the XMPP remote cannot be used with git at the
-command line.
-
-## XMPP server support status
-[[!table  data="""
-Provider|Status|Type|Notes
-[[Gmail|http://gmail.com]]|Working|?|Google Apps: [setup your SRV records](http://www.olark.com/gtalk/check_srv) or configure `.git/annex/creds/xmpp` manually
-[[Coderollers|http://www.coderollers.com/xmpp-server/]]|Working|[[Openfire|http://www.igniterealtime.org/projects/openfire/]]
-[[jabber.me|http://jabber.me/]]|Working|[[Tigase|http://www.tigase.org/]]
-[[xmpp.ru.net|https://www.xmpp.ru.net]]|Working|[[jabberd2|http://jabberd2.org/]]
-[[jabber.org|http://jabber.org]]|Working|[[Isode M-Link|http://www.isode.com/products/m-link.html]]
--|Working|[[Prosody|http://prosody.im/]]|No providers tested.
--|Working|[[Metronome|http://www.lightwitch.org/]]|No providers tested.
--|[[Failing|http://git-annex.branchable.com/forum/XMPP_authentication_failure/]]|ejabberd|[[Authentication bug|https://support.process-one.net/browse/EJAB-1632]]: Fixed in debian unstable (>= 2.1.10-5) and stable (>=2.1.10-4+deb7u1)
--|[[Failing|http://git-annex.branchable.com/forum/XMPP_authentication_failure/#comment-4ce5aeabd12ca3016290b3d8255f6ef1]]|jabberd14|No further information
-"""]]
-List of providers: [[http://xmpp.net/]]
-
-See also: [[xmpp_protocol_design_notes|design/assistant/xmpp]]
+XMPP (Jabber) used to be able to be used by the [[assistant]] as a git remote.
+This never worked very well, and it was not entirely secure, since the XMPP
+server saw the contents of git pushes without encryption. So, XMPP support
+has been removed. Use [[tor]] instead.

doc/tips/peer_to_peer_network_with_tor.mdwn

@@ -21,6 +21,10 @@ connect them together over Tor so they share their contents. Or, you and a
 friend want to connect your repositories together. Pairing is an easy way
 to accomplish this.
 
+(The instructions below use the command line. If you or your friend would
+rather avoid using the command line, follow the
+[[share_with_a_friend_walkthrough]].)
+
 In each git-annex repository, run these commands:
 
 	git annex enable-tor

doc/todo/windows_support.mdwn

@@ -21,8 +21,6 @@ Seems like this would need Windows 10.
   Workaround: Put your git-annex repo in `C:\annex` or some similar short
   path if possible.
 
-* XMPP library not yet built. (See below.)
-
 * Local pairing seems to fail, after acking on Linux box, it stalls.
   (Also, of course, the Windows box is unlikely to have a ssh server,
   so only pairing with a !Windows box will work.)
@@ -88,42 +86,3 @@ seems unreliable/broken on Windows.
   it and files can be transferred to it and back
 * Does stopping in progress transfers work in the webapp?
 
-## trying to build XMPP
-
-Lots of library deps:
-
-1. gsasl-$LATEST.zip from <http://josefsson.org/gnutls4win/> (includes
-   gnuidn and gnutls)
-2. pkg-config from
-   <http://sourceforge.net/projects/pkgconfiglite/files/latest/download?source=files>
-3. libxml2 from mingw:
-   <http://sourceforge.net/projects/mingw/files/MSYS/Extension/libxml2/libxml2-2.7.6-1/>
-   both the -dll and the -dev
-3. Extract all the above into the Haskell platform's mingw directory. Note
-   that pkg-config needs to be moved out of a named subdirectory.
-4. Run in DOS prompt (not cygwin!): cabal install network-protocol-xmpp
-
-Current FAIL:
-
-<pre>
-Loading package gnutls-0.1.5 ... ghc.exe: internal error: Misaligned section: 18206e5b
-    (GHC version 7.6.3 for i386_unknown_mingw32)
-        Please report this as a GHC bug:
-	http://www.haskell.org/ghc/reportabug
-</pre>
-
-<https://ghc.haskell.org/trac/ghc/ticket/8830>
-
-Note: This only happens in the TH link stage. So building w/o the webapp
-works with XMPP.
-
-Options:
-
-1. Use EvilSplicer, building first without XMPP library, but with its UI,
-   and a second time without TH, but with the XMPP library. Partially done
-   on the `winsplicehack` branch, but requires building patched versions
-   of lots of yesod dependency chain to export modules referenced by TH
-   splices, like had to be done on Android. Horrible pain. Ugly as hell.
-2. Make a helper program with the XMPP support in it, that does not use TH.
-3. Swich to a different XMPP client library, like
-   <http://hackage.haskell.org/package/pontarius-xmpp>

doc/todo/wishlist__58___Advanced_settings_for_xmpp_and_webdav.mdwn

@@ -5,3 +5,5 @@ Currently XMPP fails if you use a google apps account. Since the domain provided
 Same goes for webdav support. If i have my own webdav server somewhere on the internet there is no way to set it up in the assistant.
 
 [[!tag /design/assistant]]
+
+> [[done]]; xmpp support has been removed --[[Joey]]

doc/todo/xmpp_removal.mdwn

@@ -25,3 +25,5 @@ The [[no-xmpp]] branch is ready for merging.
 
 Next step is probably to default the flag to false by default,
 except for in a few builds like the Debian package and standalone builds.
+
+> [[done]]

doc/videos/git-annex_assistant_remote_sharing.mdwn

@@ -1,6 +0,0 @@
-<video controls width=400>
-<source src="https://downloads.kitenet.net/videos/git-annex/git-annex-xmpp-pairing.ogv">
-</video><br>
-A <a href="https://downloads.kitenet.net/videos/git-annex/git-annex-xmpp-pairing.ogv">6 minute screencast</a>
-showing how to share files between your computers in different locations,
-such as home and work.

git-annex.cabal

@@ -137,7 +137,6 @@ Extra-Source-Files:
   doc/git-annex-watch.mdwn
   doc/git-annex-webapp.mdwn
   doc/git-annex-whereis.mdwn
-  doc/git-annex-xmppgit.mdwn
   doc/git-remote-tor-annex.mdwn
   doc/logo.svg
   doc/logo_16x16.png
@@ -198,13 +197,9 @@ Extra-Source-Files:
   templates/configurators/enablewebdav.hamlet
   templates/configurators/pairing/local/inprogress.hamlet
   templates/configurators/pairing/local/prompt.hamlet
+  templates/configurators/pairing/wormhole/prompt.hamlet
+  templates/configurators/pairing/wormhole/start.hamlet
   templates/configurators/pairing/disabled.hamlet
-  templates/configurators/pairing/xmpp/self/retry.hamlet
-  templates/configurators/pairing/xmpp/self/prompt.hamlet
-  templates/configurators/pairing/xmpp/friend/prompt.hamlet
-  templates/configurators/pairing/xmpp/friend/confirm.hamlet
-  templates/configurators/pairing/xmpp/end.hamlet
-  templates/configurators/xmpp.hamlet
   templates/configurators/addglacier.hamlet
   templates/configurators/fsck.cassius
   templates/configurators/edit/nonannexremote.hamlet
@@ -226,19 +221,20 @@ Extra-Source-Files:
   templates/configurators/addrepository/archive.hamlet
   templates/configurators/addrepository/cloud.hamlet
   templates/configurators/addrepository/connection.hamlet
-  templates/configurators/addrepository/xmppconnection.hamlet
   templates/configurators/addrepository/ssh.hamlet
   templates/configurators/addrepository/misc.hamlet
+  templates/configurators/addrepository/wormholepairing.hamlet
   templates/configurators/rsync.net/add.hamlet
   templates/configurators/rsync.net/encrypt.hamlet
   templates/configurators/gitlab.com/add.hamlet
   templates/configurators/needgcrypt.hamlet
+  templates/configurators/needtor.hamlet
+  templates/configurators/needmagicwormhole.hamlet
   templates/configurators/enabledirectory.hamlet
   templates/configurators/fsck/status.hamlet
   templates/configurators/fsck/form.hamlet
   templates/configurators/fsck/preferencesform.hamlet
   templates/configurators/fsck/formcontent.hamlet
-  templates/configurators/delete/xmpp.hamlet
   templates/configurators/delete/finished.hamlet
   templates/configurators/delete/start.hamlet
   templates/configurators/delete/currentrepository.hamlet
@@ -246,9 +242,6 @@ Extra-Source-Files:
   templates/configurators/adddrive.hamlet
   templates/configurators/preferences.hamlet
   templates/configurators/addia.hamlet
-  templates/configurators/xmpp/buddylist.hamlet
-  templates/configurators/xmpp/disabled.hamlet
-  templates/configurators/xmpp/needcloudrepo.hamlet
   templates/configurators/enableaws.hamlet
   templates/configurators/addrepository.hamlet
   templates/actionbutton.hamlet
@@ -308,9 +301,6 @@ Flag Cryptonite
 Flag Dbus
   Description: Enable dbus support
 
-Flag XMPP
-  Description: Enable notifications using XMPP
-
 source-repository head
   type: git
   location: git://git-annex.branchable.com/
@@ -481,11 +471,6 @@ Executable git-annex
     Build-Depends: network-multicast, network-info
     CPP-Options: -DWITH_PAIRING
 
-  if flag(XMPP)
-    if (! os(windows))
-      Build-Depends: network-protocol-xmpp, gnutls (>= 0.1.4), xml-types
-      CPP-Options: -DWITH_XMPP
-  
   if flag(TorrentParser)
     Build-Depends: torrent (>= 10000.0.0)
     CPP-Options: -DWITH_TORRENTPARSER
@@ -580,7 +565,6 @@ Executable git-annex
     Assistant.MakeRemote
     Assistant.Monad
     Assistant.NamedThread
-    Assistant.NetMessager
     Assistant.Pairing
     Assistant.Pairing.MakeRemote
     Assistant.Pairing.Network
@@ -613,20 +597,16 @@ Executable git-annex
     Assistant.Threads.Upgrader
     Assistant.Threads.Watcher
     Assistant.Threads.WebApp
-    Assistant.Threads.XMPPClient
-    Assistant.Threads.XMPPPusher
     Assistant.TransferQueue
     Assistant.TransferSlots
     Assistant.TransferrerPool
     Assistant.Types.Alert
     Assistant.Types.BranchChange
-    Assistant.Types.Buddies
     Assistant.Types.Changes
     Assistant.Types.Commits
     Assistant.Types.CredPairCache
     Assistant.Types.DaemonStatus
     Assistant.Types.NamedThread
-    Assistant.Types.NetMessager
     Assistant.Types.Pushes
     Assistant.Types.RemoteControl
     Assistant.Types.RepoProblem
@@ -654,7 +634,6 @@ Executable git-annex
     Assistant.WebApp.Configurators.Unused
     Assistant.WebApp.Configurators.Upgrade
     Assistant.WebApp.Configurators.WebDAV
-    Assistant.WebApp.Configurators.XMPP
     Assistant.WebApp.Control
     Assistant.WebApp.DashBoard
     Assistant.WebApp.Documentation
@@ -664,15 +643,12 @@ Executable git-annex
     Assistant.WebApp.Notifications
     Assistant.WebApp.OtherRepos
     Assistant.WebApp.Page
+    Assistant.WebApp.Pairing
     Assistant.WebApp.Repair
     Assistant.WebApp.RepoId
     Assistant.WebApp.RepoList
     Assistant.WebApp.SideBar
     Assistant.WebApp.Types
-    Assistant.XMPP
-    Assistant.XMPP.Buddies
-    Assistant.XMPP.Client
-    Assistant.XMPP.Git
     Backend
     Backend.Hash
     Backend.URL
@@ -812,7 +788,6 @@ Executable git-annex
     Command.Watch
     Command.WebApp
     Command.Whereis
-    Command.XMPPGit
     Common
     Config
     Config.Cost

stack.yaml

@@ -13,7 +13,6 @@ flags:
     webapp: true
     magicmime: false
     dbus: false
-    xmpp: false
     android: false
     androidsplice: false
 packages:

standalone/android/cabal.config

@@ -111,7 +111,6 @@ constraints: unix installed,
              network-conduit ==1.1.0,
              network-info ==0.2.0.5,
              network-multicast ==0.0.10,
-             network-protocol-xmpp ==0.4.6,
              network-uri ==2.6.0.1,
              optparse-applicative ==0.11.0.2,
              parallel ==3.2.0.4,

standalone/android/haskell-patches/gnuidn_fix-build-with-new-base.patch

@@ -1,50 +0,0 @@
-From afdec6c9e66211a0ac8419fffe191b059d1fd00c Mon Sep 17 00:00:00 2001
-From: foo <foo@bar>
-Date: Sun, 22 Sep 2013 17:24:33 +0000
-Subject: [PATCH] fix build with new base
-
----
- Data/Text/IDN/IDNA.chs       |    1 +
- Data/Text/IDN/Punycode.chs   |    1 +
- Data/Text/IDN/StringPrep.chs |    1 +
- 3 files changed, 3 insertions(+)
-
-diff --git a/Data/Text/IDN/IDNA.chs b/Data/Text/IDN/IDNA.chs
-index ed29ee4..dbb4ba5 100644
---- a/Data/Text/IDN/IDNA.chs
-+++ b/Data/Text/IDN/IDNA.chs
-@@ -31,6 +31,7 @@ import Foreign
- import Foreign.C
- 
- import Data.Text.IDN.Internal
-+import System.IO.Unsafe
- 
- #include <idna.h>
- #include <idn-free.h>
-diff --git a/Data/Text/IDN/Punycode.chs b/Data/Text/IDN/Punycode.chs
-index 24b5fa6..4e62555 100644
---- a/Data/Text/IDN/Punycode.chs
-+++ b/Data/Text/IDN/Punycode.chs
-@@ -32,6 +32,7 @@ import Data.List (unfoldr)
- import qualified Data.ByteString as B
- import qualified Data.Text as T
- 
-+import System.IO.Unsafe
- import Foreign
- import Foreign.C
- 
-diff --git a/Data/Text/IDN/StringPrep.chs b/Data/Text/IDN/StringPrep.chs
-index 752dc9e..5e9fd84 100644
---- a/Data/Text/IDN/StringPrep.chs
-+++ b/Data/Text/IDN/StringPrep.chs
-@@ -39,6 +39,7 @@ import qualified Data.ByteString as B
- import qualified Data.Text as T
- import qualified Data.Text.Encoding as TE
- 
-+import System.IO.Unsafe
- import Foreign
- import Foreign.C
- 
--- 
-1.7.10.4
-

standalone/android/haskell-patches/gnutls_0.1.4-0001-statically-link-with-gnutls.patch

@@ -1,43 +0,0 @@
-From 311aab1ae9d7a653edfbec1351f548b98de85c4b Mon Sep 17 00:00:00 2001
-From: androidbuilder <androidbuilder@example.com>
-Date: Mon, 26 May 2014 21:54:18 +0000
-Subject: [PATCH] hack gnutls to link on android
-
-This uses a hardcoded path to the library, which includes the
-arm-linux-androideabi-4.8 part. Will need to be changed when that changes..
-
-Have to list all the libraries that gnutls depends on, pkgconfig depends
-seems not to be working.
----
- gnutls.cabal |    9 +++++----
- 1 file changed, 5 insertions(+), 4 deletions(-)
-
-diff --git a/gnutls.cabal b/gnutls.cabal
-index 5bfe687..61db23f 100644
---- a/gnutls.cabal
-+++ b/gnutls.cabal
-@@ -31,16 +31,17 @@ source-repository this
- library
-   hs-source-dirs: lib
-   ghc-options: -Wall -O2
-+  LD-Options: -L /home/builder/.ghc/android-14/arm-linux-androideabi-4.8/sysroot/usr/lib/
-+
-+  extra-libraries: gnutls nettle hogweed gmp z
-+  pkgconfig-depends: gnutls
- 
-   build-depends:
-       base >= 4.0 && < 5.0
--    , bytestring >= 0.9
-+    , bytestring >= 0.10.3.0
-     , transformers >= 0.2
-     , monads-tf >= 0.1 && < 0.2
- 
--  extra-libraries: gnutls
--  pkgconfig-depends: gnutls
--
-   exposed-modules:
-     Network.Protocol.TLS.GNU
- 
--- 
-1.7.10.4
-

standalone/android/install-haskell-packages

@@ -111,10 +111,7 @@ EOF
 	patched DAV
 	patched yesod-static
 	patched dns
-	patched gnutls
 	patched unbounded-delays
-	patched gnuidn
-	patched network-protocol-xmpp
 	patched uuid
 
 	cd ..

templates/configurators/addrepository/connection.hamlet

@@ -1,3 +1,3 @@
-^{makeXMPPConnection}
-
 ^{makeSshRepository}
+
+^{makeWormholePairing}

templates/configurators/addrepository/misc.hamlet

@@ -8,7 +8,7 @@
   <a href="http://en.wikipedia.org/wiki/Sneakernet">SneakerNet</a> #
   between computers. 
 
-^{makeXMPPConnection}
+^{makeWormholePairing}
 
 <h3>
   <a href="@{StartLocalPairR}">

templates/configurators/addrepository/wormholepairing.hamlet

@@ -1,12 +1,12 @@
 <h3>
-  <a href="@{StartXMPPPairSelfR}">
+  <a href="@{StartWormholePairSelfR}">
     <span .glyphicon .glyphicon-plus-sign>
     \ Share with your other devices
 <p>
   Keep files in sync between your devices running git-annex.
 
 <h3>
-  <a href="@{StartXMPPPairFriendR}">
+  <a href="@{StartWormholePairFriendR}">
     <span .glyphicon .glyphicon-plus-sign>
     \ Share with a friend
 <p>

templates/configurators/delete/xmpp.hamlet

@@ -1,12 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      Disconnecting from Jabber
-    <p>
-      This won't delete the repository or repositories at the other end
-      of the Jabber connection, but it will disconnect from them, and stop
-      using Jabber.
-    <p>
-    <a .btn .btn-primary href="@{DisconnectXMPPR}">
-      <span .glyphicon .glyphicon-minus>
-      \ Disconnect

templates/configurators/main.hamlet

@@ -27,16 +27,3 @@
           Unused files
       <p>
         Configure what to do with old and deleted files.
-  <div .row>
-    <div .col-sm-4>
-      <h3>
-        <a href="@{XMPPConfigR}">
-          Jabber account
-      $if xmppconfigured
-        <p>
-          Your jabber account is set up, and will be used to keep #
-          in touch with remote devices, and with your friends.
-      $else
-        <p>
-          Keep in touch with remote devices, and with your friends, #
-          by configuring a jabber account.

templates/configurators/needmagicwormhole.hamlet

@@ -0,0 +1,11 @@
+<div .col-sm-9>
+  <div .content-box>
+    <h2>
+      Need Magic Wormhole
+    <p>
+      You need to install #
+      <a href="https://github.com/warner/magic-wormhole">
+        Magic Wormhole
+    <p>
+      <a .btn .btn-primary .btn-lg href="">
+        Retry

templates/configurators/needtor.hamlet

@@ -0,0 +1,11 @@
+<div .col-sm-9>
+  <div .content-box>
+    <h2>
+      Need Tor
+    <p>
+      You need to install #
+      <a href="https://torproject.org/">
+        Tor
+    <p>
+      <a .btn .btn-primary .btn-lg href="">
+        Retry

templates/configurators/pairing/wormhole/prompt.hamlet

@@ -0,0 +1,59 @@
+<div .col-sm-9>
+  <div .content-box>
+    <h2>
+      $case pairingwith
+        $of PairingWithSelf
+          Pairing your devices
+        $of PairingWithFriend
+          Pairing with a friend
+    <p>
+      Pairing will connect two git-annex repositories using #
+      <a href="https://torproject.org/">Tor</a>, #
+      allowing files to be shared between them.
+    <p>
+      $case pairingwith
+        $of PairingWithSelf
+          This device's #
+        $of PairingWithFriend
+          Your repository's #
+      pairing code is: <b><big>#{Wormhole.fromCode ourcode}</big></b>
+    <p>
+      $case pairingwith
+        $of PairingWithSelf
+          Enter that code into the device you want to pair with. #
+        $of PairingWithFriend
+          Tell that code to your friend. #
+    <p>
+      <form method="post" .form-horizontal enctype=#{enctype}>
+        <fieldset>
+          ^{form}
+          ^{webAppFormAuthToken}
+          <div .form-group>
+            <div .col-sm-10 .col-sm-offset-2>
+              <button .btn .btn-primary type=submit>
+                Finish pairing
+  <div .alert .alert-info>
+    <h3 .alert-heading>
+      ^{htmlIcon InfoIcon} Keep pairing codes safe
+    $case pairingwith
+      $of PairingWithSelf
+        <p>
+          Pairing codes can only be used a single time, but if someone #
+          saw the pairing codes before you use them, they could #
+          pair with your devices. So be careful with the pairing codes!
+      $of PairingWithFriend
+        <p>
+          Pairing codes can only be used a single time, but if someone #
+          overhears you exchanging them with your friend, they could #
+          pair with your repositories. #
+        <p>
+          Here are some suggestions for how to exchange the pairing #
+          code with your friend, with the safest ways first:
+          <ul>
+            <li>
+              In person.
+            <li>
+              In an encrypted message #
+              (gpg signed email, Off The Record (OTR) conversation, etc).
+            <li>
+              By a voice phone call.

templates/configurators/pairing/wormhole/start.hamlet

@@ -0,0 +1,31 @@
+<div .col-sm-9>
+  <div .content-box>
+    <h2>
+      $case pairingwith
+        $of PairingWithSelf
+          Preparing for pairing your devices
+        $of PairingWithFriend
+          Preparing for pairing with a friend
+    <p>
+      Pairing will connect two git-annex repositories using #
+      <a href="https://torproject.org/">Tor</a>, #
+      allowing files to be shared between them.
+    <p>
+      First, a Tor hidden service needs to be set up on this computer.
+    <p>
+      <a .btn .btn-primary onclick="$('#setupmodal').modal('show');" href="@{PrepareWormholePairR pairingwith}">
+        <span .glyphicon .glyphicon-resize-small>
+        \ Let's get started #
+<div .modal .fade #setupmodal>
+  <div .modal-dialog>
+    <div .modal-content>
+      <div .modal-header>
+        <h3>
+          Enabling Tor hidden service ...
+      <div .modal-body>
+        <p>
+          This could take a few minutes, and you may be prompted for a #
+          password in order to enable the Tor hidden service.
+        <p>
+          If this is taking too long, check that you are connected to the #
+          network, and that Tor is working.

templates/configurators/pairing/xmpp/end.hamlet

@@ -1,33 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    $if inprogress
-      <h2>
-        Pair request sent ...
-      <p>
-        $maybe name <- friend
-          A pair request has been sent to #{name}. Now it's up to them #
-          to accept it and finish pairing.
-        $nothing
-          A pair request has been sent to all other devices that #
-          have been configured to use your jabber account. #
-          It will be answered automatically by any devices that see it.
-    $else
-      Pair request accepted.
-    <h2>
-      Configure a shared cloud repository
-    $maybe name <- friend
-      <p>
-        &#9730; To share files with #{name}, you'll need a repository in #
-        the cloud, that you both can access.
-    $nothing
-      <p>
-        &#9730; To share files with your other devices, when they're not #
-        nearby, you'll need a repository in the cloud.
-      <p>
-        Make sure that your other devices are configured to access a #
-        cloud repository, and that the same repository is enabled here #
-        too.
-    ^{cloudRepoList}
-    <h2>
-      Add a cloud repository
-    ^{makeCloudRepositories}

templates/configurators/pairing/xmpp/friend/confirm.hamlet

@@ -1,12 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      Pair request received from #{name}
-    <p>
-      Pairing with #{name} will combine your two git annex #
-      repositories into one, allowing you to share files.
-    <p>
-      <a .btn .btn-primary .btn-lg href="@{FinishXMPPPairFriendR pairkey}">
-        Accept pair request
-      <a .btn .btn-default .btn-lg href="@{DashboardR}">
-        No thanks

templates/configurators/pairing/xmpp/friend/prompt.hamlet

@@ -1,13 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      Share with a friend
-    <p>
-      You can combine your repository with a friend's repository #
-      to share your files. Your repositories will automatically be kept in #
-      sync. Only do this if you want your friend to see all the files #
-      in this repository!
-    <p>
-      Here are the friends currently available via your Jabber account.
-      <p>
-        ^{buddyListDisplay}

templates/configurators/pairing/xmpp/self/prompt.hamlet

@@ -1,21 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      Sharing with your other devices
-    <p>
-      If you have multiple devices, all running git-annex, and using #
-      your Jabber account #{account}, you can configure them to share #
-      your files between themselves.
-    <p>
-      For example, you can have a computer at home, one at work, and a #
-      laptop, and their repositories will automatically be kept in sync.
-    <p>
-      Make sure your other devices are online and configured to use #
-      your Jabber account before continuing. Note that <b>all</b> #
-      repositories configured to use the same Jabber account will be #
-      combined together when you do this.
-    <p>
-      <a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}">
-        Start sharing with my other devices #
-      <a .btn .btn-default .btn-lg href="@{DashboardR}">
-        Cancel

templates/configurators/pairing/xmpp/self/retry.hamlet

@@ -1,12 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      Unable to get in touch with any other devices.
-    <p>
-      Make sure your other devices are online and configured to use #
-      your Jabber account before continuing.
-    <p>
-      <a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}">
-        Start sharing with my other devices #
-      <a .btn .btn-default .btn-lg href="@{DashboardR}">
-        Cancel

templates/configurators/xmpp.hamlet

@@ -1,43 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      Configuring jabber account
-    <p>
-      A jabber account is used to communicate between #
-      devices that are not in direct contact. #
-      It can also be used to pair up with a friend's repository, if desired.
-    <p>
-      It's fine to reuse an existing jabber account; git-annex won't #
-      post any messages to it.
-    <p>
-      $maybe msg <- problem
-        <span .glyphicon .glyphicon-warning-sign>
-        \ Unable to connect to the Jabber server. #
-        Maybe you entered the wrong password? (Error message: #{msg})
-      $nothing
-        <span .glyphicon .glyphicon-user>
-        \ If you have a Gmail account, you can use #
-        Google Talk. Just enter your full Gmail address #
-        <small>(<tt>you@gmail.com</tt>)</small> #
-        and password below.
-    <p>
-      <form method="post" .form-horizontal enctype=#{enctype}>
-        <fieldset>
-          ^{form}
-          ^{webAppFormAuthToken}
-          <div .form-group>
-            <div .col-sm-10 .col-sm-offset-2>
-              <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
-                Use this account
-              \ 
-              <a .btn .btn-default href="@{DisconnectXMPPR}">
-                Stop using this account
-<div .modal .fade #workingmodal>
-  <div .modal-dialog>
-    <div .modal-content>
-      <div .modal-header>
-        <h3>
-          Testing account ...
-      <div .modal-body>
-        <p>
-          Testing jabber account. This could take a minute.

templates/configurators/xmpp/buddylist.hamlet

@@ -1,40 +0,0 @@
-<div ##{ident}>
-  <table .table>
-    <tbody>
-    $if null buddies
-      <tr>
-        <td>
-          $if isNothing myjid
-            Not connected to the jabber server. Check your network connection ...
-          $else
-            Searching...
-    $else
-      $forall (name, away, canpair, paired, buddyid) <- buddies
-        <tr>
-          <td>
-            $if isself buddyid
-              <span .glyphicon .glyphicon-star> #
-              <span :away:.text-muted>
-                your other devices
-            $else
-              <span .glyphicon .glyphicon-user> #
-              <span :away:.text-muted>
-                  #{name}
-          <td>
-            $if away
-              <span .text-muted>
-                away
-            $else
-              $if paired
-                <span .label .label-success>
-                  paired
-              $else
-                $if canpair
-                  $if isself buddyid
-                    <a .btn .btn-primary .btn-sm href="@{RunningXMPPPairSelfR}">
-                      Start pairing
-                  $else
-                    <a .btn .btn-primary .btn-sm href="@{RunningXMPPPairFriendR buddyid}">
-                      Start pairing
-                $else
-                  not using git-annex

templates/configurators/xmpp/disabled.hamlet

@@ -1,6 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      Jabber not supported
-    <p>
-      This build of git-annex does not support Jabber. Sorry!

templates/configurators/xmpp/needcloudrepo.hamlet

@@ -1,18 +0,0 @@
-<div .col-sm-9>
-  <div .content-box>
-    <h2>
-      &#9730; Configure a shared cloud repository
-    $maybe name <- buddyname
-      <p>
-        You and #{name} have combined your repositores. But you can't open #
-        each other's files yet. To start sharing files with #{name}, #
-        you need a repository in the cloud, that you both can access.
-    $nothing
-      <p>
-        You've combined the repositories on two or more of your devices. #
-        But files are not flowing yet. To start sharing files #
-        between your devices, you should set up a repository in the cloud.
-    ^{cloudRepoList}
-    <h2>
-      Add a cloud repository
-    ^{makeCloudRepositories}

templates/documentation/about.hamlet

@@ -9,7 +9,7 @@
       For full details, see #
       <a href="http://git-annex.branchable.com/">the git-annex website</a>.
     <hr>
-      git-annex is © 2010-2014 Joey Hess. It is free software, licensed #
+      git-annex is © 2010-2017 Joey Hess. It is free software, licensed #
       under the terms of the GNU General Public License, version 3 or above. #
       This webapp is licensed under the terms of the GNU Affero General #
       Public License, version 3 or above. #