File Coverage

blib/lib/XML/Atom/Client.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

# $Id$

package XML::Atom::Client;
use strict;

use XML::Atom;
use base qw( XML::Atom::ErrorHandler );
use LWP::UserAgent;
use XML::Atom::Entry;
use XML::Atom::Feed;
use XML::Atom::Util qw( first textValue );
use Digest::SHA1 qw( sha1 );
use MIME::Base64 qw( encode_base64 );
use DateTime;

use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/';

sub new {
    my $class = shift;
    my $client = bless { }, $class;
    $client->init(@_) or return $class->error($client->errstr);
    $client;
}

sub init {
    my $client = shift;
    my %param = @_;
    $client->{ua} = LWP::UserAgent::AtomClient->new($client);
    $client->{ua}->agent('XML::Atom/' . XML::Atom->VERSION);
    $client->{ua}->parse_head(0);
    $client;
}

sub username {
    my $client = shift;
    $client->{username} = shift if @_;
    $client->{username};
}

sub password {
    my $client = shift;
    $client->{password} = shift if @_;
    $client->{password};
}

sub use_soap {
    my $client = shift;
    $client->{use_soap} = shift if @_;
    $client->{use_soap};
}

sub auth_digest {
    my $client = shift;
    $client->{auth_digest} = shift if @_;
    $client->{auth_digest};
}

sub getEntry {
    my $client = shift;
    my($url) = @_;
    my $req = HTTP::Request->new(GET => $url);
    my $res = $client->make_request($req);
    return $client->error("Error on GET $url: " . $res->status_line)
        unless $res->code == 200;
    XML::Atom::Entry->new(Stream => \$res->content);
}

sub createEntry {
    my $client = shift;
    my($uri, $entry) = @_;
    return $client->error("Must pass a PostURI before posting")
        unless $uri;
    my $req = HTTP::Request->new(POST => $uri);
    $req->content_type($entry->content_type);
    my $xml = $entry->as_xml;
    _utf8_off($xml);
    $req->content_length(length $xml);
    $req->content($xml);
    my $res = $client->make_request($req);
    return $client->error("Error on POST $uri: " . $res->status_line)
        unless $res->code == 201;
    $res->header('Location') || 1;
}

sub updateEntry {
    my $client = shift;
    my($url, $entry) = @_;
    my $req = HTTP::Request->new(PUT => $url);
    $req->content_type($entry->content_type);
    my $xml = $entry->as_xml;
    _utf8_off($xml);
    $req->content_length(length $xml);
    $req->content($xml);
    my $res = $client->make_request($req);
    return $client->error("Error on PUT $url: " . $res->status_line)
        unless $res->code == 200;
    1;
}

sub deleteEntry {
    my $client = shift;
    my($url) = @_;
    my $req = HTTP::Request->new(DELETE => $url);
    my $res = $client->make_request($req);
    return $client->error("Error on DELETE $url: " . $res->status_line)
        unless $res->code == 200;
    1;
}

sub getFeed {
    my $client = shift;
    my($uri) = @_;
    return $client->error("Must pass a FeedURI before retrieving feed")
        unless $uri;
    my $req = HTTP::Request->new(GET => $uri);
    my $res = $client->make_request($req);
    return $client->error("Error on GET $uri: " . $res->status_line)
        unless $res->code == 200;
    my $feed = XML::Atom::Feed->new(Stream => \$res->content)
        or return $client->error(XML::Atom::Feed->errstr);
    $feed;
}

sub make_request {
    my $client = shift;
    my($req) = @_;
    $client->munge_request($req);
    my $res = $client->{ua}->request($req);
    $client->munge_response($res);
    $client->{response} = $res;
    $res;
}

sub munge_request {
    my $client = shift;
    my($req) = @_;
    $req->header(
        Accept => 'application/atom+xml, application/x.atom+xml, application/xml, text/xml, */*',
    );
    my $nonce = $client->make_nonce;
    my $nonce_enc = encode_base64($nonce, '');
    my $now = DateTime->now->iso8601 . 'Z';
    my $digest = encode_base64(sha1($nonce . $now . ($client->password || '')), '');
    if ($client->use_soap) {
        my $xml = $req->content || '';
        $xml =~ s!^(<\?xml.*?\?>)!!;
        my $method = $req->method;
        $xml = ($1 || '') . <

  xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"
  xmlns:wsu="http://schemas.xmlsoap.org/ws/2002/07/utility"
  xmlns:wsse="http://schemas.xmlsoap.org/ws/2002/07/secext">



        @{[ $client->username || '' ]}
        $digest
        $nonce_enc
        $now




    <$method xmlns="http://schemas.xmlsoap.org/wsdl/http/">
$xml



SOAP
        $req->content($xml);
        $req->content_length(length $xml);
        $req->header('SOAPAction', 'http://schemas.xmlsoap.org/wsdl/http/' . $method);
        $req->method('POST');
        $req->content_type('text/xml');
    } else {
        if ($client->username) {
            $req->header('X-WSSE', sprintf
              qq(UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"),
              $client->username || '', $digest, $nonce_enc, $now);
            $req->header('Authorization', 'WSSE profile="UsernameToken"');
        }
    }
}

sub munge_response {
    my $client = shift;
    my($res) = @_;
    if ($client->use_soap && (my $xml = $res->content)) {
        my $doc;
        if (LIBXML) {
            my $parser = $client->libxml_parser;
            $doc = $parser->parse_string($xml);
        } else {
            my $xp = XML::XPath->new(xml => $xml);
            $doc = ($xp->find('/')->get_nodelist)[0];
        }
        my $body = first($doc, NS_SOAP, 'Body');
        if (my $fault = first($body, NS_SOAP, 'Fault')) {
            $res->code(textValue($fault, undef, 'faultcode'));
            $res->message(textValue($fault, undef, 'faultstring'));
            $res->content('');
            $res->content_length(0);
        } else {
            $xml = join '', map $_->toString(LIBXML ? 1 : 0),
                LIBXML ? $body->childNodes : $body->getChildNodes;
            $res->content($xml);
            $res->content_length(1);
        }
    }
}

sub make_nonce { sha1(sha1(time() . {} . rand() . $$)) }

sub _utf8_off {
    if ($] >= 5.008) {
        require Encode;
        Encode::_utf8_off($_[0]);
    }
}

sub libxml_parser { XML::Atom->libxml_parser }

package LWP::UserAgent::AtomClient;
use strict;
use Scalar::Util;

use base qw( LWP::UserAgent );

my %ClientOf;
sub new {
    my($class, $client) = @_;
    my $ua = $class->SUPER::new;
    $ClientOf{$ua} = $client;
    Scalar::Util::weaken($ClientOf{$ua});
    $ua;
}

sub get_basic_credentials {
    my($ua, $realm, $url, $proxy) = @_;
    my $client = $ClientOf{$ua} or die "Cannot find $ua";
    return $client->username, $client->password;
}

sub DESTROY {
    my $self = shift;
    delete $ClientOf{$self};
}

1;
__END__