massively simplified the pairing protocol

Only 2 messages are needed to do pairing.

And added a nice Verifiable data type.

1 files changed, 26 insertions, 128 deletions

diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index b15917f42..b4861b20d 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -16,143 +16,41 @@ type HMACDigest = String
 type UserName = String
 type Secret = String
 
-{- "I'd like to pair with somebody. My name is requestingHost
- - and my user is requestingUser" -}
-data RequestPair = RequestPair
-	{ requestingHost :: HostName
-	, requestingUser :: UserName
+data HostInfo = HostInfo
+	{ hostName :: HostName
+	, userName :: UserName
 	}
 	deriving (Eq, Read, Show)
 
-{- "I'll pair with you! My name is respondingHost
- - and my user is respondingUser" -}
-data StartPair = StartPair
-	{ respondingHost :: HostName
-	, respondingUser :: UserName
- 	, requestPair :: RequestPair
-	}
+data PairStage
+	{- "I'd like to pair with somebody who knows a secret.
+	 - Here's my ssh key, and hostinfo, both verifiable with
+	 - our shared secret." -}
+	= PairRequest
+	{- "I've checked your PairRequest, and like it; I set up
+	 - your ssh key already. Here's mine, also verified, please set it
+	 - up too, and start syncing!" -}
+	| PairAck
 	deriving (Eq, Read, Show)
 
-{- Sent to authenticate a pair request.
- - The digest is of startPair + sshPubKey, using a shared secret. -}
-data AuthPair = AuthPair
-	{ sshPubKey :: SshPubKey
+type PairMsg = Verifiable (PairStage, HostInfo, SshPubKey)
+
+mkPairMsg :: Secret -> PairStage -> HostInfo -> SshPubKey -> PairMsg
+mkPairMsg secret pairstage hostinfo sshkey = mkVerifiable
+	(pairstage, hostinfo, sshkey) secret
+
+{- A value, verifiable using a HMAC digest to encrypt using a shared secret. -}
+data Verifiable a = Verifiable
+	{ val :: a
 	, digest :: HMACDigest
-	, startPair :: StartPair
 	}
 	deriving (Eq, Read, Show)
 
-{- Acknowledges authentication of a pair request, and indicates that one side
- - of the pairing is done. -}
-data AckPair = AckPair { ackAuthPair :: AuthPair }
-	deriving (Eq, Read, Show)
--- ... Or authentication failed.
-data NackPair = NackPair { nackAuthPair :: AuthPair }
-	deriving (Eq, Read, Show)
+mkVerifiable :: Show a => a -> Secret -> Verifiable a
+mkVerifiable a secret = Verifiable a (calcDigest (show a) secret)
 
-data PairMsg
-	= RequestPairM RequestPair
-	| StartPairM StartPair
-	| AuthPairM AuthPair
-	| AckPairM AckPair
-	| NackPairM NackPair
-	deriving (Eq, Read, Show)
-
-{- All the information needed to hold a conversation. -}
-data PairInfo = PairInfo
-	{ myHostName :: HostName
-	, myUserName :: UserName
-	, mySshPubKey :: SshPubKey
-	, mySecret :: Secret
-	}
+verified :: (Eq a, Show a) => Verifiable a -> Secret -> Bool
+verified v secret = v == mkVerifiable (val v) secret
 
-{- Given a message from the other side, returns any response. -}
-response :: PairInfo -> PairMsg -> Maybe PairMsg
-response i (RequestPairM v) = Just $ StartPairM $ StartPair
-	{ respondingHost = myHostName i
-	, respondingUser = myUserName i
-	, requestPair = v
-	}
-response i (StartPairM v) = Just $ AuthPairM $ AuthPair
-	{ sshPubKey = mySshPubKey i
-	, digest = calcDigest v i
-	, startPair = v
-	}
-response i (AuthPairM v)
-	| goodAuth v (mySecret i) = Just $ AckPairM $ AckPair { ackAuthPair = v }
-	| otherwise = Just $ NackPairM $ NackPair { nackAuthPair = v }
-response i (AckPairM v) = Nothing
-response i (NackPairM v) = Nothing
-
-calcDigest :: StartPair -> PairInfo -> HMACDigest
+calcDigest :: String -> Secret -> HMACDigest
 calcDigest = undefined -- TODO
-
-goodAuth :: AuthPair -> Secret -> Bool
-goodAuth = undefined
-
-{- State machine to handle pairing.
- - 
- - The send action is responsible for repeating the message as necessary
- - until its receipt is acked.
- - 
- - The receive action should block until a message is received, and ack
- - its receipt. It may time out, and return Nothing.
- -
- - Returns our AckPairM/NAckPairM, and the remote's AckPairM/NAckPairM
- -}
-runPair :: Monad m
-	=> PairInfo
-	-> (PairMsg -> m ())
-	-> (m (Maybe PairMsg))
-	-> m (Maybe PairMsg, Maybe PairMsg)
-runPair i send receive = do
-	send initialrequest
-	go Nothing Nothing
-	where
-		initialrequest = RequestPairM $ RequestPair
-			{ requestingHost = myHostName i
-			, requestingUser = myUserName i
-			}
-		go local_ack@(Just _) remote_ack@(Just _) =
-			return (local_ack, remote_ack)
-		go local_ack remote_ack = do
-			mr <- receive
-			case mr of
-				Nothing -> return (local_ack, remote_ack)
-				Just r -> case response i r of
-					Just resp@(AckPairM _) -> do
-						send resp
-						go (Just resp) remote_ack
-					Just resp@(NackPairM _) -> do
-						send resp
-						go (Just resp) remote_ack
-					Just resp -> do
-						send resp
-						go local_ack remote_ack
-					Nothing -> go local_ack (Just r)
-
-{- A sample conversation between two hosts, Left and Right.
- -
- - The order of some messages can vary, as there are really two independant
- - threads of conversation here, one started by leftreq and the other by
- - rightreq. -}
-sample :: [Either PairMsg PairMsg]
-sample =
-	[ Left $ RequestPairM $ leftreq
-	, Right $ RequestPairM $ rightreq
-	, Right $ StartPairM $ StartPair "foo" "bar" leftreq
-	, Left $ StartPairM $ StartPair "gnu" "joey" rightreq
-	, Left $ AuthPairM $ AuthPair "ssh-key-left" "digestleft" $
-		StartPair "foo" "bar" leftreq
-	, Right $ AuthPairM $ AuthPair "ssh-key-right" "digestright" $
-		StartPair "gnu" "joey" rightreq
-	, Right $ AckPairM $ AckPair $
-		AuthPair "ssh-key-left" "digestleft" $
- 	               StartPair "foo" "bar" leftreq
-	, Left $ AckPairM $ AckPair $
-		AuthPair "ssh-key-right" "digestright" $
-        	        StartPair "gnu" "joey" rightreq
-	]
-	where
-		leftreq = RequestPair "gnu" "joey"
-		rightreq = RequestPair "foo" "bar"