1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
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"
|
