clean up authorized_keys handling

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

5 files changed, 40 insertions, 39 deletions

diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index 9e65f4d13..1b39fcff7 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -19,6 +19,16 @@ import Assistant.MakeRemote
 import Network.Socket
 import qualified Data.Text as T
 
+{- Authorized keys are set up before pairing is complete, so that the other
+ - side can immediately begin syncing. -}
+setupAuthorizedKeys :: PairMsg -> IO ()
+setupAuthorizedKeys msg = do
+	validateSshPubKey pubkey
+	unlessM (liftIO $ addAuthorizedKeys False pubkey) $
+		error "failed setting up ssh authorized keys"
+	where
+		pubkey = remoteSshPubKey $ pairMsgData msg
+
 {- 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 ()
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index ad0749fb7..eefc2a2e2 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -101,14 +101,23 @@ validateSshPubKey pubkey = do
 		unless (all (\c -> isAlphaNum c || c == '@') (ws !! 2)) $
 			error $ "bad comment in ssh public key " ++ pubkey
 
-makeAuthorizedKeys :: Bool -> SshPubKey -> IO Bool
-makeAuthorizedKeys rsynconly pubkey = boolSystem "sh"
-	[ Param "-c" , Param $ makeAuthorizedKeysCommand rsynconly pubkey ]
+addAuthorizedKeys :: Bool -> SshPubKey -> IO Bool
+addAuthorizedKeys rsynconly pubkey = boolSystem "sh"
+	[ Param "-c" , Param $ addAuthorizedKeysCommand rsynconly pubkey ]
+
+removeAuthorizedKeys :: Bool -> SshPubKey -> IO ()
+removeAuthorizedKeys rsynconly pubkey = do
+	let keyline = authorizedKeysLine rsynconly pubkey
+	sshdir <- sshDir
+	let keyfile = sshdir </> ".authorized_keys"
+	ls <- lines <$> readFileStrict keyfile
+	writeFile keyfile $ unlines $
+		filter (\l -> not $ l == keyline) ls
 
 {- Implemented as a shell command, so it can be run on remote servers over
  - ssh. -}
-makeAuthorizedKeysCommand :: Bool -> SshPubKey -> String
-makeAuthorizedKeysCommand rsynconly pubkey = join "&&" $
+addAuthorizedKeysCommand :: Bool -> SshPubKey -> String
+addAuthorizedKeysCommand rsynconly pubkey = join "&&" $
 	[ "mkdir -p ~/.ssh"
 	, "touch ~/.ssh/authorized_keys"
 	, "chmod 600 ~/.ssh/authorized_keys"
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index e0ed1217a..5cf20fa70 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -94,7 +94,7 @@ pairReqReceived False dstatus urlrenderer msg = do
 
 {- When a verified PairAck is seen, a host is ready to pair with us, and has
  - already configured our ssh key. Stop sending PairReqs, finish the pairing,
- - and send a few PairDones.
+ - and send a single PairDone.
  -
  - TODO: A stale PairAck might also be seen, after we've finished pairing.
  - Perhaps our PairDone was not received. To handle this, we keep
@@ -106,9 +106,10 @@ pairAckReceived False _ _ _ _ _ = noop -- not verified
 pairAckReceived True Nothing _ _ _ _ = noop -- not in progress
 pairAckReceived True (Just pip) st dstatus scanremotes msg = do
 	stopSending dstatus pip
+	setupAuthorizedKeys msg
 	finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
 	startSending dstatus pip $ multicastPairMsg
-		(Just 10) (inProgressSecret pip) PairDone (inProgressPairData pip)
+		(Just 1) (inProgressSecret pip) PairDone (inProgressPairData pip)
 
 {- If we get a verified PairDone, the host has accepted our PairAck, and
  - has paired with us. Stop sending PairAcks, and finish pairing with them.
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
 			]