ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-MP/MP/Transport.pm
(Generate patch)

Comparing AnyEvent-MP/MP/Transport.pm (file contents):
Revision 1.5 by root, Sun Aug 2 14:44:37 2009 UTC vs.
Revision 1.7 by root, Mon Aug 3 14:47:25 2009 UTC

… …
9=head1 DESCRIPTION 9=head1 DESCRIPTION
10 10
11This is the superclass for MP transports, most of which is considered an 11This is the superclass for MP transports, most of which is considered an
12implementation detail. 12implementation detail.
13 13
14Future versions might document the actual protocol. 14See the "PROTOCOL" section below if you want to write another client for
15this protocol.
15 16
16=head1 FUNCTIONS/METHODS 17=head1 FUNCTIONS/METHODS
17 18
18=over 4 19=over 4
19 20
… …
29use JSON::XS (); 30use JSON::XS ();
30 31
31use AE (); 32use AE ();
32use AnyEvent::Socket (); 33use AnyEvent::Socket ();
33use AnyEvent::Handle (); 34use AnyEvent::Handle ();
34
35use AnyEvent::MP::Util ();
36 35
37use base Exporter::; 36use base Exporter::;
38 37
39our $VERSION = '0.0'; 38our $VERSION = '0.0';
40our $PROTOCOL_VERSION = 0; 39our $PROTOCOL_VERSION = 0;
… …
113 peername => $peername, # for verification 112 peername => $peername, # for verification
114 ; 113 ;
115 114
116=cut 115=cut
117 116
118our @FRAMING_WANT = qw(json storable);#d##TODO# 117our @FRAMINGS = qw(json storable); # the framing types we accept and send, in order of preference
118our @AUTH_SND = qw(hmac_md6_64_256); # auth types we send
119our @AUTH_RCV = (@AUTH_SND, qw(hex_secret)); # auth types we accept
120
121#AnyEvent::Handle::register_write_type mp_record => sub {
122#};
119 123
120sub new { 124sub new {
121 my ($class, %arg) = @_; 125 my ($class, %arg) = @_;
122 126
123 my $self = bless \%arg, $class; 127 my $self = bless \%arg, $class;
… …
149 my $secret = $arg{secret}; 153 my $secret = $arg{secret};
150 my $greeting_kv = $self->{greeting} ||= {}; 154 my $greeting_kv = $self->{greeting} ||= {};
151 $greeting_kv->{"tls1.0"} ||= $arg{tls} 155 $greeting_kv->{"tls1.0"} ||= $arg{tls}
152 if exists $arg{tls} && $arg{tls_ctx}; 156 if exists $arg{tls} && $arg{tls_ctx};
153 $greeting_kv->{provider} = "AE-$VERSION"; 157 $greeting_kv->{provider} = "AE-$VERSION";
158 $greeting_kv->{peeraddr} = AnyEvent::Socket::format_hostport $self->{peerhost}, $self->{peerport};
154 159
155 # send greeting 160 # send greeting
156 my $lgreeting = "aemp;$PROTOCOL_VERSION;$PROTOCOL_VERSION" # version, min 161 my $lgreeting1 = "aemp;$PROTOCOL_VERSION;$PROTOCOL_VERSION" # version, min
157 . ";$AnyEvent::MP::Base::UNIQ" 162 . ";$AnyEvent::MP::Base::UNIQ"
158 . ";$AnyEvent::MP::Base::NODE" 163 . ";$AnyEvent::MP::Base::NODE"
159 . ";" . (MIME::Base64::encode_base64 AnyEvent::MP::Base::nonce (33), "") 164 . ";" . (join ",", @AUTH_RCV)
160 . ";hmac_md6_64_256" # hardcoded atm. 165 . ";" . (join ",", @FRAMINGS)
161 . ";json" # hardcoded atm.
162 . ";$self->{peerhost};$self->{peerport}"
163 . (join "", map ";$_=$greeting_kv->{$_}", keys %$greeting_kv); 166 . (join "", map ";$_=$greeting_kv->{$_}", keys %$greeting_kv);
167 my $lgreeting2 = MIME::Base64::encode_base64 AnyEvent::MP::Base::nonce (33), "";
164 168
165 $self->{hdl}->push_write ("$lgreeting\012"); 169 $self->{hdl}->push_write ("$lgreeting1\012$lgreeting2\012");
166 170
167 # expect greeting 171 # expect greeting
168 $self->{hdl}->push_read (line => sub { 172 $self->{hdl}->push_read (line => sub {
169 my $rgreeting = $_[1]; 173 my $rgreeting1 = $_[1];
170 174
171 my ($aemp, $version, $version_min, $uniq, $rnode, undef, $auth, $framing, $peerport, $peerhost, @kv) = split /;/, $rgreeting; 175 my ($aemp, $version, $version_min, $uniq, $rnode, $auths, $framings, @kv) = split /;/, $rgreeting1;
172 176
173 if ($aemp ne "aemp") { 177 if ($aemp ne "aemp") {
174 return $self->error ("unparsable greeting"); 178 return $self->error ("unparsable greeting");
175 } elsif ($version_min > $PROTOCOL_VERSION) { 179 } elsif ($version_min > $PROTOCOL_VERSION) {
176 return $self->error ("version mismatch (we: $PROTOCOL_VERSION, they: $version_min .. $version)"); 180 return $self->error ("version mismatch (we: $PROTOCOL_VERSION, they: $version_min .. $version)");
177 } elsif ($auth ne "hmac_md6_64_256") {
178 return $self->error ("unsupported auth method ($auth)");
179 } elsif ($framing ne "json") {
180 return $self->error ("unsupported framing method ($auth)");
181 } 181 }
182
183 my $s_auth;
184 for my $auth_ (split /,/, $auths) {
185 if (grep $auth_ eq $_, @AUTH_SND) {
186 $s_auth = $auth_;
187 last;
188 }
189 }
190
191 defined $s_auth
192 or return $self->error ("$auths: no common auth type supported");
193
194 die unless $s_auth eq "hmac_md6_64_256"; # hardcoded atm.
195
196 my $s_framing;
197 for my $framing_ (split /,/, $framings) {
198 if (grep $framing_ eq $_, @FRAMINGS) {
199 $s_framing = $framing_;
200 last;
201 }
202 }
203
204 defined $s_framing
205 or return $self->error ("$framings: no common framing method supported");
182 206
183 $self->{remote_uniq} = $uniq; 207 $self->{remote_uniq} = $uniq;
184 $self->{remote_node} = $rnode; 208 $self->{remote_node} = $rnode;
185 209
186 $self->{remote_greeting} = { 210 $self->{remote_greeting} = {
… …
192 if ($self->{tls} ne $self->{remote_greeting}{"tls1.0"}) { 216 if ($self->{tls} ne $self->{remote_greeting}{"tls1.0"}) {
193 return $self->error ("TLS server/client mismatch"); 217 return $self->error ("TLS server/client mismatch");
194 } 218 }
195 $self->{hdl}->starttls ($self->{tls}, $self->{tls_ctx}); 219 $self->{hdl}->starttls ($self->{tls}, $self->{tls_ctx});
196 } 220 }
197
198 # auth 221
199 require Digest::MD6; 222 # read nonce
200 require Digest::HMAC_MD6;
201
202 my $key = Digest::MD6::md6_hex ($secret);
203 my $lauth = Digest::HMAC_MD6::hmac_md6_base64 ($key, "$lgreeting\012$rgreeting", 64, 256);
204 my $rauth = Digest::HMAC_MD6::hmac_md6_base64 ($key, "$rgreeting\012$lgreeting", 64, 256);
205
206 $lauth ne $rauth # echo attack?
207 or return $self->error ("authentication error");
208
209 $self->{hdl}->push_write ("$auth;$lauth;$framing\012");
210
211 $self->{hdl}->rbuf_max (64); # enough for 44 reply bytes or so
212 $self->{hdl}->push_read (line => sub { 223 $self->{hdl}->push_read (line => sub {
224 my $rgreeting2 = $_[1];
225
226 # auth
227 require Digest::MD6;
228 require Digest::HMAC_MD6;
229
230 my $key = Digest::MD6::md6_hex ($secret);
231 my $lauth = Digest::HMAC_MD6::hmac_md6_base64 ($key, "$lgreeting1\012$lgreeting2\012$rgreeting1\012$rgreeting2\012", 64, 256);
232
233 my $rauth =
234 $s_auth eq "hmac_md6_64_256" ? Digest::HMAC_MD6::hmac_md6_base64 ($key, "$rgreeting1\012$rgreeting2\012$lgreeting1\012$lgreeting2\012", 64, 256)
235 : $s_auth eq "hex_secret" ? unpack "H*", $secret
236 : die;
237
238 $lauth ne $rauth # echo attack?
239 or return $self->error ("authentication error");
240
241 $self->{hdl}->push_write ("$s_auth;$lauth;$s_framing\012");
242
243 $self->{hdl}->rbuf_max (64); # enough for 44 reply bytes or so
244 $self->{hdl}->push_read (line => sub {
213 my ($hdl, $rline) = @_; 245 my ($hdl, $rline) = @_;
214 246
215 my ($auth_method, $rauth2, $r_framing) = split /;/, $rline; 247 my ($auth_method, $rauth2, $r_framing) = split /;/, $rline;
216 248
217 if ($rauth2 ne $rauth) { 249 if ($rauth2 ne $rauth) {
218 return $self->error ("authentication failure/shared secret mismatch"); 250 return $self->error ("authentication failure/shared secret mismatch");
219 } 251 }
220 252
221 $self->{s_framing} = "json";#d# 253 $self->{s_framing} = $s_framing;
222 254
223 $hdl->rbuf_max (undef); 255 $hdl->rbuf_max (undef);
224 my $queue = delete $self->{queue}; # we are connected 256 my $queue = delete $self->{queue}; # we are connected
225 257
226 $self->connected; 258 $self->connected;
227 259
228 $hdl->push_write ($self->{s_framing} => $_) 260 $hdl->push_write ($self->{s_framing} => $_)
229 for @$queue; 261 for @$queue;
230 262
231 my $rmsg; $rmsg = sub { 263 my $rmsg; $rmsg = sub {
232 $_[0]->push_read ($r_framing => $rmsg); 264 $_[0]->push_read ($r_framing => $rmsg);
233 265
234 AnyEvent::MP::Base::_inject ($_[1]); 266 AnyEvent::MP::Base::_inject ($_[1]);
235 }; 267 };
236 $hdl->push_read ($r_framing => $rmsg); 268 $hdl->push_read ($r_framing => $rmsg);
269 });
237 }); 270 });
238 }); 271 });
239 } 272 }
240 273
241 $self 274 $self
… …
245 my ($self, $msg) = @_; 278 my ($self, $msg) = @_;
246 279
247 if ($self->{node} && $self->{node}{transport} == $self) { 280 if ($self->{node} && $self->{node}{transport} == $self) {
248 $self->{node}->clr_transport; 281 $self->{node}->clr_transport;
249 } 282 }
250# $self->{on_error}($self, $msg); 283 $AnyEvent::MP::Base::WARN->("$self->{peerhost}:$self->{peerport}: $msg");
251 $self->destroy; 284 $self->destroy;
252} 285}
253 286
254sub connected { 287sub connected {
255 my ($self) = @_; 288 my ($self) = @_;
… …
276 $self->destroy; 309 $self->destroy;
277} 310}
278 311
279=back 312=back
280 313
314=head1 PROTOCOL
315
316The protocol is relatively simple, and consists of three phases which are
317symmetrical for both sides: greeting (followed by optionally switching to
318TLS mode), authentication and packet exchange.
319
320the protocol is designed to allow both full-text and binary streams.
321
322The greeting consists of two text lines that are ended by either an ASCII
323CR LF pair, or a single ASCII LF (recommended).
324
325=head2 GREETING
326
327The first line contains strings seperated (not ended) by C<;>
328characters. The first seven strings are fixed by the protocol, the
329remaining strings are C<KEY=VALUE> pairs. None of them may contain C<;>
330characters themselves.
331
332The seven fixed strings are:
333
334=over 4
335
336=item C<aemp>
337
338The constant C<aemp> to identify the protocol.
339
340=item protocol version
341
342The (maximum) protocol version supported by this end, currently C<0>.
343
344=item minimum protocol version
345
346The minimum protocol version supported by this end, currently C<0>.
347
348=item a token uniquely identifying the current node instance
349
350This is a string that must change between restarts. It usually contains
351things like the current time, the (OS) process id or similar values, but
352no meaning of the contents are assumed.
353
354=item the node endpoint descriptors
355
356for public nodes, this is a comma-separated list of protocol endpoints,
357i.e., the noderef. For slave nodes, this is a unique identifier.
358
359=item the acceptable authentication methods
360
361A comma-separated list of authentication methods supported by the
362node. Note that AnyEvent::MP supports a C<hex_secret> authentication
363method that accepts a cleartext password (hex-encoded), but will not use
364this auth method itself.
365
366The receiving side should choose the first auth method it supports.
367
368=item the acceptable framing formats
369
370A comma-separated list of packet encoding/framign formats understood. The
371receiving side should choose the first framing format it supports for
372sending packets (which might be different from the format it has to accept).
373
374 . ";$self->{peerhost};$self->{peerport}"
375 . (join "", map ";$_=$greeting_kv->{$_}", keys %$greeting_kv);
376 my $lgreeting2 = MIME::Base64::encode_base64 AnyEvent::MP::Base::nonce (33), "";
281=head1 SEE ALSO 377=head1 SEE ALSO
282 378
283L<AnyEvent>. 379L<AnyEvent>.
284 380
285=head1 AUTHOR 381=head1 AUTHOR

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines