view release on metacpan or  search on metacpan

lib/AnyEvent/Radius/Server.pm  view on Meta::CPAN

package AnyEvent::Radius::Server;
# AnyEvent-based radius server
use strict;
use warnings;
use AnyEvent;
use AnyEvent::Handle::UDP;

use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(handler packer));

use Data::Radius v1.2.8;
use Data::Radius::Constants qw(:all);
use Data::Radius::Dictionary ();
use Data::Radius::Packet ();

use constant {
    READ_TIMEOUT_SEC => 5,
    WRITE_TIMEOUT_SEC => 5,
    RADIUS_PORT => 1812,
};

my %DEFAUL_REPLY = (
    &ACCESS_REQUEST => ACCESS_REJECT,
    &ACCOUNTING_REQUEST => ACCOUNTING_RESPONSE,
    &DISCONNECT_REQUEST => DISCONNECT_REJECT,
    &COA_REQUEST => COA_REJECT,
);

# new 'server'
# args:
#   ip
#   port
#   secret
#   dictionary
#- callbacks:
#    on_read
#    on_read_raw
#    on_wrong_request
#    on_error
sub new {
    my ($class, %h) = @_;

    die "No IP argument" if (! $h{ip});
    # either pre-created packer obect, or need radius secret to create new one
    # dictionary is optional
    die "No radius secret" if (! $h{packer} && ! $h{secret});

    my $obj = bless {}, $class;

    my $on_read_cb = sub {
        my ($data, $handle, $from) = @_;

        if ($h{on_read_raw}) {
            # dump raw data
            $h{on_read_raw}->($obj, $data, $from);
        }

        # how to decoded $from
        # my($port, $host) = AnyEvent::Socket::unpack_sockaddr($from);
        # my $ip = format_ipv4($host);

        my ($type, $req_id, $authenticator, $av_list) = $obj->packer()->parse($data);

        if (! $obj->packer()->is_request($type)) {
            # we expect only requests in server
            if ($h{on_wrong_request}) {
                 $h{on_wrong_request}->($obj, {
                            type => $type,
                            request_id => $req_id,
                            av_list => $av_list,
                            # from is sockaddr binary data
                            from => $from,
                        });
            }

            # Do not reply
            warn "Ignore wrong request type " . $type;
            return
        }

        my ($reply_type, $reply_av_list) = ();

        if($h{on_read}) {
            # custom-reply
            ($reply_type, $reply_av_list) = $h{on_read}->($obj, {
                        type => $type,
                        request_id => $req_id,
                        av_list => $av_list,
                        # from is sockaddr binary data
                        from => $from,
                    });
        }

        if (! $reply_type) {
            # reject by default