view release on metacpan or  search on metacpan

lib/Data/Radius/Packet.pm  view on Meta::CPAN

    my $msg_auth;
    my $pos = 0;
    my $len = length($attributes);

    while ($pos < $len) {
        my ($attr_val, $vendor_id, $vendor, $vsa_len, $attr, $tag) = ();
        # FIXME not supported
        my $wimax_cont;

        my ($attr_id, $attr_len) = unpack('C C', substr($attributes, $pos, 2));

        if ($attr_id == ATTR_VENDOR) {
            my $vsa_header_len = 6;

            ($vendor_id, $attr_id, $vsa_len) = unpack('N C C', substr($attributes, $pos + 2, $vsa_header_len) );
            if ($vendor_id == WIMAX_VENDOR) {
                # +1 continuation byte
                $vsa_header_len = 7;
                $wimax_cont = unpack('C', substr($attributes, $pos + 8, 1));
                warn 'continuation field is not supported' if ($wimax_cont);
                printf "WIMAX cont: %d\n", $wimax_cont;
            }

            if ($dict) {
                $vendor = $dict->vendor_name($vendor_id) // $vendor_id;
                $attr = $dict->attribute_name($vendor, $attr_id);
            }

            $attr_val = substr($attributes, $pos + 2 + $vsa_header_len, $attr_len - 2 - $vsa_header_len);
        }
        else {
            if ($dict) {
                $attr = $dict->attribute_name(undef, $attr_id);
            }

            $attr_val = substr($attributes, $pos + 2, $attr_len - 2);
        }

        if ($attr_id == ATTR_MSG_AUTH && ! $vendor) {
            die "Invalid Message-Authenticator len" if ($attr_len != ATTR_MSG_AUTH_LEN);
            $msg_auth = $attr_val;
            # zero it to verify later
            $attr_val = "\x0" x (ATTR_MSG_AUTH_LEN - 2);
            substr($attributes, $pos + 2, $attr_len - 2, $attr_val);
        }

        $pos += $attr_len;

        if (! $attr) {
            # raw data for unknown attribute
            push @attr, {
                Name => $attr_id,
                Value => $attr_val,
                Type => undef,
                Vendor => $vendor,
                Tag => undef,
            };
            next;
        }

        (my $decoded, $tag) = decode($attr, $attr_val, $self->dict);
        if (is_enum_type($attr->{type})) {
            # try to convert value to constants
            $decoded = $dict->constant($attr->{name}, $decoded) // $decoded;
        }

        # password is expected only in auth request
        if ($type == ACCESS_REQUEST && $attr->{id} == ATTR_PASSWORD && ! $attr->{vendor}) {
            $decoded = decrypt_pwd($decoded, $self->secret, $auth);
        }

        push @attr, {
            Name => $attr->{name},
            Value => $decoded,
            Type => $attr->{type},
            Vendor => $vendor,
            Tag => $tag,
        };
    }

    if($msg_auth) {
        # we already replaced msg auth value to \x0...
        my $auth_used;
        if ($self->is_reply($type)) {
            $auth_used = $orig_auth;
        }
        elsif ($type == ACCESS_REQUEST) {
            $auth_used = $auth;
        }
        else {
            # other type of request should use 00x16
            # Message-Authenticator should not be present in ACCOUNTING_REQUEST
            $auth_used = "\x00" x 16;
        }

        my $data = join('',
                        pack('C C n', $type, $req_id, $length),
                        $auth_used,
                        $attributes,
                    );
        my $hmac = Digest::HMAC_MD5->new($self->secret);
        $hmac->add( $data );
        my $exp_msg_auth = $hmac->digest;

        if ($msg_auth ne $exp_msg_auth) {
            warn "Message-Authenticator not verified";
            return undef;
        }
    }

    return ($type, $req_id, $auth, \@attr);
}

# extract request id from packet header without parsing attributes
# should be used to find original authenticator value for received reply packet to pass it to decode_request()
sub request_id {
    my ($self, $packet) = @_;
    my $req_id = unpack('C', substr($packet, 1, 1));
    return $req_id;
}

sub is_reply {
    my ($class, $type) = @_;
    return $IS_REPLY{ $type } // 0;
}

sub is_request {
    my ($class, $type) = @_;
    return $IS_REQUEST{ $type } // 0;
}

1;

__END__