From 61115bb6cacfd5b33da20bb5bd700ca19fa6a824 Mon Sep 17 00:00:00 2001
From: Nigel Kukard <nkukard@lbsd.net>
Date: Sat, 22 Jun 2013 13:03:12 +0000
Subject: [PATCH] Major functionality changes
* Added webserver module
* Added radius dictionaries
* Got basic processing working
---
INSTALL | 3 +
Radius/Dictionary.pm | 386 ++++++++++
Radius/Packet.pm | 669 ++++++++++++++++++
Radius/README.Net-Radius | 119 ++++
dicts/dictionary | 266 +++++++
dicts/dictionary.allworldit | 24 +
opentrafficshaper.conf | 8 +
opentrafficshaper/logger.pm | 95 +++
.../plugins/webserver/webserver.pm | 118 +++
opentrafficshaper/version.pm | 39 +
opentrafficshaperd | 467 ++++++++++++
11 files changed, 2194 insertions(+)
create mode 100644 Radius/Dictionary.pm
create mode 100644 Radius/Packet.pm
create mode 100644 Radius/README.Net-Radius
create mode 100644 dicts/dictionary
create mode 100644 dicts/dictionary.allworldit
create mode 100644 opentrafficshaper.conf
create mode 100644 opentrafficshaper/logger.pm
create mode 100644 opentrafficshaper/plugins/webserver/webserver.pm
create mode 100644 opentrafficshaper/version.pm
create mode 100755 opentrafficshaperd
diff --git a/INSTALL b/INSTALL
index 4ab3e23..f97da8c 100644
--- a/INSTALL
+++ b/INSTALL
@@ -5,6 +5,9 @@ Installing OpenTrafficShaper:
* Requirements for OpenTrafficShaper
*
+- POE
+- Config::IniFiles
+
- Perl 5.6+
diff --git a/Radius/Dictionary.pm b/Radius/Dictionary.pm
new file mode 100644
index 0000000..484256f
--- /dev/null
+++ b/Radius/Dictionary.pm
@@ -0,0 +1,386 @@
+package Radius::Dictionary;
+
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+# $Id: Dictionary.pm,v 1.11 2007/04/26 20:20:02 lem Exp $
+
+$VERSION = '1.55';
+
+sub new {
+ my $class = shift;
+ my $self = {
+ rvsattr => {},
+ vsattr => {},
+ vsaval => {},
+ rvsaval => {},
+ attr => {},
+ rattr => {},
+ val => {},
+ rval => {},
+ vendors => {},
+ packet => undef, # Fall back to default
+ rpacket => undef, # Fall back to default
+ };
+ bless $self, $class;
+ $self->readfile($_) for @_; # Read all given dictionaries
+ return $self;
+}
+
+sub readfile {
+ my ($self, $filename) = @_;
+
+ open(DICT, "< $filename") or return undef;
+
+ while (defined(my $l = <DICT>)) {
+ next if $l =~ /^\#/;
+ next unless my @l = split /\s+/, $l;
+
+ if ($l[0] =~ m/^vendor$/i)
+ {
+ if (defined $l[1] and defined $l[2] and $l[2] =~ /^[xo0-9]+$/)
+ {
+ if (substr($l[2],0,1) eq "0") { #allow hex or octal
+ my $num = lc($l[2]);
+ $num =~ s/^0b//;
+ $l[2] = oct($num);
+ }
+ $self->{vendors}->{$l[1]} = $l[2];
+ }
+ else
+ {
+ warn "Garbled VENDOR line $l\n";
+ }
+ }
+ elsif ($l[0] =~ m/^attribute$/i)
+ {
+ if (@l == 4)
+ {
+ $self->{attr}->{$l[1]} = [@l[2,3]];
+ $self->{rattr}->{$l[2]} = [@l[1,3]];
+ }
+ elsif (@l == 5) # VENDORATTR
+ {
+ if (substr($l[2],0,1) eq "0") { #allow hex or octal
+ my $num = lc($l[2]);
+ $num =~ s/^0b//;
+ $l[2] = oct($num);
+ }
+ if (exists $self->{vendors}->{$l[4]})
+ {
+ $self->{vsattr}->{$self->{vendors}->{$l[4]}}->{$l[1]}
+ = [@l[2, 3]];
+ $self->{rvsattr}->{$self->{vendors}->{$l[4]}}->{$l[2]}
+ = [@l[1, 3]];
+ }
+ elsif ($l[4] =~ m/^\d+$/)
+ {
+ $self->{vsattr}->{$l[4]}->{$l[1]} = [@l[2, 3]];
+ $self->{rvsattr}->{$l[4]}->{$l[2]} = [@l[1, 3]];
+ }
+ else
+ {
+ warn "Warning: Unknown vendor $l[4]\n";
+ }
+ }
+ }
+ elsif ($l[0] =~ m/^value$/i) {
+ if (exists $self->{attr}->{$l[1]}) {
+ $self->{val}->{$self->{attr}->{$l[1]}->[0]}->{$l[2]} = $l[3];
+ $self->{rval}->{$self->{attr}->{$l[1]}->[0]}->{$l[3]} = $l[2];
+ }
+ else {
+ for my $v (keys %{$self->{vsattr}})
+ {
+ if (defined $self->{vsattr}->{$v}->{$l[1]})
+ {
+ $self->{vsaval}->{$v}->{$self->{vsattr}->{$v}
+ ->{$l[1]}->[0]}->{$l[2]}
+ = $l[3];
+ $self->{rvsaval}->{$v}->{$self->{vsattr}->{$v}
+ ->{$l[1]}->[0]}->{$l[3]}
+ = $l[2];
+ }
+ }
+ }
+ }
+ elsif ($l[0] =~ m/^vendorattr$/i) {
+ if (substr($l[3],0,1) eq "0") { #allow hex or octal
+ my $num = lc($l[3]);
+ $num =~ s/^0b//;
+ $l[3] = oct($num);
+ }
+ if (exists $self->{vendors}->{$l[1]})
+ {
+ $self->{vsattr}->{$self->{vendors}->{$l[1]}}->{$l[2]}
+ = [@l[3, 4]];
+ $self->{rvsattr}->{$self->{vendors}->{$l[1]}}->{$l[3]}
+ = [@l[2, 4]];
+ }
+ elsif ($l[1] =~ m/^\d+$/)
+ {
+ $self->{vsattr}->{$l[1]}->{$l[2]} = [@l[3, 4]];
+ $self->{rvsattr}->{$l[1]}->{$l[3]} = [@l[2, 4]];
+ }
+ else
+ {
+ warn "Warning: Unknown vendor $l[1]\n";
+ }
+ }
+ elsif ($l[0] =~ m/^vendorvalue$/i) {
+ if (substr($l[4],0,1) eq "0")
+ { #allow hex or octal
+ my $num = lc($l[4]);
+ $num =~ s/^0b//;
+ $l[4] = oct($num);
+ }
+ if (exists $self->{vendors}->{$l[1]})
+ {
+ $self->{vsaval}->{$self->{vendors}->{$l[1]}}
+ ->{$self->{vsattr}->{$self->{vendors}->{$l[1]}}
+ ->{$l[2]}->[0]}->{$l[3]} = $l[4];
+ $self->{rvsaval}->{$self->{vendors}->{$l[1]}}
+ ->{$self->{vsattr}->{$self->{vendors}->{$l[1]}}
+ ->{$l[2]}->[0]}->{$l[4]} = $l[3];
+ }
+ elsif ($l[1] =~ m/^\d+$/)
+ {
+ $self->{vsaval}->{$l[1]}->{$self->{vsattr}->{$l[1]}->{$l[2]}
+ ->[0]}->{$l[3]} = $l[4];
+ $self->{rvsaval}->{$l[1]}->{$self->{vsattr}->{$l[1]}->{$l[2]}
+ ->[0]}->{$l[4]} = $l[3];
+ }
+ else {
+ warn "Warning: $filename contains vendor value for ",
+ "unknown vendor attribute - ignored ",
+ "\"$l[1]\"\n $l";
+ }
+ }
+ elsif (lc($l[0]) eq 'packet') {
+ my ($name, $value) = @l[1,2];
+ $self->{packet}{$name} = $value;
+ $self->{rpacket}{$value} = $name;
+ }
+ else {
+ warn "Warning: Weird dictionary line: $l\n";
+ }
+ }
+ close DICT;
+}
+
+# Accessors for standard attributes
+
+sub vendor_num { $_[0]->{vendors}->{$_[1]}; }
+sub attr_num { $_[0]->{attr}->{$_[1]}->[0]; }
+sub attr_type { $_[0]->{attr}->{$_[1]}->[1]; }
+sub attr_name { $_[0]->{rattr}->{$_[1]}->[0]; }
+sub attr_numtype { $_[0]->{rattr}->{$_[1]}->[1]; }
+sub attr_has_val { $_[0]->{val}->{$_[1]}; }
+sub val_has_name { $_[0]->{rval}->{$_[1]}; }
+sub val_num { $_[0]->{val}->{$_[1]}->{$_[2]}; }
+sub val_name { $_[0]->{rval}->{$_[1]}->{$_[2]}; }
+sub val_tag { $_[0]->{val}->{$_[1]}->{$_[3]}; }
+
+# Accessors for Vendor-Specific Attributes
+
+sub vsattr_num { $_[0]->{vsattr}->{$_[1]}->{$_[2]}->[0]; }
+sub vsattr_type { $_[0]->{vsattr}->{$_[1]}->{$_[2]}->[1]; }
+sub vsattr_name { $_[0]->{rvsattr}->{$_[1]}->{$_[2]}->[0]; }
+sub vsattr_numtype { $_[0]->{rvsattr}->{$_[1]}->{$_[2]}->[1]; }
+sub vsattr_has_val { $_[0]->{vsaval}->{$_[1]}->{$_[2]}; }
+sub vsaval_has_name { $_[0]->{rvsaval}->{$_[1]}->{$_[2]}; }
+sub vsaval_has_tval { $_[0]->{vsaval}->{$_[1]}->{$_[2]}->[0]; }
+sub vsaval_has_tag { $_[0]->{vsaval}->{$_[1]}->{$_[2]}->[1]; }
+sub vsaval_num { $_[0]->{vsaval}->{$_[1]}->{$_[2]}->{$_[3]}; }
+sub vsaval_name { $_[0]->{rvsaval}->{$_[1]}->{$_[2]}->{$_[3]}; }
+
+# Accessors for packet types. Fall-back to defaults if the case.
+
+# Defaults taken from http://www.iana.org/assignments/radius-types
+# as of Oct 21, 2006
+my %default_packets = (
+ 'Access-Request' => 1, # [RFC2865]
+ 'Access-Accept' => 2, # [RFC2865]
+ 'Access-Reject' => 3, # [RFC2865]
+ 'Accounting-Request' => 4, # [RFC2865]
+ 'Accounting-Response' => 5, # [RFC2865]
+ 'Accounting-Status' => 6, # [RFC2882] (now Interim Accounting)
+ 'Interim-Accounting' => 6, # see previous note
+ 'Password-Request' => 7, # [RFC2882]
+ 'Password-Ack' => 8, # [RFC2882]
+ 'Password-Reject' => 9, # [RFC2882]
+ 'Accounting-Message' => 10, # [RFC2882]
+ 'Access-Challenge' => 11, # [RFC2865]
+ 'Status-Server' => 12, # (experimental) [RFC2865]
+ 'Status-Client' => 13, # (experimental) [RFC2865]
+ 'Resource-Free-Request' => 21, # [RFC2882]
+ 'Resource-Free-Response' => 22, # [RFC2882]
+ 'Resource-Query-Request' => 23, # [RFC2882]
+ 'Resource-Query-Response' => 24, # [RFC2882]
+ 'Alternate-Resource-Reclaim-Request' => 25, # [RFC2882]
+ 'NAS-Reboot-Request' => 26, # [RFC2882]
+ 'NAS-Reboot-Response' => 27, # [RFC2882]
+ # 28 Reserved
+ 'Next-Passcode' => 29, # [RFC2882]
+ 'New-Pin' => 30, # [RFC2882]
+ 'Terminate-Session' => 31, # [RFC2882]
+ 'Password-Expired' => 32, # [RFC2882]
+ 'Event-Request' => 33, # [RFC2882]
+ 'Event-Response' => 34, # [RFC2882]
+ 'Disconnect-Request' => 40, # [RFC3575]
+ 'Disconnect-ACK' => 41, # [RFC3575]
+ 'Disconnect-NAK' => 42, # [RFC3575]
+ 'CoA-Request' => 43, # [RFC3575]
+ 'CoA-ACK' => 44, # [RFC3575]
+ 'CoA-NAK' => 45, # [RFC3575]
+ 'IP-Address-Allocate' => 50, # [RFC2882]
+ 'IP-Address-Release' => 51, # [RFC2882]
+ # 250-253 Experimental Use
+ # 254 Reserved
+ # 255 Reserved [RFC2865]
+);
+
+# Reverse defaults. Remember that code #6 has a double mapping, force
+# to Interim-Accouting
+my %default_rpackets
+ = map { $default_packets{$_} => $_ } keys %default_packets;
+$default_rpackets{6} = 'Interim-Accounting';
+
+# Get full hashes
+sub packet_numbers { %{ $_[0]->{packet} || \%default_packets } }
+sub packet_names { %{ $_[0]->{rpacket} || \%default_rpackets }; }
+
+# Single resolution, I'm taking care of avoiding auto-vivification
+sub packet_hasname {
+ my $href = $_[0]->{packet} || \%default_packets;
+ my $ok = exists $href->{$_[1]};
+ return $ok unless wantarray;
+ # return both answer and the resolution
+ return ($ok, $ok ? $href->{$_[1]} : undef);
+}
+
+sub packet_hasnum {
+ my $href = $_[0]->{rpacket} || \%default_rpackets;
+ my $ok = exists $href->{$_[1]};
+ return $ok unless wantarray;
+ # return both answer and the resolution
+ return ($ok, $ok ? $href->{$_[1]} : undef);
+}
+
+# Note: crossed, as it might not be immediately evident
+sub packet_num { ($_[0]->packet_hasname($_[1]))[1]; }
+sub packet_name { ($_[0]->packet_hasnum($_[1]))[1]; }
+
+1;
+__END__
+
+=head1 NAME
+
+Net::Radius::Dictionary - RADIUS dictionary parser
+
+=head1 SYNOPSIS
+
+ use Net::Radius::Dictionary;
+
+ my $dict = new Net::Radius::Dictionary "/etc/radius/dictionary";
+ $dict->readfile("/some/other/file");
+ my $num = $dict->attr_num('User-Name');
+ my $name = $dict->attr_name(1);
+ my $vsa_num = $dict->vsattr_num(9, 'cisco-avpair');
+ my $vsa_name = $dict->vsattr_name(9, 1);
+
+=head1 DESCRIPTION
+
+This is a simple module that reads a RADIUS dictionary file and
+parses it, allowing conversion between dictionary names and numbers.
+Vendor-Specific attributes are supported in a way consistent to the
+standards.
+
+A few earlier versions of this module attempted to make dictionaries
+case-insensitive. This proved to be a very bad decision. From this
+version on, this tendency is reverted: Dictionaries and its contents
+are to be case-sensitive to prevent random, hard to debug failures in
+production code.
+
+=head2 METHODS
+
+=over
+
+=item B<new($dict_file, ...)>
+
+Returns a new instance of a Net::Radius::Dictionary object. This
+object will have no attributes defined, as expected.
+
+If given an (optional) list of filenames, it calls I<readfile> for you
+for all of them, in the given order.
+
+=item B<-E<gt>readfile($dict_file)>
+
+Parses a dictionary file and learns the mappings to use. It can be
+called multiple times for the same object. The result will be that new
+entries will override older ones, thus you could load a default
+dictionary and then have a smaller dictionary that override specific
+entries.
+
+=item B<-E<gt>vendor_num($vendorname)>
+
+Return the vendor number for the given vendor name.
+
+=item B<-E<gt>attr_num($attrname)>
+
+Returns the number of the named attribute.
+
+=item B<-E<gt>attr_type($attrname)>
+
+Returns the type (I<string>, I<integer>, I<ipaddr>, or I<time>) of the
+named attribute.
+
+=item B<-E<gt>attr_name($attrnum)>
+
+Returns the name of the attribute with the given number.
+
+=item B<-E<gt>attr_numtype($attrnum)>
+
+Returns the type of the attribute with the given number.
+
+=item B<-E<gt>attr_has_val($attrnum)>
+
+Returns a true or false value, depending on whether or not the numbered
+attribute has any known value constants.
+
+=item B<-E<gt>val_has_name($attrnum)>
+
+Alternate (bad) name for I<attr_has_val>.
+
+=item B<-E<gt>val_num($attrnum, $valname)>
+
+Returns the number of the named value for the attribute number supplied.
+
+=item B<-E<gt>val_name($attrnum, $valnumber)>
+
+Returns the name of the numbered value for the attribute number supplied.
+
+=back
+
+There is an equivalent family of accessor methods for Vendor-Specific
+attributes and its values. Those methods are identical to their standard
+attributes counterparts with two exceptions. Their names have a
+I<vsa> prepended to the accessor name and the first argument to each one
+is the vendor code on which they apply.
+
+=head1 CAVEATS
+
+This module is mostly for the internal use of Net::Radius::Packet, and
+may otherwise cause insanity and/or blindness if studied.
+
+=head1 AUTHOR
+
+Christopher Masto <chris@netmonger.net>,
+Luis E. Muñoz <luismunoz@cpan.org> contributed the VSA code.
+
+=head1 SEE ALSO
+
+Net::Radius::Packet
+
+=cut
diff --git a/Radius/Packet.pm b/Radius/Packet.pm
new file mode 100644
index 0000000..7d1d233
--- /dev/null
+++ b/Radius/Packet.pm
@@ -0,0 +1,669 @@
+package Radius::Packet;
+
+use strict;
+require Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $VSA);
+@ISA = qw(Exporter);
+@EXPORT = qw(auth_resp auth_acct_verify auth_req_verify);
+@EXPORT_OK = qw( );
+
+$VERSION = '1.55';
+
+$VSA = 26; # Type assigned in RFC2138 to the
+ # Vendor-Specific Attributes
+
+# Be sure our dictionaries are current
+use Radius::Dictionary 1.50;
+use Carp;
+use Socket;
+use Digest::MD5;
+
+my (%unkvprinted, %unkgprinted);
+
+sub new {
+ my ($class, $dict, $data) = @_;
+ my $self = { unknown_entries => 1 };
+ bless $self, $class;
+ $self->set_dict($dict) if defined($dict);
+ $self->unpack($data) if defined($data);
+ return $self;
+}
+
+# Set the dictionary
+sub set_dict {
+ my ($self, $dict) = @_;
+ $self->{Dict} = $dict;
+}
+
+# Functions for accessing data structures
+sub code { $_[0]->{Code}; }
+sub identifier { $_[0]->{Identifier}; }
+sub authenticator { $_[0]->{Authenticator}; }
+
+sub set_code { $_[0]->{Code} = $_[1]; }
+sub set_identifier { $_[0]->{Identifier} = $_[1]; }
+sub set_authenticator { $_[0]->{Authenticator} = substr($_[1]
+ . "\x0" x 16,
+ 0, 16); }
+
+sub vendors { keys %{$_[0]->{VSAttributes}}; }
+sub vsattributes { keys %{$_[0]->{VSAttributes}->{$_[1]}}; }
+sub vsattr { $_[0]->{VSAttributes}->{$_[1]}->{$_[2]}; }
+sub set_vsattr {
+ my ($self, $vendor, $name, $value, $rewrite_flag, $rawValue) = @_;
+ $self->{VSAttributes}->{$vendor} = {} unless exists($self->{VSAttributes}->{$vendor});
+ my $attr = $self->{VSAttributes}->{$vendor};
+
+ if ($rewrite_flag) {
+ my $found = 0;
+
+ if (exists($attr->{$name})) {
+ $found = $#{$attr->{$name}} + 1;
+ }
+
+ if ($found == 1) {
+ $attr->{$name}[0] = $value;
+ return;
+ }
+ }
+
+ # Check if we should be adding the raw value or not
+ if (defined($rawValue)) {
+ push @{$attr->{$name}}, $value, $rawValue;
+ } else {
+ push @{$attr->{$name}}, $value;
+ }
+}
+
+sub unset_vsattr {
+ my ($self, $vendor, $name) = @_;
+
+ delete($self->{VSAttributes}->{$name});
+}
+
+sub show_unknown_entries { $_[0]->{unknown_entries} = $_[1]; }
+
+sub set_attr
+{
+ my ($self, $name, $value, $rewrite_flag, $rawValue) = @_;
+ my ($push, $pos );
+
+ $push = 1 unless $rewrite_flag;
+
+ if ($rewrite_flag) {
+ my $found = 0;
+ my @attr = $self->_attributes;
+
+ for (my $i = 0; $i <= $#attr; $i++ ) {
+ if ($attr[$i][0] eq $name) {
+ $found++;
+ $pos = $i;
+ }
+ }
+
+ if ($found > 1) {
+ $push = 1;
+ } elsif ($found) {
+ $attr[$pos][0] = $name;
+ $attr[$pos][1] = $value;
+ $attr[$pos][2] = $rawValue;
+ $self->_set_attributes( \@attr );
+ return;
+ } else {
+ $push = 1;
+ }
+ }
+
+ $self->_push_attr( $name, $value, $rawValue ) if $push;
+}
+
+sub attr
+{
+ my ($self, $name ) = @_;
+
+ my @attr = $self->_attributes;
+
+ for (my $i = $#attr; $i >= 0; $i-- ) {
+ return $attr[$i][1] if $attr[$i][0] eq $name;
+ }
+ return;
+}
+
+sub rawattr
+{
+ my ($self, $name ) = @_;
+
+ my @attr = $self->_attributes;
+
+ for (my $i = $#attr; $i >= 0; $i-- ) {
+ # Check if this is the attr we're after
+ if ($attr[$i][0] eq $name) {
+ # If it is, return the raw attribute if it exists, else return the nicer dict one
+ return defined($attr[$i][2]) ? $attr[$i][2] : $attr[$i][1];
+ }
+ }
+ return;
+}
+
+sub attributes {
+ my ($self) = @_;
+
+ my @attr = $self->_attributes;
+ my @attriblist = ();
+ for (my $i = $#attr; $i >= 0; $i-- ) {
+ push @attriblist, $attr[$i][0];
+ }
+ return @attriblist;
+}
+
+sub unset_attr
+{
+ my ($self, $name, $value ) = @_;
+
+ my $found;
+ my @attr = $self->_attributes;
+
+ for (my $i = 0; $i <= $#attr; $i++ ) {
+ if ( $name eq $attr[$i][0] && $value eq $attr[$i][1])
+ {
+ $found = 1;
+ if ( $#attr == 0 ) {
+ # no more attributes left on the stack
+ $self->_set_attributes( [ ] );
+ } else {
+ splice @attr, $i, 1;
+ $self->_set_attributes( \@attr );
+ }
+ return 1;
+ }
+ }
+ return 0;
+}
+
+# XXX - attr_slot is deprecated - Use attr_slot_* instead
+sub attr_slot { attr_slot_val($@); }
+
+sub attr_slots { scalar ($_[0]->_attributes); }
+
+sub attr_slot_name
+{
+ my $self = shift;
+ my $slot = shift;
+ my @stack = $self->_attributes;
+
+ return unless exists $stack[$slot];
+ return unless exists $stack[$slot]->[0];
+ $stack[$slot]->[0];
+}
+
+sub attr_slot_val
+{
+ my $self = shift;
+ my $slot = shift;
+ my @stack = $self->_attributes;
+
+ return unless exists $stack[$slot];
+ return unless exists $stack[$slot]->[0];
+ $stack[$slot]->[1];
+}
+
+sub unset_attr_slot {
+ my ($self, $position ) = @_;
+
+ my @attr = $self->_attributes;
+
+ if ( not $position > $#attr ) {
+ splice @attr, $position, 1;
+ $self->_set_attributes( \@attr );
+ return 1;
+ } else {
+ return;
+ }
+
+}
+
+# 'Attributes' is now array of arrays, so that we can have multiple
+# Proxy-State values in the order in which they were added,
+# as specified in RFC 2865
+sub _attributes { @{ $_[0]->{Attributes} || [] }; }
+sub _set_attributes { $_[0]->{Attributes} = $_[1]; }
+sub _push_attr { push @{ $_[0]->{Attributes} }, [ $_[1], $_[2], $_[3] ]; }
+
+# Decode the password
+sub password {
+ my ($self, $secret, $attr) = @_;
+ my $lastround = $self->authenticator;
+ my $pwdin = $self->attr($attr || "User-Password");
+ my $pwdout = ""; # avoid possible undef warning
+ for (my $i = 0; $i < length($pwdin); $i += 16) {
+ $pwdout .= substr($pwdin, $i, 16) ^ Digest::MD5::md5($secret . $lastround);
+ $lastround = substr($pwdin, $i, 16);
+ }
+ $pwdout =~ s/\000*$// if $pwdout;
+ substr($pwdout,length($pwdin)) = ""
+ unless length($pwdout) <= length($pwdin);
+ return $pwdout;
+}
+
+# Encode the password
+sub set_password {
+ my ($self, $pwdin, $secret, $attribute) = @_;
+ $attribute ||= 'User-Password';
+ my $lastround = $self->authenticator;
+ my $pwdout = ""; # avoid possible undef warning
+ $pwdin .= "\000" x (15-(15 + length $pwdin)%16); # pad to 16n bytes
+
+ for (my $i = 0; $i < length($pwdin); $i += 16) {
+ $lastround = substr($pwdin, $i, 16)
+ ^ Digest::MD5::md5($secret . $lastround);
+ $pwdout .= $lastround;
+ }
+ $self->set_attr($attribute => $pwdout, 1);
+}
+
+# Set response authenticator in binary packet
+sub auth_resp {
+ my $new = $_[0];
+ substr($new, 4, 16) = Digest::MD5::md5($_[0] . $_[1]);
+ return $new;
+}
+
+# Verify the authenticator in a packet
+sub auth_acct_verify { auth_req_verify(@_, "\x0" x 16); }
+sub auth_req_verify
+{
+ my ($packet, $secret, $prauth) = @_;
+
+ return 1 if Digest::MD5::md5(substr($packet, 0, 4) . $prauth
+ . substr($packet, 20) . $secret)
+ eq substr($packet, 4, 16);
+ return;
+}
+
+# Utility functions for printing/debugging
+sub pdef { defined $_[0] ? $_[0] : "UNDEF"; }
+sub pclean {
+ my $str = $_[0];
+ $str =~ s/([\044-\051\133-\136\140\173-\175])/'\\' . $1/ge;
+ $str =~ s/([\000-\037\177-\377])/sprintf('\x{%x}', ord($1))/ge;
+ return $str;
+}
+
+sub dump {
+ print str_dump(@_);
+}
+
+sub str_dump {
+ my $self = shift;
+ my $ret = '';
+ $ret .= "*** DUMP OF RADIUS PACKET ($self)\n";
+ $ret .= "Code: ". pdef($self->{Code}). "\n";
+ $ret .= "Identifier: ". pdef($self->{Identifier}). "\n";
+ $ret .= "Authentic: ". pclean(pdef($self->{Authenticator})). "\n";
+ $ret .= "Attributes:\n";
+
+ for (my $i = 0; $i < $self->attr_slots; ++$i)
+ {
+ $ret .= sprintf(" %-20s %s\n", $self->attr_slot_name($i) . ":" ,
+ pclean(pdef($self->attr_slot_val($i))));
+ }
+
+ foreach my $vendor ($self->vendors) {
+ $ret .= "VSA for vendor $vendor\n";
+ foreach my $attr ($self->vsattributes($vendor)) {
+ $ret .= sprintf(" %-20s %s\n", $attr . ":" ,
+ pclean(join("|", @{$self->vsattr($vendor, $attr)})));
+ }
+ }
+ $ret .= "*** END DUMP\n";
+ return $ret;
+}
+
+sub pack {
+ my $self = shift;
+ my $hdrlen = 1 + 1 + 2 + 16; # Size of packet header
+ my $p_hdr = "C C n a16 a*"; # Pack template for header
+ my $p_attr = "C C a*"; # Pack template for attribute
+ my $p_vsa = "C C N C C a*"; # VSA
+
+ # XXX - The spec says that a
+ # 'Vendor-Type' must be included
+ # but there are no documented definitions
+ # for this! We'll simply skip this value
+
+ my $p_vsa_3com = "C C N N a*";
+
+ my %codes = $self->{Dict}->packet_numbers();
+ my $attstr = ""; # To hold attribute structure
+ # Define a hash of subroutine references to pack the various data types
+ my %packer = (
+ "octets" => sub { return $_[0]; },
+ "string" => sub { return $_[0]; },
+ "ipv6addr" => sub { return $_[0]; },
+ "date" => sub { return $_[0]; },
+ "ifid" => sub { return $_[0]; },
+ "integer" => sub {
+ return pack "N",
+ (
+ defined $self->{Dict}->attr_has_val($_[1]) &&
+ defined $self->{Dict}->val_num(@_[1, 0])
+ )
+ ? $self->{Dict}->val_num(@_[1, 0])
+ : $_[0];
+ },
+ "ipaddr" => sub {
+ return inet_aton($_[0]);
+ },
+ "time" => sub {
+ return pack "N", $_[0];
+ },
+ "date" => sub {
+ return pack "N", $_[0];
+ },
+ "tagged-string" => sub {
+ return $_[0];
+ },
+ "tagged-integer" => sub {
+ return $_[0];
+ },
+ "tagged-ipaddr" => sub {
+ my ($tag,$val)=unpack "C a*",$_[0];
+ return pack "C N" , $tag , inet_aton($val);
+ });
+
+ my %vsapacker = (
+ "octets" => sub { return $_[0]; },
+ "string" => sub { return $_[0]; },
+ "ipv6addr" => sub { return $_[0]; },
+ "date" => sub { return $_[0]; },
+ "ifid" => sub { return $_[0]; },
+ "integer" => sub {
+ my $vid = $self->{Dict}->vendor_num($_[2]) || $_[2];
+ return pack "N",
+ (defined $self->{Dict}->vsattr_has_val($vid, $_[1])
+ && defined $self->{Dict}->vsaval_num($vid, @_[1, 0])
+ ) ? $self->{Dict}->vsaval_num($vid, @_[1, 0]) : $_[0];
+ },
+ "ipaddr" => sub {
+ return inet_aton($_[0]);
+ },
+ "time" => sub {
+ return pack "N", $_[0];
+ },
+ "date" => sub {
+ return pack "N", $_[0];
+ },
+ "tagged-string" => sub {
+ return $_[0];
+ },
+ "tagged-integer" => sub {
+ return $_[0];
+ },
+ "tagged-ipaddr" => sub {
+ my ($tag,$val)=unpack "C a*",$_[0];
+ return pack "C a*" , $tag , inet_aton($val);
+ });
+
+ # Pack the attributes
+ for (my $i = 0; $i < $self->attr_slots; ++$i)
+ {
+ my $attr = $self->attr_slot_name($i);
+ if (! defined $self->{Dict}->attr_num($attr))
+ {
+ carp("Unknown RADIUS tuple $attr => " . $self->attr_slot_val($i)
+ . "\n")
+ if ($self->{unknown_entries});
+ next;
+ }
+
+ next unless ref($packer{$self->{Dict}->attr_type($attr)}) eq 'CODE';
+
+ my $val = &{$packer{$self->{Dict}->attr_type($attr)}}
+ ($self->attr_slot_val($i), $self->{Dict} ->attr_num($attr));
+
+ $attstr .= pack $p_attr, $self->{Dict}->attr_num($attr),
+ length($val)+2, $val;
+ }
+
+ # Pack the Vendor-Specific Attributes
+
+ foreach my $vendor ($self->vendors)
+ {
+ my $vid = $self->{Dict}->vendor_num($vendor) || $vendor;
+ foreach my $attr ($self->vsattributes($vendor)) {
+ next unless ref($vsapacker{$self->{Dict}
+ ->vsattr_type($vid, $attr)})
+ eq 'CODE';
+ foreach my $datum (@{$self->vsattr($vendor, $attr)}) {
+ my $vval = &{$vsapacker{$self->{'Dict'}->vsattr_type($vid, $attr)}}
+ ($datum, $self->{'Dict'}->vsattr_num($vid, $attr), $vendor);
+
+ if ($vid == 429) {
+
+ # As pointed out by Quan Choi,
+ # we need special code to handle the
+ # 3Com case - See RFC-2882, sec 2.3.1
+
+ $attstr .= pack $p_vsa_3com, 26,
+ length($vval) + 10, $vid,
+ $self->{'Dict'}->vsattr_num($vid, $attr),
+ $vval;
+ }
+ else
+ {
+ $attstr .= pack $p_vsa, 26, length($vval) + 8, $vid,
+ $self->{'Dict'}->vsattr_num($vid, $attr),
+ length($vval) + 2, $vval;
+ }
+ }
+ }
+ }
+
+ # Prepend the header and return the complete binary packet
+ return pack $p_hdr, $codes{$self->code}, $self->identifier,
+ length($attstr) + $hdrlen, $self->authenticator,
+ $attstr;
+}
+
+sub unpack {
+ my ($self, $data) = @_;
+ my $dict = $self->{Dict};
+ my $p_hdr = "C C n a16 a*"; # Pack template for header
+ my $p_attr = "C C a*"; # Pack template for attribute
+ my $p_taggedattr = "C C C a*"; # Pack template for tagged-attribute
+ my %rcodes = $dict->packet_names();
+
+ # Decode the header
+ my ($code, $id, $len, $auth, $attrdat) = unpack $p_hdr, $data;
+
+ # Generate a skeleton data structure to be filled in
+ $self->set_code($rcodes{$code});
+ $self->set_identifier($id);
+ $self->set_authenticator($auth);
+
+ # Functions for the various data types
+ my %unpacker =
+ (
+ "string" => sub {
+ return $_[0];
+ },
+ "ipv6addr" => sub { return $_[0]; },
+ "date" => sub { return $_[0]; },
+ "ifid" => sub { return $_[0]; },
+ "octets" => sub {
+ return $_[0];
+ },
+ "integer" => sub {
+ my $num=unpack("N", $_[0]);
+ return ( defined $dict->val_has_name($_[1]) &&
+ defined $dict->val_name($_[1],$num) ) ?
+ ($dict->val_name($_[1],$num),undef,$num) : $num ;
+ },
+ "ipaddr" => sub {
+ return length($_[0]) == 4 ? inet_ntoa($_[0]) : $_[0];
+ },
+ "address" => sub {
+ return length($_[0]) == 4 ? inet_ntoa($_[0]) : $_[0];
+ },
+ "time" => sub {
+ return unpack "N", $_[0];
+ },
+ "date" => sub {
+ return unpack "N", $_[0];
+ },
+ "tagged-string" => sub {
+ my ($tag,$val) = unpack "a a*", $_[0];
+ return $val, $tag;
+ },
+ "tagged-integer" => sub {
+ my ($tag,$num) = unpack "a a*", $_[0];
+ return ( defined $dict->val_has_name($_[1]) &&
+ defined $dict->val_name($_[1],$num) ) ?
+ $dict->val_name($_[1],$num) : $num
+ ,$tag ;
+ },
+ "tagged-ipaddr" => sub {
+ my ( $tag, $num ) = unpack "a a*", $_[0];
+ return inet_ntoa($num), $tag;
+ });
+
+ my %vsaunpacker =
+ (
+ "octets" => sub {
+ return $_[0];
+ },
+ "string" => sub {
+ return $_[0];
+ },
+ "ipv6addr" => sub { return $_[0]; },
+ "date" => sub { return $_[0]; },
+ "ifid" => sub { return $_[0]; },
+ "integer" => sub {
+ my $num=unpack("N", $_[0]);
+ return ( $dict->vsaval_has_name($_[2], $_[1])
+ && $dict->vsaval_name($_[2], $_[1],$num) )
+ ? ( $dict->vsaval_name($_[2], $_[1], $num ), undef, $num)
+ : $num;
+ },
+ "ipaddr" => sub {
+ return length($_[0]) == 4 ? inet_ntoa($_[0]) : $_[0];
+ },
+ "address" => sub {
+ return length($_[0]) == 4 ? inet_ntoa($_[0]) : $_[0];
+ },
+ "time" => sub {
+ return unpack "N", $_[0];
+ },
+ "date" => sub {
+ return unpack "N", $_[0];
+ },
+ "tagged-string" => sub {
+ my ($tag,$val) = unpack "a a*", $_[0];
+ return $val, $tag;
+ },
+ "tagged-integer" => sub {
+ my ( $tag, $num ) = unpack "a a*", $_[0];
+ return ($dict->vsaval_has_name($_[2], $_[1])
+ && $dict->vsaval_name($_[2], $_[1],$num)
+ )?$dict->vsaval_name($_[2], $_[1],$num):$num
+ , $tag ;
+
+ },
+ "tagged-ipaddr" => sub {
+ my ( $tag, $num ) = unpack "a a*", $_[0];
+ return inet_ntoa($num), $tag;
+ });
+
+ # Unpack the attributes
+ while (length($attrdat))
+ {
+ my $length = unpack "x C", $attrdat;
+ my ($type, $value) = unpack "C x a${\($length-2)}", $attrdat;
+ if ($type == $VSA) { # Vendor-Specific Attribute
+ my ($vid) = unpack "N", $value;
+ substr ($value, 0, 4) = "";
+
+ while (length($value))
+ {
+ my ($vtype, $vlength) = unpack "C C", $value;
+
+ # XXX - How do we calculate the length
+ # of the VSA? It's not defined!
+
+ # XXX - 3COM seems to do things a bit differently.
+ # The IF below takes care of that. This was contributed by
+ # Ian Smith. Check the file CHANGES on this distribution for
+ # more information.
+
+ my $vvalue;
+ if ($vid == 429)
+ {
+ ($vtype) = unpack "N", $value;
+ $vvalue = unpack "xxxx a${\($length-10)}", $value;
+ }
+ else
+ {
+ $vvalue = unpack "x x a${\($vlength-2)}", $value;
+ }
+
+ if ((not defined $dict->vsattr_numtype($vid, $vtype)) or
+ (ref $vsaunpacker{$dict->vsattr_numtype($vid, $vtype)}
+ ne 'CODE'))
+ {
+ my $whicherr
+ = (defined $dict->vsattr_numtype($vid, $vtype)) ?
+ "Garbled":"Unknown";
+ warn "$whicherr vendor attribute $vid/$vtype for unpack()\n"
+ unless $unkvprinted{"$vid/$vtype"};
+ $unkvprinted{"$vid/$vtype"} = 1;
+ substr($value, 0, $vlength) = ""; # Skip this section
+ next;
+ }
+ my ($val, $tag, $rawValue) =
+ &{$vsaunpacker{$dict->vsattr_numtype($vid, $vtype)}}($vvalue,
+ $vtype,
+ $vid);
+ if ( defined $tag )
+ {
+ $val = "-emtpy-" unless defined $val;
+ $self->set_taggedvsattr($vid,
+ $dict->vsattr_name($vid, $vtype),
+ $val,
+ $tag);
+ }
+ else
+ {
+ $self->set_vsattr($vid, $dict->vsattr_name($vid, $vtype),
+ $val, undef, $rawValue);
+ }
+ substr($value, 0, $vlength) = "";
+ }
+ }
+ else
+ { # Normal attribute
+ if ((not defined $dict->attr_numtype($type)) or
+ (ref ($unpacker{$dict->attr_numtype($type)}) ne 'CODE'))
+ {
+ my $whicherr = (defined $dict->attr_numtype($type)) ?
+ "Garbled":"Unknown";
+ warn "$whicherr general attribute $type for unpack()\n"
+ unless $unkgprinted{$type};
+ $unkgprinted{$type} = 1;
+ substr($attrdat, 0, $length) = ""; # Skip this section
+ next;
+ }
+ my ($val,$tag,$rawValue) = &{$unpacker{$dict->attr_numtype($type)}}($value,
+ $type);
+ if ( defined $tag ) {
+ if ( ! defined $val ) { $val = "-emtpy-" };
+ $self->set_taggedattr($dict->attr_name($type), $val , $tag);
+ }
+ else {
+ $self->set_attr($dict->attr_name($type), $val, undef, $rawValue);
+ }
+ }
+ substr($attrdat, 0, $length) = ""; # Skip this section
+ }
+}
+
+1;
diff --git a/Radius/README.Net-Radius b/Radius/README.Net-Radius
new file mode 100644
index 0000000..cc1d127
--- /dev/null
+++ b/Radius/README.Net-Radius
@@ -0,0 +1,119 @@
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+
+
+Net::Radius Modules
+===================
+
+The modules included here provide an interface to the RADIUS
+protocol. It consists of the following modules:
+
+Net::Radius::Packet - Deals with RADIUS packets
+Net::Radius::Dictionary - Deals with RADIUS dictionaries
+
+This module is essentially the original RADIUS-1.0 distribution by
+Christopher Masto plus a number of changes and fixes by Luis Muñoz and
+Ian Smith.
+
+It has been changed so that it better fits the CPAN namespace. See the
+other README.* files in this archive for additional information.
+
+The installation follows the standard protocol...
+
+$ perl Makefile.PL
+$ make
+$ make test
+$ make install
+
+The ./examples directory contain a number of simple examples.
+
+This code supports the use of vendor specific attributes. This
+type of attribute is defined in RFC-2138 and is used to support
+'propietary' extensions on top of the base RADIUS specification.
+
+There are two new kinds of entries in the RADIUS dictionary in
+order to specify VSAs.
+
+VENDORATTR <vendor> <attribute> <id> <type>
+
+This entry is used to create a new kind of vendor attribute,
+such as in this example
+
+VENDORATTR 9 cisco-avpair 1 string
+
+This creates a new vendor-specific attribute for vendor 9 (Cisco
+Systems), with name 'cisco-avpair'. This attribute is identified by
+numeric id '1' and is associated with a string value.
+
+The second type of entry allows the specification of named values.
+The following is an hypotetical example of named value entry.
+
+VENDORATTR 9 cisco-enum 254 integer
+VENDORVALUE 9 cisco-enum Value-1 1
+VENDORVALUE 9 cisco-enum Value-2 2
+VENDORVALUE 9 cisco-enum Value-3 3
+
+Alternatively, you can use the widely deployed FreeRadius dictionary
+files' syntax of:
+
+VENDOR Cisco 9
+ATTRIBUTE Cisco-AVPair 1 string Cisco
+
+About the stability, this code has been in very active use at a
+largish ISP with millions of users using a variety of network
+equipment with impressive results. It has been succesfully used under
+FreeBSD, Linux, Solaris and Tru64.
+
+There's copious support material along with this distribution. Please
+do take a look.
+
+DO YOU WANT TO THANK ME?
+
+If you consider this a valuable contribution, there is a web page
+where you can express your gratitude. Please see
+
+ http://mipagina.cantv.net/lem/thanks-en.html (English)
+ http://mipagina.cantv.net/lem/thanks-es.html (Spanish)
+
+SECURITY CONSIDERATIONS
+
+I have no control on the machanisms involved in the storage or
+transport of this distribution. This means that I cannot guarantee
+that the distribution you have in your hands is indeed, the same
+distribution I packed and uploaded.
+
+Along the distribution file, you should have a file with the extension
+".asc". This contains a GPG "detached signature" that makes it
+impossible for anybody to alter this distribution. If security is of
+any concern to you, by all means verify the signature of this file and
+contact the author if any discrepancy is detected.
+
+You can find more information about this at the following URL
+
+ http://mipagina.cantv.net/lem/gpg/
+
+COPYRIGHT AND LICENSE
+
+Original work (c) Christopher Masto. Changes (c) 2002,2003 Luis
+E. Muñoz <luismunoz@cpan.org>.
+
+This software can be used under the same terms as perl itself. It also
+carries the same warranties.
+
+Please send bug reports (or patches) as well as feedback and
+suggestions to
+
+luismunoz@cpan.org
+
+When submitting bugs, it is very important that you include the
+relevant information for reproducing the bug. Packet dumps are most
+useful.
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.2.1 (Darwin)
+
+iD8DBQFEznquQyDWGRI/hhARAq37AJ4nwkdiU1eqgpTObZ0G2QZ0jvQU2QCgkR28
+nf3syw7TJsGGyrr/KSTcyfU=
+=Of85
+-----END PGP SIGNATURE-----
diff --git a/dicts/dictionary b/dicts/dictionary
new file mode 100644
index 0000000..34cbefb
--- /dev/null
+++ b/dicts/dictionary
@@ -0,0 +1,266 @@
+# Basic radius dictionary
+# Copyright (C) 2009-2013, AllWorldIT
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+ATTRIBUTE User-Name 1 string
+ATTRIBUTE User-Password 2 string
+ATTRIBUTE CHAP-Password 3 string
+ATTRIBUTE NAS-IP-Address 4 ipaddr
+ATTRIBUTE NAS-Port 5 integer
+ATTRIBUTE Service-Type 6 integer
+ATTRIBUTE Framed-Protocol 7 integer
+ATTRIBUTE Framed-IP-Address 8 ipaddr
+ATTRIBUTE Framed-IP-Netmask 9 ipaddr
+ATTRIBUTE Framed-Routing 10 integer
+ATTRIBUTE Filter-Id 11 string
+ATTRIBUTE Framed-MTU 12 integer
+ATTRIBUTE Framed-Compression 13 integer
+ATTRIBUTE Login-IP-Host 14 ipaddr
+ATTRIBUTE Login-Service 15 integer
+ATTRIBUTE Login-TCP-Port 16 integer
+ATTRIBUTE Reply-Message 18 string
+ATTRIBUTE Callback-Number 19 string
+ATTRIBUTE Callback-Id 20 string
+ATTRIBUTE Framed-Route 22 string
+ATTRIBUTE Framed-IPX-Network 23 ipaddr
+ATTRIBUTE State 24 string
+ATTRIBUTE Class 25 string
+ATTRIBUTE Vendor-Specific 26 string
+ATTRIBUTE Session-Timeout 27 integer
+ATTRIBUTE Idle-Timeout 28 integer
+ATTRIBUTE Termination-Action 29 integer
+ATTRIBUTE Called-Station-Id 30 string
+ATTRIBUTE Calling-Station-Id 31 string
+ATTRIBUTE NAS-Identifier 32 string
+ATTRIBUTE Proxy-State 33 string
+ATTRIBUTE Login-LAT-Service 34 string
+ATTRIBUTE Login-LAT-Node 35 string
+ATTRIBUTE Login-LAT-Group 36 string
+ATTRIBUTE Framed-AppleTalk-Link 37 integer
+ATTRIBUTE Framed-AppleTalk-Network 38 integer
+ATTRIBUTE Framed-AppleTalk-Zone 39 string
+
+ATTRIBUTE Acct-Status-Type 40 integer
+ATTRIBUTE Acct-Delay-Time 41 integer
+ATTRIBUTE Acct-Input-Octets 42 integer
+ATTRIBUTE Acct-Output-Octets 43 integer
+ATTRIBUTE Acct-Session-Id 44 string
+ATTRIBUTE Acct-Authentic 45 integer
+ATTRIBUTE Acct-Session-Time 46 integer
+ATTRIBUTE Acct-Input-Packets 47 integer
+ATTRIBUTE Acct-Output-Packets 48 integer
+ATTRIBUTE Acct-Terminate-Cause 49 integer
+ATTRIBUTE Acct-Multi-Session-Id 50 string
+ATTRIBUTE Acct-Link-Count 51 integer
+ATTRIBUTE Acct-Input-Gigawords 52 integer
+ATTRIBUTE Acct-Output-Gigawords 53 integer
+ATTRIBUTE Event-Timestamp 55 date
+
+ATTRIBUTE CHAP-Challenge 60 string
+ATTRIBUTE NAS-Port-Type 61 integer
+ATTRIBUTE Port-Limit 62 integer
+ATTRIBUTE Login-LAT-Port 63 integer
+
+ATTRIBUTE Acct-Tunnel-Connection 68 string
+
+ATTRIBUTE ARAP-Password 70 string
+ATTRIBUTE ARAP-Features 71 string
+ATTRIBUTE ARAP-Zone-Access 72 integer
+ATTRIBUTE ARAP-Security 73 integer
+ATTRIBUTE ARAP-Security-Data 74 string
+ATTRIBUTE Password-Retry 75 integer
+ATTRIBUTE Prompt 76 integer
+ATTRIBUTE Connect-Info 77 string
+ATTRIBUTE Configuration-Token 78 string
+ATTRIBUTE EAP-Message 79 string
+ATTRIBUTE Message-Authenticator 80 string
+ATTRIBUTE ARAP-Challenge-Response 84 string
+ATTRIBUTE Acct-Interim-Interval 85 integer
+ATTRIBUTE NAS-Port-Id 87 string
+ATTRIBUTE Framed-Pool 88 string
+ATTRIBUTE NAS-IPv6-Address 95 ipv6addr
+ATTRIBUTE Framed-Interface-Id 96 ifid
+ATTRIBUTE Framed-IPv6-Prefix 97 string
+ATTRIBUTE Login-IPv6-Host 98 ipv6addr
+ATTRIBUTE Framed-IPv6-Route 99 string
+ATTRIBUTE Framed-IPv6-Pool 100 string
+
+# As defined in RFC 3576
+ATTRIBUTE Error-Cause 101 integer
+
+# As defined in draft-sterman-aaa-sip-00.txt
+ATTRIBUTE Digest-Response 206 string
+ATTRIBUTE Digest-Attributes 207 string
+
+
+#
+# Integer Translations
+#
+
+# User Types
+VALUE Service-Type Login-User 1
+VALUE Service-Type Framed-User 2
+VALUE Service-Type Callback-Login-User 3
+VALUE Service-Type Callback-Framed-User 4
+VALUE Service-Type Outbound-User 5
+VALUE Service-Type Administrative-User 6
+VALUE Service-Type NAS-Prompt-User 7
+VALUE Service-Type Authenticate-Only 8
+VALUE Service-Type Callback-NAS-Prompt 9
+VALUE Service-Type Call-Check 10
+VALUE Service-Type Callback-Administrative 11
+VALUE Service-Type Voice 12
+VALUE Service-Type Fax 13
+VALUE Service-Type Modem-Relay 14
+VALUE Service-Type IAPP-Register 15
+VALUE Service-Type IAPP-AP-Check 16
+VALUE Service-Type Authorize-Only 17
+
+
+# Framed Protocols
+VALUE Framed-Protocol PPP 1
+VALUE Framed-Protocol SLIP 2
+VALUE Framed-Protocol ARAP 3
+VALUE Framed-Protocol Gandalf-SLML 4
+VALUE Framed-Protocol Xylogics-IPX-SLIP 5
+VALUE Framed-Protocol X.75-Synchronous 6
+VALUE Framed-Protocol GPRS-PDP-Context 7
+
+# Framed Routing Values
+VALUE Framed-Routing None 0
+VALUE Framed-Routing Broadcast 1
+VALUE Framed-Routing Listen 2
+VALUE Framed-Routing Broadcast-Listen 3
+
+# Framed Compression Types
+VALUE Framed-Compression None 0
+VALUE Framed-Compression Van-Jacobson-TCP-IP 1
+VALUE Framed-Compression IPX-Header-Compression 2
+VALUE Framed-Compression Stac-LZS 3
+
+# Login Services
+VALUE Login-Service Telnet 0
+VALUE Login-Service Rlogin 1
+VALUE Login-Service TCP-Clear 2
+VALUE Login-Service PortMaster 3
+VALUE Login-Service LAT 4
+VALUE Login-Service X25-PAD 5
+VALUE Login-Service X25-T3POS 6
+VALUE Login-Service TCP-Clear-Quiet 7
+
+# Login-TCP-Port
+VALUE Login-TCP-Port Telnet 23
+VALUE Login-TCP-Port Rlogin 513
+VALUE Login-TCP-Port Rsh 514
+
+# Status Types
+VALUE Acct-Status-Type Start 1
+VALUE Acct-Status-Type Stop 2
+VALUE Acct-Status-Type Interim-Update 3
+VALUE Acct-Status-Type Accounting-On 7
+VALUE Acct-Status-Type Accounting-Off 8
+# RFC 2867 Additional Status-Type Values
+VALUE Acct-Status-Type Tunnel-Start 9
+VALUE Acct-Status-Type Tunnel-Stop 10
+VALUE Acct-Status-Type Tunnel-Reject 11
+VALUE Acct-Status-Type Tunnel-Link-Start 12
+VALUE Acct-Status-Type Tunnel-Link-Stop 13
+VALUE Acct-Status-Type Tunnel-Link-Reject 14
+VALUE Acct-Status-Type Failed 15
+
+# Authentication Types
+VALUE Acct-Authentic RADIUS 1
+VALUE Acct-Authentic Local 2
+VALUE Acct-Authentic Remote 3
+VALUE Acct-Authentic Diameter 4
+
+# Termination Options
+VALUE Termination-Action Default 0
+VALUE Termination-Action RADIUS-Request 1
+
+# NAS Port Types
+VALUE NAS-Port-Type Async 0
+VALUE NAS-Port-Type Sync 1
+VALUE NAS-Port-Type ISDN 2
+VALUE NAS-Port-Type ISDN-V120 3
+VALUE NAS-Port-Type ISDN-V110 4
+VALUE NAS-Port-Type Virtual 5
+VALUE NAS-Port-Type PIAFS 6
+VALUE NAS-Port-Type HDLC-Clear-Channel 7
+VALUE NAS-Port-Type X.25 8
+VALUE NAS-Port-Type X.75 9
+VALUE NAS-Port-Type G.3-Fax 10
+VALUE NAS-Port-Type SDSL 11
+VALUE NAS-Port-Type ADSL-CAP 12
+VALUE NAS-Port-Type ADSL-DMT 13
+VALUE NAS-Port-Type IDSL 14
+VALUE NAS-Port-Type Ethernet 15
+VALUE NAS-Port-Type xDSL 16
+VALUE NAS-Port-Type Cable 17
+VALUE NAS-Port-Type Wireless-Other 18
+VALUE NAS-Port-Type Wireless-802.11 19
+VALUE NAS-Port-Type Token-Ring 20
+VALUE NAS-Port-Type FDDI 21
+VALUE NAS-Port-Type Wireless-CDMA2000 22
+VALUE NAS-Port-Type Wireless-UMTS 23
+VALUE NAS-Port-Type Wireless-1X-EV 24
+VALUE NAS-Port-Type IAPP 25
+VALUE NAS-Port-Type FTTP 26
+
+# Acct Terminate Causes
+VALUE Acct-Terminate-Cause User-Request 1
+VALUE Acct-Terminate-Cause Lost-Carrier 2
+VALUE Acct-Terminate-Cause Lost-Service 3
+VALUE Acct-Terminate-Cause Idle-Timeout 4
+VALUE Acct-Terminate-Cause Session-Timeout 5
+VALUE Acct-Terminate-Cause Admin-Reset 6
+VALUE Acct-Terminate-Cause Admin-Reboot 7
+VALUE Acct-Terminate-Cause Port-Error 8
+VALUE Acct-Terminate-Cause NAS-Error 9
+VALUE Acct-Terminate-Cause NAS-Request 10
+VALUE Acct-Terminate-Cause NAS-Reboot 11
+VALUE Acct-Terminate-Cause Port-Unneeded 12
+VALUE Acct-Terminate-Cause Port-Preempted 13
+VALUE Acct-Terminate-Cause Port-Suspended 14
+VALUE Acct-Terminate-Cause Service-Unavailable 15
+VALUE Acct-Terminate-Cause Callback 16
+VALUE Acct-Terminate-Cause User-Error 17
+VALUE Acct-Terminate-Cause Host-Request 18
+VALUE Acct-Terminate-Cause Supplicant-Restart 19
+VALUE Acct-Terminate-Cause Reauthentication-Failure 20
+VALUE Acct-Terminate-Cause Port-Reinit 21
+VALUE Acct-Terminate-Cause Port-Disabled 22
+
+# Prompt - As per RFC2869
+VALUE Prompt No-Echo 0
+VALUE Prompt Echo 1
+
+# Error-Cause - As per RFC3576
+VALUE Error-Cause Residual-Context-Removed 201
+VALUE Error-Cause Invalid-EAP-Packet 202
+VALUE Error-Cause Unsupported-Attribute 401
+VALUE Error-Cause Missing-Attribute 402
+VALUE Error-Cause NAS-Identification-Mismatch 403
+VALUE Error-Cause Invalid-Request 404
+VALUE Error-Cause Unsupported-Service 405
+VALUE Error-Cause Unsupported-Extension 406
+VALUE Error-Cause Administratively-Prohibited 501
+VALUE Error-Cause Proxy-Request-Not-Routable 502
+VALUE Error-Cause Session-Context-Not-Found 503
+VALUE Error-Cause Session-Context-Not-Removable 504
+VALUE Error-Cause Proxy-Processing-Error 505
+VALUE Error-Cause Resources-Unavailable 506
+VALUE Error-Cause Request-Initiated 507
+
diff --git a/dicts/dictionary.allworldit b/dicts/dictionary.allworldit
new file mode 100644
index 0000000..75cec44
--- /dev/null
+++ b/dicts/dictionary.allworldit
@@ -0,0 +1,24 @@
+# AllWorldIT vendor radius dictionary
+# Copyright (C) 2009-2013, AllWorldIT
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+
+VENDOR AllWorldIT 11111
+
+ATTRIBUTE OpenTrafficShaper-Traffic-Limit 1 string AllWorldIT
+ATTRIBUTE OpenTrafficShaper-Traffic-Group 2 integer AllWorldIT
+ATTRIBUTE OpenTrafficShaper-Traffic-Class 3 integer AllWorldIT
+
diff --git a/opentrafficshaper.conf b/opentrafficshaper.conf
new file mode 100644
index 0000000..377353a
--- /dev/null
+++ b/opentrafficshaper.conf
@@ -0,0 +1,8 @@
+[system]
+
+[plugins]
+load=webserver
+
+[dictionary]
+load=dicts/dictionary
+load=dicts/dictionary.allworldit
diff --git a/opentrafficshaper/logger.pm b/opentrafficshaper/logger.pm
new file mode 100644
index 0000000..2c009b4
--- /dev/null
+++ b/opentrafficshaper/logger.pm
@@ -0,0 +1,95 @@
+# Logging functionality
+# Copyright (C) 2007-2013, AllWorldIT
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+package opentrafficshaper::logger;
+
+use strict;
+use warnings;
+
+
+# Exporter stuff
+require Exporter;
+our (@ISA,@EXPORT,@EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT = qw(
+ LOG_ERR
+ LOG_WARN
+ LOG_NOTICE
+ LOG_INFO
+ LOG_DEBUG
+);
+@EXPORT_OK = qw(
+);
+
+
+use constant {
+ LOG_ERR => 0,
+ LOG_WARN => 1,
+ LOG_NOTICE => 2,
+ LOG_INFO => 3,
+ LOG_DEBUG => 4
+};
+
+
+use POSIX qw( strftime );
+
+
+
+# Instantiate
+sub new {
+ my ($class) = @_;
+ my $self = { };
+ bless $self, $class;
+ return $self;
+}
+
+# Logging function
+sub log
+{
+ my ($self,$level,$msg,@args) = @_;
+
+ # Check log level and set text
+ my $logtxt = "UNKNOWN";
+ if ($level == LOG_DEBUG) {
+ $logtxt = "DEBUG";
+ } elsif ($level == LOG_INFO) {
+ $logtxt = "INFO";
+ } elsif ($level == LOG_NOTICE) {
+ $logtxt = "NOTICE";
+ } elsif ($level == LOG_WARN) {
+ $logtxt = "WARNING";
+ } elsif ($level == LOG_ERR) {
+ $logtxt = "ERROR";
+ }
+
+ # Parse message nicely
+ if ($msg =~ /^(\[[^\]]+\]) (.*)/s) {
+ $msg = "$1 $logtxt: $2";
+ } else {
+ $msg = "[CORE] $logtxt: $msg";
+ }
+
+ # If we have args, this is more than likely a format string & args
+ if (@args > 0) {
+ $msg = sprintf($msg,@args);
+ }
+# $self->SUPER::log($level,"[".$self->log_time." - $$] $msg");
+ print(STDERR "[".strftime('%F %T',localtime)." - $$] $msg\n");
+}
+
+1;
+# vim: ts=4
diff --git a/opentrafficshaper/plugins/webserver/webserver.pm b/opentrafficshaper/plugins/webserver/webserver.pm
new file mode 100644
index 0000000..530d91e
--- /dev/null
+++ b/opentrafficshaper/plugins/webserver/webserver.pm
@@ -0,0 +1,118 @@
+# OpenTrafficShaper webserver module
+# Copyright (C) 2007-2013, AllWorldIT
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+
+package opentrafficshaper::plugins::webserver;
+
+use strict;
+use warnings;
+
+
+use POE;
+
+
+# Exporter stuff
+require Exporter;
+our (@ISA,@EXPORT,@EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT = qw(
+);
+@EXPORT_OK = qw(
+);
+
+use constant {
+ VERSION => '0.0.1'
+};
+
+
+# Plugin info
+our $pluginInfo = {
+ Name => "Webserver",
+ Version => VERSION,
+
+ Init => \&init,
+};
+
+
+# Copy of system globals
+my $globals;
+
+
+# Initialize plugin
+sub init
+{
+ $globals = shift;
+
+
+ print STDERR "HI HTERE!! \n";
+
+
+ # Spawn a web server on port 8088 of all interfaces.
+ POE::Component::Server::TCP->new(
+ Alias => "webserver",
+ Port => 8088,
+ ClientFilter => 'POE::Filter::HTTPD',
+ # Function to handle HTTP requests (as we passing through a filter)
+ ClientInput => \&handle_request
+ );
+}
+
+
+sub handle_request
+{
+ my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
+
+
+ # We may have a response from the filter indicating an error
+ if ($request->isa("HTTP::Response")) {
+ $heap->{client}->put($request);
+ $kernel->yield("shutdown");
+ return;
+ }
+
+ my $response = HTTP::Response->new(200);
+ $response->push_header('Content-type', 'text/html');
+
+ my $content =
+ # Break the HTML tag for the wiki.
+ "<html><head><title>Your Request</title></head>"
+ ;
+
+
+ $content .= "<table>";
+ $content .= " <tr><td>User</td><td>IP</td></tr>";
+ foreach my $user (keys %{$globals->{'users'}}) {
+ $content .= " <tr><td>".$user."</td><td>".$globals->{'users'}->{$user}."</td></tr>";
+ }
+
+ $content .= "</table>";
+
+ $content .= "</body></html>";
+
+ $response->content($content);
+ # Once the content has been built, send it back to the client
+ # and schedule a shutdown.
+
+ $heap->{client}->put($response);
+ $kernel->yield("shutdown");
+}
+
+
+
+
+1;
+# vim: ts=4
diff --git a/opentrafficshaper/version.pm b/opentrafficshaper/version.pm
new file mode 100644
index 0000000..ab286d3
--- /dev/null
+++ b/opentrafficshaper/version.pm
@@ -0,0 +1,39 @@
+# OpenTrafficShaper version package
+# Copyright (C) 2007-2013, AllWorldIT
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+package opentrafficshaper::version;
+
+use strict;
+use warnings;
+
+
+# Exporter stuff
+require Exporter;
+our (@ISA,@EXPORT,@EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT = qw(
+ VERSION
+);
+
+
+use constant {
+ VERSION => "1.0.0",
+};
+
+
+
+1;
+# vim: ts=4
diff --git a/opentrafficshaperd b/opentrafficshaperd
new file mode 100755
index 0000000..f904a47
--- /dev/null
+++ b/opentrafficshaperd
@@ -0,0 +1,467 @@
+#!/usr/bin/perl
+# Main OpenTrafficShaper program
+# Copyright (C) 2007-2013, AllWorldIT
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+use strict;
+use warnings;
+
+
+# Set the dirs we look for library files in
+use lib('/usr/local/lib/opentrafficshaper-1.0','/usr/lib/opentrafficshaper-1.0',
+ '/usr/lib64/opentrafficshaper-1.0','opentrafficshaper','awitpt');
+
+# System stuff we need
+use Config::IniFiles;
+use Getopt::Long;
+use Time::HiRes qw(time);
+
+# UDP
+use IO::Socket::INET;
+use constant DATAGRAM_MAXLEN => 1500;
+
+# TCP/HTTP
+use POE qw(Component::Server::TCP Filter::HTTPD);
+use HTTP::Response;
+
+# Our own stuff
+use opentrafficshaper::version;
+use opentrafficshaper::logger;
+use Radius::Dictionary;
+use Radius::Packet;
+
+
+# Main config
+my $globals;
+# We just create the logger first, its only using STDERR here
+my $logger = new opentrafficshaper::logger;
+
+
+
+# Process basically starts here
+$logger->log(LOG_NOTICE,"[MAIN] OpenTrafficShaper v".VERSION." - Copyright (c) 2007-2013, AllWorldIT");
+parseCfgCmdLine();
+init();
+
+
+
+
+# This is our configuration processing session
+# TODO: Current just a trigger
+POE::Session->create(
+ inline_states => {
+ _start => sub {
+ $_[KERNEL]->delay(tick => 5);
+ },
+
+ tick => sub {
+ print STDERR "tick at ", time(), ": users = ". (keys %{$globals->{'users'}}) ."\n";
+ $_[KERNEL]->delay(tick => 5);
+ },
+ }
+);
+
+
+
+# Radius listener
+POE::Session->create(
+ inline_states => {
+ _start => \&server_start,
+ get_datagram => \&server_read,
+ }
+);
+
+sub server_start {
+ my $kernel = $_[KERNEL];
+ my $socket = IO::Socket::INET->new(
+ Proto => 'udp',
+ LocalPort => '1812',
+ );
+ my $socket2 = IO::Socket::INET->new(
+ Proto => 'udp',
+ LocalPort => '1813',
+ );
+ die "Couldn't create server socket: $!" unless $socket;
+ $kernel->select_read($socket, "get_datagram");
+ $kernel->select_read($socket2, "get_datagram");
+}
+
+sub server_read {
+ my ($kernel, $socket) = @_[KERNEL, ARG0];
+ my $remote_address = recv($socket, my $udp_packet = "", DATAGRAM_MAXLEN, 0);
+ return unless defined $remote_address;
+ my ($peer_port, $peer_addr) = unpack_sockaddr_in($remote_address);
+ my $human_addr = inet_ntoa($peer_addr);
+
+ print "(server) $human_addr : $peer_port sent us a packet\n";
+
+
+
+ # Parse packet
+ my $pkt = new Radius::Packet($globals->{'radius'}->{'dictionary'},$udp_packet);
+
+ my $logLine = sprintf("Code: %s, Identifier: %s => ",$pkt->code,$pkt->identifier);
+foreach my $attr ($pkt->attributes) {
+ $logLine .= sprintf(" %s: '%s',", $attr, $pkt->rawattr($attr));
+}
+
+ # Add vattributes onto logline
+ $logLine .= ". VREPLY => ";
+ # Loop with vendors
+ foreach my $vendor ($pkt->vendors()) {
+ # Loop with attributes
+ foreach my $attr ($pkt->vsattributes($vendor)) {
+ # Grab the value
+ my @attrRawVal = ( $pkt->vsattr($vendor,$attr) );
+ my $attrVal = $attrRawVal[0][0];
+ # Sanatize it a bit
+ if ($attrVal =~ /[[:cntrl:]]/) {
+ $attrVal = "-nonprint-";
+ } else {
+ $attrVal = "'$attrVal'";
+ }
+
+ $logLine .= sprintf(" %s/%s: %s,",$vendor,$attr,$attrVal);
+ }
+ }
+
+
+ # Pull in a variables from packet
+ my $user = $pkt->rawattr("User-Name");
+ my $trafficGroup;
+ if (my $attrRawVal = $pkt->vsattr(11111,'OpenTrafficShaper-Traffic-Group')) {
+ $trafficGroup = @{ $attrRawVal }[0];
+ }
+ my $trafficClass;
+ if (my $attrRawVal = $pkt->vsattr(11111,'OpenTrafficShaper-Traffic-Class')) {
+ $trafficClass = @{ $attrRawVal }[0];
+ }
+ my $trafficLimit;
+ if (my $attrRawVal = $pkt->vsattr(11111,'OpenTrafficShaper-Traffic-Limit')) {
+ $trafficLimit = @{ $attrRawVal }[0];
+ }
+
+ # Grab rate limits from the string we got
+ my $trafficLimitRx = 0; my $trafficLimitTx = 0;
+ my $trafficLimitRxBurst = 0; my $trafficLimitTxBurst = 0;
+ if (defined($trafficLimit)) {
+ my ($trafficLimitRxQuantifier,$trafficLimitTxQuantifier);
+ my ($trafficLimitRxBurstQuantifier,$trafficLimitTxBurstQuantifier);
+ # Match rx-rate[/tx-rate] rx-burst-rate[/tx-burst-rate]
+ if ($trafficLimit =~ /^(\d+)([km])(?:\/(\d+)([km]))?(?: (\d+)([km])(?:\/(\d+)([km]))?)?/) {
+ $trafficLimitRx = getKbit($1,$2);
+ $trafficLimitTx = getKbit($3,$4);
+ $trafficLimitRxBurst = getKbit($5,$6);
+ $trafficLimitTxBurst = getKbit($7,$8);
+ }
+ }
+
+ # Set default if they undefined
+ if (!defined($trafficGroup)) {
+ $trafficGroup = 0;
+ }
+ if (!defined($trafficClass)) {
+ $trafficClass = 0;
+ }
+
+ my $userIP = $pkt->attr('Framed-IP-Address');
+
+ my $status = $pkt->rawattr('Acct-Status-Type');
+
+
+ $globals->{'users'}->{$user} = $userIP;
+
+ $logger->log(LOG_DEBUG,"=> Code: $status, User: $user, IP: $userIP, Group: $trafficGroup, Class: $trafficClass, Limits: $trafficLimitRx/$trafficLimitTx, Burst: $trafficLimitRxBurst/$trafficLimitTxBurst");
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#
+# MAIN
+#
+POE::Kernel->run();
+exit;
+
+
+
+
+
+# Function to parse our config and commandline
+sub parseCfgCmdLine
+{
+
+ # Set defaults
+ my $cfg;
+ $cfg->{'config_file'} = "/etc/opentrafficshaper.conf";
+
+ $cfg->{'timeout'} = 120;
+ $cfg->{'background'} = "yes";
+ $cfg->{'pid_file'} = "/var/run/opentrafficshaper/opentrafficshaperd.pid";
+ $cfg->{'log_level'} = 2;
+ $cfg->{'log_file'} = "/var/log/opentrafficshaper/opentrafficshaperd.log";
+
+# $server->{'host'} = "*";
+# $server->{'port'} = [ 1812, 1813 ];
+# $server->{'proto'} = 'udp';
+
+ # Parse command line params
+ my $cmdline;
+ %{$cmdline} = ();
+ GetOptions(
+ \%{$cmdline},
+ "help",
+ "config:s",
+ "debug",
+ "fg",
+ ) or die "Error parsing commandline arguments";
+
+ # Check for some args
+ if ($cmdline->{'help'}) {
+ displayHelp();
+ exit 0;
+ }
+ if (defined($cmdline->{'config'}) && $cmdline->{'config'} ne "") {
+ $cfg->{'config_file'} = $cmdline->{'config'};
+ }
+
+ # Check config file exists
+ if (! -f $cfg->{'config_file'}) {
+ die("No configuration file '".$cfg->{'config_file'}."' found!\n");
+ }
+
+ # Use config file, ignore case
+ tie my %inifile, 'Config::IniFiles', (
+ -file => $cfg->{'config_file'},
+ -nocase => 1
+ ) or die "Failed to open config file '".$cfg->{'config_file'}."': $!";
+ # Copy config
+ my %config = %inifile;
+
+ # Pull in params for the server
+ my @server_params = (
+ 'log_level','log_file',
+ 'host',
+ 'pid_file',
+ 'user', 'group',
+ 'timeout',
+ 'background',
+ );
+ foreach my $param (@server_params) {
+ $cfg->{$param} = $config{'server'}{$param} if (defined($config{'server'}{$param}));
+ }
+
+ # Override
+ if ($cmdline->{'debug'}) {
+ $cfg->{'log_level'} = 4;
+ $cfg->{'debug'} = 1;
+ }
+
+ # If we set on commandline for foreground, keep in foreground
+ if ($cmdline->{'fg'} || (defined($config{'server'}{'background'}) && $config{'server'}{'background'} eq "no" )) {
+ $cfg->{'background'} = undef;
+ $cfg->{'log_file'} = undef;
+ } else {
+ $cfg->{'setsid'} = 1;
+ }
+
+ # Loop with logging detail
+ if (defined($config{'server'}{'log_detail'})) {
+ # Lets see what we have to enable
+ foreach my $detail (split(/[,\s;]/,$config{'server'}{'log_detail'})) {
+ $cfg->{'logging'}{$detail} = 1;
+ }
+ }
+
+ #
+ # System plugins
+ #
+ if (ref($config{'plugins'}{'load'}) eq "ARRAY") {
+ foreach my $plugin (@{$config{'plugins'}{'load'}}) {
+ $plugin =~ s/\s+//g;
+ # Skip comments
+ next if ($plugin =~ /^#/);
+ push(@{$cfg->{'plugin_list'}},$plugin);
+ }
+ } elsif (defined($config{'plugins'}{'load'})) {
+ my @pluginList = split(/\s+/,$config{'plugins'}{'load'});
+ foreach my $plugin (@pluginList) {
+ # Skip comments
+ next if ($plugin =~ /^#/);
+ push(@{$cfg->{'plugin_list'}},$plugin);
+ }
+ }
+
+ #
+ # Dictionary configuration
+ #
+ # Split off dictionaries to load
+ if (ref($config{'dictionary'}->{'load'}) eq "ARRAY") {
+ foreach my $dict (@{$config{'dictionary'}->{'load'}}) {
+ $dict =~ s/\s+//g;
+ # Skip comments
+ next if ($dict =~ /^#/);
+ push(@{$cfg->{'dictionary_list'}},$dict);
+ }
+ } elsif (defined($config{'dictionary'}->{'load'})) {
+ my @dictList = split(/\s+/,$config{'dictionary'}->{'load'});
+ foreach my $dict (@dictList) {
+ # Skip comments
+ next if ($dict =~ /^#/);
+ push(@{$cfg->{'dictionary_list'}},$dict);
+ }
+ }
+
+ # Check if the user specified a cache_file in the config
+ if (defined($config{'server'}{'cache_file'})) {
+ $cfg->{'cache_file'} = $config{'server'}{'cache_file'};
+ }
+
+ $globals->{'config'} = $cfg;
+}
+
+
+# Display help
+sub displayHelp {
+
+ print(STDERR<<EOF);
+
+Usage: $0 [args]
+ --config=<file> Configuration file
+ --debug Put into debug mode
+ --fg Don't go into background
+
+EOF
+}
+
+
+# Initialize things we need
+sub init
+{
+ # Certain things we need
+ $globals->{'users'} = { };
+
+
+ # Load dictionaries
+ $logger->log(LOG_INFO,"[INIT] Initializing dictionaries...");
+ my $dict = new Radius::Dictionary;
+ foreach my $df (@{$globals->{'config'}->{'dictionary_list'}}) {
+ # Load dictionary
+ if (!$dict->readfile($df)) {
+ $logger->log(LOG_WARN,"[INIT] Failed to load dictionary '$df': $!");
+ }
+ $logger->log(LOG_DEBUG,"[INIT] Loaded dictionary '$df'.");
+ }
+ $logger->log(LOG_INFO,"[INIT] Dictionaries initialized.");
+ # Store the dictionary
+ $globals->{'radius'}->{'dictionary'} = $dict;
+
+
+ # Load plugins
+ $logger->log(LOG_INFO,"[INIT] Initializing plugins...");
+ foreach my $plugin (@{$globals->{'config'}->{'plugin_list'}}) {
+ # Load plugin
+ my $res = eval("
+ use opentrafficshaper::plugins::${plugin}::${plugin};
+ plugin_register(\$globals,\"${plugin}\",\$opentrafficshaper::plugins::${plugin}::pluginInfo);
+ ");
+ if ($@ || (defined($res) && $res != 0)) {
+ $logger->log(LOG_WARN,"[INIT] Error loading plugin $plugin ($@)");
+ } else {
+ $logger->log(LOG_DEBUG,"[INIT] Plugin '$plugin' loaded.");
+ }
+ }
+ $logger->log(LOG_INFO,"[INIT] Plugins initialized.");
+}
+# Register plugin info
+sub plugin_register {
+ my ($globals,$plugin,$info) = @_;
+
+
+ # If no info, return
+ if (!defined($info)) {
+ $logger->log(LOG_WARN,"WARNING: Plugin info not found for plugin => $plugin\n");
+ return -1;
+ }
+
+ # Set real module name & save
+ $info->{'Plugin'} = $plugin;
+# push(@{$logger->{'module_list'}},$info);
+
+ # If we should, init the module
+ if (defined($info->{'Init'})) {
+ $info->{'Init'}($globals);
+ }
+
+ return 0;
+}
+
+
+# Simple function to reduce everything to kbit
+sub getKbit
+{
+ my ($counter,$quantifier) = @_;
+
+ # If there is no counter, return 0
+ return 0 if (!defined($counter));
+
+ # We need a quantifier
+ return undef if (!defined($quantifier));
+
+ # Initialize counter
+ my $newCounter = $counter;
+
+ if ($quantifier =~ /^m$/i) {
+ $newCounter = $counter * 1024;
+ } elsif ($quantifier =~ /^k$/i) {
+ $newCounter = $counter * 1;
+ } else {
+ return undef;
+ }
+
+ return $newCounter;
+}
+
+
+# vim: ts=4
--
GitLab