clean up authorized_keys handling

Including rollback of adding the key when a pairing response
gets canceled by the user.

2 files changed, 13 insertions, 32 deletions

diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 4ff81c750..dab5bf4f8 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -1,25 +1,5 @@
 {- git-annex assistant webapp configurator for pairing
  -
- - Pairing works like this:
- -
- - * The user opens StartPairR, which prompts them for a secret.
- - * The user submits it. The pairing secret is stored for later.
- -   A PairReq is broadcast out.
- - * On another device, it's received, and that causes its webapp to 
- -   display an Alert.
- - * The user there clicks the button, which opens FinishPairR,
- -   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 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. 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>
  -
  - Licensed under the GNU GPL version 3 or higher.
@@ -38,6 +18,7 @@ import Utility.Yesod
 #ifdef WITH_PAIRING
 import Assistant.Common
 import Assistant.Pairing.Network
+import Assistant.Pairing.MakeRemote
 import Assistant.Ssh
 import Assistant.Alert
 import Assistant.DaemonStatus
@@ -57,6 +38,7 @@ import qualified Control.Exception as E
 import Control.Concurrent
 #endif
 
+{- Starts sending out pair requests. -}
 getStartPairR :: Handler RepHtml
 #ifdef WITH_PAIRING
 getStartPairR = promptSecret Nothing $ startPairing PairReq noop
@@ -64,18 +46,18 @@ getStartPairR = promptSecret Nothing $ startPairing PairReq noop
 getStartPairR = noPairing
 #endif
 
+{- Runs on the system that responds to a pair request; sets up the ssh
+ - authorized key first so that the originating host can immediately sync
+ - with us. -}
 getFinishPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
 getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
-	setup
+	liftIO $ setup
 	startPairing PairAck cleanup "" secret
 	where
-		pubkey = remoteSshPubKey $ pairMsgData msg
-		setup  = do
-			liftIO $ validateSshPubKey pubkey
-			unlessM (liftIO $ makeAuthorizedKeys False pubkey) $
-				error "failed setting up ssh authorized keys"
-		cleanup = error "TODO clean up authorized keys and generated ssh key and remove git remote"
+		setup  = setupAuthorizedKeys msg
+		cleanup = removeAuthorizedKeys False $
+			remoteSshPubKey $ pairMsgData msg
 #else
 getFinishPairR _ = noPairing
 #endif
@@ -104,7 +86,6 @@ startPairing stage oncancel displaysecret secret = do
 	keypair <- liftIO $ genSshKeyPair
 	dstatus <- daemonStatus <$> lift getYesod
 	urlrender <- lift getUrlRender
-	let homeurl = urlrender HomeR
 	pairdata <- PairData
 		<$> liftIO getHostname
 		<*> liftIO getUserName
@@ -113,7 +94,7 @@ startPairing stage oncancel displaysecret secret = do
 	liftIO $ do
 		let sender = multicastPairMsg Nothing secret stage pairdata
 		let pip = PairingInProgress secret Nothing keypair pairdata
-		startSending dstatus pip $ sendrequests sender dstatus homeurl
+		startSending dstatus pip $ sendrequests sender dstatus urlrender
 	lift $ redirect $ InprogressPairR displaysecret
 	where
 		{- Sends pairing messages until the thread is killed,
@@ -124,11 +105,11 @@ startPairing stage 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 = do
+		sendrequests sender dstatus urlrender = do
 			tid <- myThreadId
 			let selfdestruct = AlertButton
 				{ buttonLabel = "Cancel"
-				, buttonUrl = homeurl
+				, buttonUrl = urlrender HomeR
 				, buttonAction = Just $ const $ do
 					oncancel
 					killThread tid
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index f2e80ff5b..e39291459 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -204,7 +204,7 @@ makeSsh' rsync sshdata keypair =
 			, if rsync then Nothing else Just $ "git init --bare --shared"
 			, if rsync then Nothing else Just $ "git annex init"
 			, if needsPubKey sshdata
-				then maybe Nothing (Just . makeAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey) keypair
+				then maybe Nothing (Just . addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey) keypair
 				else Nothing
 			]