aboutsummaryrefslogtreecommitdiff
path: root/Assistant/Pairing.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-07 22:48:46 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-07 22:58:14 -0400
commitc12caf0a4e665d121c7ffd5a992306f7511bc305 (patch)
tree7c7a1a74651e495c76a764cbd440fbd4dceb8c18 /Assistant/Pairing.hs
parent24bfabe263204192acea3a1e9bb991111a8154a4 (diff)
massively simplified the pairing protocol
Only 2 messages are needed to do pairing. And added a nice Verifiable data type.
Diffstat (limited to 'Assistant/Pairing.hs')
-rw-r--r--Assistant/Pairing.hs154
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"