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:
parent
a8e05c8da1
commit
c28b54c469
1 changed files with 158 additions and 0 deletions
158
Assistant/Pairing.hs
Normal file
158
Assistant/Pairing.hs
Normal 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"
|
Loading…
Reference in a new issue