cvsroot/AnyEvent-Porttracker/Porttracker.pm

=head1 NAME

AnyEvent::Porttracker - Porttracker/PortIQ API client interface.

=head1 SYNOPSIS

   use AnyEvent::Porttracker;

=head1 DESCRIPTION

Porttracker (L<http://www.porttracker.com/>) is a product that (among
other things) scans switches and routers in a network and gives a coherent
view of which end devices are connected to which switch ports on which
switches and routers. It also offers a JSON-based client API, for which
this module is an implementation.

In addition to Porttracker, the PortIQ product is also supported, as it
uses the same protocol.

If you do not have access to either a Porttracker or PortIQ box then this
module will be of little value to you.

This module is an L<AnyEvent> user, you need to make sure that you use and
run a supported event loop.

=head1 THE AnyEvent::Porttracker CLASS

=over 4

=cut

package AnyEvent::Porttracker;

use common::sense;

use Scalar::Util ();

use AnyEvent ();
use AnyEvent::Handle ();

use MIME::Base64 ();
use Digest::HMAC_MD6 ();
use JSON ();

our $VERSION = '0.0';

sub call {
   my ($self, $type, @args) = @_;

   $self->{$type}
      ? $self->{$type}($self, @args)
      : ($type = (UNIVERSAL::can $self, $type))
         ? $type->($self, @args)
         : ()
}

=item new AnyEvent::Porttracker

=cut

sub new {
   my $class = shift;

   my $self = bless {
      id => "a",
      @_,
   }, $class;

   {
      Scalar::Util::weaken (my $self = $self);

      $self->{hdl} = new AnyEvent::Handle
         connect  => [$self->{host}, $self->{port} || "porttracker=55"],
         on_error => sub {
            $self->error ();
         },
         on_connect => sub {
            if ($self->{tls}) {
               $self->{queue} ||= [];
               $self->_req (start_tls => sub {
                  $_[1]
                     or return $self->error ("TLS rejected by server");

                  $self->unqueue;
               });
            }
         },
         on_read  => sub {
            while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
               my $msg = JSON::decode_json $1;
               my $id = shift @$msg;

               if (defined $id) {
                  my $cb = delete $self->{cb}{$id}
                     or return $self->error ("received unexpected reply msg with id $id");

                  $cb->($self, @$msg);
               } else {
                  $msg->[0] = "on_$msg->[0]_notify";
                  call $self, @$msg;
               }
            }
         },
      ;
   }

   $self
}

sub DESTROY {
   my ($self) = @_;

   $self->{hdl}->destroy
      if $self->{hdl};
}

sub error {
   my ($self, $msg) = @_;

   warn $msg;

   ()
}

sub _req {
   my $self = shift;
   my $cb   = pop;

   my $id   = ++$self->{id};

   unshift @_, $id;
   $self->{cb}{$id} = $cb;

   my $msg = JSON::encode_json \@_;

   $self->{hdl}->push_write ($msg);
}

sub req {
   $_[0]{queue}
      ? push @{ $_[0]{queue} }, [@_]
      : &_req
}

sub unqueue {
   my ($self) = @_;

   my $queue = delete $self->{queue}
      or return;

   _req @$_
      for @$queue;
}

sub on_start_tls_notify {
   my ($self) = @_;

   $self->{hdl}->starttls ("connect");

   $self->unqueue;
}

sub on_hello_notify {
   my ($self, $version, $auths, $nonce) = @_;

   $version == 1
      or return $self->error ("protocol mismatch, got $version, expected/supported 1");

   $nonce = MIME::Base64::decode_base64 $nonce;

   if (grep $_ eq "none", @$auths) {
      call $self, "on_login";

   } elsif (grep $_ eq "login_cram_md6", @$auths) {
      my $cc = join "", map chr 256 * rand, 0..63;

      my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256;
      my $cr  = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
      my $sr  = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;

      $cc = MIME::Base64::encode_base64 $cc;

      $self->req (login_cram_md6 => $self->{username}, $cr, $cc, sub {
         my ($self, $ok, $msg) = @_;

         $ok
            or return call $self, on_login_failure => $msg;

         $msg eq $sr
            or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";

         call $self, "on_login";
      });
   } elsif (grep $_ eq "login", @$auths) {
      $self->req (login => $self->{username}, $self->{password}, sub {
         my ($self, $ok, $msg) = @_;

         $ok
            or return call $self, on_login_failure => $msg;

         call $self, "on_login";
      });
   } else {
      call $self, on_login_failure => "no supported auth method (@$auths)";
   }
}

sub on_login_failure {
   my ($self, $msg) = @_;

   $msg =~ s/\n$//;
   $self->error ("login failed: $msg");
}

sub on_error_notify {
   my ($self, $msg) = @_;

   $self->error ($msg);
}

=back

=head1 SEE ALSO

L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.

=head1 AUTHOR

 Marc Lehmann <marc@porttracker.net>

=cut

1
Revision:	1.2
Committed:	Mon Nov 15 04:57:39 2010 UTC (13 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.1:	+50 -8 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::Porttracker - Porttracker/PortIQ API client interface.
4
5			=head1 SYNOPSIS
6
7			use AnyEvent::Porttracker;
8
9			=head1 DESCRIPTION
10
11			Porttracker (L<http://www.porttracker.com/>) is a product that (among
12			other things) scans switches and routers in a network and gives a coherent
13			view of which end devices are connected to which switch ports on which
14			switches and routers. It also offers a JSON-based client API, for which
15			this module is an implementation.
16
17			In addition to Porttracker, the PortIQ product is also supported, as it
18			uses the same protocol.
19
20			If you do not have access to either a Porttracker or PortIQ box then this
21			module will be of little value to you.
22
23			This module is an L<AnyEvent> user, you need to make sure that you use and
24			run a supported event loop.
25
26			=head1 THE AnyEvent::Porttracker CLASS
27
28			=over 4
29
30			=cut
31
32			package AnyEvent::Porttracker;
33
34			use common::sense;
35
36			use Scalar::Util ();
37
38			use AnyEvent ();
39			use AnyEvent::Handle ();
40
41			use MIME::Base64 ();
42			use Digest::HMAC_MD6 ();
43			use JSON ();
44
45			our $VERSION = '0.0';
46
47			sub call {
48			my ($self, $type, @args) = @_;
49
50			$self->{$type}
51			? $self->{$type}($self, @args)
52	root	1.2	: ($type = (UNIVERSAL::can $self, $type))
53	root	1.1	? $type->($self, @args)
54			: ()
55			}
56
57			=item new AnyEvent::Porttracker
58
59			=cut
60
61			sub new {
62			my $class = shift;
63
64			my $self = bless {
65			id => "a",
66			@_,
67			}, $class;
68
69			{
70			Scalar::Util::weaken (my $self = $self);
71
72			$self->{hdl} = new AnyEvent::Handle
73			connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],
74			on_error => sub {
75			$self->error ();
76			},
77	root	1.2	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			}
87			},
88	root	1.1	on_read => sub {
89			while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
90			my $msg = JSON::decode_json $1;
91			my $id = shift @$msg;
92
93			if (defined $id) {
94			my $cb = delete $self->{cb}{$id}
95			or return $self->error ("received unexpected reply msg with id $id");
96
97			$cb->($self, @$msg);
98			} else {
99			$msg->[0] = "on_$msg->[0]_notify";
100			call $self, @$msg;
101			}
102			}
103			},
104			;
105			}
106
107			$self
108			}
109
110			sub DESTROY {
111			my ($self) = @_;
112
113			$self->{hdl}->destroy
114			if $self->{hdl};
115			}
116
117			sub error {
118			my ($self, $msg) = @_;
119
120			warn $msg;
121
122			()
123			}
124
125	root	1.2	sub _req {
126	root	1.1	my $self = shift;
127			my $cb = pop;
128
129			my $id = ++$self->{id};
130
131			unshift @_, $id;
132			$self->{cb}{$id} = $cb;
133
134			my $msg = JSON::encode_json \@_;
135
136			$self->{hdl}->push_write ($msg);
137			}
138
139	root	1.2	sub req {
140			$_[0]{queue}
141			? push @{ $_[0]{queue} }, [@_]
142			: &_req
143			}
144
145			sub unqueue {
146			my ($self) = @_;
147
148			my $queue = delete $self->{queue}
149			or return;
150
151			_req @$_
152			for @$queue;
153			}
154
155			sub on_start_tls_notify {
156			my ($self) = @_;
157
158			$self->{hdl}->starttls ("connect");
159
160			$self->unqueue;
161			}
162
163	root	1.1	sub on_hello_notify {
164			my ($self, $version, $auths, $nonce) = @_;
165
166			$version == 1
167			or return $self->error ("protocol mismatch, got $version, expected/supported 1");
168
169			$nonce = MIME::Base64::decode_base64 $nonce;
170
171			if (grep $_ eq "none", @$auths) {
172	root	1.2	call $self, "on_login";
173
174	root	1.1	} elsif (grep $_ eq "login_cram_md6", @$auths) {
175			my $cc = join "", map chr 256 * rand, 0..63;
176
177			my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256;
178			my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
179			my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
180
181			$cc = MIME::Base64::encode_base64 $cc;
182
183	root	1.2	$self->req (login_cram_md6 => $self->{username}, $cr, $cc, sub {
184	root	1.1	my ($self, $ok, $msg) = @_;
185
186			$ok
187			or return call $self, on_login_failure => $msg;
188
189			$msg eq $sr
190			or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
191
192	root	1.2	call $self, "on_login";
193	root	1.1	});
194			} elsif (grep $_ eq "login", @$auths) {
195	root	1.2	$self->req (login => $self->{username}, $self->{password}, sub {
196	root	1.1	my ($self, $ok, $msg) = @_;
197
198			$ok
199			or return call $self, on_login_failure => $msg;
200
201	root	1.2	call $self, "on_login";
202	root	1.1	});
203			} else {
204	root	1.2	call $self, on_login_failure => "no supported auth method (@$auths)";
205	root	1.1	}
206			}
207
208			sub on_login_failure {
209			my ($self, $msg) = @_;
210
211			$msg =~ s/\n$//;
212			$self->error ("login failed: $msg");
213			}
214
215	root	1.2	sub on_error_notify {
216			my ($self, $msg) = @_;
217
218			$self->error ($msg);
219			}
220
221	root	1.1	=back
222
223			=head1 SEE ALSO
224
225			L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
226
227			=head1 AUTHOR
228
229			Marc Lehmann <marc@porttracker.net>
230
231			=cut
232
233			1