[catagits/Gitalist.git] / local-lib5 / lib / perl5 / XML / Atom / Client.pm

# $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 || '') . <<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 {
        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 = 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 {
    if ($] >= 5.008) {
        require Encode;
        Encode::_utf8_off($_[0]);
    }
}

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__

=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
Commit	Line	Data
3fea05b9	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