pairing probably works now (untested)

Assistant.hs

@@ -181,7 +181,7 @@ startAssistant assistant daemonize webappwaiter = do
 #ifdef WITH_WEBAPP
 				, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots urlrenderer Nothing webappwaiter
 #ifdef WITH_PAIRING
-				, assist $ pairListenerThread st dstatus urlrenderer
+				, assist $ pairListenerThread st dstatus scanremotes urlrenderer
 #endif
 #endif
 				, assist $ pushThread st dstatus commitchan pushmap

Assistant/MakeRemote.hs

@@ -0,0 +1,107 @@
+{- git-annex assistant remote creation utilities
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.MakeRemote where
+
+import Assistant.Common
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.Ssh
+import Assistant.Sync
+import qualified Types.Remote as R
+import qualified Remote
+import Remote.List
+import qualified Remote.Rsync as Rsync
+import qualified Git
+import qualified Git.Command
+import qualified Command.InitRemote
+import Logs.UUID
+import Logs.Remote
+
+import qualified Data.Text as T
+import qualified Data.Map as M
+
+{- Sets up and begins syncing with a new ssh or rsync remote. -}
+makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO ()
+makeSshRemote st dstatus scanremotes forcersync sshdata = do
+	r <- runThreadState st $
+		addRemote $ maker (sshRepoName sshdata) sshurl
+	syncNewRemote st dstatus scanremotes r
+	where
+		rsync = forcersync || rsyncOnly sshdata
+		maker
+			| rsync = makeRsyncRemote
+			| otherwise = makeGitRemote
+		sshurl = T.unpack $ T.concat $
+			if rsync
+				then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"]
+				else [T.pack "ssh://", u, h, d, T.pack "/"]
+			where
+				u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
+				h = sshHostName sshdata
+				d
+					| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = d
+					| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
+	
+{- Runs an action that returns a name of the remote, and finishes adding it. -}
+addRemote :: Annex String -> Annex Remote
+addRemote a = do
+	name <- a
+	void $ remoteListRefresh
+	maybe (error "failed to add remote") return =<< Remote.byName (Just name)
+
+{- Inits a rsync special remote, and returns the name of the remote. -}
+makeRsyncRemote :: String -> String -> Annex String
+makeRsyncRemote name location = makeRemote name location $ const $ do
+	(u, c) <- Command.InitRemote.findByName name
+	c' <- R.setup Rsync.remote u $ M.union config c
+	describeUUID u name
+	configSet u c'
+	where
+		config = M.fromList
+			[ ("encryption", "shared")
+			, ("rsyncurl", location)
+			, ("type", "rsync")
+			]
+
+{- Returns the name of the git remote it created. If there's already a
+ - remote at the location, returns its name. -}
+makeGitRemote :: String -> String -> Annex String
+makeGitRemote basename location = makeRemote basename location $ \name ->
+	void $ inRepo $
+		Git.Command.runBool "remote"
+			[Param "add", Param name, Param location]
+
+{- If there's not already a remote at the location, adds it using the
+ - action, which is passed the name of the remote to make.
+ -
+ - Returns the name of the remote. -}
+makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
+makeRemote basename location a = do
+	r <- fromRepo id
+	if (null $ filter samelocation $ Git.remotes r)
+		then do
+			let name = uniqueRemoteName r basename 0
+			a name
+			return name
+		else return basename
+	where
+		samelocation x = Git.repoLocation x == location
+
+{- Generate an unused name for a remote, adding a number if
+ - necessary. -}
+uniqueRemoteName :: Git.Repo -> String -> Int -> String
+uniqueRemoteName r basename n
+	| null namecollision = name
+	| otherwise = uniqueRemoteName r basename (succ n)
+	where
+		namecollision = filter samename (Git.remotes r)
+		samename x = Git.remoteName x == Just name
+		name
+			| n == 0 = basename
+			| otherwise = basename ++ show n

Assistant/Pairing.hs

@@ -25,23 +25,24 @@ data PairStage
 	| PairDone
 	deriving (Eq, Read, Show)
 
-newtype PairMsg = PairMsg (Verifiable (PairStage, PairData))
+newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
 	deriving (Eq, Read, Show)
 
-fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData))
+fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData, SomeAddr))
 fromPairMsg (PairMsg m) = m
 
 pairMsgStage :: PairMsg -> PairStage
-pairMsgStage (PairMsg (Verifiable (s, _) _)) = s
+pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s
 
 pairMsgData :: PairMsg -> PairData
-pairMsgData (PairMsg (Verifiable (_, d) _)) = d
+pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d
+
+pairMsgAddr :: PairMsg -> SomeAddr
+pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a
 
 data PairData = PairData
 	-- uname -n output, not a full domain name
 	{ remoteHostName :: Maybe HostName
-	-- the address is included so that it can be verified, avoiding spoofing
-	, remoteAddress :: SomeAddr
 	, remoteUserName :: UserName
 	, remoteDirectory :: FilePath
 	, remoteSshPubKey :: SshPubKey
@@ -55,8 +56,9 @@ type UserName = String
  - set up on disk. -}
 data PairingInProgress = PairingInProgress
 	{ inProgressSecret :: Secret
-	, inProgressThreadId :: ThreadId
+	, inProgressThreadId :: Maybe ThreadId
 	, inProgressSshKeyPair :: SshKeyPair
+	, inProgressPairData :: PairData
 	}
 
 data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6

Assistant/Pairing/MakeRemote.hs

@@ -0,0 +1,81 @@
+{- git-annex assistant pairing remote creation
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pairing.MakeRemote where
+
+import Assistant.Common
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.Ssh
+import Assistant.Pairing
+import Assistant.Pairing.Network
+import Assistant.MakeRemote
+
+import Network.Socket
+import qualified Data.Text as T
+
+{- When pairing is complete, this is used to set up the remote for the host
+ - we paired with. -}
+finishedPairing :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> SshKeyPair -> IO ()
+finishedPairing st dstatus scanremotes msg keypair = do
+	sshdata <- setupSshKeyPair keypair =<< pairMsgToSshData msg
+	{- Ensure that we know
+	 - the ssh host key for the host we paired with.
+	 - If we don't, ssh over to get it. -}
+	unlessM (knownHost $ sshHostName sshdata) $ do
+		void $ sshTranscript
+			[ sshOpt "StrictHostKeyChecking" "no"
+			, sshOpt "NumberOfPasswordPrompts" "0"
+			, "-n"
+			, genSshHost (sshHostName sshdata) (sshUserName sshdata)
+			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
+			]
+			""
+	makeSshRemote st dstatus scanremotes False sshdata
+
+{- Mostly a straightforward conversion.  Except:
+ -  * Determine the best hostname to use to contact the host.
+ -  * Strip leading ~/ from the directory name.
+ -}
+pairMsgToSshData :: PairMsg -> IO SshData
+pairMsgToSshData msg = do
+	let d = pairMsgData msg
+	hostname <- liftIO $ bestHostName msg
+	let dir = case remoteDirectory d of
+		('~':'/':v) -> v
+		v -> v
+	return $ SshData
+		{ sshHostName = T.pack hostname
+		, sshUserName = Just (T.pack $ remoteUserName d)
+		, sshDirectory = T.pack dir
+		, sshRepoName = genSshRepoName hostname dir
+		, needsPubKey = True
+		, rsyncOnly = False
+	}
+
+{- Finds the best hostname to use for the host that sent the PairMsg.
+ -
+ - If remoteHostName is set, tries to use a .local address based on it.
+ - That's the most robust, if this system supports .local.
+ - Otherwise, looks up the hostname in the DNS for the remoteAddress,
+ - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
+bestHostName :: PairMsg -> IO HostName
+bestHostName msg = case (remoteHostName $ pairMsgData msg) of
+	Just h -> do
+		let localname = h ++ ".local"
+		addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
+		maybe fallback (const $ return localname) (headMaybe addrs)
+	Nothing -> fallback
+	where
+		fallback = do
+			let a = pairMsgAddr msg
+			let sockaddr = case a of
+				IPv4Addr addr -> SockAddrInet (PortNum 0) addr
+				IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
+			fromMaybe (showAddr a)
+				<$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing

Assistant/Pairing/Network.hs

@@ -1,4 +1,8 @@
 {- git-annex assistant pairing network code
+ -
+ - All network traffic is sent over multicast UDP. For reliability,
+ - each message is repeated until acknowledged. This is done using a
+ - thread, that gets stopped before the next message is sent.
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
@@ -7,15 +11,18 @@
 
 module Assistant.Pairing.Network where
 
-import Common
+import Assistant.Common
 import Assistant.Pairing
+import Assistant.DaemonStatus
 import Utility.ThreadScheduler
+import Utility.Verifiable
 
 import Network.Multicast
 import Network.Info
 import Network.Socket
 import Control.Exception (bracket)
 import qualified Data.Map as M
+import Control.Concurrent
 
 {- This is an arbitrary port in the dynamic port range, that could
  - conceivably be used for some other broadcast messages.
@@ -30,8 +37,9 @@ multicastAddress :: SomeAddr -> HostName
 multicastAddress (IPv4Addr _) = "224.0.0.1"
 multicastAddress (IPv6Addr _) = "ff02::1"
 
-{- Multicasts a message repeatedly on all interfaces forever, until killed
+{- Multicasts a message repeatedly on all interfaces, with a 2 second
- - with a 2 second delay between each transmission.
+ - delay between each transmission. The message is repeated forever
+ - unless a number of repeats is specified.
  -
  - The remoteHostAddress is set to the interface's IP address.
  -
@@ -39,15 +47,16 @@ multicastAddress (IPv6Addr _) = "ff02::1"
  - but it allows new network interfaces to be used as they come up.
  - On the other hand, the expensive DNS lookups are cached.
  -}
-multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ()
+multicastPairMsg :: Maybe Int -> Secret -> PairStage -> PairData -> IO ()
-multicastPairMsg mkmsg = go M.empty
+multicastPairMsg repeats secret stage pairdata = go M.empty repeats
 	where
-		go cache = do
+		go _ (Just 0) = noop
+		go cache n = do
 			addrs <- activeNetworkAddresses
 			let cache' = updatecache cache addrs
 			mapM_ (sendinterface cache') addrs
 			threadDelaySeconds (Seconds 2)
-			go cache'
+			go cache' $ pred <$> n
 		sendinterface cache i = void $ catchMaybeIO $
 			withSocketsDo $ bracket
 				(multicastSender (multicastAddress i) pairingPort)
@@ -61,27 +70,23 @@ multicastPairMsg mkmsg = go M.empty
 		updatecache cache (i:is)
 			| M.member i cache = updatecache cache is
 			| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
+		mkmsg addr = PairMsg $
+			mkVerifiable (stage, pairdata, addr) secret
 
-{- Finds the best hostname to use for the host that sent the PairData.
+startSending :: DaemonStatusHandle -> PairingInProgress -> IO () -> IO ()
- -
+startSending dstatus pip sender = do
- - If remoteHostName is set, tries to use a .local address based on it.
+	tid <- forkIO sender
- - That's the most robust, if this system supports .local.
+	let pip' = pip { inProgressThreadId = Just tid }
- - Otherwise, looks up the hostname in the DNS for the remoteAddress,
+	oldpip <- modifyDaemonStatus dstatus $
- - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
+		\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
-bestHostName :: PairData -> IO HostName
+	maybe noop stopold oldpip
-bestHostName d = case remoteHostName d of
-	Just h -> do
-		let localname = h ++ ".local"
-		addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
-		maybe fallback (const $ return localname) (headMaybe addrs)
-	Nothing -> fallback
 	where
-		fallback = do
+		stopold = maybe noop killThread . inProgressThreadId
-			let sockaddr = case remoteAddress d of
+
-				IPv4Addr a -> SockAddrInet (PortNum 0) a
+stopSending :: DaemonStatusHandle ->  PairingInProgress -> IO ()
-				IPv6Addr a -> SockAddrInet6 (PortNum 0) 0 a 0
+stopSending dstatus pip = do
-			fromMaybe (show $ remoteAddress d) 
+	maybe noop killThread $ inProgressThreadId pip
-				<$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
+	modifyDaemonStatus_ dstatus $ \s -> s { pairingInProgress = Nothing }
 
 class ToSomeAddr a where
 	toSomeAddr :: a -> SomeAddr

Assistant/Ssh.hs

@@ -7,7 +7,7 @@
 
 module Assistant.Ssh where
 
-import Common
+import Common.Annex
 import Utility.TempFile
 
 import Data.Text (Text)
@@ -43,6 +43,10 @@ sshDir = do
 	home <- myHomeDir
 	return $ home </> ".ssh"
 
+{- user@host or host -}
+genSshHost :: Text -> Maybe Text -> String
+genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
+
 {- host_dir, with all / in dir replaced by _, and bad characters removed -}
 genSshRepoName :: String -> FilePath -> String
 genSshRepoName host dir
@@ -171,3 +175,12 @@ setupSshKeyPair sshkeypair sshdata = do
 		sshpubkeyfile = sshprivkeyfile ++ ".pub"
 		mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
 		user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
+
+{- Does ssh have known_hosts data for a hostname? -}
+knownHost :: Text -> IO Bool
+knownHost hostname = do
+	sshdir <- sshDir
+	ifM (doesFileExist $ sshdir </> "known_hosts")
+		( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack hostname]
+		, return False
+		)

Assistant/Sync.hs

@@ -24,6 +24,7 @@ import qualified Annex.Branch
 
 import Data.Time.Clock
 import qualified Data.Map as M
+import Control.Concurrent
 
 {- Syncs with remotes that may have been disconnected for a while.
  - 
@@ -108,3 +109,9 @@ manualPull st currentbranch remotes = do
 	forM_ remotes $ \r ->
 		runThreadState st $ Command.Sync.mergeRemote r currentbranch
 	return haddiverged
+
+{- Start syncing a newly added remote, using a background thread. -}
+syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
+syncNewRemote st dstatus scanremotes remote = do
+	runThreadState st $ updateKnownRemotes dstatus
+	void $ forkIO $ do reconnectRemotes "SyncRemote" st dstatus scanremotes [remote]

Assistant/Threads/PairListener.hs

@@ -10,7 +10,9 @@ module Assistant.Threads.PairListener where
 import Assistant.Common
 import Assistant.Pairing
 import Assistant.Pairing.Network
+import Assistant.Pairing.MakeRemote
 import Assistant.ThreadedMonad
+import Assistant.ScanRemotes
 import Assistant.DaemonStatus
 import Assistant.WebApp
 import Assistant.WebApp.Types
@@ -25,8 +27,8 @@ import qualified Data.Text as T
 thisThread :: ThreadName
 thisThread = "PairListener"
 
-pairListenerThread :: ThreadState -> DaemonStatusHandle -> UrlRenderer -> NamedThread
+pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread
-pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
+pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do
 	sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
 	go sock
 	where
@@ -47,15 +49,16 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
 
 		dispatch Nothing = noop
 		dispatch (Just m@(PairMsg v)) = do
-			verified <- maybe False (verify v . inProgressSecret)
+			pip <- pairingInProgress <$> getDaemonStatus dstatus
-				. pairingInProgress
+			let verified = maybe False (verify v . inProgressSecret) pip
-				<$> getDaemonStatus dstatus
 			case pairMsgStage m of
 				PairReq -> pairReqReceived verified dstatus urlrenderer m
-				PairAck -> pairAckReceived verified dstatus m
+				PairAck -> pairAckReceived verified pip st dstatus scanremotes m
-				PairDone -> pairDoneReceived verified dstatus m
+				PairDone -> pairDoneReceived verified pip st dstatus scanremotes m
 
-{- Pair request alerts from the same host combine,
+{- Show an alert when a PairReq is seen.
+ -
+ - Pair request alerts from the same host combine,
  - so repeated requests do not add additional alerts. -}
 pairReqReceived :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
 pairReqReceived True _ _ _ = noop -- ignore out own PairReq
@@ -69,12 +72,11 @@ pairReqReceived False dstatus urlrenderer msg = do
 			, buttonAction = Just onclick
 			}
 	where
-		v = fromPairMsg msg
+		pairdata = pairMsgData msg
-		(_, pairdata) = verifiableVal v
 		repo = concat
 			[ remoteUserName pairdata
 			, "@"
-			, fromMaybe (showAddr $ remoteAddress pairdata)
+			, fromMaybe (showAddr $ pairMsgAddr msg)
 				(remoteHostName pairdata)
 			, ":"
 			, (remoteDirectory pairdata)
@@ -90,27 +92,34 @@ pairReqReceived False dstatus urlrenderer msg = do
 			, alertData = [UnTensed $ T.pack $ "pair request with " ++ repo ++ " in progress"]
 			}
 
-{- When a valid PairAck is seen, a host has successfully paired with
+{- When a verified PairAck is seen, a host is ready to pair with us, and has
- - us, and we should finish pairing with them. Then send a single PairDone.
+ - already configured our ssh key. Stop sending PairReqs, finish the pairing,
+ - and send a few PairDones.
  -
- - A stale PairAck might also be seen, after we've finished pairing.
+ - TODO: A stale PairAck might also be seen, after we've finished pairing.
  - Perhaps our PairDone was not received. To handle this, we keep
  - a list of recently finished pairings, and re-send PairDone in
  - response to stale PairAcks for them.
  -}
-pairAckReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO ()
+pairAckReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
-pairAckReceived False _ _ = noop -- not verified
+pairAckReceived False _ _ _ _ _ = noop -- not verified
-pairAckReceived True dstatus msg = error "TODO"
+pairAckReceived True Nothing _ _ _ _ = noop -- not in progress
+pairAckReceived True (Just pip) st dstatus scanremotes msg = do
+	stopSending dstatus pip
+	finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
+	startSending dstatus pip $ multicastPairMsg
+		(Just 10) (inProgressSecret pip) PairDone (inProgressPairData pip)
 
-{- If we get a valid PairDone, and are sending PairAcks, we can stop
+{- If we get a verified PairDone, the host has accepted our PairAck, and
- - sending them, as the message has been received.
+ - has paired with us. Stop sending PairAcks, and finish pairing with them.
  -
- - Also, now is the time to remove the pair request alert, as pairing is
+ - TODO: Should third-party hosts remove their pair request alert when they
- - over. Do that even if the PairDone cannot be validated, as we might
+ - see a PairDone? How to tell if a PairDone matches with the PairReq 
- - be a third host that did not participate in the pairing.
+ - that brought up the alert? Cannot verify it without the secret..
- - Note: This does allow a bad actor to squelch pairing on a network
- - by sending bogus PairDones.
  -}
-pairDoneReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO ()
+pairDoneReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
-pairDoneReceived False _ _ = noop -- not verified
+pairDoneReceived False _ _ _ _ _ = noop -- not verified
-pairDoneReceived True dstatus msg = error "TODO"
+pairDoneReceived True Nothing _ _ _ _ = noop -- not in progress
+pairDoneReceived True (Just pip) st dstatus scanremotes msg = do
+	stopSending dstatus pip
+	finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)

Assistant/WebApp/Configurators/Local.hs

@@ -14,15 +14,12 @@ import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Assistant.Sync
-import Assistant.DaemonStatus
+import Assistant.MakeRemote
 import Utility.Yesod
-import Remote.List
-import qualified Remote
 import Init
 import qualified Git
 import qualified Git.Construct
 import qualified Git.Config
-import qualified Git.Command
 import qualified Annex
 import Locations.UserConfig
 import Utility.FreeDesktop
@@ -37,7 +34,6 @@ import qualified Data.Text as T
 import Data.Char
 import System.Posix.Directory
 import qualified Control.Exception as E
-import Control.Concurrent
 
 data RepositoryPath = RepositoryPath Text
 	deriving Show
@@ -198,61 +194,15 @@ getAddDriveR = bootstrap (Just Config) $ do
 				void $ makeGitRemote hostname hostlocation
 			addRemote $ makeGitRemote name dir
 
-{- Runs an action that returns a name of the remote, and finishes adding it. -}
-addRemote :: Annex String -> Annex Remote
-addRemote a = do
-	name <- a
-	void $ remoteListRefresh
-	maybe (error "failed to add remote") return =<< Remote.byName (Just name)
-
-{- Returns the name of the git remote it created. If there's already a
- - remote at the location, returns its name. -}
-makeGitRemote :: String -> String -> Annex String
-makeGitRemote basename location = makeRemote basename location $ \name ->
-	void $ inRepo $
-		Git.Command.runBool "remote"
-			[Param "add", Param name, Param location]
-
-{- If there's not already a remote at the location, adds it using the
- - action, which is passed the name of the remote to make.
- -
- - Returns the name of the remote. -}
-makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
-makeRemote basename location a = do
-	r <- fromRepo id
-	if (null $ filter samelocation $ Git.remotes r)
-		then do
-			let name = uniqueRemoteName r basename 0
-			a name
-			return name
-		else return basename
-	where
-		samelocation x = Git.repoLocation x == location
-
-{- Generate an unused name for a remote, adding a number if
- - necessary. -}
-uniqueRemoteName :: Git.Repo -> String -> Int -> String
-uniqueRemoteName r basename n
-	| null namecollision = name
-	| otherwise = uniqueRemoteName r basename (succ n)
-	where
-		namecollision = filter samename (Git.remotes r)
-		samename x = Git.remoteName x == Just name
-		name
-			| n == 0 = basename
-			| otherwise = basename ++ show n
-
 {- Start syncing a newly added remote, using a background thread. -}
 syncRemote :: Remote -> Handler ()
 syncRemote remote = do
 	webapp <- getYesod
-	runAnnex () $ updateKnownRemotes (daemonStatus webapp)
+	liftIO $ syncNewRemote
-	void $ liftIO $ forkIO $ do
+		(fromJust $ threadState webapp)
-		reconnectRemotes "WebApp"
+		(daemonStatus webapp)
-			(fromJust $ threadState webapp)
+		(scanRemotes webapp)
-			(daemonStatus webapp)
+		remote
-			(scanRemotes webapp)
-			[remote]
 
 {- List of removable drives. -}
 driveList :: IO [RemovableDrive]

Assistant/WebApp/Configurators/Pairing.hs

@@ -39,7 +39,6 @@ import Utility.Yesod
 import Assistant.Common
 import Assistant.Pairing.Network
 import Assistant.Ssh
-import qualified Assistant.WebApp.Configurators.Ssh as Ssh
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.Verifiable
@@ -60,9 +59,7 @@ import Control.Concurrent
 
 getStartPairR :: Handler RepHtml
 #ifdef WITH_PAIRING
-getStartPairR = do
+getStartPairR = promptSecret Nothing $ startPairing PairReq noop
-	keypair <- liftIO genSshKeyPair
-	promptSecret Nothing $ startPairing PairReq keypair noop
 #else
 getStartPairR = noPairing
 #endif
@@ -70,44 +67,19 @@ getStartPairR = noPairing
 getFinishPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
 getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
-	keypair <- setup
+	setup
-	startPairing PairAck keypair cleanup "" secret
+	startPairing PairAck cleanup "" secret
 	where
 		pubkey = remoteSshPubKey $ pairMsgData msg
 		setup  = do
-			validateSshPubKey pubKey
+			liftIO $ validateSshPubKey pubkey
 			unlessM (liftIO $ makeAuthorizedKeys False pubkey) $
 				error "failed setting up ssh authorized keys"
-			keypair <- liftIO genSshKeyPair
-			sshdata <- liftIO $ pairMsgToSshData msg
-			sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-			void $ lift $ Ssh.makeSshWithKeyPair False sshdata' (Just keypair)
-			return keypair
 		cleanup = error "TODO clean up authorized keys and generated ssh key and remove git remote"
 #else
 getFinishPairR _ = noPairing
 #endif
 
-{- Mostly a straightforward conversion.  Except:
- -  * Determine the best hostname to use to contact the host.
- -  * Strip leading ~/ from the directory name.
- -}
-pairMsgToSshData :: PairMsg -> IO SshData
-pairMsgToSshData msg = do
-	let d = pairMsgData msg
-	hostname <- liftIO $ bestHostName d
-	let dir = case remoteDirectory d of
-		('~':'/':v) -> v
-		v -> v
-	return $ SshData
-		{ sshHostName = T.pack hostname
-		, sshUserName = Just (T.pack $ remoteUserName d)
-		, sshDirectory = T.pack dir
-		, sshRepoName = genSshRepoName besthostname dir
-		, needsPubKey = True
-		, rsyncOnly = False
-		}
-
 getInprogressPairR :: Text -> Handler RepHtml
 #ifdef WITH_PAIRING
 getInprogressPairR secret = pairPage $ do
@@ -127,27 +99,23 @@ getInprogressPairR _ = noPairing
  -
  - Redirects to the pairing in progress page.
  -}
-startPairing :: PairStage -> SshKeyPair -> IO () -> Text -> Secret -> Widget
+startPairing :: PairStage -> IO () -> Text -> Secret -> Widget
-startPairing stage keypair oncancel displaysecret secret = do
+startPairing stage oncancel displaysecret secret = do
+	keypair <- liftIO $ genSshKeyPair
 	dstatus <- daemonStatus <$> lift getYesod
 	urlrender <- lift getUrlRender
 	let homeurl = urlrender HomeR
-	sender <- mksender
+	pairdata <- PairData
+		<$> liftIO getHostname
+		<*> liftIO getUserName
+		<*> (fromJust . relDir <$> lift getYesod)
+		<*> pure (sshPubKey keypair)
 	liftIO $ do
-		pip <- PairingInProgress secret
+		let sender = multicastPairMsg Nothing secret stage pairdata
-			<$> sendrequests sender dstatus homeurl
+		let pip = PairingInProgress secret Nothing keypair pairdata
-			<*> pure keypair
+		startSending dstatus pip $ sendrequests sender dstatus homeurl
-		oldpip <- modifyDaemonStatus dstatus $
-			\s -> (s { pairingInProgress = Just pip }, pairingInProgress s)
-		maybe noop stopold oldpip
 	lift $ redirect $ InprogressPairR displaysecret
 	where
-		mksender = do
-			hostname <- liftIO getHostname
-			username <- liftIO getUserName
-			reldir <- fromJust . relDir <$> lift getYesod
-			return $ multicastPairMsg $ \addr -> PairMsg $ mkVerifiable
-				(stage, PairData hostname addr username reldir (sshPubKey keypair)) secret
 		{- Sends pairing messages until the thread is killed,
 		 - and shows an activity alert while doing it.
 		 -
@@ -156,7 +124,7 @@ startPairing stage keypair oncancel displaysecret secret = do
 		 - have been on a page specific to the in-process pairing
 		 - that just stopped, so can't go back there.
 		 -}
-		sendrequests sender dstatus homeurl = forkIO $ do
+		sendrequests sender dstatus homeurl = do
 			tid <- myThreadId
 			let selfdestruct = AlertButton
 				{ buttonLabel = "Cancel"
@@ -168,7 +136,6 @@ startPairing stage keypair oncancel displaysecret secret = do
 			alertDuring dstatus (pairingAlert selfdestruct) $ do
 				_ <- E.try sender :: IO (Either E.SomeException ())
 				return ()
-		stopold = killThread  . inProgressThreadId
 
 data InputSecret = InputSecret { secretText :: Maybe Text }
 
@@ -200,7 +167,7 @@ promptSecret msg cont = pairPage $ do
 			let badphrase = isJust mproblem
 			let problem = fromMaybe "" mproblem
 			let (username, hostname) = maybe ("", "")
-				(\(_, v) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
+				(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v)))
 				(verifiableVal . fromPairMsg <$> msg)
 			u <- T.pack <$> liftIO getUserName
 			let sameusername = username == u

Assistant/WebApp/Configurators/Ssh.hs

@@ -11,21 +11,15 @@ module Assistant.WebApp.Configurators.Ssh where
 
 import Assistant.Common
 import Assistant.Ssh
+import Assistant.MakeRemote
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
-import Assistant.WebApp.Configurators.Local
-import qualified Types.Remote as R
-import qualified Remote.Rsync as Rsync
-import qualified Command.InitRemote
-import Logs.UUID
-import Logs.Remote
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Map as M
 import Network.BSD
 import System.Posix.User
 
@@ -127,7 +121,7 @@ getAddSshR = sshConfigurator $ do
 testServer :: SshServer -> IO (ServerStatus, Bool)
 testServer (SshServer { hostname = Nothing }) = return
 	(UnusableServer "Please enter a host name.", False)
-testServer sshserver = do
+testServer sshserver@(SshServer { hostname = Just hn }) = do
 	status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
 	if usable status
 		then return (status, False)
@@ -141,7 +135,7 @@ testServer sshserver = do
 				, checkcommand "git-annex-shell"
 				, checkcommand "rsync"
 				]
-			knownhost <- knownHost sshserver
+			knownhost <- knownHost hn
 			let sshopts = filter (not . null) $ extraopts ++
 				{- If this is an already known host, let
 				 - ssh check it as usual.
@@ -165,10 +159,6 @@ testServer sshserver = do
 		token r = "git-annex-probe " ++ r
 		report r = "echo " ++ token r
 
-{- user@host or host -}
-genSshHost :: Text -> Maybe Text -> String
-genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
-
 {- Runs a ssh command; if it fails shows the user the transcript,
  - and if it succeeds, runs an action. -}
 sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml
@@ -182,16 +172,6 @@ showSshErr :: String -> Handler RepHtml
 showSshErr msg = sshConfigurator $
 	$(widgetFile "configurators/ssh/error")
 
-{- Does ssh have known_hosts data for a hostname? -}
-knownHost :: SshServer -> IO Bool
-knownHost (SshServer { hostname = Nothing }) = return False
-knownHost (SshServer { hostname = Just h }) = do
-	sshdir <- sshDir
-	ifM (doesFileExist $ sshdir </> "known_hosts")
-		( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack h]
-		, return False
-		)
-
 getConfirmSshR :: SshData -> Handler RepHtml
 getConfirmSshR sshdata = sshConfigurator $ do
 	let authtoken = webAppFormAuthToken
@@ -208,11 +188,11 @@ makeSsh rsync sshdata
 	| needsPubKey sshdata = do
 		keypair <- liftIO $ genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-		makeSshWithKeyPair rsync sshdata' (Just keypair)
+		makeSsh' rsync sshdata' (Just keypair)
-	| otherwise = makeSshWithKeyPair rsync sshdata Nothing
+	| otherwise = makeSsh' rsync sshdata Nothing
 
-makeSshWithKeyPair :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
+makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
-makeSshWithKeyPair rsync sshdata keypair =
+makeSsh' rsync sshdata keypair =
 	sshSetup [sshhost, remoteCommand] "" $
 		makeSshRepo rsync sshdata
 	where
@@ -230,40 +210,13 @@ makeSshWithKeyPair rsync sshdata keypair =
 
 makeSshRepo :: Bool -> SshData -> Handler RepHtml
 makeSshRepo forcersync sshdata = do
-	r <- runAnnex undefined $
+	webapp <- getYesod
-		addRemote $ maker (sshRepoName sshdata) sshurl
+	liftIO $ makeSshRemote
-	syncRemote r
+		(fromJust $ threadState webapp)
+		(daemonStatus webapp)
+		(scanRemotes webapp)
+		forcersync sshdata
 	redirect RepositoriesR
-	where
-		rsync = forcersync || rsyncOnly sshdata
-		maker
-			| rsync = makeRsyncRemote
-			| otherwise = makeGitRemote
-		sshurl = T.unpack $ T.concat $
-			if rsync
-				then [u, h, ":", sshDirectory sshdata, "/"]
-				else ["ssh://", u, h, d, "/"]
-			where
-				u = maybe "" (\v -> T.concat [v, "@"]) $ sshUserName sshdata
-				h = sshHostName sshdata
-				d
-					| "/" `T.isPrefixOf` sshDirectory sshdata = d
-					| otherwise = T.concat ["/~/", sshDirectory sshdata]
-	
-
-{- Inits a rsync special remote, and returns the name of the remote. -}
-makeRsyncRemote :: String -> String -> Annex String
-makeRsyncRemote name location = makeRemote name location $ const $ do
-	(u, c) <- Command.InitRemote.findByName name
-	c' <- R.setup Rsync.remote u $ M.union config c
-	describeUUID u name
-	configSet u c'
-	where
-		config = M.fromList
-			[ ("encryption", "shared")
-			, ("rsyncurl", location)
-			, ("type", "rsync")
-			]
 
 getAddRsyncNetR :: Handler RepHtml
 getAddRsyncNetR = do
@@ -276,7 +229,7 @@ getAddRsyncNetR = do
 		$(widgetFile "configurators/addrsync.net")
 	case result of
 		FormSuccess sshserver -> do
-			knownhost <- liftIO $ knownHost sshserver
+			knownhost <- liftIO $ maybe (return False) knownHost (hostname sshserver)
 			keypair <- liftIO $ genSshKeyPair
 			sshdata <- liftIO $ setupSshKeyPair keypair
 				(mkSshData sshserver)