File Coverage

blib/lib/WWW/HKP.pm

Criterion	Covered	Total	%
statement	51	91	56.0
branch	27	50	54.0
condition	17	48	35.4
subroutine	9	16	56.2
pod	4	4	100.0
total	108	209	51.6

use strict;
use warnings;
package WWW::HKP;
# ABSTRACT: Interface to HTTP Keyserver Protocol (HKP)

use Carp;
use 5.010;
use LWP::UserAgent 6.05;
use URI 1.60;
use URI::Escape 3.31;

our $VERSION = '0.04'; # VERSION


sub new($;%) {
    my ($class, %options) = @_;

    my $uri = URI->new('http:');
    $uri->host($options{host} || 'localhost');
    $uri->port($options{port} || 11371);

    my $ua = LWP::UserAgent->new;
    $ua->agent(__PACKAGE__.'/'.$VERSION);

    my $self = {
		ua => $ua,
		uri => $uri,
    };

    return bless $self => (ref $class || $class);
}

sub _ua($) { shift->{ua} }
sub _uri($) { shift->{uri} }

sub _get($$) {
    my ($self, %query) = @_;
    $self->{error} = undef;
    $self->_uri->path('/pks/lookup');
    $self->_uri->query_form(%query);
    my $response = $self->_ua->get($self->_uri);
    if (defined $response and ref $response and $response->isa('HTTP::Response') and $response->is_success) {
		return $response->decoded_content;
    } else {
		$self->{error} = $response->status_line;
		return undef;
    }
}

sub _post($%) {
    my ($self, %query) = @_;
    $self->{error} = undef;
    $self->_uri->path('/pks/lookup');
    my $response = $self->_ua->post($self->_uri, \%query);
    if (defined $response and ref $response and $response->isa('HTTP::Response') and $response->is_success) {
		return $response->decoded_content;
    } else {
		$self->{error} = $response->status_line;
		return undef;
    }

}

sub _parse_mr($$$) {
    my ($self, $lines, $filter_ok) = @_;
    my $keys = {};
    my $key;
    my ($keyc, $keyn) = (0, 0);
    foreach my $line (split /\r?\n/ => $lines) {
		if ($line =~ /^info:(\d+):(\d+)$/) {
			croak "unsupported hkp version: v$1" unless $1 == 1;
			$keyc = $2;
		} elsif ($line =~ /^pub:([0-9a-f]{8,16}):(\d*):(\d*):(\d*):(\d*):([der]*)$/i) {
			$key = $1;
			$keyn++;
			my ($algo, $keylen, $created, $expires, $flags, $ok) = ($2, $3, $4, $5, $6, undef);
			$ok = ((($created and $created > time) or ($expires and $expires < time) or (length $flags)) ? 0 : 1);
			if ($filter_ok and !$ok) {
				$key = undef;
				next;
			}
			$keys->{$key} = {
				algo => $algo,
				keylen => $keylen,
				created => $created || undef,
				expires => $expires || undef,
				revoked => ($flags =~ /r/ ? 1 : 0),
				expired => ($flags =~ /e/ ? 1 : 0),
				deleted => ($flags =~ /d/ ? 1 : 0),
				ok => $ok,
				uids => []
			};
		} elsif ($line =~ /^uid:([^:]*):(\d*):(\d*):([der]*)$/i) {
			next unless defined $key;
			my ($uid, $created, $expires, $flags, $ok) = ($1, $2, $3, $4, undef);
			$ok = ((($created and $created > time) or ($expires and $expires < time) or (length $flags)) ? 0 : 1);
			next if $filter_ok and !$ok;
			push @{ $keys->{$key}->{uids} } => {
				uid => uri_unescape($uid),
				created => $created || undef,
				expires => $expires || undef,
				revoked => ($flags =~ /r/ ? 1 : 0),
				expired => ($flags =~ /e/ ? 1 : 0),
				deleted => ($flags =~ /d/ ? 1 : 0),
				ok => $ok
			};
		} else {
			carp "unknown line: $line";
		}
    }
    carp "server said there where $keyc keys, but $keyn keys parsed" unless $keyc == $keyn;
    return $keys;
}


sub query($$$;%) {
    my ($self, $type, $search, %options) = @_;


		if ($type eq 'index') {
			my @options = qw(mr);
			push @options => 'exact' if $options{exact};
			my $message = $self->_get(op => 'index', options => join(',' => @options), search => $search);
			return undef unless defined $message;
			return $self->_parse_mr($message, $options{filter_ok} ? 1 : 0);
		}


		elsif ($type eq 'get') {
			if ($search !~ /^0x/) {
				$search = '0x'.$search;
			}
			my $message = $self->_get(op => 'get', options => 'exact', search => $search);
			return undef unless defined $message;
			return $message;
		}


		else {
			confess "unknown query type '$type'";
		}
}


sub submit($@) {
    my ($self, @keys) = @_;
    my $status = $self->_post(map {( keytext => $_ )} @keys);
    return (defined $status and $status ? 1 : 0);
}


sub error($) { shift->{error} }

1;

__END__