HOME

5h-3LL 1.0
DIR: /usr/lib/x86_64-linux-gnu/perl5/5.20/Net/DNS/RR
/usr/lib/x86_64-linux-gnu/perl5/5.20/Net/DNS/RR/
Current File : /usr/lib/x86_64-linux-gnu/perl5/5.20/Net/DNS/RR/TSIG.pm
package Net::DNS::RR::TSIG;

#
# $Id: TSIG.pm 1282 2014-10-27 09:45:19Z willem $
#
use vars qw($VERSION);
$VERSION = (qw$LastChangedRevision: 1282 $)[1];


use strict;
use base qw(Net::DNS::RR);

=head1 NAME

Net::DNS::RR::TSIG - DNS TSIG resource record

=cut


use integer;

use Carp;
use MIME::Base64;

use Net::DNS::Parameters;

require Net::DNS::DomainName;

require Digest::HMAC;
require Digest::MD5;
require Digest::SHA;

use constant ANY  => classbyname qw(ANY);
use constant TSIG => typebyname qw(TSIG);


{
	my @algbyname = (
		'HMAC-MD5.SIG-ALG.REG.INT' => 157,
		'HMAC-SHA1'		   => 161,
		'HMAC-SHA224'		   => 162,
		'HMAC-SHA256'		   => 163,
		'HMAC-SHA384'		   => 164,
		'HMAC-SHA512'		   => 165,
		);

	my @algbyalias = (
		'HMAC-MD5' => 157,
		'HMAC-SHA' => 161,
		);

	my %algbyval = reverse @algbyname;


	my @algbynum = map { ( $_, 0 + $_ ) } keys %algbyval;	# accept algorithm number

	my %algbyname = map { s /[^A-Za-z0-9]//g; $_ } @algbyalias, @algbyname, @algbynum;


	sub algbyname {
		my $key = uc shift;				# synthetic key
		$key =~ s /[^A-Z0-9]//g;			# strip non-alphanumerics
		return $algbyname{$key};
	}

	sub algbyval {
		my $value = shift;
		return $algbyval{$value} || $value;
	}
}



sub decode_rdata {			## decode rdata from wire-format octet string
	my $self = shift;
	my ( $data, $offset ) = @_;

	( $self->{algorithm}, $offset ) = decode Net::DNS::DomainName(@_);

	# Design decision: Use 32 bits, which will work until the end of time()!
	@{$self}{qw(time_signed fudge)} = unpack "\@$offset xxN n", $$data;
	$offset += 8;

	my $mac_size = unpack "\@$offset n", $$data;
	$self->{macbin} = unpack "\@$offset xx a$mac_size", $$data;
	$offset += $mac_size + 2;

	@{$self}{qw(original_id error)} = unpack "\@$offset nn", $$data;
	$offset += 4;

	my $other_size = unpack "\@$offset n", $$data;
	$self->{other} = unpack "\@$offset xx a$other_size", $$data;
	$offset += $other_size + 2;

	croak('misplaced or corrupt TSIG') unless $offset == length $$data;
	substr( $$data, $self->{offset} || $offset ) = '';
	$self->{rawref} = $data;
}


sub encode_rdata {			## encode rdata as wire-format octet string
	my $self = shift;

	my $macbin = $self->macbin;
	unless ($macbin) {
		my ( $offset, undef, $packet ) = @_;

		my $sigdata = $self->sig_data($packet);		# form data to be signed
		$macbin = $self->macbin( $self->_mac_function($sigdata) );
		$self->original_id( $packet->header->id );
	}

	my $rdata = $self->{algorithm}->canonical;

	# Design decision: Use 32 bits, which will work until the end of time()!
	$rdata .= pack 'xxN n', $self->time_signed, $self->fudge;

	$rdata .= pack 'na*', length($macbin), $macbin;

	$rdata .= pack 'nn', $self->original_id, $self->{error} || 0;

	my $other = $self->other || '';
	$rdata .= pack 'na*', length($other), $other;

	return $rdata;
}


sub format_rdata {			## format rdata portion of RR string.
	my $self = shift;

	my @lines = (
		join( "\t", 'algorithm:', $self->algorithm ),
		join( "\t", 'time signed:', $self->time_signed, 'fudge:', $self->fudge ),
		join( "\t", 'signature:',   $self->mac ),
		join( "\t", 'original id:', $self->original_id ),
		join( "\t", $self->error, $self->other || '' ) );
	join "\n; ", '', @lines;
}


sub defaults() {			## specify RR attribute default values
	my $self = shift;

	$self->algorithm(157);
	$self->class('ANY');
	$self->fudge(300);
}


sub encode {				## overide RR method
	my $self = shift;

	my $kname = $self->{owner}->encode();			# uncompressed key name
	my $rdata = eval { $self->encode_rdata(@_) } || '';
	return pack 'a* n2 N n a*', $kname, TSIG, ANY, 0, length $rdata, $rdata;
}


sub algorithm { &_algorithm; }


sub key {
	my $self = shift;

	$self->keybin( MIME::Base64::decode( join "", @_ ) ) if scalar @_;
	return MIME::Base64::encode( $self->keybin(), "" ) if defined wantarray;
}


sub keybin { &_keybin; }


sub time_signed {
	my $self = shift;

	$self->{time_signed} = 0 + shift if scalar @_;
	return $self->{time_signed} ||= time();
}


sub fudge {
	my $self = shift;

	$self->{fudge} = 0 + shift if scalar @_;
	return $self->{fudge} || 0;
}


sub mac {
	my $self = shift;

	$self->macbin( pack "H*", map { die "!hex!" if m/[^0-9A-Fa-f]/; $_ } join "", @_ ) if scalar @_;
	unpack "H*", $self->macbin() if defined wantarray;
}


sub macbin {
	my $self = shift;

	$self->{macbin} = shift if scalar @_;
	$self->{macbin} || "";
}


sub prior_mac {
	my $self = shift;

	$self->prior_macbin( pack "H*", map { die "!hex!" if m/[^0-9A-Fa-f]/; $_ } join "", @_ ) if scalar @_;
	unpack "H*", $self->prior_macbin() if defined wantarray;
}


sub prior_macbin {
	my $self = shift;

	$self->{prior_macbin} = shift if scalar @_;
	$self->{prior_macbin} || "";
}


sub request_mac {
	my $self = shift;

	$self->request_macbin( pack "H*", map { die "!hex!" if m/[^0-9A-Fa-f]/; $_ } join "", @_ ) if scalar @_;
	unpack "H*", $self->request_macbin() if defined wantarray;
}


sub request_macbin {
	my $self = shift;

	$self->{request_macbin} = shift if scalar @_;
	$self->{request_macbin} || "";
}


sub original_id {
	my $self = shift;

	$self->{original_id} = 0 + shift if scalar @_;
	return $self->{original_id} || 0;
}


sub error {
	my $self = shift;
	$self->{error} = rcodebyname(shift) if scalar @_;
	rcodebyval( $self->{error} || 0 );
}


sub other {
	my $self = shift;

	$self->{other} = shift if scalar @_;
	$self->{other} || "";
}


sub other_data {&other}


sub sig_function {
	my $self = shift;

	return $self->{sig_function} unless scalar @_;
	$self->{sig_function} = shift;
}

sub sign_func { &sig_function; }	## historical


sub sig_data {
	my ( $self, $message ) = @_;

	if ( ref($message) ) {
		die 'missing packet reference' unless $message->isa('Net::DNS::Packet');
		my @unsigned = grep ref($_) ne ref($self), @{$message->{additional}};
		local $message->{additional} = \@unsigned;	# remake header image
		my @part = qw(question answer authority additional);
		my @size = map scalar( @{$message->{$_}} ), @part;
		my $data = $self->{rawref};
		delete $self->{rawref};
		my $orig = $data ? $self->original_id : $message->{id};
		my $hbin = pack 'n6', $orig, $message->{status}, @size;
		$message = $hbin . substr $data ? $$data : $message->data, length $hbin;
	}

	# Design decision: Use 32 bits, which will work until the end of time()!
	my $time = pack 'xxN n', $self->time_signed, $self->fudge;

	# Insert the prior MAC if present (multi-packet message).
	$self->prior_macbin( $self->{link}->macbin ) if $self->{link};
	if ( my $prior_mac = $self->prior_macbin ) {
		return pack 'na* a* a*', length($prior_mac), $prior_mac, $message, $time;
	}

	# Insert the request MAC if present (used to validate responses).
	my $req_mac = $self->request_macbin;
	my $sigdata = $req_mac ? pack( 'na*', length($req_mac), $req_mac ) : '';

	$sigdata .= $message || '';

	my $kname = $self->{owner}->canonical;			# canonical key name
	$sigdata .= pack 'a* n N', $kname, ANY, 0;

	$sigdata .= $self->{algorithm}->canonical;		# canonical algorithm name

	$sigdata .= $time;

	$sigdata .= pack 'n', $self->{error} || 0;

	my $other = $self->other || '';
	$sigdata .= pack 'na*', length($other), $other;

	return $sigdata;
}


sub create {
	my $class = shift;
	my $karg = shift || croak 'argument missing or undefined';

	if ( ref($karg) ) {
		return $karg->_chain if ref($karg) eq __PACKAGE__;
		croak "Usage:	create $class( keyfile )\n\tcreate $class( keyname, key )"
				unless $karg->isa('Net::DNS::Packet');

		my $sigrr = $karg->sigrr || die 'no TSIG in request packet';
		return new Net::DNS::RR(			# ( request, options )
			name	       => $sigrr->name,
			type	       => 'TSIG',
			algorithm      => $sigrr->algorithm,
			request_macbin => $sigrr->macbin,
			@_
			);

	} elsif ( scalar(@_) == 1 ) {
		my $key = shift;				# ( keyname, key )
		return new Net::DNS::RR(
			name => $karg,
			type => 'TSIG',
			key  => $key
			);

	} elsif ( $karg =~ /[+.0-9]+private$/ ) {		# ( keyfile, options )
		require File::Spec;
		require Net::DNS::ZoneFile;
		my $keyfile = new Net::DNS::ZoneFile($karg);
		my ( $alg, $key, $junk );
		while ( my $line = $keyfile->_getline ) {
			for ($line) {
				( $junk, $alg ) = split if /Algorithm:/;
				( $junk, $key ) = split if /Key:/;
			}
		}

		my ( $vol, $dir, $file ) = File::Spec->splitpath( $keyfile->name );
		my $kname = $file =~ /^K([^+]+)+.+private$/ ? $1 : undef;
		return new Net::DNS::RR(
			name	  => $kname,
			type	  => 'TSIG',
			algorithm => $alg,
			key	  => $key,
			@_
			);

	} else {						# ( keyfile, options )
		require Net::DNS::ZoneFile;
		my $keyfile = new Net::DNS::ZoneFile($karg);
		my $keyline = $keyfile->_getline;		# bad news: KEY is in Net::DNS::SEC
		my ( $kname, $c, $t, $f, $p, $algorithm, @key ) = split /\s+/, $keyline;
		croak 'key file incompatible with TSIG' unless "$c $t $f $p" eq 'IN KEY 512 3';
		my $key = join '', @key;
		return new Net::DNS::RR(
			name	  => $kname,
			type	  => 'TSIG',
			algorithm => $algorithm,
			key	  => $key,
			@_
			);
	}
}


sub verify {
	my $self = shift;
	my $data = shift;

	unless ( abs( time() - $self->time_signed ) < $self->fudge ) {
		$self->error(18);				# bad time
		$self->other( pack 'xxN', time() );
		return;
	}

	if ( scalar @_ ) {

		unless ( my $arg = shift ) {
			$self->error(16);			# bad sig (multi-packet)
			return;

		} elsif ( ref($arg) && $arg->isa('Net::DNS::Packet') ) {
			my $sigrr = $arg->sigrr;		# query TSIG
			$self->request_macbin( $sigrr->macbin );
			$self->error(17) && return unless $self->name eq $sigrr->name;
			$self->error(17) && return unless lc $self->algorithm eq lc $sigrr->algorithm;

		} elsif ( ref($arg) && $arg->isa(__PACKAGE__) ) {
			my $sigrr = $arg;			# multi-packet
			$self->prior_macbin( $sigrr->macbin );
			$self->error(17) && return unless $self->name eq $sigrr->name;
			$self->error(17) && return unless lc $self->algorithm eq lc $sigrr->algorithm;

		} else {
			croak 'Usage: $tsig->verify( $reply, $query )';
		}

	}

	my $sigdata = $self->sig_data($data);			# form data to be verified
	my $tsigmac = $self->_mac_function($sigdata);
	my $tsig    = $self->_chain;
	$tsig->macbin($tsigmac);

	my $macbin = $self->macbin;
	my $maclen = length $macbin;
	my $minlen = length($tsigmac) >> 1;			# per RFC4635, 3.1
	$self->error(1) && return if $maclen < 10;
	$self->error(1) && return if $maclen < $minlen;
	$self->error(1) && return if $maclen > length $tsigmac;

	$self->error(16) && return unless $macbin eq substr $tsigmac, 0, $maclen;
	return $tsig;
}

sub vrfyerrstr {
	my $self = shift;
	return $self->error;
}


########################################


{
	my %digest = (
		'157' => ['Digest::MD5'],
		'161' => ['Digest::SHA'],
		'162' => ['Digest::SHA', 224, 64],
		'163' => ['Digest::SHA', 256, 64],
		'164' => ['Digest::SHA', 384, 128],
		'165' => ['Digest::SHA', 512, 128],
		);


	my %keytable;

	sub _algorithm {		## install sig function in key table
		my $self = shift;

		if ( my $algname = shift ) {

			unless ( my $digtype = algbyname($algname) ) {
				$self->{algorithm} = new Net::DNS::DomainName($algname);

			} else {
				$algname = algbyval($digtype);
				$self->{algorithm} = new Net::DNS::DomainName($algname);

				my ( $hash, @param ) = @{$digest{$digtype}};
				my ( undef, @block ) = @param;
				my $function = sub {
					my $digest = new $hash(@param);
					my $hmac = new Digest::HMAC( shift, $digest, @block );
					$hmac->add(shift);
					return $hmac->digest;
				};

				$self->sig_function($function);

				my $keyname = ( $self->{owner} || return )->canonical;
				$keytable{$keyname}{digest} = $function;
			}
		}

		return $self->{algorithm}->name if defined wantarray;
	}


	sub _keybin {			## install key in key table
		my $self = shift;
		croak 'Unauthorised access to TSIG key material denied' unless scalar @_;
		my $keyref = $keytable{$self->{owner}->canonical} ||= {};
		my $private = shift;	# closure keeps private key private
		$keyref->{key} = sub {
			my $function = $keyref->{digest};
			return &$function( $private, shift );
		};
		return undef;
	}


	sub _mac_function {		## apply keyed hash function to argument
		my $self = shift;

		my $keyref = $keytable{$self->{owner}->canonical} ||= {};
		$self->algorithm( $self->algorithm ) unless $keyref->{digest};
		$keyref->{digest} ||= $self->sig_function;
		my $function = $keyref->{key};
		return &$function(shift);
	}
}


# _chain() creates a new TSIG object linked to the original
# RR, for the purpose of signing multi-message transfers.

sub _chain {
	my $self = shift;
	return bless {%$self, macbin => undef, link => $self}, ref($self);
}


1;
__END__


=head1 SYNOPSIS

    use Net::DNS;
    $tsig = create Net::DNS::RR::TSIG( $keyfile,
					fudge => 300
					);

    $tsig = create Net::DNS::RR::TSIG( $keyname, $key );

=head1 DESCRIPTION

Class for DNS Transaction Signature (TSIG) resource records.

=head1 METHODS

The available methods are those inherited from the base class augmented
by the type-specific methods defined in this package.

Use of undocumented package features or direct access to internal data
structures is discouraged and could result in program termination or
other unpredictable behaviour.


=head2 algorithm

    $algorithm = $rr->algorithm;
    $rr->algorithm( $algorithm );

A domain name which specifies the name of the algorithm.

=head2 key

    $rr->key( $key );

Base64 representation of the key material.

=head2 keybin

    $rr->keybin( $keybin );

Binary representation of the key material.

=head2 time_signed

    $time_signed = $rr->time_signed;
    $rr->time_signed( $time_signed );

Signing time as the number of seconds since 1 Jan 1970 00:00:00 UTC.
The default signing time is the current time.

=head2 fudge

    $fudge = $rr->fudge;
    $rr->fudge( $fudge );

"fudge" represents the permitted error in the signing time.
The default fudge is 300 seconds.

=head2 mac

    $mac = $rr->mac;

Returns the message authentication code (MAC) as a string of hex
characters.  The programmer must call the Net::DNS::Packet data()
object method before this will return anything meaningful.

=cut


=head2 macbin

    $macbin = $rr->macbin;
    $rr->macbin( $macbin );

Binary message authentication code (MAC).

=head2 prior_mac

    $prior_mac = $rr->prior_mac;
    $rr->prior_mac( $prior_mac );

Prior message authentication code (MAC).

=head2 prior_macbin

    $prior_macbin = $rr->prior_macbin;
    $rr->prior_macbin( $prior_macbin );

Binary prior message authentication code.

=head2 request_mac

    $request_mac = $rr->request_mac;
    $rr->request_mac( $request_mac );

Request message authentication code (MAC).

=head2 request_macbin

    $request_macbin = $rr->request_macbin;
    $rr->request_macbin( $request_macbin );

Binary request message authentication code.

=head2 original_id

    $original_id = $rr->original_id;
    $rr->original_id( $original_id );

The message ID from the header of the original packet.

=head2 error

     $rcode = $tsig->error;

Returns the RCODE covering TSIG processing.  Common values are
NOERROR, BADSIG, BADKEY, and BADTIME.  See RFC 2845 for details.


=head2 other

    $other = $rr->other;
    $rr->other( $other );

This field should be empty unless the error is BADTIME, in which
case it will contain the server time as the number of seconds since
1 Jan 1970 00:00:00 UTC.

=head2 sig_function

    sub signing_function {
	my ( $keybin, $data ) = @_;

	my $hmac = new Digest::HMAC( $keybin, 'Digest::MD5' );
	$hmac->add( $data );
	return $hmac->digest;
    }

    $tsig->sig_function( \&signing_function );

This sets the signing function to be used for this TSIG record.
The default signing function is HMAC-MD5.


=head2 sig_data

     $sigdata = $tsig->sig_data($packet);

Returns the packet packed according to RFC2845 in a form for signing. This
is only needed if you want to supply an external signing function, such as is
needed for TSIG-GSS.


=head2 create

    $tsig = create Net::DNS::RR::TSIG( $keyfile );

    $tsig = create Net::DNS::RR::TSIG( $keyfile,
					fudge => 300
					);

    $tsig = create Net::DNS::RR::TSIG( $keyname, $key );

Returns a TSIG RR constructed using the parameters in the specified
key file, which is assumed to have been generated by dnssec-keygen.

The two argument form is supported for backward compatibility.

=head2 verify

    $verify = $tsig->verify( $data );
    $verify = $tsig->verify( $packet );

    $verify = $tsig->verify( $reply,  $query );

    $verify = $tsig->verify( $packet, $prior );

The boolean verify method will return true if the hash over the
packet data conforms to the data in the TSIG itself


=head1 TSIG Keys

TSIG keys are symmetric keys generated using dnssec-keygen:

	$ dnssec-keygen -a HMAC-SHA1 -b 160 -n HOST <keyname>

	The key will be stored as a private and public keyfile pair
	K<keyname>+161+<keyid>.private and K<keyname>+161+<keyid>.key

    where
	<keyname> is the DNS name of the key.

	<keyid> is the (generated) numerical identifier used to
	distinguish this key.

Other algorithms may be substituted for HMAC-SHA1 in the above example.

It is recommended that the keyname be globally unique and incorporate
the fully qualified domain names of the resolver and nameserver in
that order. It should be possible for more than one key to be in use
simultaneously between any such pair of hosts.

Although the formats differ, the private and public keys are identical
and both should be stored and handled as secret data.


=head1 Configuring BIND Nameserver

The following lines must be added to the /etc/named.conf file:

    key <keyname> {
	algorithm HMAC-SHA1;
	secret "<keydata>";
    };

<keyname> is the name of the key chosen when the key was generated.

<keydata> is the key string extracted from the generated key file.


=head1 ACKNOWLEDGMENT

Most of the code in the Net::DNS::RR::TSIG module was contributed
by Chris Turbeville. 

Support for external signing functions was added by Andrew Tridgell.

TSIG verification, BIND keyfile handling and support for HMAC-SHA1,
HMAC-SHA224, HMAC-SHA256, HMAC-SHA384 and HMAC-SHA512 functions was
added by Dick Franks.


=head1 BUGS

A 32-bit representation of time is used, contrary to RFC2845 which
demands 48 bits.  This design decision will need to be reviewed
before the code stops working on 7 February 2106.


=head1 COPYRIGHT

Copyright (c)2002 Michael Fuhr. 

Portions Copyright (c)2002-2004 Chris Reinhardt.

Portions Copyright (c)2013 Dick Franks.

All rights reserved.

This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.

Package template (c)2009,2012 O.M.Kolkman and R.W.Franks.


=head1 SEE ALSO

L<perl>, L<Net::DNS>, L<Net::DNS::RR>, RFC2845, RFC4635

=cut