massively simplified the pairing protocol
Only 2 messages are needed to do pairing. And added a nice Verifiable data type.
This commit is contained in:
Joey Hess
parent
24bfabe263
commit
c12caf0a4e
1 changed files with 26 additions and 128 deletions
|
|
@ -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)
|
||||
verified :: (Eq a, Show a) => Verifiable a -> Secret -> Bool
|
||||
verified v secret = v == mkVerifiable (val v) secret
|
||||
|
||||
{- 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 :: 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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue