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.3 by root, Mon Nov 15 19:49:36 2010 UTC vs.
Revision 1.7 by root, Tue Nov 16 01:16:58 2010 UTC

… …
25 25
26To quickly understand how this module works you should read how to 26To quickly understand how this module works you should read how to
27construct a new connection object and then read about the event/callback 27construct a new connection object and then read about the event/callback
28system. 28system.
29 29
30The actual low-level protocol and, more importantly, the existing
31requests and responses, are documented in the official Porttracker
32API documentation (a copy of which is included in this module as
33L<AnyEvent::Porttracker::protocol>.
34
30=head1 THE AnyEvent::Porttracker CLASS 35=head1 THE AnyEvent::Porttracker CLASS
31 36
32The AnyEvent::Porttracker class represents a single connection. 37The AnyEvent::Porttracker class represents a single connection.
33 38
34=over 4 39=over 4
… …
58 : ($type = (UNIVERSAL::can $self, $type)) 63 : ($type = (UNIVERSAL::can $self, $type))
59 ? $type->($self, @args) 64 ? $type->($self, @args)
60 : () 65 : ()
61} 66}
62 67
63=item new AnyEvent::Porttracker [key => value...] 68=item $api = new AnyEvent::Porttracker [key => value...]
64 69
65Creates a new porttracker API connection object and tries to connect to 70Creates a new porttracker API connection object and tries to connect to
66the specified host (see below). After the connection has been established, 71the specified host (see below). After the connection has been established,
67the TLS handshake (if requested) will take place, followed by a login 72the TLS handshake (if requested) will take place, followed by a login
68attempt using either the C<none>, C<login_cram_md6> or C<login> methods, 73attempt using either the C<none>, C<login_cram_md6> or C<login> methods,
… …
88=item user => $string, pass => $string 93=item user => $string, pass => $string
89 94
90These are the username and password to use when authentication is required 95These are the username and password to use when authentication is required
91(which it is in almost all cases, so these keys are normally mandatory). 96(which it is in almost all cases, so these keys are normally mandatory).
92 97
93=item tls => ... 98=item tls => $bool
99
100Enables or disables TLS (default: disables). When enabled, then the
101connection will try to handshake a TLS connection before logging in. If
102unsuccessful a fatal error will be raised.
103
104Since most Porttracker/PortIQ boxes will not have a sensible/verifiable
105certificate, no attempt at verifying it will be done (which means
106man-in-the-middle-attacks will be trivial). If you want some form of
107verification you need to provide your own C<tls_ctx> object with C<<
108verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
109you wish to use.
110
111=item tls_ctx => $tls_ctx
112
113The L<AnyEvent::TLS> object to use.
94 114
95#TODO# 115#TODO#
96 116
97=item on_XYZ => $coderef 117=item on_XYZ => $coderef
98 118
… …
107sub new { 127sub new {
108 my $class = shift; 128 my $class = shift;
109 129
110 my $self = bless { 130 my $self = bless {
111 id => "a", 131 id => "a",
132 ids => [],
112 queue => [], # ininitially queue everything 133 queue => [], # ininitially queue everything
113 @_, 134 @_,
114 }, $class; 135 }, $class;
115 136
116 { 137 {
117 Scalar::Util::weaken (my $self = $self); 138 Scalar::Util::weaken (my $self = $self);
118 139
119 $self->{hdl} = new AnyEvent::Handle 140 $self->{hdl} = new AnyEvent::Handle
120 connect => [$self->{host}, $self->{port} || "porttracker=55"], 141 connect => [$self->{host}, $self->{port} || "porttracker=55"],
121 on_error => sub { 142 on_error => sub {
122 $self->error (); 143 $self->error ($_[2]);
123 }, 144 },
124 on_connect => sub { 145 on_connect => sub {
125 if ($self->{tls}) { 146 if ($self->{tls}) {
126 $self->_req (start_tls => sub { 147 $self->_req (start_tls => sub {
127 $_[1] 148 $_[1]
… …
137 my $id = shift @$msg; 158 my $id = shift @$msg;
138 159
139 if (defined $id) { 160 if (defined $id) {
140 my $cb = delete $self->{cb}{$id} 161 my $cb = delete $self->{cb}{$id}
141 or return $self->error ("received unexpected reply msg with id $id"); 162 or return $self->error ("received unexpected reply msg with id $id");
163
164 push @{ $self->{ids} }, $id;
142 165
143 $cb->($self, @$msg); 166 $cb->($self, @$msg);
144 } else { 167 } else {
145 $msg->[0] = "on_$msg->[0]_notify"; 168 $msg->[0] = "on_$msg->[0]_notify";
146 call $self, @$msg; 169 call $self, @$msg;
… …
161} 184}
162 185
163sub error { 186sub error {
164 my ($self, $msg) = @_; 187 my ($self, $msg) = @_;
165 188
166 call on_error => $msg; 189 call $self, on_error => $msg;
167 190
168 () 191 ()
169} 192}
170 193
171sub _req { 194sub _req {
172 my $self = shift; 195 my $self = shift;
173 my $cb = pop; 196 my $cb = pop;
174 197
175 my $id = ++$self->{id}; 198 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
176 199
177 unshift @_, $id; 200 unshift @_, $id;
178 $self->{cb}{$id} = $cb; 201 $self->{cb}{$id} = $cb;
179 202
180 my $msg = JSON::encode_json \@_; 203 my $msg = JSON::encode_json \@_;
181 204
182 $self->{hdl}->push_write ($msg); 205 $self->{hdl}->push_write ($msg);
183} 206}
184 207
208=item $api->req ($type => @args, $callback->($api, @reply))
209
210Sends a generic request of type C<$type> to the server. When the server
211responds, the API object and the response arguments (without the success
212status) are passed to the callback, which is the last argument to this
213method.
214
215If the request fails, then a fatal error will be raised. If you want to
216handle failures gracefully, you need to use C<< ->req_failok >> instead.
217
218The available requests are documented in the Porttracker API
219documentation (a copy of which is included in this module as
220L<AnyEvent::Porttracker::protocol>.
221
222It is permissible to call this (or any other request function) at any
223time, even before the connection has been established - the API object
224always waits until after login before it actually sends the requests, and
225queues them until then.
226
227Example: ping the porttracker server.
228
229 $api->req ("ping", sub {
230 my ($api, $ok, $timestamp, $pid) = @_;
231 ...
232 });
233
234Example: determine the product ID.
235
236 $api->req (product_id => sub {
237 my ($api, $ok, $branding, $product_id) = @_;
238 ...
239 });
240
241Example: set a new license.
242
243 $api->req (set_license => $LICENSE_STRING, sub {
244 my ($api, $ok) = @_;
245
246 $ok or die "failed to set license";
247 });
248
249=cut
250
185sub req { 251sub req {
252 my $cb = pop;
253 push @_, sub {
254 splice @_, 1, 1
255 or $_[0]->error ($_[1]);
256
257 &$cb
258 };
259
186 $_[0]{queue} 260 $_[0]{queue}
187 ? push @{ $_[0]{queue} }, [@_] 261 ? push @{ $_[0]{queue} }, [@_]
188 : &_req 262 : &_req
189} 263}
190 264
265=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
266
267Just like C<< ->req >>, with two differences: first, a failure will not
268raise an error, second, the initial status reply which indicates success
269or failure is not removed before calling the callback.
270
271=cut
272
273sub req_failok {
274 $_[0]{queue}
275 ? push @{ $_[0]{queue} }, [@_]
276 : &_req
277}
278
191sub on_start_tls_notify { 279sub on_start_tls_notify {
192 my ($self) = @_; 280 my ($self) = @_;
193 281
194 $self->{hdl}->starttls ("connect"); 282 $self->{hdl}->starttls (connect => $self->{tls_ctx});
195 $self->{tls} ||= 1; 283 $self->{tls} ||= 1;
196 284
197 $self->_login; 285 $self->_login;
198} 286}
199 287

Diff Legend

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