File Coverage

blib/lib/AnyEvent/Radius/Server.pm

Criterion	Covered	Total	%
statement	27	68	39.7
branch	0	20	0.0
condition	0	8	0.0
subroutine	9	13	69.2
pod	2	2	100.0
total	38	111	34.2

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::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
            $reply_type = $DEFAUL_REPLY{ $type };
            $reply_av_list = [{Name => 'Reply-Message', Value => 'Default rule: reject'}];
        }

        my ($reply, $r_id, $r_auth) = $obj->packer()->build(
                                type => $reply_type,
                                av_list => $reply_av_list,
                                authenticator => $authenticator,
                                request_id => $req_id,
                                with_msg_auth => 1,
                            );
        if(! $reply) {
            warn "Failed to build reply";
            return
        }

        $obj->handler()->push_send($reply, $from);

        return;
    };

    # low-level socket errors
    my $on_error_cb = sub {
        my ($handle, $fatal, $error) = @_;
        if ($h{on_error}) {
            $h{on_error}->($obj, $error);
        }
        else {
            warn "Error occured: $error";
        }
    };

    my $server = AnyEvent::Handle::UDP->new(
            bind => [$h{ip}, $h{port} // RADIUS_PORT ],
            on_recv => $on_read_cb,
            on_error => $on_error_cb,
        );
    $obj->handler($server);

    # allow to pass custom object
    my $packer = $h{packer} || Data::Radius::Packet->new(dict => $h{dictionary}, secret => $h{secret});
    $obj->packer($packer);

    return $obj;
}

sub load_dictionary {
    my ($class, $path) = @_;
    my $dict = Data::Radius::Dictionary->load_file($path);

    if(ref($class)) {
        $class->packer()->dict($dict);
    }

    return $dict;
}

1;

__END__