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.
This commit is contained in:
Joey Hess 2012-09-07 18:04:06 -04:00
parent a8e05c8da1
commit c28b54c469

158
Assistant/Pairing.hs Normal file
View file

@ -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"