diff options
author | 2012-09-07 22:48:46 -0400 | |
---|---|---|
committer | 2012-09-07 22:58:14 -0400 | |
commit | c12caf0a4e665d121c7ffd5a992306f7511bc305 (patch) | |
tree | 7c7a1a74651e495c76a764cbd440fbd4dceb8c18 | |
parent | 24bfabe263204192acea3a1e9bb991111a8154a4 (diff) |
massively simplified the pairing protocol
Only 2 messages are needed to do pairing.
And added a nice Verifiable data type.
-rw-r--r-- | Assistant/Pairing.hs | 154 |
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" |