local-lib5/lib/perl5/XML/Atom/Client.pm

   1 # $Id$
   2
   3 package XML::Atom::Client;
   4 use strict;
   5
   6 use XML::Atom;
   7 use base qw( XML::Atom::ErrorHandler );
   8 use LWP::UserAgent;
   9 use XML::Atom::Entry;
  10 use XML::Atom::Feed;
  11 use XML::Atom::Util qw( first textValue );
  12 use Digest::SHA1 qw( sha1 );
  13 use MIME::Base64 qw( encode_base64 );
  14 use DateTime;
  15
  16 use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/';
  17
  18 sub new {
  19     my $class = shift;
  20     my $client = bless { }, $class;
  21     $client->init(@_) or return $class->error($client->errstr);
  22     $client;
  23 }
  24
  25 sub init {
  26     my $client = shift;
  27     my %param = @_;
  28     $client->{ua} = LWP::UserAgent::AtomClient->new($client);
  29     $client->{ua}->agent('XML::Atom/' . XML::Atom->VERSION);
  30     $client->{ua}->parse_head(0);
  31     $client;
  32 }
  33
  34 sub username {
  35     my $client = shift;
  36     $client->{username} = shift if @_;
  37     $client->{username};
  38 }
  39
  40 sub password {
  41     my $client = shift;
  42     $client->{password} = shift if @_;
  43     $client->{password};
  44 }
  45
  46 sub use_soap {
  47     my $client = shift;
  48     $client->{use_soap} = shift if @_;
  49     $client->{use_soap};
  50 }
  51
  52 sub auth_digest {
  53     my $client = shift;
  54     $client->{auth_digest} = shift if @_;
  55     $client->{auth_digest};
  56 }
  57
  58 sub getEntry {
  59     my $client = shift;
  60     my($url) = @_;
  61     my $req = HTTP::Request->new(GET => $url);
  62     my $res = $client->make_request($req);
  63     return $client->error("Error on GET $url: " . $res->status_line)
  64         unless $res->code == 200;
  65     XML::Atom::Entry->new(Stream => \$res->content);
  66 }
  67
  68 sub createEntry {
  69     my $client = shift;
  70     my($uri, $entry) = @_;
  71     return $client->error("Must pass a PostURI before posting")
  72         unless $uri;
  73     my $req = HTTP::Request->new(POST => $uri);
  74     $req->content_type($entry->content_type);
  75     my $xml = $entry->as_xml;
  76     _utf8_off($xml);
  77     $req->content_length(length $xml);
  78     $req->content($xml);
  79     my $res = $client->make_request($req);
  80     return $client->error("Error on POST $uri: " . $res->status_line)
  81         unless $res->code == 201;
  82     $res->header('Location') || 1;
  83 }
  84
  85 sub updateEntry {
  86     my $client = shift;
  87     my($url, $entry) = @_;
  88     my $req = HTTP::Request->new(PUT => $url);
  89     $req->content_type($entry->content_type);
  90     my $xml = $entry->as_xml;
  91     _utf8_off($xml);
  92     $req->content_length(length $xml);
  93     $req->content($xml);
  94     my $res = $client->make_request($req);
  95     return $client->error("Error on PUT $url: " . $res->status_line)
  96         unless $res->code == 200;
  97     1;
  98 }
  99
 100 sub deleteEntry {
 101     my $client = shift;
 102     my($url) = @_;
 103     my $req = HTTP::Request->new(DELETE => $url);
 104     my $res = $client->make_request($req);
 105     return $client->error("Error on DELETE $url: " . $res->status_line)
 106         unless $res->code == 200;
 107     1;
 108 }
 109
 110 sub getFeed {
 111     my $client = shift;
 112     my($uri) = @_;
 113     return $client->error("Must pass a FeedURI before retrieving feed")
 114         unless $uri;
 115     my $req = HTTP::Request->new(GET => $uri);
 116     my $res = $client->make_request($req);
 117     return $client->error("Error on GET $uri: " . $res->status_line)
 118         unless $res->code == 200;
 119     my $feed = XML::Atom::Feed->new(Stream => \$res->content)
 120         or return $client->error(XML::Atom::Feed->errstr);
 121     $feed;
 122 }
 123
 124 sub make_request {
 125     my $client = shift;
 126     my($req) = @_;
 127     $client->munge_request($req);
 128     my $res = $client->{ua}->request($req);
 129     $client->munge_response($res);
 130     $client->{response} = $res;
 131     $res;
 132 }
 133
 134 sub munge_request {
 135     my $client = shift;
 136     my($req) = @_;
 137     $req->header(
 138         Accept => 'application/atom+xml, application/x.atom+xml, application/xml, text/xml, */*',
 139     );
 140     my $nonce = $client->make_nonce;
 141     my $nonce_enc = encode_base64($nonce, '');
 142     my $now = DateTime->now->iso8601 . 'Z';
 143     my $digest = encode_base64(sha1($nonce . $now . ($client->password || '')), '');
 144     if ($client->use_soap) {
 145         my $xml = $req->content || '';
 146         $xml =~ s!^(<\?xml.*?\?>)!!;
 147         my $method = $req->method;
 148         $xml = ($1 || '') . <<SOAP;
 149 <soap:Envelope
 150   xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"
 151   xmlns:wsu="http://schemas.xmlsoap.org/ws/2002/07/utility"
 152   xmlns:wsse="http://schemas.xmlsoap.org/ws/2002/07/secext">
 153   <soap:Header>
 154     <wsse:Security>
 155       <wsse:UsernameToken>
 156         <wsse:Username>@{[ $client->username || '' ]}</wsse:Username>
 157         <wsse:Password Type="wsse:PasswordDigest">$digest</wsse:Password>
 158         <wsse:Nonce>$nonce_enc</wsse:Nonce>
 159         <wsu:Created>$now</wsu:Created>
 160       </wsse:UsernameToken>
 161     </wsse:Security>
 162   </soap:Header>
 163   <soap:Body>
 164     <$method xmlns="http://schemas.xmlsoap.org/wsdl/http/">
 165 $xml
 166     </$method>
 167   </soap:Body>
 168 </soap:Envelope>
 169 SOAP
 170         $req->content($xml);
 171         $req->content_length(length $xml);
 172         $req->header('SOAPAction', 'http://schemas.xmlsoap.org/wsdl/http/' . $method);
 173         $req->method('POST');
 174         $req->content_type('text/xml');
 175     } else {
 176         if ($client->username) {
 177             $req->header('X-WSSE', sprintf
 178               qq(UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"),
 179               $client->username || '', $digest, $nonce_enc, $now);
 180             $req->header('Authorization', 'WSSE profile="UsernameToken"');
 181         }
 182     }
 183 }
 184
 185 sub munge_response {
 186     my $client = shift;
 187     my($res) = @_;
 188     if ($client->use_soap && (my $xml = $res->content)) {
 189         my $doc;
 190         if (LIBXML) {
 191             my $parser = XML::LibXML->new;
 192             $doc = $parser->parse_string($xml);
 193         } else {
 194             my $xp = XML::XPath->new(xml => $xml);
 195             $doc = ($xp->find('/')->get_nodelist)[0];
 196         }
 197         my $body = first($doc, NS_SOAP, 'Body');
 198         if (my $fault = first($body, NS_SOAP, 'Fault')) {
 199             $res->code(textValue($fault, undef, 'faultcode'));
 200             $res->message(textValue($fault, undef, 'faultstring'));
 201             $res->content('');
 202             $res->content_length(0);
 203         } else {
 204             $xml = join '', map $_->toString(LIBXML ? 1 : 0),
 205                 LIBXML ? $body->childNodes : $body->getChildNodes;
 206             $res->content($xml);
 207             $res->content_length(1);
 208         }
 209     }
 210 }
 211
 212 sub make_nonce { sha1(sha1(time() . {} . rand() . $$)) }
 213
 214 sub _utf8_off {
 215     if ($] >= 5.008) {
 216         require Encode;
 217         Encode::_utf8_off($_[0]);
 218     }
 219 }
 220
 221 package LWP::UserAgent::AtomClient;
 222 use strict;
 223 use Scalar::Util;
 224
 225 use base qw( LWP::UserAgent );
 226
 227 my %ClientOf;
 228 sub new {
 229     my($class, $client) = @_;
 230     my $ua = $class->SUPER::new;
 231     $ClientOf{$ua} = $client;
 232     Scalar::Util::weaken($ClientOf{$ua});
 233     $ua;
 234 }
 235
 236 sub get_basic_credentials {
 237     my($ua, $realm, $url, $proxy) = @_;
 238     my $client = $ClientOf{$ua} or die "Cannot find $ua";
 239     return $client->username, $client->password;
 240 }
 241
 242 sub DESTROY {
 243     my $self = shift;
 244     delete $ClientOf{$self};
 245 }
 246
 247 1;
 248 __END__
 249
 250 =head1 NAME
 251
 252 XML::Atom::Client - A client for the Atom API
 253
 254 =head1 SYNOPSIS
 255
 256     use XML::Atom::Client;
 257     use XML::Atom::Entry;
 258     my $api = XML::Atom::Client->new;
 259     $api->username('Melody');
 260     $api->password('Nelson');
 261
 262     my $entry = XML::Atom::Entry->new;
 263     $entry->title('New Post');
 264     $entry->content('Content of my post.');
 265     my $EditURI = $api->createEntry($PostURI, $entry);
 266
 267     my $feed = $api->getFeed($FeedURI);
 268     my @entries = $feed->entries;
 269
 270     my $entry = $api->getEntry($EditURI);
 271
 272 =head1 DESCRIPTION
 273
 274 I<XML::Atom::Client> implements a client for the Atom API described at
 275 I<http://bitworking.org/projects/atom/draft-gregorio-09.html>, with the
 276 authentication scheme described at
 277 I<http://www.intertwingly.net/wiki/pie/DifferentlyAbledClients>.
 278
 279 B<NOTE:> the API, and particularly the authentication scheme, are still
 280 in flux.
 281
 282 =head1 USAGE
 283
 284 =head2 XML::Atom::Client->new(%param)
 285
 286 =head2 $api->use_soap([ 0 | 1 ])
 287
 288 I<XML::Atom::Client> supports both the REST and SOAP-wrapper versions of the
 289 Atom API. By default, the REST version of the API will be used, but you can
 290 turn on the SOAP wrapper--for example, if you need to connect to a server
 291 that supports only the SOAP wrapper--by calling I<use_soap> with a value of
 292 C<1>:
 293
 294     $api->use_soap(1);
 295
 296 If called without arguments, returns the current value of the flag.
 297
 298 =head2 $api->username([ $username ])
 299
 300 If called with an argument, sets the username for login to I<$username>.
 301
 302 Returns the current username that will be used when logging in to the
 303 Atom server.
 304
 305 =head2 $api->password([ $password ])
 306
 307 If called with an argument, sets the password for login to I<$password>.
 308
 309 Returns the current password that will be used when logging in to the
 310 Atom server.
 311
 312 =head2 $api->createEntry($PostURI, $entry)
 313
 314 Creates a new entry.
 315
 316 I<$entry> must be an I<XML::Atom::Entry> object.
 317
 318 =head2 $api->getEntry($EditURI)
 319
 320 Retrieves the entry with the given URL I<$EditURI>.
 321
 322 Returns an I<XML::Atom::Entry> object.
 323
 324 =head2 $api->updateEntry($EditURI, $entry)
 325
 326 Updates the entry at URL I<$EditURI> with the entry I<$entry>, which must be
 327 an I<XML::Atom::Entry> object.
 328
 329 Returns true on success, false otherwise.
 330
 331 =head2 $api->deleteEntry($EditURI)
 332
 333 Deletes the entry at URL I<$EditURI>.
 334
 335 =head2 $api->getFeed($FeedURI)
 336
 337 Retrieves the feed at I<$FeedURI>.
 338
 339 Returns an I<XML::Atom::Feed> object representing the feed returned
 340 from the server.
 341
 342 =head2 ERROR HANDLING
 343
 344 Methods return C<undef> on error, and the error message can be retrieved
 345 using the I<errstr> method.
 346
 347 =head1 AUTHOR & COPYRIGHT
 348
 349 Please see the I<XML::Atom> manpage for author, copyright, and license
 350 information.
 351
 352 =cut