pairing probably works now (untested)

2 files changed, 112 insertions, 26 deletions

diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
new file mode 100644
index 000000000..9e65f4d13
--- /dev/null
+++ b/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
diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs
index 8832db05f..2afbf1f56 100644
--- a/Assistant/Pairing/Network.hs
+++ b/Assistant/Pairing/Network.hs
@@ -1,5 +1,9 @@
 {- 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>
  -
  - Licensed under the GNU GPL version 3 or higher.
@@ -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
- - with a 2 second delay between each transmission.
+{- Multicasts a message repeatedly on all interfaces, with a 2 second
+ - 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 mkmsg = go M.empty
+multicastPairMsg :: Maybe Int -> Secret -> PairStage -> PairData -> IO ()
+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.
- -
- - 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 :: PairData -> IO HostName
-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
+startSending :: DaemonStatusHandle -> PairingInProgress -> IO () -> IO ()
+startSending dstatus pip sender = do
+	tid <- forkIO sender
+	let pip' = pip { inProgressThreadId = Just tid }
+	oldpip <- modifyDaemonStatus dstatus $
+		\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
+	maybe noop stopold oldpip
 	where
-		fallback = do
-			let sockaddr = case remoteAddress d of
-				IPv4Addr a -> SockAddrInet (PortNum 0) a
-				IPv6Addr a -> SockAddrInet6 (PortNum 0) 0 a 0
-			fromMaybe (show $ remoteAddress d) 
-				<$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
+		stopold = maybe noop killThread . inProgressThreadId
+
+stopSending :: DaemonStatusHandle ->  PairingInProgress -> IO ()
+stopSending dstatus pip = do
+	maybe noop killThread $ inProgressThreadId pip
+	modifyDaemonStatus_ dstatus $ \s -> s { pairingInProgress = Nothing }
 
 class ToSomeAddr a where
 	toSomeAddr :: a -> SomeAddr