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

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents):
Revision 1.1 by root, Mon Nov 15 04:39:36 2010 UTC vs.
Revision 1.2 by root, Mon Nov 15 04:57:39 2010 UTC

… …
47sub call { 47sub call {
48 my ($self, $type, @args) = @_; 48 my ($self, $type, @args) = @_;
49 49
50 $self->{$type} 50 $self->{$type}
51 ? $self->{$type}($self, @args) 51 ? $self->{$type}($self, @args)
52 : $type = (UNIVERSAL::can $self, $type) 52 : ($type = (UNIVERSAL::can $self, $type))
53 ? $type->($self, @args) 53 ? $type->($self, @args)
54 : () 54 : ()
55} 55}
56 56
57=item new AnyEvent::Porttracker 57=item new AnyEvent::Porttracker
… …
71 71
72 $self->{hdl} = new AnyEvent::Handle 72 $self->{hdl} = new AnyEvent::Handle
73 connect => [$self->{host}, $self->{port} || "porttracker=55"], 73 connect => [$self->{host}, $self->{port} || "porttracker=55"],
74 on_error => sub { 74 on_error => sub {
75 $self->error (); 75 $self->error ();
76 },
77 on_connect => sub {
78 if ($self->{tls}) {
79 $self->{queue} ||= [];
80 $self->_req (start_tls => sub {
81 $_[1]
82 or return $self->error ("TLS rejected by server");
83
84 $self->unqueue;
85 });
86 }
76 }, 87 },
77 on_read => sub { 88 on_read => sub {
78 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) { 89 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
79 my $msg = JSON::decode_json $1; 90 my $msg = JSON::decode_json $1;
80 my $id = shift @$msg; 91 my $id = shift @$msg;
… …
109 warn $msg; 120 warn $msg;
110 121
111 () 122 ()
112} 123}
113 124
114sub send { 125sub _req {
115 my $self = shift; 126 my $self = shift;
116 my $cb = pop; 127 my $cb = pop;
117 128
118 my $id = ++$self->{id}; 129 my $id = ++$self->{id};
119 130
… …
123 my $msg = JSON::encode_json \@_; 134 my $msg = JSON::encode_json \@_;
124 135
125 $self->{hdl}->push_write ($msg); 136 $self->{hdl}->push_write ($msg);
126} 137}
127 138
139sub req {
140 $_[0]{queue}
141 ? push @{ $_[0]{queue} }, [@_]
142 : &_req
143}
144
145sub unqueue {
146 my ($self) = @_;
147
148 my $queue = delete $self->{queue}
149 or return;
150
151 _req @$_
152 for @$queue;
153}
154
155sub on_start_tls_notify {
156 my ($self) = @_;
157
158 $self->{hdl}->starttls ("connect");
159
160 $self->unqueue;
161}
162
128sub on_hello_notify { 163sub on_hello_notify {
129 my ($self, $version, $auths, $nonce) = @_; 164 my ($self, $version, $auths, $nonce) = @_;
130 165
131 $version == 1 166 $version == 1
132 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 167 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
133 168
134 $nonce = MIME::Base64::decode_base64 $nonce; 169 $nonce = MIME::Base64::decode_base64 $nonce;
135 170
136 if (grep $_ eq "none", @$auths) { 171 if (grep $_ eq "none", @$auths) {
137 # successfully authenticated... 172 call $self, "on_login";
173
138 } elsif (grep $_ eq "login_cram_md6", @$auths) { 174 } elsif (grep $_ eq "login_cram_md6", @$auths) {
139 my $cc = join "", map chr 256 * rand, 0..63; 175 my $cc = join "", map chr 256 * rand, 0..63;
140 176
141 my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256; 177 my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256;
142 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 178 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
143 my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256; 179 my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
144 180
145 $cc = MIME::Base64::encode_base64 $cc; 181 $cc = MIME::Base64::encode_base64 $cc;
146 182
147 $self->send (login_cram_md6 => $self->{username}, $cr, $cc, sub { 183 $self->req (login_cram_md6 => $self->{username}, $cr, $cc, sub {
148 my ($self, $ok, $msg) = @_; 184 my ($self, $ok, $msg) = @_;
149 185
150 $ok 186 $ok
151 or return call $self, on_login_failure => $msg; 187 or return call $self, on_login_failure => $msg;
152 188
153 $msg eq $sr 189 $msg eq $sr
154 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack"; 190 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
155 191
156 call $self, "on_login" 192 call $self, "on_login";
157 }); 193 });
158 } elsif (grep $_ eq "login", @$auths) { 194 } elsif (grep $_ eq "login", @$auths) {
159 $self->send (login => $self->{username}, $self->{password}, sub { 195 $self->req (login => $self->{username}, $self->{password}, sub {
160 my ($self, $ok, $msg) = @_; 196 my ($self, $ok, $msg) = @_;
161 197
162 $ok 198 $ok
163 or return call $self, on_login_failure => $msg; 199 or return call $self, on_login_failure => $msg;
164 200
165 call $self, "on_login" 201 call $self, "on_login";
166 }); 202 });
167 } else { 203 } else {
168 return $self->error ("no supported auth method (@$auths)"); 204 call $self, on_login_failure => "no supported auth method (@$auths)";
169 } 205 }
170} 206}
171 207
172sub on_login_failure { 208sub on_login_failure {
173 my ($self, $msg) = @_; 209 my ($self, $msg) = @_;
174 210
175 $msg =~ s/\n$//; 211 $msg =~ s/\n$//;
176 $self->error ("login failed: $msg"); 212 $self->error ("login failed: $msg");
177} 213}
178 214
215sub on_error_notify {
216 my ($self, $msg) = @_;
217
218 $self->error ($msg);
219}
220
179=back 221=back
180 222
181=head1 SEE ALSO 223=head1 SEE ALSO
182 224
183L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 225L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.

Diff Legend

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