high-level pairing implementation

Roughed out a data type that models the whole pairing conversation,
and can be serialized to implement it. And a state machine to run
that conversation. Not yet hooked up to any transport such as multicast
UDP.

1 files changed, 158 insertions, 0 deletions

diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
new file mode 100644
index 000000000..b15917f42
--- /dev/null
+++ b/Assistant/Pairing.hs
@@ -0,0 +1,158 @@
+{- git-annex assistant repo pairing
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pairing where
+
+import Assistant.Common
+
+import Network.Socket (HostName)
+
+type SshPubKey = String
+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
+	}
+	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
+	}
+	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
+	, 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)
+
+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
+	}
+
+{- 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 = 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"