responding to pair requests *almost* works

Assistant/Alert.hs

@@ -286,9 +286,9 @@ sanityCheckFixAlert msg = Alert
 		alerthead = "The daily sanity check found and fixed a problem:"
 		alertfoot = "If these problems persist, consider filing a bug report."
 
-pairRequestAlert :: AlertButton -> Alert
-pairRequestAlert button = baseActivityAlert
-	{ alertData = [ UnTensed "Pairing request in progress" ]
+pairingAlert :: AlertButton -> Alert
+pairingAlert button = baseActivityAlert
+	{ alertData = [ UnTensed "Pairing in progress" ]
 	, alertPriority = High
 	, alertButton = Just button
 	}

Assistant/Pairing.hs

@@ -34,6 +34,9 @@ fromPairMsg (PairMsg m) = m
 pairMsgStage :: PairMsg -> PairStage
 pairMsgStage (PairMsg (Verifiable (s, _) _)) = s
 
+pairMsgData :: PairMsg -> PairData
+pairMsgData (PairMsg (Verifiable (_, d) _)) = d
+
 data PairData = PairData
 	-- uname -n output, not a full domain name
 	{ remoteHostName :: Maybe HostName
@@ -45,11 +48,11 @@ data PairData = PairData
 	}
 	deriving (Eq, Read, Show)
 
-type SshPubKey = String
 type UserName = String
 
-{- A pairing that is in progress has a secret, and a thread that is
- - broadcasting pairing requests. -}
+{- A pairing that is in progress has a secret, a thread that is
+ - broadcasting pairing messages, and a SshKeyPair that has not yet been
+ - set up on disk. -}
 data PairingInProgress = PairingInProgress
 	{ inProgressSecret :: Secret
 	, inProgressThreadId :: ThreadId

Assistant/Pairing/Network.hs

@@ -30,7 +30,7 @@ multicastAddress :: SomeAddr -> HostName
 multicastAddress (IPv4Addr _) = "224.0.0.1"
 multicastAddress (IPv6Addr _) = "ff02::1"
 
-{- Multicasts a message repeatedly on all interfaces forever,
+{- Multicasts a message repeatedly on all interfaces forever, until killed
  - with a 2 second delay between each transmission.
  -
  - The remoteHostAddress is set to the interface's IP address.

Assistant/Ssh.hs

@@ -15,6 +15,7 @@ import qualified Data.Text as T
 import qualified Control.Exception as E
 import System.Process (CreateProcess(..))
 import Control.Concurrent
+import Data.Char
 
 data SshData = SshData
 	{ sshHostName :: Text
@@ -31,6 +32,8 @@ data SshKeyPair = SshKeyPair
 	, sshPrivKey :: String
 	}
 
+type SshPubKey = String
+
 {- ssh -ofoo=bar command-line option -}
 sshOpt :: String -> String -> String
 sshOpt k v = concat ["-o", k, "=", v]
@@ -40,6 +43,15 @@ sshDir = do
 	home <- myHomeDir
 	return $ home </> ".ssh"
 
+{- host_dir, with all / in dir replaced by _, and bad characters removed -}
+genSshRepoName :: String -> FilePath -> String
+genSshRepoName host dir
+	| null dir = filter legal host
+	| otherwise = filter legal $ host ++ "_" ++ replace "/" "_" dir
+	where
+		legal '_' = True
+		legal c = isAlphaNum c
+
 {- The output of ssh, including both stdout and stderr. -}
 sshTranscript :: [String] -> String -> IO (String, Bool)
 sshTranscript opts input = do
@@ -71,27 +83,30 @@ sshTranscript opts input = do
 	return ()
 	return (transcript, ok)
 
+
+makeAuthorizedKeys :: Bool -> SshPubKey -> IO Bool
+makeAuthorizedKeys rsynconly pubkey = boolSystem "sh"
+	[ Param "-c" , Param $ makeAuthorizedKeysCommand rsynconly pubkey ]
+
 {- Implemented as a shell command, so it can be run on remote servers over
  - ssh. -}
-makeAuthorizedKeys :: SshData -> SshKeyPair -> Maybe String
-makeAuthorizedKeys sshdata keypair
-	| needsPubKey sshdata = Just $ join "&&" $
-		[ "mkdir -p ~/.ssh"
-		, "touch ~/.ssh/authorized_keys"
-		, "chmod 600 ~/.ssh/authorized_keys"
-		, unwords
-			[ "echo"
-			, shellEscape $ authorizedKeysLine sshdata keypair
-			, ">>~/.ssh/authorized_keys"
-			]
+makeAuthorizedKeysCommand :: Bool -> SshPubKey -> String
+makeAuthorizedKeysCommand rsynconly pubkey = join "&&" $
+	[ "mkdir -p ~/.ssh"
+	, "touch ~/.ssh/authorized_keys"
+	, "chmod 600 ~/.ssh/authorized_keys"
+	, unwords
+		[ "echo"
+		, shellEscape $ authorizedKeysLine rsynconly pubkey
+		, ">>~/.ssh/authorized_keys"
 		]
-	| otherwise = Nothing
-		
-authorizedKeysLine :: SshData -> SshKeyPair -> String
-authorizedKeysLine sshdata (SshKeyPair { sshPubKey = pubkey })
+	]
+
+authorizedKeysLine :: Bool -> SshPubKey -> String
+authorizedKeysLine rsynconly pubkey
 	{- TODO: Locking down rsync is difficult, requiring a rather
 	 - long perl script. -}
-	| rsyncOnly sshdata = pubkey
+	| rsynconly = pubkey
 	| otherwise = limitcommand "git-annex-shell -c" ++ pubkey
 	where
 		limitcommand c = "command=\"perl -e 'exec qw(" ++ c ++ "), $ENV{SSH_ORIGINAL_COMMAND}'\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "

Assistant/Threads/PairListener.hs

@@ -46,15 +46,20 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
 				chunksz = 1024
 
 		dispatch Nothing = noop
-		dispatch (Just m) = case pairMsgStage m of
-			PairReq -> pairReqAlert dstatus urlrenderer m
-			PairAck -> pairAckAlert dstatus m
-			PairDone -> pairDoneAlert dstatus m
+		dispatch (Just m@(PairMsg v)) = do
+			verified <- maybe False (verify v . inProgressSecret)
+				. pairingInProgress
+				<$> getDaemonStatus dstatus
+			case pairMsgStage m of
+				PairReq -> pairReqReceived verified dstatus urlrenderer m
+				PairAck -> pairAckReceived verified dstatus m
+				PairDone -> pairDoneReceived verified dstatus m
 
 {- Pair request alerts from the same host combine,
  - so repeated requests do not add additional alerts. -}
-pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
-pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do
+pairReqReceived :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
+pairReqReceived True _ _ _ = noop -- ignore out own PairReq
+pairReqReceived False dstatus urlrenderer msg = do
 	url <- renderUrl urlrenderer (FinishPairR msg) []
 	void $ addAlert dstatus $ pairRequestReceivedAlert repo
 		(repo ++ " is sending a pair request.") $
@@ -74,11 +79,6 @@ pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do
 			, ":"
 			, (remoteDirectory pairdata)
 			]
-		{- Filter out our own pair request, by checking if we
-		 - can verify using its secret. -}
-		myreq = maybe False (verified v . inProgressSecret)
-			. pairingInProgress
-				<$> getDaemonStatus dstatus
 		{- Remove the button when it's clicked, and change the
 		 - alert to be in progress. This alert cannot be entirely
 		 - removed since more pair request messages are coming in
@@ -91,15 +91,16 @@ pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do
 			}
 
 {- When a valid PairAck is seen, a host has successfully paired with
- - us, and we should finish pairing with them. Then send a PairDone.
+ - us, and we should finish pairing with them. Then send a single PairDone.
  -
  - 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.
  -}
-pairAckAlert :: DaemonStatusHandle -> PairMsg -> IO ()
-pairAckAlert dstatus msg = error "TODO"
+pairAckReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO ()
+pairAckReceived False _ _ = noop -- not verified
+pairAckReceived True dstatus msg = error "TODO"
 
 {- If we get a valid PairDone, and are sending PairAcks, we can stop
  - sending them, as the message has been received.
@@ -110,5 +111,6 @@ pairAckAlert dstatus msg = error "TODO"
  - Note: This does allow a bad actor to squelch pairing on a network
  - by sending bogus PairDones.
  -}
-pairDoneAlert :: DaemonStatusHandle -> PairMsg -> IO ()
-pairDoneAlert dstatus msg = error "TODO"
+pairDoneReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO ()
+pairDoneReceived False _ _ = noop -- not verified
+pairDoneReceived True dstatus msg = error "TODO"

Assistant/WebApp/Configurators/Pairing.hs

@@ -11,12 +11,14 @@
  -   which prompts them for the same secret.
  - * The secret is used to verify the PairReq. If it checks out,
  -   a PairAck is sent, and the other device adds the ssh key from the
- -   PairReq. An Alert is displayed noting that the pairing has been set up.
+ -   PairReq to its authorized_keys, and sets up the remote.
  - * The PairAck is received back at the device that started the process.
  -   It's verified using the stored secret. The ssh key from the PairAck
  -   is added. An Alert is displayed noting that the pairing has been set
  -   up. The pairing secret is removed to prevent anyone cracking the
- -   crypto.
+ -   crypto. Syncing starts. A PairDone is sent.
+ - * The PairDone is received, and an alert shown indicating pairing is
+ -   done.
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
@@ -34,9 +36,10 @@ import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
 #ifdef WITH_PAIRING
+import Assistant.Common
 import Assistant.Pairing.Network
 import Assistant.Ssh
-import Assistant.Common
+import qualified Assistant.WebApp.Configurators.Ssh as Ssh
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.Verifiable
@@ -57,74 +60,110 @@ import Control.Concurrent
 
 getStartPairR :: Handler RepHtml
 #ifdef WITH_PAIRING
-getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
-	dstatus <- daemonStatus <$> lift getYesod
-	urlrender <- lift getUrlRender
-	let homeurl = urlrender HomeR
-	hostname <- liftIO getHostname
-	username <- liftIO getUserName
-	reldir <- fromJust . relDir <$> lift getYesod
+getStartPairR = do
 	keypair <- liftIO genSshKeyPair
-	let pubkey = sshPubKey keypair ++ "foo"
-	let mkmsg addr = PairMsg $ mkVerifiable
-		(PairReq, PairData hostname addr username reldir pubkey) secret
-	liftIO $ do
-		pip <- PairingInProgress secret
-			<$> sendrequests mkmsg dstatus homeurl
-			<*> pure keypair
-		oldpip <- modifyDaemonStatus dstatus $
-			\s -> (s { pairingInProgress = Just pip }, pairingInProgress s)
-		maybe noop stopold oldpip
-	lift $ redirect $ InprogressPairR rawsecret
-	where
-		{- Sends pairing messages until the thread is killed,
-		 - and shows an activity alert while doing it.
-		 -
-		 - The button returns the user to the HomeR. This is
-		 - not ideal, but they have to be sent somewhere, and could
-		 - have been on a page specific to the in-process pairing
-		 - that just stopped.
-		 -}
-		sendrequests mkmsg dstatus homeurl = forkIO $ do
-			tid <- myThreadId
-			let selfdestruct = AlertButton
-				{ buttonLabel = "Cancel"
-				, buttonUrl = homeurl
-				, buttonAction = Just $ const $ killThread tid
-				}
-			alertDuring dstatus (pairRequestAlert selfdestruct) $ do
-				_ <- E.try (multicastPairMsg mkmsg) :: IO (Either E.SomeException ())
-				return ()
-		stopold = killThread  . inProgressThreadId
+	promptSecret Nothing $ startPairing PairReq keypair noop
 #else
 getStartPairR = noPairing
 #endif
 
-getInprogressPairR :: Text -> Handler RepHtml
-#ifdef WITH_PAIRING
-getInprogressPairR secret = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Pairing"
-	$(widgetFile "configurators/pairing/inprogress")
-#else
-getInprogressPairR _ = noPairing
-#endif
-
 getFinishPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
 getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
-	error "TODO"
+	keypair <- setup
+	startPairing PairAck keypair cleanup "" secret
+	where
+		pubkey = remoteSshPubKey $ pairMsgData msg
+		setup  = do
+			unlessM (liftIO $ makeAuthorizedKeys False pubkey) $
+				error "failed setting up ssh authorized keys"
+			keypair <- liftIO genSshKeyPair
+			let d = pairMsgData msg
+			besthostname <- liftIO $ bestHostName d
+			let sshdata = SshData
+				{ sshHostName = T.pack besthostname
+				, sshUserName = Just (T.pack $ remoteUserName d)
+				, sshDirectory = T.pack (remoteDirectory d)
+				, sshRepoName = genSshRepoName besthostname (remoteDirectory d)
+				, needsPubKey = True
+				, rsyncOnly = False
+				}
+			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
 
+getInprogressPairR :: Text -> Handler RepHtml
 #ifdef WITH_PAIRING
+getInprogressPairR secret = pairPage $ do
+	$(widgetFile "configurators/pairing/inprogress")
+#else
+getInprogressPairR _ = noPairing
+#endif
+
+#ifdef WITH_PAIRING
+
+{- Starts pairing, at either the PairReq (initiating host) or 
+ - PairAck (responding host) stage.
+ -
+ - Displays an alert, and starts a thread sending the pairing message,
+ - which will continue running until the other host responds, or until
+ - canceled by the user. If canceled by the user, runs the oncancel action.
+ -
+ - Redirects to the pairing in progress page.
+ -}
+startPairing :: PairStage -> SshKeyPair -> IO () -> Text -> Secret -> Widget
+startPairing stage keypair oncancel displaysecret secret = do
+	dstatus <- daemonStatus <$> lift getYesod
+	urlrender <- lift getUrlRender
+	let homeurl = urlrender HomeR
+	sender <- mksender
+	liftIO $ do
+		pip <- PairingInProgress secret
+			<$> sendrequests sender dstatus homeurl
+			<*> pure keypair
+		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.
+		 -
+		 - The cancel button returns the user to the HomeR. This is
+		 - not ideal, but they have to be sent somewhere, and could
+		 - 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
+			tid <- myThreadId
+			let selfdestruct = AlertButton
+				{ buttonLabel = "Cancel"
+				, buttonUrl = homeurl
+				, buttonAction = Just $ const $ do
+					oncancel
+					killThread tid
+				}
+			alertDuring dstatus (pairingAlert selfdestruct) $ do
+				_ <- E.try sender :: IO (Either E.SomeException ())
+				return ()
+		stopold = killThread  . inProgressThreadId
+
 data InputSecret = InputSecret { secretText :: Maybe Text }
 
+{- If a PairMsg is passed in, ensures that the user enters a secret
+ - that can validate it. -}
 promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml
-promptSecret msg cont = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Pairing"
+promptSecret msg cont = pairPage $ do
 	((result, form), enctype) <- lift $
 		runFormGet $ renderBootstrap $
 			InputSecret <$> aopt textField "Secret phrase" Nothing
@@ -138,7 +177,7 @@ promptSecret msg cont = bootstrap (Just Config) $ do
 					Just problem ->
 						showform form enctype $ Just problem
 				Just m ->
-					if verified (fromPairMsg m) secret
+					if verify (fromPairMsg m) secret
 						then cont rawsecret secret
 						else showform form enctype $ Just
 							"That's not the right secret phrase."
@@ -168,6 +207,15 @@ secretProblem s
 toSecret :: Text -> Secret
 toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s]
 
+getUserName :: IO String
+getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)
+
+pairPage :: Widget -> Handler RepHtml
+pairPage w = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Pairing"
+	w
+
 {- From Dickens -}
 sampleQuote :: Text
 sampleQuote = T.unwords
@@ -177,15 +225,10 @@ sampleQuote = T.unwords
 	, "it was the age of foolishness."
 	]
 
-getUserName :: IO String
-getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)
-
 #else
 
 noPairing :: Handler RepHtml
-noPairing = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Pairing"
+noPairing = pairPage $
 	$(widgetFile "configurators/pairing/disabled")
 
 #endif

Assistant/WebApp/Configurators/Ssh.hs

@@ -49,7 +49,9 @@ mkSshData sshserver = SshData
 	{ sshHostName = fromMaybe "" $ hostname sshserver
 	, sshUserName = username sshserver
 	, sshDirectory = fromMaybe "" $ directory sshserver
-	, sshRepoName = genSshRepoName sshserver
+	, sshRepoName = genSshRepoName
+		(T.unpack $ fromJust $ hostname sshserver)
+		(maybe "" T.unpack $ directory sshserver)
 	, needsPubKey = False
 	, rsyncOnly = False
 	}
@@ -167,11 +169,6 @@ testServer sshserver = do
 genSshHost :: Text -> Maybe Text -> String
 genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
 
-{- host_dir -}
-genSshRepoName :: SshServer -> String
-genSshRepoName s = (T.unpack $ fromJust $ hostname s) ++
-	(maybe "" (\d -> '_' : T.unpack d) (directory s))
-
 {- 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
@@ -211,11 +208,11 @@ makeSsh rsync sshdata
 	| needsPubKey sshdata = do
 		keypair <- liftIO $ genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-		makeSsh' rsync sshdata' (Just keypair)
-	| otherwise = makeSsh' rsync sshdata Nothing
+		makeSshWithKeyPair rsync sshdata' (Just keypair)
+	| otherwise = makeSshWithKeyPair rsync sshdata Nothing
 
-makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
-makeSsh' rsync sshdata keypair =
+makeSshWithKeyPair :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
+makeSshWithKeyPair rsync sshdata keypair =
 	sshSetup [sshhost, remoteCommand] "" $
 		makeSshRepo rsync sshdata
 	where
@@ -226,7 +223,9 @@ makeSsh' rsync sshdata keypair =
 			, Just $ "cd " ++ shellEscape remotedir
 			, if rsync then Nothing else Just $ "git init --bare --shared"
 			, if rsync then Nothing else Just $ "git annex init"
-			, maybe Nothing (makeAuthorizedKeys sshdata) keypair
+			, if needsPubKey sshdata
+				then maybe Nothing (Just . makeAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey) keypair
+				else Nothing
 			]
 
 makeSshRepo :: Bool -> SshData -> Handler RepHtml

Utility/Verifiable.hs

@@ -24,14 +24,14 @@ data Verifiable a = Verifiable
 mkVerifiable :: Show a => a -> Secret -> Verifiable a
 mkVerifiable a secret = Verifiable a (calcDigest (show a) secret)
 
-verified :: (Eq a, Show a) => Verifiable a -> Secret -> Bool
-verified v secret = v == mkVerifiable (verifiableVal v) secret
+verify :: (Eq a, Show a) => Verifiable a -> Secret -> Bool
+verify v secret = v == mkVerifiable (verifiableVal v) secret
 
 calcDigest :: String -> Secret -> HMACDigest
 calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v
 
 {- for quickcheck -}
 prop_verifiable_sane :: String -> String -> Bool
-prop_verifiable_sane a s = verified (mkVerifiable a secret) secret
+prop_verifiable_sane a s = verify (mkVerifiable a secret) secret
 	where
 		secret = fromString s

templates/configurators/pairing/inprogress.hamlet

@@ -1,10 +1,15 @@
 <div .span9 .hero-unit>
   <h2>
     Pairing in progress ..
-  <p>
-    Now you should either go tell the owner of the computer you want to pair #
-    with the secret phrase you selected ("#{secret}"), or go enter it into #
-    the computer you want to pair with.
-  <p>
-    You do not need to leave this page open; pairing will finish automatically #
-    as soon as the secret phrase is entered into the other computer.
+  $if T.null secret
+    <p>
+      You do not need to leave this page open; pairing will finish #
+      automatically.
+  $else
+    <p>
+      Now you should either go tell the owner of the computer you want to pair #
+      with the secret phrase you selected ("#{secret}"), or go enter it into #
+      the computer you want to pair with.
+    <p>
+      You do not need to leave this page open; pairing will finish automatically #
+      as soon as the secret phrase is entered into the other computer.