ljr/livejournal/cgi-bin/XML/Atom/Client.pm

# $Id: Client.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $

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_ATOM => 'http://purl.org/atom/ns#';
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;
}

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('application/x.atom+xml');
    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('application/x.atom+xml');
    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);
    $res;
}

sub munge_request {
    my $client = shift;
    my($req) = @_;
    $req->header(
        Accept => '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 || '') . <<SOAP;
<soap:Envelope
  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">
  <soap:Header>
    <wsse:Security>
      <wsse:UsernameToken>
        <wsse:Username>@{[ $client->username || '' ]}</wsse:Username>
        <wsse:Password Type="wsse:PasswordDigest">$digest</wsse:Password>
        <wsse:Nonce>$nonce_enc</wsse:Nonce>
        <wsu:Created>$now</wsu:Created>
      </wsse:UsernameToken>
    </wsse:Security>
  </soap:Header>
  <soap:Body>
    <$method xmlns="http://schemas.xmlsoap.org/wsdl/http/">
$xml
    </$method>
  </soap:Body>
</soap:Envelope>
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 {
        $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 = XML::LibXML->new;
            $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 {
    my $val = shift;
    if ($] >= 5.008) {
        require Encode;
        Encode::_utf8_off($val);
    }
}

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

use base qw( LWP::UserAgent );

my %ClientOf;
sub new {
    my($class, $client) = @_;
    my $ua = $class->SUPER::new;
    $ClientOf{$ua} = $client;
    $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__

=head1 NAME

XML::Atom::Client - A client for the Atom API

=head1 SYNOPSIS

    use XML::Atom::Client;
    use XML::Atom::Entry;
    my $api = XML::Atom::Client->new;
    $api->username('Melody');
    $api->password('Nelson');

    my $entry = XML::Atom::Entry->new;
    $entry->title('New Post');
    $entry->content('Content of my post.');
    my $EditURI = $api->createEntry($PostURI, $entry);

    my $feed = $api->getFeed($FeedURI);
    my @entries = $feed->entries;

    my $entry = $api->getEntry($EditURI);

=head1 DESCRIPTION

I<XML::Atom::Client> implements a client for the Atom API described at
I<http://bitworking.org/projects/atom/draft-gregorio-09.html>, with the
authentication scheme described at
I<http://www.intertwingly.net/wiki/pie/DifferentlyAbledClients>.

B<NOTE:> the API, and particularly the authentication scheme, are still
in flux.

=head1 USAGE

=head2 XML::Atom::Client->new(%param)

=head2 $api->use_soap([ 0 | 1 ])

I<XML::Atom::Client> supports both the REST and SOAP-wrapper versions of the
Atom API. By default, the REST version of the API will be used, but you can
turn on the SOAP wrapper--for example, if you need to connect to a server
that supports only the SOAP wrapper--by calling I<use_soap> with a value of
C<1>:

    $api->use_soap(1);

If called without arguments, returns the current value of the flag.

=head2 $api->username([ $username ])

If called with an argument, sets the username for login to I<$username>.

Returns the current username that will be used when logging in to the
Atom server.

=head2 $api->password([ $password ])

If called with an argument, sets the password for login to I<$password>.

Returns the current password that will be used when logging in to the
Atom server.

=head2 $api->createEntry($PostURI, $entry)

Creates a new entry.

I<$entry> must be an I<XML::Atom::Entry> object.

=head2 $api->getEntry($EditURI)

Retrieves the entry with the given URL I<$EditURI>.

Returns an I<XML::Atom::Entry> object.

=head2 $api->updateEntry($EditURI, $entry)

Updates the entry at URL I<$EditURI> with the entry I<$entry>, which must be
an I<XML::Atom::Entry> object.

Returns true on success, false otherwise.

=head2 $api->deleteEntry($EditURI)

Deletes the entry at URL I<$EditURI>.

=head2 $api->getFeed($FeedURI)

Retrieves the feed at I<$FeedURI>.

Returns an I<XML::Atom::Feed> object representing the feed returned
from the server.

=head2 ERROR HANDLING

Methods return C<undef> on error, and the error message can be retrieved
using the I<errstr> method.

=head1 AUTHOR & COPYRIGHT

Please see the I<XML::Atom> manpage for author, copyright, and license
information.

=cut